diff --git a/concraft.cabal b/concraft.cabal --- a/concraft.cabal +++ b/concraft.cabal @@ -1,5 +1,5 @@ name: concraft -version: 0.5.0 +version: 0.6.0 synopsis: Morphological disambiguation based on constrained CRFs description: A morphological disambiguation library based on @@ -15,6 +15,10 @@ homepage: http://zil.ipipan.waw.pl/Concraft build-type: Simple +Flag buildAnaTool + Description: Build model analysis tool + Default: False + library hs-source-dirs: src @@ -28,11 +32,11 @@ , text-binary >= 0.1 && < 0.2 , vector , vector-binary - , crf-chain1-constrained >= 0.1.2 && < 0.2 + , crf-chain1-constrained >= 0.2 && < 0.3 , monad-ox >= 0.3 && < 0.4 - , sgd >= 0.2.2 && < 0.3 + , sgd >= 0.3 && < 0.4 , tagset-positional >= 0.3 && < 0.4 - , crf-chain2-generic >= 0.3 && < 0.4 + , crf-chain2-tiers >= 0.1 && < 0.2 , monad-codec >= 0.2 && < 0.3 , data-lens , transformers @@ -50,8 +54,7 @@ , NLP.Concraft.Disamb other-modules: - NLP.Concraft.Disamb.Tiered - , NLP.Concraft.Disamb.Positional + NLP.Concraft.Disamb.Positional , NLP.Concraft.Morphosyntax.Align , NLP.Concraft.Format.Temp @@ -61,3 +64,17 @@ source-repository head type: git location: https://github.com/kawu/concraft.git + +executable concraft-analyse-model + if flag(buildAnaTool) + build-depends: + cmdargs >= 0.10 && < 0.11 + , logfloat + , Chart + , data-accessor + , colour + else + buildable: False + hs-source-dirs: src, tools + main-is: concraft-analyse-model.hs + ghc-options: -Wall diff --git a/src/NLP/Concraft.hs b/src/NLP/Concraft.hs --- a/src/NLP/Concraft.hs +++ b/src/NLP/Concraft.hs @@ -20,7 +20,6 @@ import Data.Binary (Binary, put, get) import qualified Data.Binary as Binary import Data.Aeson -import Data.Maybe (fromJust) import qualified System.IO.Temp as Temp import qualified Data.ByteString.Lazy as BL import qualified Codec.Compression.GZip as GZip @@ -105,27 +104,27 @@ -> G.TrainConf -- ^ Guessing model training configuration -> D.TrainConf -- ^ Disambiguation model training configuration -> [SentO w P.Tag] -- ^ Training data - -> Maybe [SentO w P.Tag] -- ^ Maybe evaluation data + -> [SentO w P.Tag] -- ^ Evaluation data -> IO Concraft train tagset ana guessNum guessConf disambConf train0 eval0 = do + Temp.withTempDirectory "." ".tmp" $ \tmpDir -> do + let temp = withTemp tagset tmpDir + putStrLn "\n===== Reanalysis =====" trainR <- reAnaPar tagset ana train0 - evalR <- case eval0 of - Just ev -> Just <$> reAnaPar tagset ana ev - Nothing -> return Nothing - withTemp tagset "train" trainR $ \trainR'IO -> do - withTemp' tagset "eval" evalR $ \evalR'IO -> do + evalR <- reAnaPar tagset ana eval0 + temp "train-reana" trainR $ \trainR'IO -> do + temp "eval-reana" evalR $ \evalR'IO -> do putStrLn "\n===== Train guessing model =====" - guesser <- do - tr <- trainR'IO - ev <- evalR'IO - G.train guessConf tr ev - trainG <- map (G.guessSent guessNum guesser) <$> trainR'IO - evalG <- fmap (map (G.guessSent guessNum guesser)) <$> evalR'IO + guesser <- G.train guessConf trainR'IO evalR'IO + trainG <- map (G.guessSent guessNum guesser) <$> trainR'IO + evalG <- map (G.guessSent guessNum guesser) <$> evalR'IO + temp "train-guessed" trainG $ \trainG'IO -> do + temp "eval-guessed" evalG $ \evalG'IO -> do putStrLn "\n===== Train disambiguation model =====" - disamb <- D.train disambConf trainG evalG + disamb <- D.train disambConf trainG'IO evalG'IO return $ Concraft tagset guessNum guesser disamb @@ -140,31 +139,16 @@ withTemp :: (FromJSON w, ToJSON w) => P.Tagset + -> FilePath -- ^ Directory to create the file in -> String -- ^ Template for `Temp.withTempFile` -> [Sent w P.Tag] -- ^ Input dataset -> (IO [Sent w P.Tag] -> IO a) -- ^ Handler -> IO a -withTemp tagset tmpl xs handler = - withTemp' tagset tmpl (Just xs) (handler . fmap fromJust) - - --- | Similar to `withTemp` but on a `Maybe` dataset. --- --- Store dataset on a disk and run a handler on a list which is read --- lazily from the disk. A temporary file will be automatically --- deleted after the handler is done. -withTemp' - :: (FromJSON w, ToJSON w) - => P.Tagset - -> String - -> Maybe [Sent w P.Tag] - -> (IO (Maybe [Sent w P.Tag]) -> IO a) - -> IO a -withTemp' tagset tmpl (Just xs) handler = - Temp.withTempFile "." tmpl $ \tmpPath tmpHandle -> do +withTemp _ _ _ [] handler = handler (return []) +withTemp tagset dir tmpl xs handler = + Temp.withTempFile dir tmpl $ \tmpPath tmpHandle -> do hClose tmpHandle let txtSent = mapSent $ P.showTag tagset tagSent = mapSent $ P.parseTag tagset writePar tmpPath $ map txtSent xs - handler (Just . map tagSent <$> readPar tmpPath) -withTemp' _ _ Nothing handler = handler (return Nothing) + handler (map tagSent <$> readPar tmpPath) diff --git a/src/NLP/Concraft/Disamb.hs b/src/NLP/Concraft/Disamb.hs --- a/src/NLP/Concraft/Disamb.hs +++ b/src/NLP/Concraft/Disamb.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RecordWildCards #-} + module NLP.Concraft.Disamb ( -- * Model Disamb (..) -, Tier.CRF () -- * Tiers , P.Tier (..) @@ -20,6 +20,7 @@ , train ) where + import Control.Applicative ((<$>), (<*>)) import Data.Maybe (fromJust) import Data.List (find) @@ -29,18 +30,18 @@ import qualified Data.Vector as V import qualified Control.Monad.Ox as Ox -import qualified Data.CRF.Chain2.Generic.External as CRF +import qualified Data.CRF.Chain2.Tiers as CRF import NLP.Concraft.Schema hiding (schematize) import qualified NLP.Concraft.Morphosyntax as X -import qualified NLP.Concraft.Disamb.Tiered as Tier import qualified NLP.Concraft.Disamb.Positional as P import qualified Data.Tagset.Positional as T import qualified Numeric.SGD as SGD + -- | Schematize the input sentence with according to 'schema' rules. -schematize :: Schema w t a -> X.Sent w t -> CRF.Sent Ob t +schematize :: Schema w [t] a -> X.Sent w [t] -> CRF.Sent Ob t schematize schema sent = [ CRF.mkWord (obs i) (lbs i) | i <- [0 .. n - 1] ] @@ -51,27 +52,31 @@ lbs i = X.interpsSet w where w = v V.! i + -- | A disambiguation model. data Disamb = Disamb { tiers :: [P.Tier] , schemaConf :: SchemaConf - , crf :: Tier.CRF Ob P.Atom } + , crf :: CRF.CRF Ob P.Atom } + instance Binary Disamb where put Disamb{..} = put tiers >> put schemaConf >> put crf get = Disamb <$> get <*> get <*> get + -- | Unsplit the complex tag (assuming, that it is one -- of the interpretations of the word). unSplit :: Eq t => (r -> t) -> X.Seg w r -> t -> r unSplit split' word x = fromJust $ find ((==x) . split') (X.interps word) + -- | Perform context-sensitive disambiguation. disamb :: X.Word w => Disamb -> X.Sent w T.Tag -> [T.Tag] disamb Disamb{..} sent = map (uncurry embed) . zip sent - . Tier.tag crf + . CRF.tag crf . schematize schema . X.mapSent split $ sent @@ -80,6 +85,7 @@ split = P.split tiers embed = unSplit split + -- | Insert disambiguation results into the sentence. include :: (X.Sent w T.Tag -> [T.Tag]) -> X.Sent w T.Tag -> X.Sent w T.Tag include f sent = @@ -91,42 +97,69 @@ [ (y, if x == y then 1 else 0) | y <- X.interps word ] + -- | Combine `disamb` with `include`. disambSent :: X.Word w => Disamb -> X.Sent w T.Tag -> X.Sent w T.Tag disambSent = include . disamb + -- | Training configuration. data TrainConf = TrainConf { tiersT :: [P.Tier] , schemaConfT :: SchemaConf - , sgdArgsT :: SGD.SgdArgs } + , sgdArgsT :: SGD.SgdArgs + , onDiskT :: Bool + , pruneT :: Maybe Double } + -- | Train disamb model. train :: X.Word w - => TrainConf -- ^ Training configuration - -> [X.Sent w T.Tag] -- ^ Training data - -> Maybe [X.Sent w T.Tag] -- ^ Maybe evaluation data - -> IO Disamb -- ^ Resultant model -train TrainConf{..} trainData evalData'Maybe = do - crf <- Tier.train - (length tiersT) - sgdArgsT - (retSchemed schema split trainData) - (retSchemed schema split <$> evalData'Maybe) - return $ Disamb tiersT schemaConfT crf + => TrainConf -- ^ Training configuration + -> IO [X.Sent w T.Tag] -- ^ Training data + -> IO [X.Sent w T.Tag] -- ^ Evaluation data + -> IO Disamb -- ^ Resultant model +train TrainConf{..} trainData evalData = do + + -- Train first model + crf <- CRF.train (length tiersT) CRF.selectHidden sgdArgsT onDiskT + (schemed schema split <$> trainData) + (schemed schema split <$> evalData) + putStr "\nNumber of features: " >> print (CRF.size crf) + + -- Re-train model if prune parameter is Just + reCrf <- case pruneT of + Just th -> do + putStrLn "\n===== Prune and retrain disambiguation model =====" + crf' <- CRF.reTrain (CRF.prune th crf) + (gainMul 0.5 sgdArgsT) onDiskT + (schemed schema split <$> trainData) + (schemed schema split <$> evalData) + putStr "\nNumber of features: " >> print (CRF.size crf') + return crf' + Nothing -> return crf + + -- Final disamb model + return $ Disamb tiersT schemaConfT reCrf + where - retSchemed sc sp = return . schemed sc sp + schema = fromConf schemaConfT split = P.split tiersT + -- Muliply gain0 parameter by the given number. + gainMul x sgdArgs = + let gain0' = SGD.gain0 sgdArgs * x + in sgdArgs { SGD.gain0 = gain0' } + + -- | Schematized data from the plain file. -schemed :: Ord t => Schema w t a -> (T.Tag -> t) +schemed :: Ord t => Schema w [t] a -> (T.Tag -> [t]) -> [X.Sent w T.Tag] -> [CRF.SentL Ob t] schemed schema split = map onSent where onSent sent = let xs = map (X.mapSeg split) sent - mkDist = CRF.mkDist . M.toList . X.unWMap . X.tags - in zip (schematize schema xs) (map mkDist xs) + mkProb = CRF.mkProb . M.toList . X.unWMap . X.tags + in zip (schematize schema xs) (map mkProb xs) diff --git a/src/NLP/Concraft/Disamb/Tiered.hs b/src/NLP/Concraft/Disamb/Tiered.hs deleted file mode 100644 --- a/src/NLP/Concraft/Disamb/Tiered.hs +++ /dev/null @@ -1,258 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} - -module NLP.Concraft.Disamb.Tiered -( Ob (..) -, Lb (..) -, Feat (..) -, CRF (..) -, train -, tag -) where - -import Control.Applicative ((<$>), (<*>)) -import Control.Comonad.Trans.Store (store) -import Control.Monad (guard) -import Data.Ix (Ix, inRange, range) -import Data.Maybe (catMaybes, fromJust) -import Data.List (zip4, foldl1') -import Data.Lens.Common (Lens(..)) -import Data.Binary (Binary, get, put, Put, Get) -import Data.Vector.Binary () -import qualified Data.Map as M -import qualified Data.Vector as V -import qualified Data.Array.Unboxed as A - -import Data.CRF.Chain2.Generic.Codec - ( Codec(..), mkCodec, encodeDataL - , encodeSent, decodeLabels, unJust ) -import Data.CRF.Chain2.Generic.Model - ( FeatGen(..), Model, selectHidden - , core, withCore ) -import Data.CRF.Chain2.Generic.Internal (FeatIx(..)) -import qualified Data.CRF.Chain2.Generic.Inference as I -import qualified Data.CRF.Chain2.Generic.External as E -import qualified Data.CRF.Chain2.Generic.Train as Train -import qualified Data.CRF.Chain2.Generic.FeatMap as F -import qualified Control.Monad.Codec as C -import qualified Numeric.SGD as SGD - --- | Observation. -newtype Ob = Ob { unOb :: Int } deriving (Show, Eq, Ord, Ix, Binary) - --- | Sublabel. -newtype Lb = Lb { unLb :: Int } deriving (Show, Eq, Ord, Ix, Binary) - --- | Feature. -data Feat - = TFeat3 - { x1 :: {-# UNPACK #-} !Lb - , x2 :: {-# UNPACK #-} !Lb - , x3 :: {-# UNPACK #-} !Lb - , ln :: {-# UNPACK #-} !Int } - | TFeat2 - { x1 :: {-# UNPACK #-} !Lb - , x2 :: {-# UNPACK #-} !Lb - , ln :: {-# UNPACK #-} !Int } - | TFeat1 - { x1 :: {-# UNPACK #-} !Lb - , ln :: {-# UNPACK #-} !Int } - | OFeat - { ob :: {-# UNPACK #-} !Ob - , x1 :: {-# UNPACK #-} !Lb - , ln :: {-# UNPACK #-} !Int } - deriving (Show, Eq, Ord) - -instance Binary Feat where - put (OFeat o x k) = putI 0 >> put o >> put x >> put k - put (TFeat3 x y z k) = putI 1 >> put x >> put y >> put z >> put k - put (TFeat2 x y k) = putI 2 >> put x >> put y >> put k - put (TFeat1 x k) = putI 3 >> put x >> put k - get = getI >>= \i -> case i of - 0 -> OFeat <$> get <*> get <*> get - 1 -> TFeat3 <$> get <*> get <*> get <*> get - 2 -> TFeat2 <$> get <*> get <*> get - 3 -> TFeat1 <$> get <*> get - _ -> error "get feature: unknown code" - -putI :: Int -> Put -putI = put -{-# INLINE putI #-} - -getI :: Get Int -getI = get -{-# INLINE getI #-} - --- | Feature generation for complex [Lb] label type. -featGen :: FeatGen Ob [Lb] Feat -featGen = FeatGen - { obFeats = obFeats' - , trFeats1 = trFeats1' - , trFeats2 = trFeats2' - , trFeats3 = trFeats3' } - where - obFeats' ob' xs = - [ OFeat ob' x k - | (x, k) <- zip xs [0..] ] - trFeats1' xs = - [ TFeat1 x k - | (x, k) <- zip xs [0..] ] - trFeats2' xs1 xs2 = - [ TFeat2 x1' x2' k - | (x1', x2', k) <- - zip3 xs1 xs2 [0..] ] - trFeats3' xs1 xs2 xs3 = - [ TFeat3 x1' x2' x3' k - | (x1', x2', x3', k) <- - zip4 xs1 xs2 xs3 [0..] ] - --- | Codec internal data. The first component is used to --- encode observations of type a, the second one is used to --- encode labels of type [b]. -type CodecData a b = - ( C.AtomCodec a - , V.Vector (C.AtomCodec (Maybe b)) ) - -obLens :: Lens (a, b) a -obLens = Lens $ \(a, b) -> store (\a' -> (a', b)) a - -lbLens :: Int -> Lens (a, V.Vector b) b -lbLens k = Lens $ \(a, b) -> store - (\x -> (a, b V.// [(k, x)])) - (b V.! k) - --- | Codec dependes on the number of layers. -codec :: (Ord a, Ord b) => Int -> Codec a [b] (CodecData a b) Ob [Lb] -codec n = Codec - { empty = - let x = C.execCodec C.empty (C.encode C.idLens Nothing) - in (C.empty, V.replicate n x) - , encodeObU = fmap Ob . C.encode' obLens - , encodeObN = fmap (fmap Ob) . C.maybeEncode obLens - , encodeLbU = \ xs -> sequence - [ Lb <$> C.encode (lbLens k) (Just x) - | (x, k) <- zip xs [0..] ] - , encodeLbN = \ xs -> - let encode lens x = C.maybeEncode lens (Just x) >>= \mx -> case mx of - Just x' -> return x' - Nothing -> fromJust <$> C.maybeEncode lens Nothing - in sequence - [ Lb <$> encode (lbLens k) x - | (x, k) <- zip xs [0..] ] - , decodeLbC = \ xs -> sequence <$> sequence - [ C.decode (lbLens k) (unLb x) - | (x, k) <- zip xs [0..] ] - , hasLabel = \ cdcData xs -> and - [ M.member - (Just x) - (C.to $ snd cdcData V.! k) - | (x, k) <- zip xs [0..] ] } - --- | Dummy feature index. -dummy :: FeatIx -dummy = FeatIx (-1) -{-# INLINE dummy #-} - --- | Transition map restricted to a particular tagging layer. -type TransMap = A.UArray (Lb, Lb, Lb) FeatIx - --- | CRF feature map. -data FeatMap a = FeatMap - { transMaps :: V.Vector TransMap - , otherMap :: M.Map Feat FeatIx } - -instance Binary (FeatMap Feat) where - put FeatMap{..} = put transMaps >> put otherMap - get = FeatMap <$> get <*> get - -instance F.FeatMap FeatMap Feat where - featIndex (TFeat3 x y z k) (FeatMap v _) = do - m <- v V.!? k - ix <- m !? (x, y, z) - guard (ix /= dummy) - return ix - featIndex x (FeatMap _ m) = M.lookup x m - mkFeatMap xs = FeatMap - ( V.fromList - [ mkArray . catMaybes $ - map (getTFeat3 k) xs - | k <- [0 .. maxLayerNum xs] ] ) - (M.fromList (filter (isOther . fst) xs)) - where - maxLayerNum = maximum . map (ln.fst) - getTFeat3 i (TFeat3 x y z j, v) - | i == j = Just ((x, y, z), v) - | otherwise = Nothing - getTFeat3 _ _ = Nothing - isOther (TFeat3 _ _ _ _) = False - isOther _ = True - mkArray ys = - let p = foldl1' updateMin (map fst ys) - q = foldl1' updateMax (map fst ys) - updateMin (!x, !y, !z) (x', y', z') = - (min x x', min y y', min z z') - updateMax (!x, !y, !z) (x', y', z') = - (max x x', max y y', max z z') - zeroed pq = A.array pq [(k, dummy) | k <- range pq] - in zeroed (p, q) A.// ys - -(!?) :: (Ix i, A.IArray a b) => a i b -> i -> Maybe b -m !? x = if inRange (A.bounds m) x - then Just (m A.! x) - else Nothing -{-# INLINE (!?) #-} - --- | CRF model data. -data CRF a b = CRF - { numOfLayers :: Int - , codecData :: CodecData a b - , model :: Model FeatMap Ob [Lb] Feat } - -instance (Ord a, Ord b, Binary a, Binary b) => Binary (CRF a b) where - put CRF{..} = put numOfLayers >> put codecData >> put (core model) - get = CRF <$> get <*> get <*> do - _core <- get - return $ withCore _core featGen - --- | Codec specification given the number of layers. -codecSpec - :: (Ord a, Ord b) => Int - -> Train.CodecSpec a [b] (CodecData a b) Ob [Lb] -codecSpec n = Train.CodecSpec - { Train.mkCodec = mkCodec (codec n) - , Train.encode = encodeDataL (codec n) } - --- | Train the CRF using the stochastic gradient descent method. --- Use the provided feature selection function to determine model --- features. -train - :: (Ord o, Ord t) - => Int -- ^ Number of tagging layers - -> SGD.SgdArgs -- ^ Args for SGD - -> IO [E.SentL o [t]] -- ^ Training data 'IO' action - -> Maybe (IO [E.SentL o [t]]) -- ^ Maybe evalation data - -> IO (CRF o t) -- ^ Resulting model -train n sgdArgs trainIO evalIO'Maybe = do - (_codecData, _model) <- Train.train - sgdArgs - (codecSpec n) - featGen - selectHidden - trainIO - evalIO'Maybe - return $ CRF n _codecData _model - --- | Find the most probable label sequence. -tag :: (Ord o, Ord t) => CRF o t -> E.Sent o [t] -> [[t]] -tag CRF{..} sent - = onWords . decodeLabels cdc codecData - . I.tag model . encodeSent cdc codecData - $ sent - where - cdc = codec numOfLayers - onWords xs = - [ unJust cdc codecData word x - | (word, x) <- zip sent xs ] diff --git a/src/NLP/Concraft/Guess.hs b/src/NLP/Concraft/Guess.hs --- a/src/NLP/Concraft/Guess.hs +++ b/src/NLP/Concraft/Guess.hs @@ -84,26 +84,27 @@ -- | Training configuration. data TrainConf = TrainConf { schemaConfT :: SchemaConf - , sgdArgsT :: SGD.SgdArgs } + , sgdArgsT :: SGD.SgdArgs + -- | Store SGD dataset on disk. + , onDiskT :: Bool } -- | Train guesser. train :: (X.Word w, Ord t) => TrainConf -- ^ Training configuration - -> [X.Sent w t] -- ^ Training data - -> Maybe [X.Sent w t] -- ^ Maybe evaluation data + -> IO [X.Sent w t] -- ^ Training data + -> IO [X.Sent w t] -- ^ Evaluation data -> IO (Guesser t) -train TrainConf{..} trainData evalData'Maybe = do +train TrainConf{..} trainData evalData = do let schema = fromConf schemaConfT - crf <- CRF.train sgdArgsT - (retSchemed schema trainData) - (retSchemed schema <$> evalData'Maybe) + crf <- CRF.train sgdArgsT onDiskT + (schemed schema <$> trainData) + (schemed schema <$> evalData) (const CRF.presentFeats) return $ Guesser schemaConfT crf where - retSchemed schema = return . schemed schema --- | Schematized data from the plain file. +-- | Schematized dataset. schemed :: (X.Word w, Ord t) => Schema w t a -> [X.Sent w t] -> [CRF.SentL Ob t] schemed schema = diff --git a/tools/concraft-analyse-model.hs b/tools/concraft-analyse-model.hs new file mode 100644 --- /dev/null +++ b/tools/concraft-analyse-model.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + +import Control.Applicative ((<$>)) +import Control.Arrow (second) +import Control.Monad (void) +import System.Console.CmdArgs +import Data.List (foldl') +import qualified Data.Map as M +import qualified Data.Number.LogFloat as L + +import Data.Colour.Names +import Data.Colour +import Data.Accessor +import Graphics.Rendering.Chart + +import qualified Data.CRF.Chain2.Tiers.Model as CRF +import qualified Data.CRF.Chain2.Tiers.Feature as CRF +import qualified Data.CRF.Chain2.Tiers as CRF + +import qualified NLP.Concraft as C +import qualified NLP.Concraft.Disamb as D + + +--------------------------------------- +-- Histogram +--------------------------------------- + + +-- | Round double value. +roundTo :: Int -> Double -> Double +roundTo n x = (fromInteger $ round $ x * (10^n)) / (10.0^^n) + + +-- | Make a histogram with a given precision. +hist :: Ord a => [a] -> M.Map a Int +hist = + let update m x = M.insertWith' (+) x 1 m + in foldl' update M.empty + + +--------------------------------------- +-- Rendering +--------------------------------------- + + +drawModel :: Int -> CRF.Model -> FilePath -> IO () +drawModel rnParam model filePath = do + + void $ renderableToPNGFile (toRenderable layout) 640 480 filePath + + where + + -- Feature map with values in log domain + featMap = L.logFromLogFloat <$> CRF.toMap model + + -- Values assigned to observation features + obVals = [x | (ft, x) <- M.assocs featMap, isOFeat ft] + + -- Values assigned to transition features + trVals = [x | (ft, x) <- M.assocs featMap, not (isOFeat ft)] + + -- Is it an observation feature? + isOFeat (CRF.OFeat _ _ _) = True + isOFeat _ = False + + -- Make log-domain histogram + mkHist = map (second intLog) . M.toList . hist . map (roundTo rnParam) + + obChart = + plot_lines_style .> line_color ^= opaque blue + $ plot_lines_values ^= [mkHist obVals] + $ plot_lines_title ^= "Observation features" + $ defaultPlotLines + + trChart = + plot_lines_style .> line_color ^= opaque green + $ plot_lines_values ^= [mkHist trVals] + $ plot_lines_title ^= "Transition features" + $ defaultPlotLines + + layout = + layout1_left_axis ^: laxis_override ^= axisGridHide + $ layout1_right_axis ^: laxis_override ^= axisGridHide + $ layout1_bottom_axis ^: laxis_override ^= axisGridHide + $ layout1_plots ^= [Left (toPlot obChart), Right (toPlot trChart)] + $ layout1_grid_last ^= False + $ defaultLayout1 + + +-- | Int logarithm. +intLog :: Int -> Double +intLog = (log :: Double -> Double) . fromIntegral + + +--------------------------------------- +-- Command line options +--------------------------------------- + + +data AnaModel = AnaModel + { inModel :: FilePath + , outFile :: FilePath + , rnParam :: Int } + deriving (Data, Typeable, Show) + + +anaModel :: AnaModel +anaModel = AnaModel + { inModel = def &= argPos 0 &= typ "MODEL-FILE" + , outFile = def &= argPos 1 &= typ "OUTPUT-FILE" + , rnParam = 1 &= help "Rounding parameter" } + + +--------------------------------------- +-- Main +--------------------------------------- + + +main :: IO () +main = exec =<< cmdArgs anaModel + + +exec :: AnaModel -> IO () +exec AnaModel{..} = do + model <- CRF.model . D.crf . C.disamb <$> C.loadModel inModel + drawModel rnParam model outFile