colada 0.0.1 → 0.4.1
raw patch · 4 files changed
+389/−199 lines, 4 filesdep +mtldep +swift-ldadep −ldadep ~monad-atom
Dependencies added: mtl, swift-lda
Dependencies removed: lda
Dependency ranges changed: monad-atom
Files
- Colada/WordClass.hs +253/−128
- NLP/Symbols.hs +42/−0
- colada.cabal +28/−45
- colada.hs +66/−26
Colada/WordClass.hs view
@@ -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
+ NLP/Symbols.hs view
@@ -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)+
colada.cabal view
@@ -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
colada.hs view
@@ -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+