diff --git a/Colada/WordClass.hs b/Colada/WordClass.hs --- a/Colada/WordClass.hs +++ b/Colada/WordClass.hs @@ -46,12 +46,14 @@ -- | Feature string to atom and vice versa conversion tables , options -- | Options for Gibbs sampling + , SummaryType(..) , LDA.Finalized , LDA.docTopics , LDA.wordTopics , LDA.topics , LDA.topicDocs , LDA.topicWords + -- | Counts of words in LDA model , Options , featIds -- | Feature ids @@ -111,9 +113,8 @@ import GHC.Generics (Generic) import qualified Data.Label as L import Data.Label (get) - +import qualified NLP.Scores as Scores import qualified NLP.SwiftLDA as LDA - -- Package modules import qualified Colada.Features as F import qualified NLP.Symbols as Symbols @@ -228,40 +229,59 @@ --return (da, U.fromList $ zip was (repeat Nothing)) return (da, U.fromList was) + +data SummaryType = + Soft -- Most frequent word per class according to soft assignments. + | Hard -- Assign each word to predominant class, output most frequent per class. + | LLR -- Ranked by -2 * log-likelihood-ratio + deriving (Show) -- | @summary m@ returns a textual summary of word classes found in -- model @m@ summary :: WordClass -> Text.Text -summary = summarize False +summary = summarize Soft -summarize :: Bool -> WordClass -> Text.Text -summarize harden m = - let format (z,cs) = do +summarize :: SummaryType -> WordClass -> Text.Text +summarize typ m = + + let inv t = IntMap.toList . IntMap.fromListWith IntMap.union + $ [ (k2, IntMap.singleton k1 c) | (k1, v1) <- t, (k2, c) <- v1 ] + format (z,cs) = do cs' <- mapM (Atom.fromAtom . fst) - . takeWhile ((>0) . snd) . take 10 . List.sortBy (flip $ Ord.comparing snd) . IntMap.toList $ cs return . Text.unwords $ Text.pack (show z) - : map (Text.pack . U.toList) cs' + : map (Text.pack . U.toList) cs' + scores = case typ of + Soft -> IntMap.toList + . LDA.topicDocs + . get ldaModel + $ m + Hard -> IntMap.toList + . IntMap.fromListWith (IntMap.unionWith (+)) + . concatMap (\(d,zs) -> [ (z, IntMap.singleton d c) | (z,c) <- zs ]) + . map (\(d,zs) -> let s = sum . map snd $ zs + (z',_) = List.maximumBy (Ord.compare `on` snd) zs + in (d, [ (z, if z == z' then s else 0) | (z,_) <- zs ])) + . IntMap.toList + . IntMap.map IntMap.toList + . LDA.docTopics + . get ldaModel + $ m + LLR -> -- - 2 * logLikelihoodRatio + let t = LDA.topicDocs . get ldaModel $ m + cs = uncurry Scores.counts . unzip . concat + $ [ replicate (round c) (d, z) | + (z, ds) <- IntMap.toList t , + (d, c) <- IntMap.toList ds ] + in [ (z, IntMap.fromList [ (d, let s = - 2 * Scores.logLikelihoodRatio cs d z + in if isNaN s then -1/0 else s) | + (d, c) <- IntMap.toList ds ]) | + (z, ds) <- IntMap.toList t ] in fst . flip Atom.runAtom (get wordTypeTable m) . M.liftM Text.unlines . mapM format - . IntMap.toList - . IntMap.fromListWith (IntMap.unionWith (+)) - . concatMap (\(d,zs) -> [ (z, IntMap.singleton d c) | (z,c) <- zs ]) - -- Maybe harden - . (if harden - then - map (\(d,zs) -> let s = sum . map snd $ zs - (z',_) = List.maximumBy (Ord.compare `on` snd) zs - in (d, [ (z, if z == z' then s else 0) | (z,_) <- zs ])) - else id) - -- - . IntMap.toList - . IntMap.map IntMap.toList - . LDA.docTopics - . get ldaModel - $ m + $ scores -- | @interpWordClasses m lambda doc@ gives the class probabilities for -- word type in context @doc@ according to evolving model @m@. It @@ -284,8 +304,8 @@ s | s >= 1/0 -> uniform s -> U.map (/s) x --- | @wordTypeClasses m@ returns a Map from word types to unnormalized --- distributions over word classes +-- | @wordTypeClasses m@ returns a Map from word types to a table of +-- counts of word classes wordTypeClasses :: WordClass -> Map.Map Text.Text (IntMap.IntMap Double) wordTypeClasses m = fst . flip Atom.runAtom (get wordTypeTable m) diff --git a/colada.cabal b/colada.cabal --- a/colada.cabal +++ b/colada.cabal @@ -1,5 +1,5 @@ Name: colada -Version: 0.8.0.0 +Version: 0.8.3.0 Synopsis: Colada implements incremental word class class induction using online LDA Description: Colada implements incremental word class class induction using @@ -28,6 +28,7 @@ , bytestring >= 0.9 , mtl >= 2.0 , swift-lda >= 0.7 && < 0.8 + , nlp-scores >= 0.6.3 Exposed-modules: Colada.WordClass , NLP.CoNLL Other-modules: Colada.Features @@ -51,6 +52,7 @@ , bytestring >= 0.9 , mtl >= 2.0 , swift-lda >= 0.7 && < 0.8 + , nlp-scores >= 0.6.3 Other-modules: Colada.WordClass , Colada.Features , NLP.CoNLL diff --git a/colada.hs b/colada.hs --- a/colada.hs +++ b/colada.hs @@ -13,6 +13,8 @@ import qualified Data.List as List import qualified Data.Vector.Generic as V import qualified Data.Vector.Unboxed as U +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap import qualified System.Environment as Env import qualified Data.Label as L import qualified Data.Label.Maybe as M @@ -36,7 +38,8 @@ | Label { _modelPath :: FilePath , _noContext :: Bool } | Summary { _modelPath :: FilePath - ,_harden :: Bool } + ,_summaryType :: C.SummaryType } + | WordTypeClasses { _modelPath :: FilePath } deriving (Show) $(L.mkLabels [''Program]) @@ -64,13 +67,24 @@ summary :: Mode Program summary = - mode "summary" Summary { _modelPath = "model" , _harden = False } + mode "summary" Summary { _modelPath = "model" , _summaryType = C.Soft } "Display summary of word classes" (flagArg (\x p -> Right $ maybe p id (M.set modelPath x p)) "FILE") - [ flagNone ["harden"] (\p -> p { _harden = True }) - "Harden class assignments for summary" + [ flagReq ["summary-type"] (\x p -> case x of + "soft" -> Right $ maybe p id (M.set summaryType C.Soft p) + "hard" -> Right $ maybe p id (M.set summaryType C.Hard p) + "llr" -> Right $ maybe p id (M.set summaryType C.LLR p) + ) + ("soft|hard|llr") "Type of ranking of words in summary" ] +wordTypeClasses :: Mode Program +wordTypeClasses = + mode "word-type-classes" WordTypeClasses { _modelPath = "model" } + "Output unnormalized class distribution for each word type" + (flagArg (\x p -> Right $ maybe p id (M.set modelPath x p)) "FILE") + [ ] + label :: Mode Program label = mode "label" Label { _modelPath = "model" , _noContext = False } @@ -132,7 +146,7 @@ program :: Mode Program program = modes "colada" Help "Word class learning" - [learn, predict, label, summary, help] + [learn, predict, label, summary, wordTypeClasses, help] -- Run the program @@ -168,25 +182,37 @@ m <- C.learnIO o display ss BS.writeFile p . Serialize.encode $ m - Summary { _modelPath = p , _harden = h } -> do + Summary { _modelPath = p , _summaryType = h } -> do m <- parseModel p - if h - then do Text.putStr . C.summarize True $ m - else do Text.putStr . C.summarize False $ m - + Text.putStr . C.summarize h $ m + + WordTypeClasses { _modelPath = p } -> do + m <- parseModel p + Text.putStr . formatWordTypeClasses $ m + +formatWordTypeClasses :: C.WordClass -> Text.Text +formatWordTypeClasses m = + let wtc = C.wordTypeClasses m + size = L.get (C.topicNum . C.options) m + find t i = IntMap.findWithDefault 0 i t + tabulate t = map (Text.pack . Printf.printf "%.1f") + . map (find t) + $ [0 .. size] + in Text.unlines + . map (\ (k, v) -> Text.unwords $ [k] ++ tabulate v) + . Map.toList + $ wtc + 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) - formatFullLabeling = Text.unlines . map (Text.unwords . map (Text.pack . Printf.printf "%.3f") . U.toList) . V.toList - - parseModel :: FilePath -> IO C.WordClass parseModel p = do (either (\err -> error $ "Error reading model " ++ err) id