diff --git a/Colada/WordClass.hs b/Colada/WordClass.hs --- a/Colada/WordClass.hs +++ b/Colada/WordClass.hs @@ -1,3 +1,4 @@ + {-# LANGUAGE OverloadedStrings , FlexibleInstances @@ -5,6 +6,7 @@ , NoMonomorphismRestriction , DeriveDataTypeable , TemplateHaskell + , BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Word Class induction with LDA @@ -24,10 +26,12 @@ module Colada.WordClass ( - -- * Running - run + -- * Running the sampler + learn , defaultOptions + -- * Extracting information , summary + , wordTypeClasses -- * Class and word prediction , label , predict @@ -35,10 +39,18 @@ , WordClass , ldaModel -- | LDA model - , atomTable - -- | String to atom and vice versa conversion tables + , wordTypeTable + -- | Word type string to atom and vice versa conversion tables + , featureTable + -- | Feature string to atom and vice versa conversion tables , options -- | Options for Gibbs sampling + , LDA.Finalized + , LDA.docTopics + , LDA.wordTopics + , LDA.topics + , LDA.topicDocs + , LDA.topicWords , Options , featIds -- | Feature ids @@ -56,27 +68,44 @@ -- | Number of sentences per batch , seed -- | Random seed for the sampler + , topn + -- | Number of most probable words to return + , initSize + , initPasses + , exponent + , progressive + , lambda ) where -- Standard libraries -import qualified Data.Text.Lazy as Text -import qualified Data.Text.Lazy.Encoding as Text -import qualified Data.Vector as V -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed as U -import qualified Data.IntMap as IntMap -import qualified Data.Serialize as Serialize -import qualified Control.Monad as M -import qualified Data.List as List -import qualified Data.List.Split as Split -import qualified Data.Ord as Ord -import Data.Word (Word64) -import Data.Typeable (Typeable) -import Data.Data (Data) -import Prelude hiding ((.)) -import Control.Category ((.)) - +import qualified Data.Text.Lazy.IO as Text +import qualified Data.Text.Lazy as Text +import qualified Data.Text.Lazy.Builder as Text +import qualified Data.Text.Lazy.Builder.Int as Text +import qualified Data.Text.Lazy.Encoding as Text +import qualified Data.Vector as V +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Unboxed as U +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Data.Serialize as Serialize +import qualified Control.Monad as M +import qualified Data.List as List +import qualified Data.List.Split as Split +import qualified Data.Ord as Ord +import qualified Data.Foldable as Fold +import qualified Data.Traversable as Trav +import qualified Control.Monad.ST as ST +import qualified Control.Monad.ST.Lazy as LST +import Control.Monad.Writer +import Data.Word (Word32) +import Data.Typeable (Typeable) +import Data.Data (Data) +import Prelude hiding ((.), exponent) +import Control.Category ((.)) +import Control.Applicative ((<$>)) +import qualified System.IO.Unsafe as Unsafe -- Third party modules import qualified Control.Monad.Atom as Atom import qualified NLP.CoNLL as CoNLL @@ -85,32 +114,36 @@ import qualified Data.Label as L import Data.Label (get) -import qualified NLP.LDA as LDA -import NLP.LDA.Utils (count) +import qualified NLP.SwiftLDA as LDA -- Package modules import qualified Colada.Features as F +import qualified NLP.Symbols as Symbols -- | Container for the Word Class model data WordClass = - WordClass { _ldaModel :: LDA.Finalized -- ^ LDA model - , _atomTable :: Atom.AtomTable (U.Vector Char) -- ^ String to - -- Int - -- conversion - -- table - , _options :: Options + WordClass { _ldaModel :: LDA.Finalized -- ^ LDA model + , _wordTypeTable :: Atom.AtomTable (U.Vector Char) + , _featureTable :: Atom.AtomTable (U.Vector Char) + , _options :: Options } deriving (Generic) -data Options = Options { _featIds :: [Int] - , _topicNum :: !Int - , _alphasum :: !Double - , _beta :: !Double - , _passes :: !Int - , _repeats :: !Int - , _batchSize :: !Int - , _seed :: !Word64 +data Options = Options { _featIds :: [Int] + , _topicNum :: !Int + , _alphasum :: !Double + , _beta :: !Double + , _passes :: !Int + , _repeats :: !Int + , _batchSize :: !Int + , _seed :: !Word32 + , _topn :: !Int + , _initSize :: !Int + , _initPasses :: !Int + , _exponent :: !(Maybe Double) + , _progressive :: !Bool + , _lambda :: !Double } deriving (Eq, Show, Typeable, Data, Generic) @@ -119,62 +152,112 @@ $(L.mkLabels [''WordClass, ''Options]) defaultOptions :: Options -defaultOptions = Options { _featIds = [-1,1] - , _topicNum = 10 - , _alphasum = 10 - , _beta = 0.1 - , _passes = 1 - , _repeats = 1 - , _batchSize = 1 - , _seed = 0 +defaultOptions = Options { _featIds = [-1,1] + , _topicNum = 10 + , _alphasum = 10 + , _beta = 0.1 + , _passes = 1 + , _repeats = 1 + , _batchSize = 1 + , _seed = 0 + , _topn = maxBound + , _initSize = 0 + , _initPasses = 100 + , _exponent = Nothing + , _progressive= False + , _lambda = 0.5 } --- | @run options xs@ runs the LDA Gibbs sampler for word classes with --- @options@ on sentences @xs@, and returns the resulting model -run :: Options -> [CoNLL.Sentence] -> WordClass -run opts xs = - let (ss, atomTab) = flip Atom.runAtom Atom.empty - . prepareData (get repeats opts) - (get featIds opts) - $ xs - bs = batches (get batchSize opts) ss - m = LDA.initial (get topicNum opts) (get alphasum opts) (get beta opts) - lda = mapM_ (\b -> M.foldM (const . LDA.pass) b [1..get passes opts]) - bs - m' = snd . LDA.runSampler (get seed opts) m $ lda - in WordClass (LDA.finalize m') atomTab opts +-- | @learn options xs@ runs the LDA Gibbs sampler for word classes +-- with @options@ on sentences @xs@, and returns the resulting model +-- together progressive class the assignments +learn :: Options -> [CoNLL.Sentence] -> (WordClass, [V.Vector LDA.D]) +learn opts xs = + let ((sbs_init, sbs_rest), atomTabD, atomTabW) = + Symbols.runSymbols prepare Symbols.empty Symbols.empty + prepare = do + let (xs_init, xs_rest) = List.splitAt (get initSize opts) xs + ini <- prepareData (get initSize opts) + 1 + (get featIds opts) + xs_init + rest <- prepareData (get batchSize opts) + (get repeats opts) + (get featIds opts) + xs_rest + return (ini, rest) + best = V.map U.maxIndex + sampler :: WriterT [V.Vector LDA.D] (LST.ST s) LDA.Finalized + sampler = do + m <- st $ LDA.initial (U.singleton (get seed opts)) + (get topicNum opts) + (get alphasum opts) + (get beta opts) + (get exponent opts) + let loop t z i = do + r <- st $ Trav.forM z $ \b -> do + Trav.forM b $ \s -> do + LDA.pass t m s + M.when (get progressive opts && i == 1) $ do + let b = V.head z + Fold.forM_ b $ \s -> do + ls <- st $ V.mapM (interpWordClasses m (get lambda opts)) s + tell [best ls] + return $! r + -- Initialize with batch sampler on prefix sbs_init + Fold.forM_ sbs_init $ \sb -> do + Fold.foldlM (loop 1) sb [1..get initPasses opts] + -- Continue sampling + Fold.forM_ (zip [1..] sbs_rest) $ \(t,sb) -> do + Fold.foldlM (loop t) sb [1..get passes opts] + st $ LDA.finalize m + (lda, labeled) = LST.runST (runWriterT sampler) + in (WordClass lda atomTabD atomTabW opts, labeled) +type Symb = Symbols.Symbols (U.Vector Char) (U.Vector Char) +type Sent = V.Vector LDA.Doc +type Batch = V.Vector Sent +type SuperBatch = V.Vector Batch +-- | Convert a stream of sentences into a stream of batches ready for +-- sampling. +prepareData :: Int -- ^ batch size + -> Int -- ^ no. repeats + -> [Int] -- ^ feature indices + -> [CoNLL.Sentence] -- ^ stream of sentences + -> Symb [SuperBatch] -- ^ stream of superbatches +prepareData bsz rep is ss = do + ss' <- mapM symbolize . map (featurize is) $ ss + return $! map (multiply rep) . batchup bsz $ ss' +-- | Extract features from a sentence +featurize :: [Int] + -> CoNLL.Sentence + -> [(Text.Text, [Text.Text])] +featurize is s = + let mk fs = + let d = IntMap.findWithDefault + (error "parseData: focus feature missing") 0 fs + ws = [ Text.concat [f,"^",Text.pack . show $ i ] + | i <- is , Just f <- [IntMap.lookup i fs] ] + in (d, ws) + in map mk . extractFeatures $ s --- | @prepareData rep is ss@ replicates each sentence in stream @ss@ --- @rep@ times. Features with indices @is@ are extracted from each --- token, and word and features are converted to ints in the Atom --- Monad. -prepareData :: Int - -> [Int] - -> [CoNLL.Sentence] - -> Atom.Atom (U.Vector Char) [V.Vector LDA.Doc] -prepareData rep is ss = do - let mk fs = let d = IntMap.findWithDefault - (error "parseData: focus feature missing") 0 fs - ws = [ Text.concat [f,"^",Text.pack . show $ i ] - | i <- is , Just f <- [IntMap.lookup i fs] ] - in (d, ws) - doc (d, ws) = do - da <- Atom.toAtom . compress $ d - was <- mapM (Atom.toAtom . compress) ws - return (da, U.fromList $ zip was (repeat Nothing)) - sent s = do fs <- mapM (doc . mk) . extractFeatures $ s - return $! V.fromList fs - ss' <- mapM sent ss - return $! concatMap (replicate rep) ss' - --- | @batches sz ss@ creates batches of size @sz@ from the stream of --- sentence feature vectors @ss@. The vectors in a batch are --- concatenated. -batches :: Int -> [V.Vector LDA.Doc] -> [V.Vector LDA.Doc] -batches sz = map V.concat . Split.chunk sz +-- | Convert text strings into symbols (ints) +symbolize :: [(Text.Text, [Text.Text])] -> Symb Sent +symbolize s = V.fromList <$> mapM doc s + where doc (d, ws) = do + da <- Symbols.toAtomA . compress $ d + was <- mapM (Symbols.toAtomB . compress) ws + return (da, U.fromList $ zip was (repeat Nothing)) +-- | Chunk sentences stream into batches +batchup :: Int -> [Sent] -> [Batch] +batchup bsz = map V.fromList . Split.chunk bsz + +-- | Replicate and flatten a batch of sentences +multiply :: Int -> Batch -> SuperBatch +multiply rep = V.replicate rep + -- | @summary m@ returns a textual summary of word classes found in -- model @m@ summary :: WordClass -> Text.Text @@ -187,7 +270,7 @@ $ cs return . Text.unwords $ Text.pack (show z) : map (Text.pack . U.toList) cs' - in fst . flip Atom.runAtom (get atomTable m) + in fst . flip Atom.runAtom (get wordTypeTable m) . M.liftM Text.unlines . mapM format . IntMap.toList @@ -196,54 +279,88 @@ . IntMap.toList . IntMap.map IntMap.toList . LDA.docTopics - . LDA.model . get ldaModel $ m - --- | @label m s@ returns for each word in sentences s, unnormalized --- probabilities of word classes. -label :: WordClass -> CoNLL.Sentence -> V.Vector (U.Vector Double) -label m s = fst . Atom.runAtom label' . L.get atomTable $ m - where label' = do +-- | @interpWordClasses m lambda doc@ gives the class probabilities for +-- word type in context @doc@ according to evolving model @m@. It +-- interpolates the prior word type probability with the +-- context-conditioned probabilities using alpha: +-- P(d,w) = lambda * P(z|d) + (1-lambda) * P(z|d,w) +interpWordClasses :: LDA.LDA s + -> Double + -> LDA.Doc + -> ST.ST s (U.Vector Double) +interpWordClasses m lambda doc@(d,_) = do + pzd <- normalize <$> LDA.priorDocTopicWeights_ m d + pzdw <- normalize <$> LDA.docTopicWeights_ m doc + return $! U.zipWith (\p q -> lambda * p + (1-lambda) * q) pzd pzdw + where normalize x = let !s = U.sum x in U.map (/s) x + +-- | @wordTypeClasses m@ returns a Map from word types to unnormalized +-- distributions over word classes +wordTypeClasses :: WordClass -> Map.Map Text.Text (IntMap.IntMap Double) +wordTypeClasses m = + fst . flip Atom.runAtom (get wordTypeTable m) + . fmap Map.fromList + . mapM (\(k,v) -> do k' <- Atom.fromAtom k ; return (decompress k',v)) + . IntMap.toList + . LDA.docTopics + . get ldaModel + $ m + + +-- | @label m s@ returns for each word in sentences s, +-- unnormalized probabilities of word classes. +label :: Bool -> WordClass -> CoNLL.Sentence -> V.Vector (U.Vector Double) +label noctx m s = fst3 $ Symbols.runSymbols label' + (L.get wordTypeTable m) + (L.get featureTable m) + where dectx doc@(d, _) = if noctx + then (d, U.singleton (-1,Nothing)) --FIXME: ugly hack + else doc + label' = do let fm = L.get ldaModel m s' <- prepareSent m s - return $! V.map (LDA.docTopicWeights . LDA.model $ fm) $ s' - + return $! V.map (LDA.docTopicWeights fm . dectx) + $ s' + -- | @predict m s@ returns for each word in sentence s, unnormalized -- probabilities of words given predicted word class. predict :: WordClass -> CoNLL.Sentence - -> V.Vector (V.Vector (Double, Text.Text)) -predict m s = fst . Atom.runAtom predict' . L.get atomTable $ m + -> [V.Vector (Double, Text.Text)] +predict m s = fst3 $ Symbols.runSymbols predict' (L.get wordTypeTable m) + (L.get featureTable m) where predict' = do let fm = L.get ldaModel m s' <- prepareSent m s - let ws = V.map (G.convert . predictDoc fm . docToWs) - $ s' - V.mapM (V.mapM fromAtom) ws + let ws = map ( G.convert + . predictDoc (get (topn . options) m) fm + . docToWs ) + . V.toList + $ s' + mapM (V.mapM fromAtom) ws docToWs = U.map fst . snd - fromAtom (n,w) = do w' <- Atom.fromAtom w + fromAtom (n,w) = do w' <- Symbols.fromAtomA w return (n, decompress w') -prepareSent :: WordClass -> CoNLL.Sentence - -> Atom.Atom (U.Vector Char) (V.Vector LDA.Doc) -prepareSent m s = do - [r] <- prepareData 1 (L.get (featIds . options) m) [s] - return r +prepareSent :: WordClass -> CoNLL.Sentence -> Symb Sent +prepareSent m = symbolize . featurize (L.get (featIds . options) m) --- | @predictDoc m ws@ returns unnormalized probabilities of each --- document id given the model @m@ and words @ws@. The candidate --- document ids are taken from the model @m@. The weights are --- computed according to the following formula: +-- | @predictDoc n m ws@ returns unnormalized probabilities of top @n@ +-- most probable document ids given the model @m@ and words @ws@. The +-- candidate document ids are taken from the model @m@. The weights +-- are computed according to the following formula: -- -- > P(d|{w}) ∝ Σ_z[n(d,z)+a Σ_{w in ws}(n(w,z)+b)/(Σ_{w in V} n(w,z)+b)] -predictDoc :: LDA.Finalized -> U.Vector LDA.W -> U.Vector (Double, LDA.D) -predictDoc m ws = - let k = LDA.topicNum . LDA.model $ m - a = LDA.alphasum (LDA.model m) / fromIntegral k - b = LDA.beta . LDA.model $ m - v = fromIntegral . LDA.vSize . LDA.model $ m - zt = LDA.topics . LDA.model $ m +predictDoc :: Int -> LDA.Finalized -> U.Vector LDA.W + -> U.Vector (Double, LDA.D) +predictDoc n m ws = + let k = LDA.topicNum m + a = LDA.alphasum m / fromIntegral k + b = LDA.beta m + v = fromIntegral . LDA.wSize $ m + zt = LDA.topics m wsums = IntMap.fromList [ (z, U.sum . U.map (\w -> (count w wt_z + b) / denom) $ ws) @@ -252,16 +369,13 @@ $ m denom = count z zt + b * v ] wsum z = IntMap.findWithDefault - (error "Colada.LDA.predictDoc: key not found") + (error $ "Colada.WordClass.predictDoc: key not found: " + ++ show z) z wsums - in U.fromList - . List.sortBy (flip $ Ord.comparing id) + in U.fromList . take n . List.sortBy (flip compare) $ [ ( sum [ (c + a) * wsum z | (z,c) <- IntMap.toList zt_d ] , d) - | d <- IntMap.keys . LDA.docTopics . LDA.model $ m - , let zt_d = IntMap.findWithDefault IntMap.empty d - . LDA.docTopics - . LDA.model - $ m ] + | (d, zt_d) <- IntMap.toList . LDA.docTopics $ m + ] extractFeatures :: CoNLL.Sentence -> [IntMap.IntMap Text.Text] extractFeatures = F.featureSeq combine @@ -284,10 +398,21 @@ decompress :: U.Vector Char -> Text.Text decompress = Text.pack . U.toList +fst3 :: (a, b, c) -> a +fst3 (a,_,_) = a + +count :: Int -> IntMap.IntMap Double -> Double +count z t = case IntMap.findWithDefault 0 z t of + n | n < 0 -> error "Colada.WordClass.count: negative count" + n -> n +{-# INLINE count #-} + +st :: Monoid w => ST.ST s a -> WriterT w (LST.ST s) a +st = lift . LST.strictToLazyST + -- Instances for serialization instance Serialize.Serialize LDA.Finalized -instance Serialize.Serialize LDA.LDA instance Serialize.Serialize Text.Text where put = Serialize.put . Text.encodeUtf8 diff --git a/NLP/Symbols.hs b/NLP/Symbols.hs new file mode 100644 --- /dev/null +++ b/NLP/Symbols.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | The Symbols monad provides two separate sources of atoms, for +-- converting objects to unique atoms (represented as Ints) +module NLP.Symbols + ( Symbols + , module Control.Monad.Atom + , toAtomA + , toAtomB + , fromAtomA + , fromAtomB + , evalSymbols + , runSymbols + ) +where +import Control.Monad.Atom +import Control.Monad.Trans + +newtype Symbols a b r = Symbols (AtomT a (Atom b) r) + deriving (Functor, Monad) + +toAtomA :: (Ord a) => a -> Symbols a b Int +toAtomA = Symbols . toAtom + +toAtomB :: (Ord b) => b -> Symbols a b Int +toAtomB = Symbols . lift . toAtom + +fromAtomA :: (Ord a) => Int -> Symbols a b a +fromAtomA = Symbols . fromAtom + +fromAtomB :: (Ord b) => Int -> Symbols a b b +fromAtomB = Symbols . lift . fromAtom + +evalSymbols :: (Ord a, Ord b) => Symbols a b r -> r +evalSymbols (Symbols s) = evalAtom $ evalAtomT s + +runSymbols :: (Ord a, Ord b) => + Symbols a b t + -> AtomTable a -> AtomTable b -> (t, AtomTable a, AtomTable b) +runSymbols (Symbols s) y z = + let ((r,a),b) = runAtom (runAtomT s y) z + in (r,a,b) + diff --git a/colada.cabal b/colada.cabal --- a/colada.cabal +++ b/colada.cabal @@ -1,59 +1,43 @@ --- colada.cabal auto-generated by cabal init. For additional options, --- see --- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. --- The name of the package. Name: colada - --- The package version. See the Haskell package versioning policy --- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for --- standards guiding when and how versions should be incremented. -Version: 0.0.1 - --- A short (one-line) description of the package. -Synopsis: Colada implements incremental word class class induction using online LDA - --- A longer description of the package. +Version: 0.4.1 +Synopsis: Colada implements incremental word class class induction + using online LDA Description: Colada implements incremental word class class induction using Latent Dirichlet Allocation (LDA) with an Online Gibbs sampler. - --- URL for the project homepage or repository. Homepage: https://bitbucket.org/gchrupala/colada - --- The license under which the package is released. License: BSD3 - --- The file containing the license text. License-file: LICENSE - --- The package author(s). Author: Grzegorz Chrupała - --- An email address to which users can send suggestions, bug reports, --- and patches. Maintainer: pitekus@gmail.com - --- A copyright notice. --- Copyright: - Category: Natural Language Processing - Build-type: Simple - --- Extra files to be distributed with the package, such as examples or --- a README. --- Extra-source-files: - --- Constraint on the version of Cabal needed to build this package. Cabal-version: >=1.2 +Library + Build-depends: base >= 3 && < 5 + , containers >= 0.4 + , ListZipper >= 1.2 + , fclabels >= 1.1 + , ghc-prim >= 0.2 + , vector >= 0.9 + , split >= 0.1.4 + , text >= 0.11.1 + , monad-atom >= 0.4.1 && < 1 + , cereal >= 0.3.5 + , cmdargs >= 0.9 + , bytestring >= 0.9 + , mtl >= 2.0 + , swift-lda >= 0.4 && <= 0.5 + Exposed-modules: Colada.WordClass + , NLP.CoNLL + Other-modules: Colada.Features + , NLP.Symbols + GHC-options: -O2 + Executable colada - -- .hs or .lhs file containing the Main module. Main-is: colada.hs - - -- Packages needed in order to build this package. Build-depends: base >= 3 && < 5 - , lda >= 0.0.2 && < 0.1 , containers >= 0.4 , ListZipper >= 1.2 , fclabels >= 1.1 @@ -61,15 +45,14 @@ , vector >= 0.9 , split >= 0.1.4 , text >= 0.11.1 - , monad-atom >= 0.4 && < 1 + , monad-atom >= 0.4.1 && < 1 , cereal >= 0.3.5 , cmdargs >= 0.9 , bytestring >= 0.9 - -- Modules not exported by this package. + , mtl >= 2.0 + , swift-lda >= 0.4 && <= 0.5 Other-modules: Colada.WordClass , Colada.Features , NLP.CoNLL - - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. - -- Build-tools: + , NLP.Symbols GHC-options: -O2 -rtsopts diff --git a/colada.hs b/colada.hs --- a/colada.hs +++ b/colada.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances , DeriveDataTypeable - , TemplateHaskell , OverloadedStrings + , TemplateHaskell , OverloadedStrings , NoMonomorphismRestriction + , FlexibleContexts #-} module Main where @@ -27,8 +28,10 @@ data Program = Help | Learn { _options :: C.Options , _modelPath :: FilePath } - | Predict { _modelPath :: FilePath } - | Label { _modelPath :: FilePath } + | Predict { _topn :: Int + , _modelPath :: FilePath } + | Label { _modelPath :: FilePath + , _noContext :: Bool } deriving (Show) $(L.mkLabels [''Program]) @@ -41,27 +44,35 @@ predict :: Mode Program predict = - mode "predict" Predict { _modelPath = "model" } "Predict words" + mode "predict" Predict { _topn = maxBound + , _modelPath = "model" } "Predict words" (flagArg (\x p -> Right $ maybe p id (M.set modelPath x p)) "FILE") - [] - + [ flagReq ["topn"] (\x p -> + case safeRead x of + Right n -> Right $ maybe p id (M.set topn n p) + Left err -> Left err + ) + + "NAT" "Number of most probable words to show" + ] + label :: Mode Program label = - mode "label" Label { _modelPath = "model" } "Label words with classes" + mode "label" Label { _modelPath = "model" , _noContext = False } + "Label words with classes" (flagArg (\x p -> Right $ maybe p id (M.set modelPath x p)) "FILE") - [] + [ flagNone ["no-context"] (\p -> p { _noContext = True }) + "Ignore context while labeling" + ] learn :: Mode Program learn = - let setOption field x p = + let setOption = setOptionWith id + setOptionWith f field x p = fmap (maybe p id . flip (M.set (field . options)) p) + . fmap f . safeRead $ x - safeRead :: Read b => String -> Either String b - safeRead x = - case reads x of - [(a,"")] -> Right a - _ -> Left $ "Couldn't parse " ++ show x in mode "learn" Learn { _options = C.defaultOptions , _modelPath = "model" } "Learn word classes" (flagArg (\x p -> Right $ maybe p id (M.set modelPath x p)) @@ -95,6 +106,23 @@ , flagReq ["seed"] (setOption C.seed) "NAT" "Random seed" + + , flagNone ["progressive"] + (\p -> + maybe p id . M.set (C.progressive . options) True $ p) + "Label progressively" + + , flagReq ["lambda"] (setOption C.lambda) + "FLOAT" "Interpolation parameter for progressive labeling" + + , flagReq ["init-size"] (setOption C.initSize) + "NAT" "Data prefix size for batch initialization" + + , flagReq ["init-passes"] (setOption C.initPasses) + "NAT" "Number of passes for initialization" + + , flagReq ["exponent"] (setOptionWith Just C.exponent) + "FLOAT" "Exponent for learning rate" ] @@ -111,29 +139,35 @@ let opts = processValue program args case opts of Help -> print $ helpText [] HelpFormatDefault program - Predict { _modelPath = p } -> do + Predict { _topn = n, _modelPath = p } -> do -- FIXME: use Data.Text.Builder instead of converting to Lists let format s = {-# SCC "format" #-} Text.unlines [ Text.concat . List.intersperse "," . map snd . V.toList $ ws - | ws <- V.toList s ] - m <- parseModel p + | ws <- s ] + m <- L.set (C.topn . C.options) n `fmap` parseModel p ss <- CoNLL.parse `fmap` Text.getContents Text.putStr . Text.unlines . map (format . C.predict m) $ ss - Label { _modelPath = p } -> do - let format s = Text.unlines - . V.toList - . V.map (Text.toLazyText . Text.decimal . V.maxIndex) - $ s + Label { _modelPath = p , _noContext = noctx } -> do m <- parseModel p ss <- CoNLL.parse `fmap` Text.getContents - Text.putStr . Text.unlines . map (format . C.label m) $ ss + Text.putStr . Text.unlines + . map (formatLabeling + . V.map V.maxIndex . C.label noctx m) + $ ss Learn { _options = o , _modelPath = p } -> do ss <- CoNLL.parse `fmap` Text.getContents - let m = C.run o ss - Text.putStr . C.summary $ m - BS.writeFile p . Serialize.encode $ m + let (m, ls) = C.learn o ss + if (L.get C.progressive o) + then do Text.putStr . Text.unlines . map formatLabeling $ ls + else do Text.putStr . C.summary $ m + BS.writeFile p . Serialize.encode $ m + +formatLabeling :: (V.Vector v Int, V.Vector v Text.Text) => + v Int -> Text.Text +formatLabeling = Text.unlines . V.toList + . V.map (Text.toLazyText . Text.decimal) parseModel :: FilePath -> IO C.WordClass parseModel p = do @@ -141,3 +175,9 @@ . Serialize.decode) `fmap` BS.readFile p +safeRead :: Read b => String -> Either String b +safeRead x = + case reads x of + [(a,"")] -> Right a + _ -> Left $ "Couldn't parse " ++ show x +