diff --git a/Colada/WordClass.hs b/Colada/WordClass.hs --- a/Colada/WordClass.hs +++ b/Colada/WordClass.hs @@ -27,7 +27,7 @@ module Colada.WordClass ( -- * Running the sampler - learn + learnIO , defaultOptions -- * Extracting information , summary @@ -63,19 +63,14 @@ -- | Dirichlet parameter beta which controls word sparseness , passes -- | Number of sampling passes per batch - , repeats - -- | Number of repeats per sentences , batchSize -- | Number of sentences per batch , seed -- | Random seed for the sampler , topn -- | Number of most probable words to return - , initSize - , initPasses , exponent , progressive - , pre , lambda ) where @@ -139,15 +134,11 @@ , _alphasum :: !Double , _beta :: !Double , _passes :: !Int - , _repeats :: !Int , _batchSize :: !Int , _seed :: !Word32 , _topn :: !Int - , _initSize :: !Int - , _initPasses :: !Int , _exponent :: !(Maybe Double) , _progressive :: !Bool - , _pre :: !Bool , _lambda :: !Double } deriving (Eq, Show, Typeable, Data, Generic) @@ -162,84 +153,52 @@ , _alphasum = 10 , _beta = 0.1 , _passes = 1 - , _repeats = 1 , _batchSize = 1 , _seed = 0 , _topn = maxBound - , _initSize = 0 - , _initPasses = 100 , _exponent = Nothing , _progressive= False - , _pre = False , _lambda = 1.0 } --- | @learn options xs@ runs the LDA Gibbs sampler for word classes --- with @options@ on sentences @xs@, and returns the resulting model --- together with progressive class assignments -learn :: Options - -> [CoNLL.Sentence] - -> (WordClass, [V.Vector (U.Vector Double)]) -learn opts xs = - let ((bs_init, bs_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) - sampler :: WriterT [V.Vector (U.Vector Double)] (LST.ST s) LDA.Finalized +-- | @learnIO options f xs@ runs the LDA Gibbs sampler for word classes +-- with @options@ on sentences @xs@, and returns the resulting +-- model. The progressive class assignments are passed to the handler +-- function f. +learnIO :: Options + -> (V.Vector (U.Vector Double) -> IO ()) + -> [CoNLL.Sentence] + -> IO WordClass +learnIO opts f xs = do + let (bs, atomTabD, atomTabW) = + Symbols.runSymbols (prepareData (get batchSize opts) (get featIds opts) xs) + Symbols.empty + Symbols.empty + sampler :: IO LDA.Finalized sampler = do - m <- st $ LDA.initial (U.singleton (get seed opts)) + m <- ST.stToIO $ LDA.initial (U.singleton (get seed opts)) (get topicNum opts) (get alphasum opts) (get beta opts) (get exponent opts) - let loop t i_last batch i = do - let label_prog = do - Fold.forM_ batch $ \rep -> do - let sent = V.head rep - ls <- st $ V.mapM (interpWordClasses m (get lambda opts)) sent - tell [ls] - -- Either label before sampling (--pre) - M.when (get progressive opts && i == 1 && get pre opts) label_prog - r <- st $ Trav.forM batch $ \rep -> do - Trav.forM rep $ \sent -> do - LDA.pass t m sent - -- Or label after sampling - M.when (get progressive opts && i == i_last && not (get pre opts)) label_prog - return $! r - -- Initialize with batch sampler on prefix sbs_init - Fold.forM_ bs_init $ \batch -> do - Fold.foldlM (loop 1 $ get initPasses opts) batch [1..get initPasses opts] - -- Continue sampling - Fold.forM_ (zip [1..] bs_rest) $ \(t, batch) -> do - Fold.foldlM (loop t $ get passes opts) batch [1..get passes opts] - st $ LDA.finalize m - (lda, labeled) = LST.runST (runWriterT sampler) - in (WordClass lda atomTabD atomTabW opts, labeled) + Fold.forM_ bs $ \b -> do + Fold.forM_ [1..get passes opts] $ \i -> do + Fold.forM_ b $ \sent -> do + _ <- ST.stToIO $ LDA.pass 1 m sent + when (get progressive opts && i == get passes opts) $ do + ls <- ST.stToIO $ V.mapM (interpWordClasses m (get lambda opts)) sent + f ls + ST.stToIO $ LDA.finalize m + lda <- sampler + return (WordClass lda atomTabD atomTabW opts) type Symb = Symbols.Symbols (U.Vector Char) (U.Vector Char) type Sent = V.Vector LDA.Doc -type Repeat = V.Vector Sent -type Batch = V.Vector Repeat --- | 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 [Batch] -- ^ stream of batches -prepareData bsz rep is ss = do +prepareData :: Int -> [Int] -> [CoNLL.Sentence] -> Symb [V.Vector Sent] +prepareData bsz is ss = do ss' <- mapM symbolize . map (featurize is) $ ss - return $! (map V.fromList . Split.chunksOf bsz . map (V.replicate rep) $ ss') + return $! map V.fromList . Split.chunksOf bsz $ ss' -- | Extract features from a sentence featurize :: [Int] diff --git a/colada.cabal b/colada.cabal --- a/colada.cabal +++ b/colada.cabal @@ -1,5 +1,5 @@ Name: colada -Version: 0.5.6 +Version: 0.7.0.0 Synopsis: Colada implements incremental word class class induction using online LDA Description: Colada implements incremental word class class induction using @@ -55,4 +55,4 @@ , Colada.Features , NLP.CoNLL , NLP.Symbols - GHC-options: -O2 -rtsopts + GHC-options: -O2 -with-rtsopts=-K128m -rtsopts diff --git a/colada.hs b/colada.hs --- a/colada.hs +++ b/colada.hs @@ -113,9 +113,6 @@ , flagReq ["passes"] (setOption C.passes) "NAT" "Passes per batch" - , flagReq ["repeats"] (setOption C.repeats) - "NAT" "Repeats per sentence" - , flagReq ["batch-size"] (setOption C.batchSize) "NAT" "Sentences per batch" @@ -127,22 +124,9 @@ maybe p id . M.set (C.progressive . options) True $ p) "Label progressively" - , flagNone ["pre"] - (\p -> - maybe p id . M.set (C.pre . options) True $ p) - "Progressive labeling done before running a pass" - , 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" ] @@ -178,11 +162,12 @@ $ ss Learn { _options = o , _modelPath = p } -> do ss <- CoNLL.parse `fmap` Text.getContents - let (m, ls) = C.learn o ss - if (L.get C.progressive o) - then do Text.putStr . Text.unlines . map formatFullLabeling $ ls - else do Text.putStr . C.summary $ m + let display x = if L.get C.progressive o + then Text.putStrLn . formatFullLabeling $ x + else return () + m <- C.learnIO o display ss BS.writeFile p . Serialize.encode $ m + Summary { _modelPath = p , _harden = h } -> do m <- parseModel p if h