concraft 0.5.0 → 0.6.0

raw patch · 6 files changed

+234/−329 lines, 6 filesdep +Chartdep +cmdargsdep +colourdep −crf-chain2-genericdep ~crf-chain1-constraineddep ~sgdnew-component:exe:concraft-analyse-modelPVP ok

version bump matches the API change (PVP)

Dependencies added: Chart, cmdargs, colour, crf-chain2-tiers, data-accessor, logfloat

Dependencies removed: crf-chain2-generic

Dependency ranges changed: crf-chain1-constrained, sgd

API changes (from Hackage documentation)

Files

• concraft.cabal +23/−6
• src/NLP/Concraft.hs +18/−34
• src/NLP/Concraft/Disamb.hs +55/−22
• src/NLP/Concraft/Disamb/Tiered.hs +0/−258
• src/NLP/Concraft/Guess.hs +10/−9
• tools/concraft-analyse-model.hs +128/−0

@@ -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

@@ -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)

@@ -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)

@@ -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 ]

@@ -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 =

@@ -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