concraft 0.9.4 → 0.11.0

raw patch · 21 files changed

+3168/−69 lines, 21 filesdep +data-memocombinatorsdep +paralleldep +pedestrian-dagdep ~aesondep ~binarydep ~comonadPVP ok

version bump matches the API change (PVP)

Dependencies added: data-memocombinators, parallel, pedestrian-dag

Dependency ranges changed: aeson, binary, comonad, crf-chain1-constrained, crf-chain2-tiers, data-lens, sgd, temporary, text-binary, transformers, vector, zlib

API changes (from Hackage documentation)

Files

• concraft.cabal +30/−14
• src/NLP/Concraft.hs +22/−3
• src/NLP/Concraft/Analysis.hs +1/−0
• src/NLP/Concraft/DAG/Disamb.hs +333/−0
• src/NLP/Concraft/DAG/DisambSeg.hs +270/−0
• src/NLP/Concraft/DAG/Guess.hs +352/−0
• src/NLP/Concraft/DAG/Morphosyntax.hs +138/−0
• src/NLP/Concraft/DAG/Morphosyntax/Accuracy.hs +304/−0
• src/NLP/Concraft/DAG/Morphosyntax/Ambiguous.hs +65/−0
• src/NLP/Concraft/DAG/Schema.hs +393/−0
• src/NLP/Concraft/DAG/Segmentation.hs +334/−0
• src/NLP/Concraft/DAG2.hs +369/−0
• src/NLP/Concraft/DAGSeg.hs +436/−0
• src/NLP/Concraft/Disamb.hs +5/−5
• src/NLP/Concraft/Disamb/Positional.hs +29/−14
• src/NLP/Concraft/Format/Temp.hs +10/−1
• src/NLP/Concraft/Guess.hs +7/−4
• src/NLP/Concraft/Morphosyntax.hs +9/−28
• src/NLP/Concraft/Morphosyntax/Accuracy.hs +1/−0
• src/NLP/Concraft/Morphosyntax/Align.hs +1/−0
• src/NLP/Concraft/Morphosyntax/WMap.hs +59/−0

@@ -1,5 +1,5 @@ name:               concraft-version:            0.9.4+version:            0.11.0 synopsis:           Morphological disambiguation based on constrained CRFs description:     A morphological disambiguation library based on@@ -7,7 +7,7 @@ license:            BSD3 license-file:       LICENSE cabal-version:      >= 1.6-copyright:          Copyright (c) 2011 Jakub Waszczuk, 2012 IPI PAN+copyright:          Copyright (c) 2011-2018 Jakub Waszczuk, 2012 IPI PAN author:             Jakub Waszczuk maintainer:         waszczuk.kuba@gmail.com stability:          experimental@@ -26,26 +26,29 @@         base                    >= 4        && < 5       , array                   >= 0.4      && < 0.6       , containers              >= 0.4      && < 0.6-      , binary                  >= 0.5      && < 0.8+      , binary                  >= 0.5      && < 0.9       , bytestring              >= 0.9      && < 0.11       , text                    >= 0.11     && < 1.3-      , text-binary             >= 0.1      && < 0.2-      , vector                  >= 0.10     && < 0.11+      , text-binary             >= 0.1      && < 0.3+      , vector                  >= 0.10     && < 0.13       , vector-binary           >= 0.1      && < 0.2       , monad-ox                >= 0.3      && < 0.4-      , sgd                     >= 0.3.3    && < 0.4+      , sgd                     >= 0.4.0    && < 0.5       , tagset-positional       >= 0.3      && < 0.4-      , crf-chain1-constrained  >= 0.3      && < 0.4-      , crf-chain2-tiers        >= 0.2.1    && < 0.3+      , crf-chain1-constrained  >= 0.4      && < 0.5+      , crf-chain2-tiers        >= 0.3      && < 0.4       , monad-codec             >= 0.2      && < 0.3-      , data-lens               >= 2.10     && < 2.11-      , transformers            >= 0.2      && < 0.5-      , comonad                 >= 4.0      && < 4.3-      , temporary               >= 1.1      && < 1.2-      , aeson                   >= 0.6      && < 0.9-      , zlib                    >= 0.5      && < 0.6+      , data-lens               >= 2.10     && < 2.12+      , transformers            >= 0.2      && < 0.6+      , comonad                 >= 4.0      && < 5.1+      , aeson                   >= 0.6      && < 1.3+      , zlib                    >= 0.5      && < 0.7       , lazy-io                 >= 0.1      && < 0.2       , cmdargs                 >= 0.10     && < 0.11+      , pedestrian-dag          >= 0.2      && < 0.3+      , temporary               >= 1.1      && < 1.3+      , parallel                >= 3.2      && < 3.3+      , data-memocombinators    >= 0.5.1    && < 0.6      exposed-modules:         NLP.Concraft@@ -54,7 +57,20 @@       , NLP.Concraft.Guess       , NLP.Concraft.Disamb       , NLP.Concraft.Morphosyntax+      , NLP.Concraft.Morphosyntax.WMap       , NLP.Concraft.Morphosyntax.Accuracy++      , NLP.Concraft.DAG.Morphosyntax+      , NLP.Concraft.DAG.Morphosyntax.Accuracy+      , NLP.Concraft.DAG.Morphosyntax.Ambiguous+      , NLP.Concraft.DAG.Segmentation+      , NLP.Concraft.DAG.Schema+      , NLP.Concraft.DAG.Guess+      , NLP.Concraft.DAG.Disamb+      , NLP.Concraft.DAG.DisambSeg+      -- , NLP.Concraft.DAG+      , NLP.Concraft.DAG2+      , NLP.Concraft.DAGSeg      other-modules:         NLP.Concraft.Disamb.Positional

@@ -3,7 +3,7 @@  module NLP.Concraft (--- * Model +-- * Model   Concraft (..) , saveModel , loadModel@@ -21,6 +21,7 @@ ) where  +import           Prelude hiding (Word) import           System.IO (hClose) import           Control.Applicative ((<$>), (<*>)) import           Control.Monad (when)@@ -233,5 +234,23 @@     hClose tmpHandle     let txtSent = mapSent $ P.showTag tagset         tagSent = mapSent $ P.parseTag tagset-    writePar tmpPath $ map txtSent xs-    handler (map tagSent <$> readPar tmpPath)+    -- writePar tmpPath $ map txtSent xs+    -- handler (map tagSent <$> readPar tmpPath)+    handler (return xs)++-- 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 _      _   _    [] 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 (map tagSent <$> readPar tmpPath)

@@ -15,6 +15,7 @@ ) where  +import           Prelude hiding (Word) import qualified Control.Monad.LazyIO as LazyIO import qualified Data.Text.Lazy as L 

@@ -0,0 +1,333 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections #-}+++module NLP.Concraft.DAG.Disamb+(+-- * Types+  Disamb (..)+, putDisamb+, getDisamb++-- * Tiers+, P.Tier (..)+, P.Atom (..)++-- -- * Marginals+-- , marginalsSent+-- , marginals++-- * Probs in general+, CRF.ProbType (..)+, probsSent+, probs++-- * Training+, TrainConf (..)+, train++-- * Pruning+, prune++-- * Internal+, schematize+) where+++import Prelude hiding (words)+import Control.Applicative ((<$>), (<*>), pure)+import Data.Binary (Binary, put, get, Put, Get)+import Data.Text.Binary ()+import System.Console.CmdArgs+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Vector as V+import qualified Data.List as List++import qualified Data.DAG as DAG+import           Data.DAG (DAG)++import qualified Control.Monad.Ox as Ox+import qualified Numeric.SGD.Momentum as SGD+import qualified Data.CRF.Chain2.Tiers.DAG as CRF+import qualified Data.Tagset.Positional as T++-- import           NLP.Concraft.Schema hiding (schematize)+-- import qualified NLP.Concraft.Morphosyntax as X+import qualified NLP.Concraft.Disamb.Positional as P+import           NLP.Concraft.DAG.Schema hiding (schematize)+import qualified NLP.Concraft.DAG.Morphosyntax as X+++-- | A disambiguation model.+data Disamb t = Disamb+    { tiers         :: [P.Tier]+    , schemaConf    :: SchemaConf+    , crf           :: CRF.CRF Ob P.Atom+    -- , simpliMap     :: M.Map t T.Tag+    , simplify      :: t -> T.Tag+      -- ^ A map which simplifies the tags of generic type `t` to simplified+      -- positional tags. The motivation behind this is that tags can have a+      -- richer structure.+      --+      -- NOTE: it can happen in real situations that a tag is encountered which+      -- is not known by the model. It would be nice to be able to treat it as+      -- the closest tag that can be handled. Then, one have to define the+      -- notion of the similarilty between tags, though... But probably it+      -- should be done at a different level (where more information about the+      -- structure of `t` is known)+    }+++-- instance (Binary t) => Binary (Disamb t) where+--     put Disamb{..} = put tiers >> put schemaConf >> put crf >> put simpliMap+--     get = Disamb <$> get <*> get <*> get <*> get+++-- | Store the entire disambiguation model apart from the simplification+-- function.+putDisamb :: Disamb t -> Put+putDisamb Disamb{..} =+  put tiers >> put schemaConf >> put crf+++-- | Get the disambiguation model, provided the simplification function.+-- getDisamb :: (M.Map t T.Tag) -> Get (Disamb t)+getDisamb :: (t -> T.Tag) -> Get (Disamb t)+getDisamb smp =+  Disamb <$> get <*> get <*> get <*> pure smp+++--------------------------+-- Simplify+--------------------------+++-- -- | Simplify the given label.+-- simplify :: (Ord t) => Disamb t -> t -> T.Tag+-- simplify Disamb{..} x =+--   case M.lookup x simpliMap of+--     Nothing -> defaultTag+--     Just y -> y+--   where+--     defaultTag = snd $ M.findMin simpliMap+++--------------------------+-- Schematize+--------------------------+++-- | Schematize the input sentence according to 'schema' rules.+schematize :: Schema w [t] a -> X.Sent w [t] -> CRF.Sent Ob t+schematize schema sent =+  DAG.mapE f sent+  where+    f i = const $ CRF.mkWord (obs i) (lbs i)+    obs = S.fromList . Ox.execOx . schema sent+    lbs i = X.interpsSet w+      where w = DAG.edgeLabel i sent+++-- --------------------------+-- -- Marginals+-- --------------------------+--+--+-- -- | Determine the marginal probabilities of to individual labels in the sentence.+-- marginals :: (X.Word w, Ord t) => Disamb t -> X.Sent w t -> DAG () (X.WMap t)+-- marginals dmb = fmap X.tags . marginalsSent dmb+--+--+-- -- | Determine the marginal probabilities of to individual labels in the sentence.+-- -- marginalsSent :: (X.Word w, Ord t) => Disamb t -> X.Sent w t -> DAG () (X.WMap [P.Atom])+-- marginalsSent :: (X.Word w, Ord t) => Disamb t -> X.Sent w t -> X.Sent w t+-- marginalsSent dmb sent+--   = (\new -> inject dmb new sent)+--   . fmap getTags+--   . marginalsCRF dmb+--   $ sent+--   where+--     getTags = X.mkWMap . M.toList . choice -- CRF.unProb . snd+--     -- below we mix the chosen and the potential interpretations together+--     choice w = M.unionWith (+)+--       (CRF.unProb . snd $ w)+--       (M.fromList . map (,0) . interps $ w)+--     interps = S.toList . CRF.lbs . fst+--+--+-- -- | Ascertain the marginal probabilities of the individual labels in the sentence.+-- marginalsCRF :: (X.Word w, Ord t) => Disamb t -> X.Sent w t -> CRF.SentL Ob P.Atom+-- marginalsCRF dmb+--   = CRF.marginals (crf dmb)+--   . schematize schema+--   . X.mapSent (split . simplify dmb)+--   where+--     schema = fromConf (schemaConf dmb)+--     split  = P.split (tiers dmb)+++--------------------------+-- Injection+--------------------------+++-- | Replace the probabilities of the sentence labels with the new probabilities+-- stemming from the CRF sentence.+inject+  :: (Ord t, X.Word w)+  => Disamb t+  -> DAG () (X.WMap [P.Atom])+  -> X.Sent w t+  -> X.Sent w t+inject dmb newSent srcSent =+  let doit (target, src) =+        let oldTags = X.tags src+            newTags = injectWMap dmb target oldTags+        in  src {X.tags = newTags}+  in  fmap doit (DAG.zipE newSent srcSent)+++-- | Replace label probabilities with the new probabilities.+injectWMap+  :: (Ord t)+  => Disamb t+  -> X.WMap [P.Atom]+  -> X.WMap t+  -> X.WMap t+injectWMap dmb newSpl src = X.mkWMap+  [ ( tag+    , maybe 0 id $+      M.lookup (P.split (tiers dmb) (simplify dmb tag) Nothing) (X.unWMap newSpl) )+  | (tag, _) <- M.toList (X.unWMap src) ]+++-- -- | Unsplit a 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 = case jy of+--     Just y  -> y+--     Nothing -> error "unSplit: no such interpretation"+--   where+--     jy = List.find ((==x) . split) (X.interps word)+++--------------------------+-- Probs in general+--------------------------+++-- | Determine the marginal probabilities of to individual labels in the sentence.+probs :: (X.Word w, Ord t) => CRF.ProbType -> Disamb t -> X.Sent w t -> DAG () (X.WMap t)+probs probTyp dmb = fmap X.tags . probsSent probTyp dmb+++-- | Determine the marginal probabilities of to individual labels in the sentence.+-- marginalsSent :: (X.Word w, Ord t) => Disamb t -> X.Sent w t -> DAG () (X.WMap [P.Atom])+probsSent :: (X.Word w, Ord t) => CRF.ProbType -> Disamb t -> X.Sent w t -> X.Sent w t+probsSent probTyp dmb sent+  = (\new -> inject dmb new sent)+  . fmap getTags+  . probsCRF probTyp dmb+  $ sent+  where+    getTags = X.mkWMap . M.toList . choice -- CRF.unProb . snd+    -- below we mix the chosen and the potential interpretations together+    choice w = M.unionWith (+)+      (CRF.unProb . snd $ w)+      (M.fromList . map (,0) . interps $ w)+    interps = S.toList . CRF.lbs . fst+++++-- | Ascertain the marginal probabilities of the individual labels in the sentence.+probsCRF :: (X.Word w, Ord t) => CRF.ProbType -> Disamb t -> X.Sent w t -> CRF.SentL Ob P.Atom+probsCRF probTyp dmb+  = CRF.probs probTyp (crf dmb)+  . schematize schema+  . X.mapSent (split . simplify dmb)+  where+    schema = fromConf (schemaConf dmb)+    split  = \t -> P.split (tiers dmb) t Nothing+++--------------------------+-- Pruning+--------------------------+++-- | Prune disamb model: discard model features with absolute values+-- (in log-domain) lower than the given threshold.+prune :: Double -> Disamb t -> Disamb t+prune x dmb =+    let crf' = CRF.prune x (crf dmb)+    in  dmb { crf = crf' }+++--------------------------+-- Training+--------------------------+++-- | Training configuration.+data TrainConf t = TrainConf+  { tiersT      :: [P.Tier]+  , schemaConfT :: SchemaConf+  , sgdArgsT    :: SGD.SgdArgs+  , onDiskT     :: Bool+  -- | Label simplification function+  , simplifyLabel :: t -> T.Tag+  }+++-- | Train disambiguation module.+train+    :: (X.Word w, Ord t)+    => TrainConf t      -- ^ Training configuration+    -> IO [X.Sent w t]  -- ^ Training data+    -> IO [X.Sent w t]  -- ^ Evaluation data+    -> IO (Disamb t)+train TrainConf{..} trainData evalData = do+--   tagSet <- S.unions . map tagSetIn <$> trainData+--   putStr "\nTagset size: " >> print (S.size tagSet)+--   let tagMap = M.fromList+--         [ (t, simplifyLabel t)+--         | t <- S.toList tagSet ]+  crf <- CRF.train (length tiersT) CRF.selectHidden sgdArgsT onDiskT+    (schemed simplifyLabel schema split <$> trainData)+    (schemed simplifyLabel schema split <$> evalData)+  putStr "\nNumber of features: " >> print (CRF.size crf)+  return $ Disamb tiersT schemaConfT crf simplifyLabel -- tagMap+  where+    schema = fromConf schemaConfT+    split  = \t -> P.split tiersT t Nothing+++-- | Schematized dataset.+schemed+  -- :: (X.Word w, Ord t)+  :: (Ord a)+  => (t -> T.Tag)+  -> Schema w [a] b+  -> (T.Tag -> [a])+  -> [X.Sent w t]+  -> [CRF.SentL Ob a]+schemed simpl schema split =+    map onSent+  where+    onSent sent =+        let xs = fmap (X.mapSeg split) (X.mapSent simpl sent)+            mkProb = CRF.mkProb . M.toList . X.unWMap . X.tags+        -- in  fmap (uncurry CRF.mkWordL) $+        in  DAG.zipE (schematize schema xs) (fmap mkProb xs)+++-- -- | Retrieve the tagset in the given sentence.+-- tagSetIn :: (Ord t) => X.Sent w t -> S.Set t+-- tagSetIn dag = S.fromList+--   [ tag+--   | edgeID <- DAG.dagEdges dag+--   , let edge = DAG.edgeLabel edgeID dag+--   , tag <- M.keys . X.unWMap . X.tags $ edge ]

@@ -0,0 +1,270 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections #-}+++-- | A version of the disambigation model adapted to perform sentence+-- segmentation as well.+++module NLP.Concraft.DAG.DisambSeg+(+-- * Types+  Tag (..)+, Disamb (..)+, putDisamb+, getDisamb++-- * Tiers+, P.Tier (..)+, P.Atom (..)++-- -- * Marginals+-- , marginalsSent+-- , marginals++-- * Probs in general+, CRF.ProbType (..)+, probsSent+, probs++-- * Training+, TrainConf (..)+, train++-- * Pruning+, prune+) where+++import Prelude hiding (words)+import Control.Applicative ((<$>), (<*>), pure)+import Data.Binary (Binary, put, get, Put, Get)+import Data.Text.Binary ()+import System.Console.CmdArgs+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Vector as V+import qualified Data.List as List++import qualified Data.DAG as DAG+import           Data.DAG (DAG)++import qualified Control.Monad.Ox as Ox+import qualified Numeric.SGD.Momentum as SGD+import qualified Data.CRF.Chain2.Tiers.DAG as CRF+import qualified Data.Tagset.Positional as T++-- import           NLP.Concraft.Schema hiding (schematize)+-- import qualified NLP.Concraft.Morphosyntax as X+import qualified NLP.Concraft.Disamb.Positional as P+import           NLP.Concraft.DAG.Schema hiding (schematize)+import qualified NLP.Concraft.DAG.Morphosyntax as X++import NLP.Concraft.DAG.Disamb (schematize)+++-- | The internal tag type.+data Tag = Tag+  { posiTag :: T.Tag+    -- ^ Positional tag+  , hasEos :: Bool+    -- ^ End-of-sentence marker+  } deriving (Show, Eq, Ord)+++-- | A disambiguation model.+data Disamb t = Disamb+    { tiers         :: [P.Tier]+    , schemaConf    :: SchemaConf+    , crf           :: CRF.CRF Ob P.Atom+    , simplify      :: t -> Tag+      -- ^ A function which simplifies the tags of the generic type `t` to (i)+      -- the corresponding positional tags and (ii) information if the segment+      -- represents sentence end.+      --+      -- NOTE: it can happen in real situations that a tag is encountered which+      -- is not known by the model. It would be nice to be able to treat it as+      -- the closest tag that can be handled. Then, one have to define the+      -- notion of the similarilty between tags, though... But probably it+      -- should be done at a different level (where more information about the+      -- structure of `t` is known)+    }+++-- | Store the entire disambiguation model apart from the simplification+-- function.+putDisamb :: Disamb t -> Put+putDisamb Disamb{..} =+  put tiers >> put schemaConf >> put crf+++-- | Get the disambiguation model, provided the simplification function.+-- getDisamb :: (M.Map t T.Tag) -> Get (Disamb t)+getDisamb :: (t -> Tag) -> Get (Disamb t)+getDisamb smp =+  Disamb <$> get <*> get <*> get <*> pure smp+++--------------------------+-- Injection+--------------------------+++-- | Replace the probabilities of the sentence labels with the new probabilities+-- stemming from the CRF sentence.+inject+  :: (Ord t, X.Word w)+  => Disamb t+  -> DAG () (X.WMap [P.Atom])+  -> X.Sent w t+  -> X.Sent w t+inject dmb newSent srcSent =+  let doit (target, src) =+        let oldTags = X.tags src+            newTags = injectWMap dmb target oldTags+        in  src {X.tags = newTags}+  in  fmap doit (DAG.zipE newSent srcSent)+++-- | Replace label probabilities with the new probabilities.+injectWMap+  :: (Ord t)+  => Disamb t+  -> X.WMap [P.Atom]+  -> X.WMap t+  -> X.WMap t+injectWMap dmb newSpl src = X.mkWMap+  [ ( tag+    , maybe 0 id $+      M.lookup (split (tiers dmb) (simplify dmb tag)) (X.unWMap newSpl) )+  | (tag, _) <- M.toList (X.unWMap src) ]+++--------------------------+-- Probs in general+--------------------------+++-- | Determine the marginal probabilities of to individual labels in the sentence.+probs :: (X.Word w, Ord t) => CRF.ProbType -> Disamb t -> X.Sent w t -> DAG () (X.WMap t)+probs probTyp dmb = fmap X.tags . probsSent probTyp dmb+++-- | Determine the marginal probabilities of to individual labels in the sentence.+-- marginalsSent :: (X.Word w, Ord t) => Disamb t -> X.Sent w t -> DAG () (X.WMap [P.Atom])+probsSent :: (X.Word w, Ord t) => CRF.ProbType -> Disamb t -> X.Sent w t -> X.Sent w t+probsSent probTyp dmb sent+  = (\new -> inject dmb new sent)+  . fmap getTags+  . probsCRF probTyp dmb+  $ sent+  where+    getTags = X.mkWMap . M.toList . choice -- CRF.unProb . snd+    -- below we mix the chosen and the potential interpretations together+    choice w = M.unionWith (+)+      (CRF.unProb . snd $ w)+      (M.fromList . map (,0) . interps $ w)+    interps = S.toList . CRF.lbs . fst+++++-- | Ascertain the marginal probabilities of the individual labels in the sentence.+probsCRF :: (X.Word w, Ord t) => CRF.ProbType -> Disamb t -> X.Sent w t -> CRF.SentL Ob P.Atom+probsCRF probTyp dmb+  = CRF.probs probTyp (crf dmb)+  . schematize schema+  . X.mapSent (split (tiers dmb) . simplify dmb)+  where+    schema = fromConf (schemaConf dmb)+++--------------------------+-- Pruning+--------------------------+++-- | Prune disamb model: discard model features with absolute values+-- (in log-domain) lower than the given threshold.+prune :: Double -> Disamb t -> Disamb t+prune x dmb =+    let crf' = CRF.prune x (crf dmb)+    in  dmb { crf = crf' }+++--------------------------+-- Training+--------------------------+++-- | Training configuration.+data TrainConf t = TrainConf+  { tiersT      :: [P.Tier]+  , schemaConfT :: SchemaConf+  , sgdArgsT    :: SGD.SgdArgs+  , onDiskT     :: Bool+  -- | Label simplification function+  , simplifyLabel :: t -> Tag+  }+++-- | Train disambiguation module.+train+    :: (X.Word w, Ord t)+    => TrainConf t      -- ^ Training configuration+    -> IO [X.Sent w t]  -- ^ Training data+    -> IO [X.Sent w t]  -- ^ Evaluation data+    -> IO (Disamb t)+train TrainConf{..} trainData evalData = do+--   tagSet <- S.unions . map tagSetIn <$> trainData+--   putStr "\nTagset size: " >> print (S.size tagSet)+--   let tagMap = M.fromList+--         [ (t, simplifyLabel t)+--         | t <- S.toList tagSet ]+  crf <- CRF.train (length tiersT) CRF.selectHidden sgdArgsT onDiskT+    (schemed simplifyLabel schema (split tiersT) <$> trainData)+    (schemed simplifyLabel schema (split tiersT) <$> evalData)+  putStr "\nNumber of features: " >> print (CRF.size crf)+  return $ Disamb tiersT schemaConfT crf simplifyLabel -- tagMap+  where+    schema = fromConf schemaConfT+++-- | Schematized dataset.+schemed+  -- :: (X.Word w, Ord t)+  :: (Ord a)+  => (t -> Tag)+  -> Schema w [a] b+  -> (Tag -> [a])+  -> [X.Sent w t]+  -> [CRF.SentL Ob a]+schemed simpl schema split =+    map onSent+  where+    onSent sent =+        let xs = fmap (X.mapSeg split) (X.mapSent simpl sent)+            mkProb = CRF.mkProb . M.toList . X.unWMap . X.tags+        -- in  fmap (uncurry CRF.mkWordL) $+        in  DAG.zipE (schematize schema xs) (fmap mkProb xs)+++-- -- | Retrieve the tagset in the given sentence.+-- tagSetIn :: (Ord t) => X.Sent w t -> S.Set t+-- tagSetIn dag = S.fromList+--   [ tag+--   | edgeID <- DAG.dagEdges dag+--   , let edge = DAG.edgeLabel edgeID dag+--   , tag <- M.keys . X.unWMap . X.tags $ edge ]++++--------------------------+-- Utils+--------------------------+++-- | Split the tag with respect to the given tiers.+split :: [P.Tier] -> Tag -> [P.Atom]+split tiers tag = P.split tiers (posiTag tag) (Just $ hasEos tag)

@@ -0,0 +1,352 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections #-}+++module NLP.Concraft.DAG.Guess+(+-- * Types+  Guesser (..)+, putGuesser+, getGuesser++-- * Marginals+, marginals+, marginalsSent++-- -- * Guessing+-- , guess+-- , include+-- , guessSent++-- * Training+, TrainConf (..)+, R0T (..)+, train++-- * Utils+, schemed+) where+++import Prelude hiding (words)+import Control.Applicative ((<$>), (<*>), pure)+import Data.Binary (Binary, put, get, Put, Get)+import Data.Text.Binary ()+import System.Console.CmdArgs+import qualified Data.Set as S+import qualified Data.Map.Strict as M+-- import qualified Data.Vector as V++import qualified Data.DAG as DAG+import           Data.DAG (DAG)++import qualified Control.Monad.Ox as Ox+-- import qualified Data.CRF.Chain1.Constrained as CRF+import qualified Data.CRF.Chain1.Constrained.DAG as CRF+-- import qualified Data.CRF.Chain1.Constrained.Dataset.External as CRF.Ext+import qualified Numeric.SGD.Momentum as SGD++-- import           NLP.Concraft.Schema hiding (schematize)+-- import qualified NLP.Concraft.Morphosyntax as X+import           NLP.Concraft.DAG.Schema hiding (schematize)+import qualified NLP.Concraft.DAG.Morphosyntax as X+++-- | A guessing model.+data Guesser t s = Guesser+    { schemaConf    :: SchemaConf+    , crf           :: CRF.CRF Ob s+    , zeroProbLab   :: s+    , unkTagSet     :: S.Set t+      -- ^ The tagset considered for the unknown words (TODO: a solution+      -- parallel and not 100% consistent with what is implemented in the CRF+      -- library)+    , simplify      :: t -> s+      -- ^ A tag simplification function+    }+++-- instance (Ord t, Binary t, Ord s, Binary s) => Binary (Guesser t s) where+--     put Guesser{..} = do+--       put schemaConf+--       put crf+--       put zeroProbLab+--       put simpliMap+--     get = Guesser <$> get <*> get <*> get <*> get+++-- | Store the entire guessing model apart from the simplification function.+putGuesser :: (Binary t, Binary s, Ord s) => Guesser t s -> Put+putGuesser Guesser{..} = do+  put schemaConf+  put crf+  put zeroProbLab+  put unkTagSet+++-- | Get the disambiguation model, provided the simplification function.+-- getGuesser :: (M.Map t T.Tag) -> Get (Guesser t)+getGuesser :: (Binary t, Binary s, Ord s) => (t -> s) -> Get (Guesser t s)+getGuesser smp =+  Guesser <$> get <*> get <*> get <*> get <*> pure smp+++-- --------------------------+-- -- Simplify+-- --------------------------+--+--+-- -- | Simplify the given label.+-- simplify :: (Ord t) => Guesser t s -> t -> s+-- simplify Guesser{..} x =+--   case M.lookup x simpliMap of+--     Nothing -> zeroProbLab+--     Just y -> y+++--------------------------+-- Schematize+--------------------------+++-- | Schematize the input sentence according to the 'schema' rules.+-- TODO: looks like there is no reason at all for `Schema w t a` to+-- be parametrized with `t`?+schematize :: (X.Word w) => Schema w t a -> X.Sent w t -> CRF.Sent Ob t+schematize schema sent =+  DAG.mapE f sent+  where+    f i = const $ CRF.Word (obs i) (lbs i)+    obs = S.fromList . Ox.execOx . schema sent+    lbs i+      | X.oov w  = S.empty+      | otherwise = X.interpsSet w+      where w = DAG.edgeLabel i sent+++--------------------------+-- Marginals+--------------------------+++-- | Determine the marginal probabilities of the individual labels in the sentence.+marginals :: (X.Word w, Ord t, Ord s) => Guesser t s -> X.Sent w t -> DAG () (X.WMap t)+marginals gsr = fmap X.tags . marginalsSent gsr+++-- | Replace the probabilities of the sentence labels with the marginal probabilities+-- stemming from the model.+marginalsSent :: (X.Word w, Ord t, Ord s) => Guesser t s -> X.Sent w t -> X.Sent w t+marginalsSent gsr sent+  = (\new -> inject gsr new sent)+  . fmap tags+  . marginalsCRF gsr+  $ sent+  where+    tags = X.mkWMap . M.toList . considerZero . choice+    -- we mix the chosen and the potential interpretations together+    choice w = M.unionWith (+)+      (CRF.unProb . CRF.choice $ w)+      (M.fromList . map (,0) . interps $ w)+    interps = S.toList . CRF.lbs . CRF.word+    -- if empty, we choose the zero probability label.+    considerZero m+      | M.null m = M.singleton (zeroProbLab gsr) 0+      | otherwise = m+++-- | Ascertain the marginal probabilities of to individual labels in the sentence.+marginalsCRF :: (X.Word w, Ord t, Ord s) => Guesser t s -> X.Sent w t -> CRF.SentL Ob s+marginalsCRF gsr dag0 =+  let schema = fromConf (schemaConf gsr)+      dag = X.mapSent (simplify gsr) dag0+  in  CRF.marginals (crf gsr) (schematize schema dag)+++-- -- | Replace the probabilities of the sentence labels with the new probabilities+-- -- stemming from the CRF sentence.+-- inject :: DAG () (X.WMap t) -> X.Sent w t -> X.Sent w t+-- inject newSent srcSent =+--   let doit (new, src) = src {X.tags = new}+--   in  fmap doit (DAG.zipE newSent srcSent)+++-- | Replace the probabilities of the sentence labels with the new probabilities+-- stemming from the CRF sentence.+--+-- TODO: The behavior for OOV words seems unoptimal, since all possible labels+-- are taken into account, and not only the default CRF ones.  Still, it's not+-- necessarily a problem, maybe not even from the speed point of view.+--+inject+  :: (Ord t, Ord s, X.Word w)+  => Guesser t s+  -> DAG () (X.WMap s)+  -> X.Sent w t+  -> X.Sent w t+inject gsr newSent srcSent =+  let doit (target, src) =+        let oldTags = if X.oov (X.word src)+                      then X.mkWMap . map (,0) . S.toList . unkTagSet $ gsr+                      else X.tags src+            newTags = injectWMap gsr target oldTags+        in  src {X.tags = newTags}+  in  fmap doit (DAG.zipE newSent srcSent)+++-- -- | Replace label probabilities with the new probabilities.+-- inject+--   :: (Ord t, Ord s)+--   => Guesser t s+--   -> DAG () (X.WMap s)+--   -> DAG () (X.WMap t)+--   -> DAG () (X.WMap t)+-- inject gsr newDat srcDag =+--   let doit (newSpl, src) = injectWMap gsr newSpl src+--   in  fmap doit (DAG.zipE newDat srcDag)+++-- | Replace label probabilities with the new probabilities.+injectWMap+  :: (Ord t, Ord s)+  => Guesser t s+  -> X.WMap s+  -> X.WMap t+  -> X.WMap t+injectWMap gsr newSpl src = X.mkWMap+  [ ( tag+    , maybe 0 id $+      M.lookup (simplify gsr tag) (X.unWMap newSpl) )+  | (tag, _) <- M.toList (X.unWMap src) ]+++-- --------------------------+-- -- ???+-- --------------------------+--+--+--+-- -- -- | Determine the 'k' most probable labels for each word in the sentence.+-- -- guess :: (X.Word w, Ord t)+-- --       => Int -> Guesser t -> X.Sent w t -> [[t]]+-- -- guess k gsr sent =+-- --     let schema = fromConf (schemaConf gsr)+-- --     in  CRF.tagK k (crf gsr) (schematize schema sent)+--+--+-- -- -- | Insert guessing results into the sentence.  Only interpretations+-- -- -- of OOV words will be extended.+-- -- include :: (X.Word w, Ord t) => [[t]] -> X.Sent w t -> X.Sent w t+-- -- include xss sent =+-- --     [ word { X.tags = tags }+-- --     | (word, tags) <- zip sent sentTags ]+-- --   where+-- --     sentTags =+-- --         [ if X.oov word+-- --             then addInterps (X.tags word) xs+-- --             else X.tags word+-- --         | (xs, word) <- zip xss sent ]+-- --     addInterps wm xs = X.mkWMap+-- --         $  M.toList (X.unWMap wm)+-- --         ++ zip xs [0, 0 ..]+-- --+-- --+-- -- -- | Combine `guess` with `include`.+-- -- guessSent :: (X.Word w, Ord t)+-- --           => Int -> Guesser t+-- --           -> X.Sent w t -> X.Sent w t+-- -- guessSent guessNum guesser sent =+-- --     include (guess guessNum guesser sent) sent+-- --+++--------------------------+-- Training+--------------------------+++-- | Method of constructing the default set of labels (R0).+data R0T+    = AnyInterps        -- ^ See `CRF.anyInterps`+    | AnyChosen         -- ^ See `CRF.anyChosen`+    | OovChosen         -- ^ See `CRF.oovChosen`+    deriving (Show, Eq, Ord, Enum, Typeable, Data)+++-- | Training configuration.+data TrainConf t s = TrainConf+    { schemaConfT   :: SchemaConf+    -- | SGD parameters.+    , sgdArgsT      :: SGD.SgdArgs+    -- | Store SGD dataset on disk+    , onDiskT       :: Bool+    -- | R0 construction method+    , r0T           :: R0T+    -- | Zero probability label+    , zeroProbLabel :: t+    -- | Label simplification function+    , simplifyLabel :: t -> s+    -- | Strip the label from irrelevant information.  Used to determine othe set of+    -- possible tags for unknown words.+    , stripLabel :: t -> t+    -- | Guess only visible features+    , onlyVisible :: Bool+    }+++-- | Train guesser.+train+    :: (X.Word w, Ord t, Ord s)+    => TrainConf t s        -- ^ Training configuration+    -> IO [X.Sent w t]      -- ^ Training data+    -> IO [X.Sent w t]      -- ^ Evaluation data+    -> IO (Guesser t s)+train TrainConf{..} trainData evalData = do+  let schema = fromConf schemaConfT+      mkR0   = case r0T of+        AnyInterps  -> CRF.anyInterps+        AnyChosen   -> CRF.anyChosen+        OovChosen   -> CRF.oovChosen+      featExtract =+        if onlyVisible+        then const CRF.presentFeats+        else \r0 -> CRF.hiddenFeats r0 . map (fmap fst)+  tagSet <- S.unions . map (tagSetIn stripLabel) <$> trainData+--   let tagMap = M.fromList+--         [ (t, simplifyLabel t)+--         | t <- S.toList tagSet ]+  crf <- CRF.train sgdArgsT onDiskT+    -- mkR0 (const CRF.presentFeats)+    -- mkR0 (\r0 -> CRF.hiddenFeats r0 . map (fmap fst))+    mkR0 featExtract+    (schemed simplifyLabel schema <$> trainData)+    (schemed simplifyLabel schema <$> evalData)+  return $ Guesser schemaConfT crf (simplifyLabel zeroProbLabel) tagSet simplifyLabel+++-- | Schematized dataset.+schemed+  :: (X.Word w, Ord t, Ord s)+  => (t -> s)+  -> Schema w s a+  -> [X.Sent w t]+  -> [CRF.SentL Ob s]+schemed simpl schema =+    map onSent+  where+    onSent dag0 =+        let dag = X.mapSent simpl dag0+            mkProb = CRF.mkProb . M.toList . X.unWMap . X.tags+        in  fmap (uncurry CRF.mkWordL) $+            DAG.zipE (schematize schema dag) (fmap mkProb dag)+++-- | Retrieve the tagset in the given sentence, provided the stripping function+-- (see `stripLabel`).+tagSetIn :: (Ord t) => (t -> t) -> X.Sent w t -> S.Set t+tagSetIn strip dag = S.fromList+  [ strip tag+  | edgeID <- DAG.dagEdges dag+  , let edge = DAG.edgeLabel edgeID dag+  , tag <- M.keys . X.unWMap . X.tags $ edge ]

@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+++-- | Types and functions related to the morphosyntax data layer.+++module NLP.Concraft.DAG.Morphosyntax+(+-- * Segment+  Seg (..)+, mapSeg+, interpsSet+, interps++-- * Word class+, Word (..)++-- * Sentence+, Sent+, mapSent+, SentO (..)+, mapSentO++-- * Weighted collection+, module NLP.Concraft.Morphosyntax.WMap+) where+++import           Prelude hiding (Word)+import           Control.Applicative ((<$>), (<*>))+import           Control.Arrow (first)+import           Data.Aeson+import           Data.Binary (Binary)+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Lazy as L++import qualified Data.DAG as DAG+import           Data.DAG (DAG)+-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG+-- import           Data.CRF.Chain1.Constrained.DAG.Dataset.Internal (DAG)++import           NLP.Concraft.Morphosyntax.WMap+++--------------------------+-- Segment+--------------------------+++-- | A segment parametrized over a word type and a tag type.+data Seg w t = Seg {+    -- | A word represented by the segment. Typically it will be an instance of+    -- the `Word` class.+      word  :: w+    -- | A set of interpretations. To each interpretation a weight of+    -- appropriateness within the context is assigned.+    , tags  :: WMap t }+    deriving (Show)+++instance ToJSON w => ToJSON (Seg w T.Text) where+    toJSON Seg{..} = object+        [ "word" .= word+        , "tags" .= unWMap tags ]++instance FromJSON w => FromJSON (Seg w T.Text) where+    parseJSON (Object v) = Seg+        <$> v .: "word"+        <*> (mkWMap <$> v .: "tags")+    parseJSON _ = error "parseJSON (segment): absurd"+++-- | Map function over segment tags.+mapSeg :: Ord b => (a -> b) -> Seg w a -> Seg w b+mapSeg f w = w { tags = mapWMap f (tags w) }+++-- | Interpretations of the segment.+interpsSet :: Seg w t -> S.Set t+interpsSet = M.keysSet . unWMap . tags+++-- | Interpretations of the segment.+interps :: Seg w t -> [t]+interps = S.toList . interpsSet+++--------------------------+-- Word class+--------------------------+++class Word a where+    -- | Orthographic form.+    orth    :: a -> T.Text+    -- | Out-of-vocabulary (OOV) word.+    oov     :: a -> Bool+++instance Word w => Word (Seg w t) where+    orth = orth . word+    {-# INLINE orth #-}+    oov = oov . word+    {-# INLINE oov #-}+++----------------------+-- Sentence+----------------------+++-- | A sentence.+-- type Sent w t = [Seg w t]+type Sent w t = DAG () (Seg w t)+++-- | Map function over sentence tags.+mapSent :: Ord b => (a -> b) -> Sent w a -> Sent w b+mapSent = fmap . mapSeg+++-- | A sentence with original, textual representation.+data SentO w t = SentO+    { segs  :: Sent w t+    , orig  :: L.Text }+    -- deriving (Show)+++-- | Map function over sentence tags.+mapSentO :: Ord b => (a -> b) -> SentO w a -> SentO w b+mapSentO f x =+    let segs' = mapSent f (segs x)+    in  x { segs = segs' }

@@ -0,0 +1,304 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+++-- | Accuracy statistics.+++module NLP.Concraft.DAG.Morphosyntax.Accuracy+(+-- * Stats+  Stats(..)+, AccCfg (..)+, collect+, precision+, recall+, accuracy+) where+++import           Prelude hiding (Word)+import           GHC.Conc (numCapabilities)++import           Control.Arrow (first)+import qualified Control.Parallel.Strategies as Par++import           Data.List (transpose)+import qualified Data.Foldable as F+import qualified Data.Set as S+import qualified Data.Map.Strict as M+import qualified Data.Tagset.Positional as P++import qualified Data.DAG as DAG+import           NLP.Concraft.DAG.Morphosyntax+import           NLP.Concraft.DAG.Morphosyntax.Ambiguous+  (identifyAmbiguousSegments)+-- import           NLP.Concraft.DAG.Morphosyntax.Align++-- import qualified Data.Text as T+import Debug.Trace (trace)+++-- | Configuration of accuracy computation.+data AccCfg x = AccCfg+  { onlyOov   :: Bool+    -- ^ Limit calculations to OOV words+  , onlyAmb   :: Bool+    -- ^ Limit calculations to segmentation-ambiguous words+  , onlyMarkedWith :: S.Set x+    -- ^ Limit calculations to segments marked with one of the given labels;+    -- if empty, the option has no effect+  , accTagset :: P.Tagset+    -- ^ The underlying tagset+  , expandTag :: Bool+    -- ^ Should the tags be expanded?+  , ignoreTag :: Bool+    -- ^ Compute segmentation-level accurracy. The actually chosen tags are+    -- ignored, only information about the chosen DAG edges is relevant.+  , weakAcc :: Bool+    -- ^ If weak, there has to be an overlap in the tags assigned to a given+    -- segment in both datasets. Otherwise, the two sets of tags have to be+    -- identical.+  , discardProb0 :: Bool+    -- ^ Whether sentences with near 0 probability should be discarded from+    -- evaluation.+  , verbose :: Bool+    -- ^ Print information about compared elements+  }+++-- | True positives, false positives, etc.+data Stats = Stats+  { tp :: !Int+    -- ^ True positive+  , fp :: !Int+    -- ^ False positive+  , tn :: !Int+    -- ^ True negative+  , fn :: !Int+    -- ^ False negative+  , ce :: !Int+    -- ^ Consistency error (number of edges for which both `fp` and `fn` hold)+  } deriving (Show, Eq, Ord)+++-- | Initial statistics.+zeroStats :: Stats+zeroStats = Stats 0 0 0 0 0+++addStats :: Stats -> Stats -> Stats+addStats x y = Stats+  { tp = tp x + tp y+  , fp = fp x + fp y+  , tn = tn x + tn y+  , fn = fn x + fn y+  , ce = ce x + ce y+  }+++goodAndBad+  :: (Word w, Ord x, Show x)+  => AccCfg x+  -> Sent w (P.Tag, x) -- ^ Gold (reference) DAG+  -> Sent w (P.Tag, x) -- ^ Tagged (to compare) DAG+  -> Stats+goodAndBad cfg dag1 dag2+  | discardProb0 cfg && (dagProb dag1 < eps || dagProb dag2 < eps) = zeroStats+  | otherwise =+    -- By using `DAG.zipE'`, we allow the DAGs to be slighly different in terms+    -- of their edge sets.+      F.foldl' addStats zeroStats+      . DAG.mapE gather+      $ dag+  where+    eps = 1e-9++    dag = DAG.zipE' dag1 dag2+    ambiDag = identifyAmbiguousSegments dag++    traceThem gold tagg =+      if verbose cfg+      then trace+           ( let info = (,) <$> orth <*> choice cfg in+               "comparing '" +++               show (info <$> gold) +++               "' with '" +++               show (info <$> tagg) +++               "'"+           )+      else id++    gather edgeID (gold, tagg)+      | (onlyOov cfg `implies` isOov) &&+        (onlyAmb cfg `implies` isAmb) &&+        ((not . S.null) (onlyMarkedWith cfg) `implies` isMarked) =+          traceThem gold tagg $+          gather0+          (maybe S.empty (choice cfg) gold)+          (maybe S.empty (choice cfg) tagg)+      | otherwise = zeroStats+      where+        isOov = oov $ case (gold, tagg) of+          (Just seg, _) -> seg+          (_, Just seg) -> seg+          _ -> error "Accuracy.goodAndBad: impossible happened"+        hasMarker =+          any (`S.member` onlyMarkedWith cfg) . map (snd . fst) . M.toList+        isMarked = hasMarker $ case (gold, tagg) of+          (Just seg1, Just seg2) ->+            unWMap (tags seg1) `M.union` unWMap (tags seg2)+          (Just seg, _) -> unWMap $ tags seg+          (_, Just seg) -> unWMap $ tags seg+          _ -> error "Accuracy.goodAndBad: impossible2 happened"+        isAmb = DAG.edgeLabel edgeID ambiDag++    gather0 gold tagg+      | S.null gold && S.null tagg =+          zeroStats {tn = 1}+      | S.null gold =+          zeroStats {fp = 1}+      | S.null tagg =+          zeroStats {fn = 1}+      | otherwise =+          if consistent gold tagg+          then zeroStats {tp = 1}+          else zeroStats {fp = 1, fn = 1, ce = 1}++    consistent xs ys+      | weakAcc cfg = (not . S.null) (S.intersection xs ys)+      | otherwise = xs == ys+++goodAndBad'+  :: (Word w, Ord x, Show x)+  => AccCfg x+  -> [Sent w (P.Tag, x)]+  -> [Sent w (P.Tag, x)]+  -> Stats+goodAndBad' cfg goldData taggData =+  F.foldl' addStats zeroStats+  [ goodAndBad cfg dag1 dag2+  | (dag1, dag2) <- zip goldData taggData ]+++-- | Compute the accuracy of the model with respect to the labeled dataset.+-- To each `P.Tag` an additional information `x` can be assigned, which will be+-- taken into account when computing statistics.+collect+  :: (Word w, Ord x, Show x)+  => AccCfg x+  -> [Sent w (P.Tag, x)] -- ^ Gold dataset+  -> [Sent w (P.Tag, x)] -- ^ Tagged dataset (to be compare with the gold)+  -> Stats+collect cfg goldData taggData =+    let k = numCapabilities+        parts = partition k (zip goldData taggData)+        xs = Par.parMap Par.rseq (uncurry (goodAndBad' cfg) . unzip) parts+    in  F.foldl' addStats zeroStats xs+    -- in  fromIntegral good / fromIntegral (good + bad)+++precision :: Stats -> Double+precision Stats{..}+  = fromIntegral tp+  / fromIntegral (tp + fp)+++recall :: Stats -> Double+recall Stats{..}+  = fromIntegral tp+  / fromIntegral (tp + fn)+++accuracy :: Stats -> Double+accuracy Stats{..}+  = fromIntegral (tp + tn)+  / fromIntegral (tp + fp + tn + fn - ce)+  -- Not that, above, we substract `ce` so as to count inconsistency errors+  -- as single ones (their are accounted for twice in `fp + fn`).+++------------------------------------------------------+-- Verification+------------------------------------------------------+++-- | Compute the probability of the DAG, based on the probabilities assigned to+-- different edges and their labels.+dagProb :: Sent w t -> Double+dagProb dag = sum+  [ fromEdge edgeID+  | edgeID <- DAG.dagEdges dag+  , DAG.isInitialEdge edgeID dag ]+  where+    fromEdge edgeID+      = edgeProb edgeID+      * fromNode (DAG.endsWith edgeID dag)+    edgeProb edgeID =+      let Seg{..} = DAG.edgeLabel edgeID dag+      in  sum . map snd . M.toList $ unWMap tags+    fromNode nodeID =+      case DAG.outgoingEdges nodeID dag of+        [] -> 1+        xs -> sum (map fromEdge xs)+++-- -- | Filter out the sentences with ~0 probability.+-- verifyDataset :: [Sent w t] -> [Sent w t]+-- verifyDataset =+--   filter verify+--   where+--     verify dag = dagProb dag >= eps+--     eps = 1e-9+++--------------------------+-- Utils+--------------------------+++-- | Select the chosen tags.+--+--   * Tag expansion is performed here (if demanded)+--   * Tags are replaced by a dummy in case of `AmbiSeg` comparison+choice :: (Ord x) => AccCfg x -> Seg w (P.Tag, x) -> S.Set (P.Tag, x)+choice AccCfg{..}+  = S.fromList . expandMaybe . best+  where+    expandMaybe+      | ignoreTag = map (first $ const dummyTag)+      | expandTag = concatMap (\(tag, x) -> map (,x) $ P.expand accTagset tag)+      | otherwise = id+    dummyTag = P.Tag "AmbiSeg" M.empty+++-- | The best tags.+best :: Seg w t -> [t]+best seg+  | null zs   = []+  | otherwise =+      let maxProb = maximum (map snd zs)+      in  if maxProb < eps+          then []+          else map fst+               . filter ((>= maxProb - eps) . snd)+               $ zs+  where+    zs = M.toList . unWMap . tags $ seg+    eps = 1.0e-9+++partition :: Int -> [a] -> [[a]]+partition n =+    transpose . group n+  where+    group _ [] = []+    group k xs = take k xs : (group k $ drop k xs)+++-- | Implication.+implies :: Bool -> Bool -> Bool+implies p q = if p then q else True

@@ -0,0 +1,65 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+++-- | Segmentation-level ambiguities. TODO: consider moving the module contents+-- to `NLP.Concraft.DAG`.+++module NLP.Concraft.DAG.Morphosyntax.Ambiguous+  ( identifyAmbiguousSegments+  ) where+++import qualified Data.MemoCombinators as Memo+import qualified Data.DAG as DAG+++------------------------------------------------------+-- Marking segmantation ambiguities+------------------------------------------------------+++-- | Identify ambigouos segments (roughly, segments which can be by-passed) in+-- the given DAG. Such ambiguous edges are marked in the resulting DAG with+-- `True` values.+identifyAmbiguousSegments :: DAG.DAG a b -> DAG.DAG a Bool+identifyAmbiguousSegments dag =+  flip DAG.mapE dag $ \edgeID _ ->+    incoming edgeID * outgoing edgeID < totalPathNum+  where+    incoming = inComingNum dag+    outgoing = outGoingNum dag+    totalPathNum = sum+      [ outgoing edgeID+      | edgeID <- DAG.dagEdges dag+      , DAG.isInitialEdge edgeID dag ]+++-- | Compute the number of paths from a starting edge to the given edge.+inComingNum :: DAG.DAG a b -> DAG.EdgeID -> Int+inComingNum dag =+  incoming+  where+    incoming =+      Memo.wrap DAG.EdgeID DAG.unEdgeID Memo.integral incoming'+    incoming' edgeID+      | DAG.isInitialEdge edgeID dag = 1+      | otherwise = sum $ do+          prevID <- DAG.prevEdges edgeID dag+          return $ incoming prevID+++-- | Compute the number of paths from the given edge to a target edge.+outGoingNum :: DAG.DAG a b -> DAG.EdgeID -> Int+outGoingNum dag =+  outgoing+  where+    outgoing =+      Memo.wrap DAG.EdgeID DAG.unEdgeID Memo.integral outgoing'+    outgoing' edgeID+      | DAG.isFinalEdge edgeID dag = 1+      | otherwise = sum $ do+          nextID <- DAG.nextEdges edgeID dag+          return $ outgoing nextID

@@ -0,0 +1,393 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Observation schema blocks for Concraft.++module NLP.Concraft.DAG.Schema+(+-- * Types+  Ob+, Ox+, Schema+, void+, sequenceS_++-- * Usage+, schematize++-- * Configuration+, Body (..)+, Entry+, entry+, entryWith+, SchemaConf (..)+, nullConf+, fromConf++-- * Schema blocks+, Block+, fromBlock+, orthB+, lowOrthB+, lowPrefixesB+, lowSuffixesB+, knownB+, shapeB+, packedB+, begPackedB+) where+++import Control.Applicative ((<$>), (<*>), pure)+import Control.Monad (forM_, guard)+import Data.Binary (Binary, put, get)+-- import qualified Data.Vector as V+import           Data.Maybe (maybeToList)+import qualified Data.Text as T+import qualified Control.Monad.Ox as Ox+import qualified Control.Monad.Ox.Text as Ox++import qualified Data.DAG as DAG+import           Data.DAG (DAG, EdgeID)++import qualified NLP.Concraft.DAG.Morphosyntax as X+++------------------------------+-- Basic Types+------------------------------+++-- | An observation consist of an index (of list type) and an actual+-- observation value.+type Ob = ([Int], T.Text)+++-- | The Ox monad specialized to word token type and text observations.+type Ox a = Ox.Ox T.Text a+++------------------------------+-- Schema+------------------------------+++-- | A schema is a block of the Ox computation performed within the+-- context of the sentence and the absolute sentence position.+type Schema w t a = X.Sent w t -> EdgeID -> Ox a+-- type Schema w t a = V.Vector (X.Seg w t) -> Int -> Ox a+++-- | A dummy schema block.+-- TODO: is it a monad, an applicative?+void :: a -> Schema w t a+void x _ _ = return x+++-- | Sequence the list of schemas (or blocks) and discard individual values.+sequenceS_+    :: [X.Sent w t -> a -> Ox b]+    ->  X.Sent w t -> a -> Ox ()+sequenceS_ xs sent =+    let ys = map ($sent) xs+    in  \k -> sequence_ (map ($k) ys)+++------------------------------+-- Primitive Observations+------------------------------+++-- | Record structure of the basic observation types.+data BaseOb = BaseOb+    { orth          :: EdgeID -> Maybe T.Text+    , lowOrth       :: EdgeID -> Maybe T.Text }+++-- | Construct the 'BaseOb' structure given the sentence.+mkBaseOb :: X.Word w => X.Sent w t -> BaseOb+mkBaseOb sent = BaseOb+    { orth      = _orth+    , lowOrth   = _lowOrth }+  where+    at          = onEdgeWith sent+    _orth       = (X.orth `at`)+    _lowOrth i  = T.toLower <$> _orth i+++------------------------------+-- Block+------------------------------+++-- | A block is a chunk of the Ox computation performed within the+-- context of the sentence and the list of absolute sentence positions.+type Block w t a = X.Sent w t -> [EdgeID] -> Ox a+++-- | Transform a block to a schema depending on+-- * A list of relative sentence positions,+-- * A boolean value; if true, the block computation+--   will be performed only on positions where an OOV+--   word resides.+fromBlock :: X.Word w => Block w t a -> [Int] -> Bool -> Schema w t a+fromBlock blk xs oovOnly sent = \i ->+  blkSent $ do+    x <- xs+    j <- maybeToList $ shift x i sent+    guard $ oov j+    return j+  -- \k -> blkSent [x + k | x <- xs, oov (x + k)]+  where+    blkSent = blk sent+    oov k   = if not oovOnly+      then True+      else maybe False id $ X.oov `at` k+    at      = onEdgeWith sent+++-- | Orthographic form at the current position.+orthB :: X.Word w => Block w t ()+orthB sent = \ks ->+    let orthOb = onEdgeWith sent X.orth+    in  mapM_ (Ox.save . orthOb) ks+++-- | Orthographic form at the current position.+lowOrthB :: X.Word w => Block w t ()+lowOrthB sent = \ks ->+    let BaseOb{..} = mkBaseOb sent+    in  mapM_ (Ox.save . lowOrth) ks+++-- | List of lowercased prefixes of given lengths.+lowPrefixesB :: X.Word w => [Int] -> Block w t ()+lowPrefixesB ns sent = \ks ->+    forM_ ks $ \i ->+        mapM_ (Ox.save . lowPrefix i) ns+  where+    BaseOb{..}      = mkBaseOb sent+    lowPrefix i j   = Ox.prefix j =<< lowOrth i+++-- | List of lowercased suffixes of given lengths.+lowSuffixesB :: X.Word w => [Int] -> Block w t ()+lowSuffixesB ns sent = \ks ->+    forM_ ks $ \i ->+        mapM_ (Ox.save . lowSuffix i) ns+  where+    BaseOb{..}      = mkBaseOb sent+    lowSuffix i j   = Ox.suffix j =<< lowOrth i+++-- | Shape of the word.+knownB :: X.Word w => Block w t ()+knownB sent = \ks -> do+    mapM_ (Ox.save . knownAt) ks+  where+    at          = onEdgeWith sent+    knownAt i   = boolF <$> (not . X.oov) `at` i+    boolF True  = "T"+    boolF False = "F"+++-- | Shape of the word.+shapeB :: X.Word w => Block w t ()+shapeB sent = \ks -> do+    mapM_ (Ox.save . shape) ks+  where+    BaseOb{..}      = mkBaseOb sent+    shape i         = Ox.shape <$> orth i+++-- | Packed shape of the word.+packedB :: X.Word w => Block w t ()+packedB sent = \ks -> do+    mapM_ (Ox.save . shapeP) ks+  where+    BaseOb{..}      = mkBaseOb sent+    shape i         = Ox.shape <$> orth i+    shapeP i        = Ox.pack <$> shape i+++-- | Packed shape of the word.+begPackedB :: X.Word w => Block w t ()+begPackedB sent = \ks -> do+    mapM_ (Ox.save . begPacked) ks+  where+    BaseOb{..}      = mkBaseOb sent+    shape i         = Ox.shape <$> orth i+    shapeP i        = Ox.pack <$> shape i+    begPacked i     = isBeg i <> pure "-" <> shapeP i+    isBeg i         = (Just . boolF) (i == 0)+    boolF True      = "T"+    boolF False     = "F"+    x <> y          = T.append <$> x <*> y+++------------------------------+-- Configuration+------------------------------+++-- | Body of configuration entry.+data Body a = Body {+    -- | Range argument for the schema block. +      range     :: [Int]+    -- | When true, the entry is used only for oov words.+    , oovOnly   :: Bool+    -- | Additional arguments for the schema block.+    , args      :: a }+    deriving (Show)++instance Binary a => Binary (Body a) where+    put Body{..} = put range >> put oovOnly >> put args+    get = Body <$> get <*> get <*> get++-- | Maybe entry.+type Entry a = Maybe (Body a)++-- | Entry with additional arguemnts.+entryWith :: a -> [Int] -> Entry a+entryWith v xs = Just (Body xs False v)+++-- | Plain entry with no additional arugments.+entry :: [Int] -> Entry ()+entry = entryWith ()+++-- | Configuration of the schema.  All configuration elements specify the+-- range over which a particular observation type should be taken on account.+-- For example, the @[-1, 0, 2]@ range means that observations of particular+-- type will be extracted with respect to previous (@k - 1@), current (@k@)+-- and after the next (@k + 2@) positions when identifying the observation+-- set for position @k@ in the input sentence.+data SchemaConf = SchemaConf {+    -- | The 'orthB' schema block.+      orthC             :: Entry ()+    -- | The 'lowOrthB' schema block.+    , lowOrthC          :: Entry ()+    -- | The 'lowPrefixesB' schema block.  The first list of ints+    -- represents lengths of prefixes.+    , lowPrefixesC      :: Entry [Int]+    -- | The 'lowSuffixesB' schema block.  The first list of ints+    -- represents lengths of suffixes.+    , lowSuffixesC      :: Entry [Int]+    -- | The 'knownB' schema block.+    , knownC            :: Entry ()+    -- | The 'shapeB' schema block.+    , shapeC            :: Entry ()+    -- | The 'packedB' schema block.+    , packedC            :: Entry ()+    -- | The 'begPackedB' schema block.+    , begPackedC         :: Entry ()+    } deriving (Show)++instance Binary SchemaConf where+    put SchemaConf{..} = do+        put orthC+        put lowOrthC+        put lowPrefixesC+        put lowSuffixesC+        put knownC+        put shapeC+        put packedC+        put begPackedC+    get = SchemaConf+        <$> get <*> get <*> get <*> get+        <*> get <*> get <*> get <*> get+++-- | Null configuration of the observation schema.+nullConf :: SchemaConf+nullConf = SchemaConf+    Nothing Nothing Nothing Nothing+    Nothing Nothing Nothing Nothing+++mkArg0 :: X.Word w => Block w t () -> Entry () -> Schema w t ()+mkArg0 blk (Just x) = fromBlock blk (range x) (oovOnly x)+mkArg0 _   Nothing  = void ()+++mkArg1 :: X.Word w => (a -> Block w t ()) -> Entry a -> Schema w t ()+mkArg1 blk (Just x) = fromBlock (blk (args x)) (range x) (oovOnly x)+mkArg1 _   Nothing  = void ()+++-- | Build the schema based on the configuration.+fromConf :: X.Word w => SchemaConf -> Schema w t ()+fromConf SchemaConf{..} = sequenceS_+    [ mkArg0 orthB orthC+    , mkArg0 lowOrthB lowOrthC+    , mkArg1 lowPrefixesB lowPrefixesC+    , mkArg1 lowSuffixesB lowSuffixesC+    , mkArg0 knownB knownC+    , mkArg0 shapeB shapeC+    , mkArg0 packedB packedC+    , mkArg0 begPackedB begPackedC ]+++-- -- | Use the schema to extract observations from the sentence.+-- schematize :: Schema w t a -> X.Sent w t -> [[Ob]]+-- schematize schema xs =+--     map (Ox.execOx . schema v) [0 .. n - 1]+--   where+--     v = V.fromList xs+--     n = V.length v+++-- | Use the schema to extract observations from the sentence.+schematize :: Schema w t a -> X.Sent w t -> DAG () [Ob]+schematize schema sent =+  let f = const . Ox.execOx . schema sent+  in  DAG.mapE f sent+++------------------------------+-- DAG+------------------------------+++-- | Value of the given function with respect to the given sentence and its+-- edge. Return Nothing if the edge is out of bounds.+onEdgeWith :: DAG x a -> (a -> b) -> EdgeID -> Maybe b+onEdgeWith dag f k = f <$> DAG.maybeEdgeLabel k dag+++-- | Value of the given function with respect to the given sentence and its+-- edge. Return `[]` if the edge is out of bounds.+onEdgeWith' :: DAG x a -> (a -> [b]) -> EdgeID -> [b]+onEdgeWith' dag f k =+  g $ f <$> DAG.maybeEdgeLabel k dag+  where+    g Nothing = []+    g (Just xs) = xs+++-- | Move the specified number of edges forward or backward. This implementation+-- always choses the shortest path, provided that DAG edges are topologicaly+-- sorted.+shift+  :: Int+  -- ^ Offset: how many edges to move forward (if positive)+  -- or backward (if negative)+  -> EdgeID+  -- ^ Move from where+  -> DAG a b+  -- ^ The underlying sentence+  -> Maybe EdgeID+  -- ^ The resulting edge ID+shift k i dag+  | k > 0 = do+      j <- mayHead $ DAG.nextEdges i dag+      shift (k - 1) j dag+  | k < 0 = do+      j <- mayTail $ DAG.prevEdges i dag+      shift (k + 1) j dag+  | otherwise = return i+  where+    mayHead (x:xs) = Just x+    mayHead [] = Nothing+    mayTail = mayHead . reverse

@@ -0,0 +1,334 @@+{-# LANGUAGE RecordWildCards #-}+++-- | Baseline word-segmentation functions.+++module NLP.Concraft.DAG.Segmentation+( PathTyp (..)+, pickPath+, findPath++-- * Frequencies+, computeFreqs+, FreqConf (..)++-- * Ambiguity-related stats+, computeAmbiStats+, AmbiCfg (..)+, AmbiStats (..)+) where+++import           Control.Monad (guard)+-- import qualified Control.Monad.State.Strict as State+import qualified Data.Foldable as F++import qualified Data.MemoCombinators as Memo+import qualified Data.Set as S+import qualified Data.Map.Strict as M+import qualified Data.List as L+import qualified Data.Text as T+import           Data.Ord (comparing)++import           Data.DAG (DAG)+import qualified Data.DAG as DAG++-- import qualified Data.Tagset.Positional as P++import qualified NLP.Concraft.DAG.Morphosyntax as X+import qualified NLP.Concraft.DAG.Morphosyntax.Ambiguous as Ambi+++------------------------------------+-- Shortest-path segmentation+------------------------------------++-- | Configuration related to frequency-based path picking.+data FreqConf = FreqConf+  { pickFreqMap :: M.Map T.Text (Int, Int)+    -- ^ A map which assigns (chosen, not chosen) counts to the invidiaul+    -- orthographic forms (see `computeFreqs`).+  , smoothingParam :: Double+    -- ^ A naive smoothing related parameter, which should be adddd to each+    -- count in `pickFreqMap`.+--   , orth :: DAG.EdgeID -> T.Text+--     -- ^ Orthographic form of a given edge+  }+++-- | Which path type to search: shortest (`Min`) or longest (`Max`)+data PathTyp+  = Min+  | Max+  | Freq FreqConf+++-- | Select the shortest-path (or longest, depending on `PathTyp`) in the given+-- DAG and remove all the edges which are not on this path.+pickPath+  :: (X.Word b)+  => PathTyp+  -> DAG a b+  -> DAG a b+pickPath pathTyp dag =+  let+    dag' = DAG.filterDAG (findPath pathTyp dag) dag+  in+    if DAG.isOK dag'+    then dag'+    else error "Segmentation.pickPath: the resulting DAG not correct"+++-- | Retrieve the edges which belong to the shortest/longest (depending on the+-- argument function: `minimum` or `maximum`) path in the given DAG.+findPath+  :: (X.Word b)+  => PathTyp+  -> DAG a b+  -> S.Set DAG.EdgeID+findPath pathTyp dag+  = S.fromList . pickNode . map fst+  -- Below, we take the node with the smallest (reverse) or highest (no reverse)+  -- distance to a target node, depending on the path type (`Min` or `Max`).+  . reverseOrNot+  . L.sortBy (comparing snd)+  $ sourceNodes+  where+    sourceNodes = do+      nodeID <- DAG.dagNodes dag+      guard . null $ DAG.ingoingEdges nodeID dag+      return (nodeID, dist nodeID)+    reverseOrNot = case pathTyp of+      Max -> reverse+      _ -> id+    forward nodeID+      | null (DAG.outgoingEdges nodeID dag) = []+      | otherwise = pick $ do+          nextEdgeID <- DAG.outgoingEdges nodeID dag+          let nextNodeID = DAG.endsWith nextEdgeID dag+          -- guard $ dist nodeID == dist nextNodeID + 1+          guard $ dist nodeID == dist nextNodeID + arcLen nextEdgeID+          -- return nextNodeID+          return nextEdgeID+    pickNode ids = case ids of+      nodeID : _ -> forward nodeID+      [] -> error "Segmentation.pickPath: no node to pick!?"+    pick ids = case ids of+      edgeID : _ -> edgeID : forward (DAG.endsWith edgeID dag)+      [] -> error "Segmentation.pickPath: nothing to pick!?"+    dist = computeDist pathTyp dag+    -- distance between two nodes connected by an arc+    arcLen =+      case pathTyp of+        Freq conf -> computeArcLen conf dag+        _ -> const 1+++------------------------------------+-- Distance from target nodes+------------------------------------+++-- | Compute the minimal/maximal distance (depending on the argument function)+-- from each node to a target node.+computeDist+  :: (X.Word b)+  => PathTyp+  -> DAG a b+  -> DAG.NodeID+  -> Double+computeDist pathTyp dag =+  dist+  where+    minMax = case pathTyp of+      Max -> maximum+      _ -> minimum+    dist =+      Memo.wrap DAG.NodeID DAG.unNodeID Memo.integral dist'+    dist' nodeID+      | null (DAG.outgoingEdges nodeID dag) = 0+      | otherwise = minMax $ do+          nextEdgeID <- DAG.outgoingEdges nodeID dag+          let nextNodeID = DAG.endsWith nextEdgeID dag+          -- return $ dist nextNodeID + 1+          return $ dist nextNodeID + arcLen nextEdgeID+    arcLen =+      case pathTyp of+        Freq conf -> computeArcLen conf dag+        _ -> const 1+++------------------------------------+-- Frequency-based segmentation+------------------------------------+++-- | Compute chosen/not-chosen counts of the individual orthographic forms in+-- the DAGs. Only the ambiguous segments are taken into account.+computeFreqs :: (X.Word w) => [X.Sent w t] -> M.Map T.Text (Int, Int)+computeFreqs dags = M.fromListWith addBoth $ do+  dag <- dags+  let ambiDAG = Ambi.identifyAmbiguousSegments dag+  edgeID <- DAG.dagEdges dag+  guard $ DAG.edgeLabel edgeID ambiDAG == True+  let seg = DAG.edgeLabel edgeID dag+      orth = edgeOrth seg+      edgeWeight = sum . M.elems . X.unWMap . X.tags $ seg+      eps = 1e-9+  return $+    if edgeWeight > eps+    then (orth, (1, 0))+    else (orth, (0, 1))+  where+    addBoth (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)+++computeArcLen+  :: (X.Word b)+  => FreqConf+  -> DAG a b+  -> DAG.EdgeID+  -> Double+computeArcLen FreqConf{..} dag edgeID =+  (\x -> -x) . log $+    case M.lookup (edgeOrth $ DAG.edgeLabel edgeID dag) pickFreqMap of+      Just (chosen, notChosen) ->+        (fromIntegral chosen + smoothingParam) /+        (fromIntegral (chosen + notChosen) + smoothingParam*2)+      Nothing -> 0.5 -- smoothingParam / (smoothingParam*2)+++-- | Retrieve the orthographic representation of a given segment for the purpose+-- of frequency-based segmentation.+edgeOrth :: X.Word w => w -> T.Text+edgeOrth = T.toLower . T.strip . X.orth+++------------------------------------+-- Frequency-based segmentation+--+-- How this can work?+--+-- For each segment (i.e, a particular orthographic form) we would like to find+-- a simple measure of how likely it is to use it in a segmentation.+--+-- # Solution 1+--+-- A simple way would be to determine the probability as follows:+--+--   p(orth) = chosen(orth) / possible(orth)+--+-- where `chosen(orth)` is the number of *chosen* (disamb) edges in the training+-- dataset whose orthographic form is `orth`, and `possible(orth)` is the total+-- number of edges in train with the `orth` orthographic form.+--+-- Now, the problem is that we would need to use smoothing to account for forms+-- not in the training dataset:+--+--   p(orth) = chosen(orth) + 1 / possible(orth) + 2+--+-- The reason to add 2 in the denominator is that it can be rewritten as:+--+--   p(orth) = chosen(orth) + 1 / chosen(orth) + 1 + not-chosen(orth) + 1+--+-- So the default probability is 1/2.  Not too bad?+--+-- # Solution 2+--+-- An alternative would be to decide, for a given segment, whether it should be+-- taken or not. For example, if a given segment (i.e., orthographic form) is+-- chosen in more than a half of situations where it can actually be chosen,+-- then it should belong to the path.  Otherwise, it should not.+--+-- Then we have to choose how to represent the fact that the edge should be+-- taken (i.e. should belong to a path). One way to do that is to say that, if+-- the form is chosen, its weight is 0; otherwise, its weight is 1. This does+-- not account for the length of edges, so another solution would be to say that+-- if the edge/form is chosen, then its weight is 0; otherwise, it is equal to+-- its length. Then again, the length of an edge can be computed in several+-- manners, e.g., as the string length of the orthographic form, or as the+-- number of segments which can be used inside. But the latter is not always+-- possible to compute.+--+-- # Choice+--+-- For now, solution 1 seems more principled. So we need to compute a map from+-- orthographic forms to pairs of (chosen, not chosen) counts on the basis of+-- the training dataset. Afterwards, we use "naive" smoothing+-- (http://ivan-titov.org/teaching/nlmi-15/lecture-4.pdf) and transform the+-- resulting probability with `(-) . log`. This gives as a positive value+-- assigned to each segment, and we need to find the path with the lowest+-- weigth.+------------------------------------+++------------------------------------+-- Ambiguity stats+------------------------------------+++-- | Numbers of tokens.+data AmbiCfg = AmbiCfg+  { onlyChosen :: Bool+    -- ^ Only take the chosen tokens into account+  } deriving (Show, Eq, Ord)+++-- | Numbers of tokens.+data AmbiStats = AmbiStats+  { ambi :: !Int+    -- ^ Ambiguous tokens+  , total :: !Int+    -- ^ All tokens+  } deriving (Show, Eq, Ord)+++-- | Initial statistics.+zeroAmbiStats :: AmbiStats+zeroAmbiStats = AmbiStats 0 0+++addAmbiStats :: AmbiStats -> AmbiStats -> AmbiStats+addAmbiStats x y = AmbiStats+  { ambi = ambi x + ambi y+  , total = total x + total y+  }+++-- | Compute:+-- * the number of tokens participating in ambiguities+-- * the total number of tokens+computeAmbiStats+  :: (X.Word w)+  => AmbiCfg+  -> [X.Sent w t]+  -> AmbiStats+computeAmbiStats cfg sents =+  F.foldl' addAmbiStats zeroAmbiStats+  [ ambiStats cfg sent+  | sent <- sents ]+++ambiStats+  :: (X.Word w)+  => AmbiCfg+  -> X.Sent w t+  -> AmbiStats+ambiStats AmbiCfg{..} dag+  = F.foldl' addAmbiStats zeroAmbiStats+  . DAG.mapE gather+  $ DAG.zipE dag ambiDag+  where+    ambiDag = Ambi.identifyAmbiguousSegments dag+    gather edgeID (seg, isAmbi)+      | isAmbi && prob >= eps =+          AmbiStats {ambi = 1, total = 1}+      | prob >= eps =+          AmbiStats {ambi = 0, total = 1}+      | otherwise =+          AmbiStats {ambi = 0, total = 0}+      where+        isChosen = (prob >= eps) || (not onlyChosen)+        prob = sum . M.elems . X.unWMap $ X.tags seg+        eps = 0.5

@@ -0,0 +1,369 @@+{-# LANGUAGE RecordWildCards #-}+++-- | Top-level module adated to DAGs, guessing and disambiguation.+++module NLP.Concraft.DAG2+(+-- * Model+  Concraft (..)+, saveModel+, loadModel+++-- * Annotation+, Anno+, replace++-- * Best paths+, findOptimalPaths+, disambPath++-- * Marginals+-- , D.ProbType (..)+, guessMarginals+, disambMarginals+, disambProbs++-- * Tagging+, guess+, guessSent+, tag+-- , tag'++-- * Training+, train++-- * Pruning+, prune+) where+++import           System.IO (hClose)+import           Control.Applicative ((<$>), (<*>)) -- , (<|>))+import           Control.Arrow (first)+import           Control.Monad (when, guard)+-- import           Data.Maybe (listToMaybe)+import qualified Data.Foldable as F+import qualified Data.Set as S+import qualified Data.Map.Strict as M+import           Data.Binary (Binary, put, get, Put, Get)+import qualified Data.Binary as Binary+import           Data.Binary.Put (runPut)+import           Data.Binary.Get (runGet)+import           Data.Aeson+import qualified System.IO.Temp as Temp+import qualified Data.ByteString.Lazy as BL+import qualified Codec.Compression.GZip as GZip++import           Data.DAG (DAG, EdgeID)+import qualified Data.DAG as DAG++import qualified Data.Tagset.Positional as P++-- import           NLP.Concraft.Analysis+import           NLP.Concraft.Format.Temp+import qualified NLP.Concraft.DAG.Morphosyntax as X+import           NLP.Concraft.DAG.Morphosyntax (Sent, WMap)+import qualified NLP.Concraft.DAG.Guess as G+import qualified NLP.Concraft.DAG.Disamb as D+++---------------------+-- Model+---------------------+++modelVersion :: String+modelVersion = "dag2:0.11"+++-- | Concraft data.+data Concraft t = Concraft+  { tagset        :: P.Tagset+  , guessNum      :: Int+  , guesser       :: G.Guesser t P.Tag+  , disamb        :: D.Disamb t }+++-- instance (Ord t, Binary t) => Binary (Concraft t) where+--     put Concraft{..} = do+--         put modelVersion+--         put tagset+--         put guessNum+--         put guesser+--         put disamb+--     get = do+--         comp <- get+--         when (comp /= modelVersion) $ error $+--             "Incompatible model version: " ++ comp +++--             ", expected: " ++ modelVersion+--         Concraft <$> get <*> get <*> get  <*> get+++putModel :: (Ord t, Binary t) => Concraft t -> Put+putModel Concraft{..} = do+  put modelVersion+  put tagset+  put guessNum+  G.putGuesser guesser+  D.putDisamb disamb+++-- | Get the model, given the tag simplification function for the disambigutation model.+getModel+  :: (Ord t, Binary t)+  => (P.Tagset -> t -> P.Tag)+     -- ^ Simplification function+  -> Get (Concraft t)+getModel smp = do+  comp <- get+  when (comp /= modelVersion) $ error $+    "Incompatible model version: " ++ comp +++    ", expected: " ++ modelVersion+  tagset <- get+  Concraft tagset <$> get <*> G.getGuesser (smp tagset) <*> D.getDisamb (smp tagset)+++-- | Save model in a file.  Data is compressed using the gzip format.+saveModel :: (Ord t, Binary t) => FilePath -> Concraft t -> IO ()+-- saveModel path = BL.writeFile path . GZip.compress . Binary.encode+saveModel path = BL.writeFile path . GZip.compress . runPut . putModel+++-- | Load model from a file.+loadModel :: (Ord t, Binary t) => (P.Tagset -> t -> P.Tag) -> FilePath -> IO (Concraft t)+loadModel smp path = do+    -- x <- Binary.decode . GZip.decompress <$> BL.readFile path+    x <- runGet (getModel smp) . GZip.decompress <$> BL.readFile path+    x `seq` return x+++----------------------+-- Annotation+----------------------+++-- | DAG annotation, assignes @b@ values to @a@ labels for each edge in the+-- graph.+type Anno a b = DAG () (M.Map a b)+++-- | Replace sentence probability values with the given annotation.+replace :: (Ord t) => Anno t Double -> Sent w t -> Sent w t+replace anno sent =+  fmap join $ DAG.zipE anno sent+  where+    join (m, seg) = seg {X.tags = X.fromMap m}+--     apply f+--       = X.fromMap+--       . M.mapWithKey (\key _val -> f M.! key)+--       . X.unWMap+++-- | Extract marginal annotations from the given sentence.+extract :: Sent w t -> Anno t Double+extract = fmap $ X.unWMap . X.tags+++----------------------+-- Best path+----------------------+++-- | Find all optimal paths in the given annotation. Optimal paths are those+-- which go through tags with the assigned probability 1.+findOptimalPaths :: Anno t Double -> [[(EdgeID, t)]]+findOptimalPaths dag = do+  edgeID <- DAG.dagEdges dag+  guard $ DAG.isInitialEdge edgeID dag+  doit edgeID+  where+    doit i = inside i ++ final i+    inside i = do+      (tag, weight) <- M.toList (DAG.edgeLabel i dag)+      guard $ weight >= 1.0 - eps+      j <- DAG.nextEdges i dag+      xs <- doit j+      return $ (i, tag) : xs+    final i = do+      guard $ DAG.isFinalEdge i dag+      (tag, weight) <- M.toList (DAG.edgeLabel i dag)+      guard $ weight >= 1.0 - eps+      return [(i, tag)]+    eps = 1.0e-9+++-- | Make the given path with disamb markers in the given annotation+-- and produce a new disamb annotation.+disambPath :: (Ord t) => [(EdgeID, t)] -> Anno t Double -> Anno t Bool+disambPath path =+  DAG.mapE doit+  where+    pathMap = M.fromList path+    doit edgeID m = M.fromList $ do+      let onPath = M.lookup edgeID pathMap+      x <- M.keys m+      return (x, Just x == onPath)+++----------------------+-- Marginals and Probs+----------------------+++-- | Determine marginal probabilities corresponding to individual+-- tags w.r.t. the guessing model.+guessMarginals :: (X.Word w, Ord t) => G.Guesser t P.Tag -> Sent w t -> Anno t Double+guessMarginals gsr = fmap X.unWMap . G.marginals gsr+++-- | Determine marginal probabilities corresponding to individual+-- tags w.r.t. the guessing model.+disambMarginals :: (X.Word w, Ord t) => D.Disamb t -> Sent w t -> Anno t Double+-- disambMarginals dmb = fmap X.unWMap . D.marginals dmb+disambMarginals = disambProbs D.Marginals+++-- | Determine probabilities corresponding to individual+-- tags w.r.t. the guessing model.+disambProbs :: (X.Word w, Ord t) => D.ProbType -> D.Disamb t -> Sent w t -> Anno t Double+disambProbs typ dmb = fmap X.unWMap . D.probs typ dmb+++-------------------------------------------------+-- Trimming+-------------------------------------------------+++-- | Trim down the set of potential labels to `k` most probable ones+-- for each OOV word in the sentence.+trimOOV :: (X.Word w, Ord t) => Int -> Sent w t -> Sent w t+trimOOV k =+  fmap trim+  where+    trim edge = if X.oov edge+      then trimEdge edge+      else edge+    trimEdge edge = edge {X.tags = X.trim k (X.tags edge)}+++---------------------+-- Tagging+---------------------+++-- | Determine marginal probabilities corresponding to individual tags w.r.t.+-- the guessing model and, afterwards, trim the sentence to keep only the `k`+-- most probably labels for each OOV edge. Note that, for OOV words, the entire+-- set of default tags is considered.+guessSent :: (X.Word w, Ord t) => Int -> G.Guesser t P.Tag -> Sent w t -> Sent w t+guessSent k gsr sent = trimOOV k $ replace (guessMarginals gsr sent) sent+++-- | Perform guessing, trimming, and finally determine marginal probabilities+-- corresponding to individual tags w.r.t. the guessing model.+guess :: (X.Word w, Ord t) => Int -> G.Guesser t P.Tag -> Sent w t -> Anno t Double+guess k gsr = extract . guessSent k gsr+++-- | Perform guessing, trimming, and finally determine marginal probabilities+-- corresponding to individual tags w.r.t. the disambiguation model.+tag :: (X.Word w, Ord t) => Int -> Concraft t -> Sent w t -> Anno t Double+tag k crf = disambMarginals (disamb crf) . guessSent k (guesser crf)+++-- -- | Perform guessing, trimming, and finally determine probabilities+-- -- corresponding to individual tags w.r.t. the disambiguation model.+-- tag' :: X.Word w => Int -> D.ProbType -> Concraft -> Sent w P.Tag -> Anno P.Tag Double+-- tag' k typ Concraft{..} = disambProbs typ disamb . guessSent k guesser+++---------------------+-- Training+---------------------+++-- | Train the `Concraft` model.+-- No reanalysis of the input data will be performed.+--+-- The `FromJSON` and `ToJSON` instances are used to store processed+-- input data in temporary files on a disk.+train+    :: (X.Word w, Ord t)+    => P.Tagset             -- ^ A morphosyntactic tagset to which `P.Tag`s+                            --   of the training and evaluation input data+                            --   must correspond.+    -> Int                  -- ^ How many tags is the guessing model supposed+                            --   to produce for a given OOV word?  It will be+                            --   used (see `G.guessSent`) on both training and+                            --   evaluation input data prior to the training+                            --   of the disambiguation model.+    -> G.TrainConf t P.Tag  -- ^ Training configuration for the guessing model.+    -> D.TrainConf t        -- ^ Training configuration for the+                            --   disambiguation model.+    -> IO [Sent w t]    -- ^ Training dataset.  This IO action will be+                            --   executed a couple of times, so consider using+                            --   lazy IO if your dataset is big.+    -> IO [Sent w t]    -- ^ Evaluation dataset IO action.  Consider using+                            --   lazy IO if your dataset is big.+    -> IO (Concraft t)+train tagset guessNum guessConf disambConf trainR'IO evalR'IO = do+  Temp.withTempDirectory "." ".guessed" $ \tmpDir -> do+  let temp = withTemp tagset tmpDir++  putStrLn "\n===== Train guessing model ====="+  guesser <- G.train guessConf trainR'IO evalR'IO+  let guess = guessSent guessNum guesser+  trainG  <- map guess <$> trainR'IO+  evalG   <- map guess <$> evalR'IO++  temp "train" trainG $ \trainG'IO -> do+  temp "eval"  evalG  $ \evalG'IO  -> do++  putStrLn "\n===== Train disambiguation model ====="+  disamb <- D.train disambConf trainG'IO evalG'IO+  return $ Concraft tagset guessNum guesser disamb+++---------------------+-- Temporary storage+---------------------+++-- | 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.+--+-- NOTE: (11/11/2017): it's just a dummy function right now, which does+-- not use disk storage at all.+--+withTemp+  -- :: (FromJSON w, ToJSON w)+  :: P.Tagset+  -> FilePath                     -- ^ Directory to create the file in+  -> String                       -- ^ Template for `Temp.withTempFile`+  -> [Sent w t]                   -- ^ Input dataset+  -> (IO [Sent w t] -> IO a)      -- ^ Handler+  -> IO a+withTemp _      _   _    [] handler = handler (return [])+withTemp tagset dir tmpl xs handler =+  Temp.withTempFile dir tmpl $ \tmpPath tmpHandle -> do+    hClose tmpHandle+    let txtSent = X.mapSent $ P.showTag tagset+        tagSent = X.mapSent $ P.parseTag tagset+    handler (return xs)+++---------------------+-- Pruning+---------------------+++-- | Prune disambiguation model: discard model features with+-- absolute values (in log-domain) lower than the given threshold.+prune :: Double -> Concraft t -> Concraft t+prune x concraft =+    let disamb' = D.prune x (disamb concraft)+    in  concraft { disamb = disamb' }

@@ -0,0 +1,436 @@+{-# LANGUAGE RecordWildCards #-}+++-- | Top-level module adated to DAGs, guessing and disambiguation.+++module NLP.Concraft.DAGSeg+(+-- * Model+  Concraft (..)+, saveModel+, loadModel+++-- * Annotation+, Anno++-- * Best paths+, findOptimalPaths+, disambPath++-- * Marginals+-- , D.ProbType (..)+, guessMarginals+, disambMarginals+, disambProbs++-- * Tagging+, guessSent+, guess+, tag+-- , tag'++-- -- * Training+-- , train++-- * Pruning+, prune+) where+++-- import           Prelude hiding (Word)+import           System.IO (hClose)+import           Control.Applicative ((<$>), (<*>)) -- , (<|>))+import           Control.Arrow (first, second)+import           Control.Monad (when, guard)+-- import           Data.Maybe (listToMaybe)+import qualified Data.Foldable as F+import qualified Data.Set as S+import qualified Data.Map.Strict as M+import           Data.Binary (Binary, put, get, Put, Get)+import qualified Data.Binary as Binary+import           Data.Binary.Put (runPut)+import           Data.Binary.Get (runGet)+import           Data.Aeson+import qualified System.IO.Temp as Temp+import qualified Data.ByteString.Lazy as BL+import qualified Codec.Compression.GZip as GZip+import           Data.Ord (comparing)+import           Data.List (sortBy)++import           Data.DAG (DAG, EdgeID)+import qualified Data.DAG as DAG++import qualified Data.Tagset.Positional as P++-- import           NLP.Concraft.Analysis+import           NLP.Concraft.Format.Temp+import qualified NLP.Concraft.DAG.Morphosyntax as X+import           NLP.Concraft.DAG.Morphosyntax (Sent, WMap)+import qualified NLP.Concraft.DAG.Guess as G+import qualified NLP.Concraft.DAG.DisambSeg as D+++---------------------+-- Model+---------------------+++modelVersion :: String+modelVersion = "dagseg:0.11"+++-- | Concraft data.+data Concraft t = Concraft+  { tagset        :: P.Tagset+  , guessNum      :: Int+  , guesser       :: G.Guesser t P.Tag+  , segmenter     :: D.Disamb t+  , disamb        :: D.Disamb t+  }+++putModel :: (Ord t, Binary t) => Concraft t -> Put+putModel Concraft{..} = do+  put modelVersion+  put tagset+  put guessNum+  G.putGuesser guesser+  D.putDisamb segmenter+  D.putDisamb disamb+++-- | Get the model, given the tag simplification function for the disambigutation model.+getModel+  :: (Ord t, Binary t)+  => (P.Tagset -> t -> P.Tag)+     -- ^ Guesser simplification function+  -> (P.Tagset -> t -> D.Tag)+     -- ^ Segmentation/disamb simplification function (TODO: two different+     -- simplification functions?)+  -> Get (Concraft t)+getModel gsrSmp dmbSmp = do+  comp <- get+  when (comp /= modelVersion) $ error $+    "Incompatible model version: " ++ comp +++    ", expected: " ++ modelVersion+  tagset <- get+  Concraft tagset <$> get+    <*> G.getGuesser (gsrSmp tagset)+    <*> D.getDisamb (dmbSmp tagset)+    <*> D.getDisamb (dmbSmp tagset)+++-- | Save model in a file.  Data is compressed using the gzip format.+saveModel :: (Ord t, Binary t) => FilePath -> Concraft t -> IO ()+-- saveModel path = BL.writeFile path . GZip.compress . Binary.encode+saveModel path = BL.writeFile path . GZip.compress . runPut . putModel+++-- | Load model from a file.+loadModel+  :: (Ord t, Binary t)+  => (P.Tagset -> t -> P.Tag)+     -- ^ Guesser simplification function+  -> (P.Tagset -> t -> D.Tag)+     -- ^ Disamb simplification function+  -> FilePath+  -> IO (Concraft t)+loadModel gsrSmp dmbSmp path = do+    -- x <- Binary.decode . GZip.decompress <$> BL.readFile path+    x <- runGet (getModel gsrSmp dmbSmp) . GZip.decompress <$> BL.readFile path+    x `seq` return x+++----------------------+-- Annotation+----------------------+++-- | DAG annotation, assignes @b@ values to @a@ labels for each edge in the+-- graph.+type Anno a b = DAG () (M.Map a b)+++-- | Replace sentence probability values with the given annotation.+replace :: (Ord t) => Anno t Double -> Sent w t -> Sent w t+replace anno sent =+  fmap join $ DAG.zipE anno sent+  where+    join (m, seg) = seg {X.tags = X.fromMap m}+++-- | Insert the guessing results into the sentence. Only interpretations of OOV+-- words will be extended.  The probabilities of the new tags are set to 0.+insertGuessed :: (X.Word w, Ord t) => Anno t Double -> Sent w t -> Sent w t+insertGuessed anno sent =+  fmap join $ DAG.zipE anno sent+  where+    join (gueMap, seg)+      | X.oov (X.word seg) =+          let oldMap  = X.unWMap (X.tags seg)+              gueMap0 = M.fromList+                      . map (second $ const 0)+                      $ M.toList gueMap+              newMap  = M.unionWith (+) oldMap gueMap0+          in  seg {X.tags = X.fromMap newMap}+      | otherwise = seg+++-- | Extract marginal annotations from the given sentence.+extract :: Sent w t -> Anno t Double+extract = fmap $ X.unWMap . X.tags+++----------------------+-- Best path+----------------------+++-- -- | Find all optimal paths in the given annotation. Optimal paths are those+-- -- which go through tags with the assigned probability 1.+-- findOptimalPaths :: Anno t Double -> [[(EdgeID, t)]]+-- findOptimalPaths dag = do+--   edgeID <- DAG.dagEdges dag+--   guard $ DAG.isInitialEdge edgeID dag+--   doit edgeID+--   where+--     doit i = inside i ++ final i+--     inside i = do+--       (tag, weight) <- M.toList (DAG.edgeLabel i dag)+--       guard $ weight >= 1.0 - eps+--       j <- DAG.nextEdges i dag+--       xs <- doit j+--       return $ (i, tag) : xs+--     final i = do+--       guard $ DAG.isFinalEdge i dag+--       (tag, weight) <- M.toList (DAG.edgeLabel i dag)+--       guard $ weight >= 1.0 - eps+--       return [(i, tag)]+--     eps = 1.0e-9+++-- | Find all optimal paths in the given annotation. Optimal paths are those+-- which go through tags with the assigned probability 1. For a given chosen+-- edge, all the tags with probability 1 are selected.+findOptimalPaths :: Ord t => Anno t Double -> [[(EdgeID, S.Set t)]]+findOptimalPaths dag = do+  edgeID <- DAG.dagEdges dag+  guard $ DAG.isInitialEdge edgeID dag+  doit edgeID+  where+    doit i = inside i ++ final i+    inside i = do+      let tags =+            [ tag+            | (tag, weight) <- M.toList (DAG.edgeLabel i dag)+            , weight >= 1.0 - eps ]+      guard . not $ null tags+      j <- DAG.nextEdges i dag+      xs <- doit j+      return $ (i, S.fromList tags) : xs+    final i = do+      guard $ DAG.isFinalEdge i dag+      let tags =+            [ tag+            | (tag, weight) <- M.toList (DAG.edgeLabel i dag)+            , weight >= 1.0 - eps ]+      guard . not $ null tags+      return [(i, S.fromList tags)]+    eps = 1.0e-9+++-- -- | Make the given path with disamb markers in the given annotation+-- -- and produce a new disamb annotation.+-- disambPath :: (Ord t) => [(EdgeID, t)] -> Anno t Double -> Anno t Bool+-- disambPath path =+--   DAG.mapE doit+--   where+--     pathMap = M.fromList path+--     doit edgeID m = M.fromList $ do+--       let onPath = M.lookup edgeID pathMap+--       x <- M.keys m+--       return (x, Just x == onPath)+++-- | Make the given path with disamb markers in the given annotation+-- and produce a new disamb annotation.+disambPath :: (Ord t) => [(EdgeID, S.Set t)] -> Anno t Double -> Anno t Bool+disambPath path =+  DAG.mapE doit+  where+    pathMap = M.fromList path+    doit edgeID m = M.fromList $ do+      let onPath = maybe S.empty id $ M.lookup edgeID pathMap+      x <- M.keys m+      return (x, S.member x onPath)+++----------------------+-- Marginals and Probs+----------------------+++-- | Determine marginal probabilities corresponding to individual+-- tags w.r.t. the guessing model.+guessMarginals :: (X.Word w, Ord t) => G.Guesser t P.Tag -> Sent w t -> Anno t Double+guessMarginals gsr = fmap X.unWMap . G.marginals gsr+++-- | Determine marginal probabilities corresponding to individual+-- tags w.r.t. the guessing model.+disambMarginals :: (X.Word w, Ord t) => D.Disamb t -> Sent w t -> Anno t Double+-- disambMarginals dmb = fmap X.unWMap . D.marginals dmb+disambMarginals = disambProbs D.Marginals+++-- | Determine probabilities corresponding to individual+-- tags w.r.t. the guessing model.+disambProbs :: (X.Word w, Ord t) => D.ProbType -> D.Disamb t -> Sent w t -> Anno t Double+disambProbs typ dmb = fmap X.unWMap . D.probs typ dmb+++-------------------------------------------------+-- Trimming+-------------------------------------------------+++-- | Trim down the set of potential labels to `k` most probable ones+-- for each OOV word in the sentence.+trimOOV :: (X.Word w, Ord t) => Int -> Sent w t -> Sent w t+trimOOV k =+  fmap trim+  where+    trim edge = if X.oov edge+      then edge {X.tags = trimWMap k (X.tags edge)}+      else edge+    trimWMap n = X.fromMap . trimMap n . X.unWMap+++-- | Trim down the set of potential labels to the `k` most probable ones.+trimMap :: (Ord t) => Int -> M.Map t Double -> M.Map t Double+trimMap k+  = M.fromList+  . take k+  . reverse+  . sortBy (comparing snd)+  . M.toList+++---------------------+-- Tagging+---------------------+++-- | Extend the OOV words with new, guessed interpretations.+--+-- Determine marginal probabilities corresponding to individual tags w.r.t.+-- the guessing model and, afterwards, trim the sentence to keep only the `k`+-- most probably labels for each OOV edge. Note that, for OOV words, the entire+-- set of default tags is considered.+--+guessSent :: (X.Word w, Ord t) => Int -> G.Guesser t P.Tag -> Sent w t -> Sent w t+guessSent k gsr sent = insertGuessed (fmap (trimMap k) (guessMarginals gsr sent)) sent+-- guessSent k gsr sent = trimOOV k $ replace (guessMarginals gsr sent) sent+++-- | Perform guessing, trimming, and finally determine marginal probabilities+-- corresponding to individual tags w.r.t. the guessing model.+guess :: (X.Word w, Ord t) => Int -> G.Guesser t P.Tag -> Sent w t -> Anno t Double+guess k gsr sent = extract . trimOOV k $ replace (guessMarginals gsr sent) sent+++-- | Perform guessing, trimming, and finally determine marginal probabilities+-- corresponding to individual tags w.r.t. the disambiguation model.+tag :: (X.Word w, Ord t) => Int -> Concraft t -> Sent w t -> Anno t Double+tag k crf = disambMarginals (disamb crf) . guessSent k (guesser crf)+++---------------------+-- Training+---------------------+++-- -- | Train the `Concraft` model.+-- -- No reanalysis of the input data will be performed.+-- --+-- -- The `FromJSON` and `ToJSON` instances are used to store processed+-- -- input data in temporary files on a disk.+-- train+--     :: (X.Word w, Ord t)+--     => P.Tagset             -- ^ A morphosyntactic tagset to which `P.Tag`s+--                             --   of the training and evaluation input data+--                             --   must correspond.+--     -> Int                  -- ^ How many tags is the guessing model supposed+--                             --   to produce for a given OOV word?  It will be+--                             --   used (see `G.guessSent`) on both training and+--                             --   evaluation input data prior to the training+--                             --   of the disambiguation model.+--     -> G.TrainConf t P.Tag  -- ^ Training configuration for the guessing model.+--     -> D.TrainConf t        -- ^ Training configuration for the+--                             --   disambiguation model.+--     -> IO [Sent w t]    -- ^ Training dataset.  This IO action will be+--                             --   executed a couple of times, so consider using+--                             --   lazy IO if your dataset is big.+--     -> IO [Sent w t]    -- ^ Evaluation dataset IO action.  Consider using+--                             --   lazy IO if your dataset is big.+--     -> IO (Concraft t)+-- train tagset guessNum guessConf disambConf trainR'IO evalR'IO = do+--   Temp.withTempDirectory "." ".guessed" $ \tmpDir -> do+--   let temp = withTemp tagset tmpDir+--+--   putStrLn "\n===== Train guessing model ====="+--   guesser <- G.train guessConf trainR'IO evalR'IO+--   let guess = guessSent guessNum guesser+--   trainG  <- map guess <$> trainR'IO+--   evalG   <- map guess <$> evalR'IO+--+--   temp "train" trainG $ \trainG'IO -> do+--   temp "eval"  evalG  $ \evalG'IO  -> do+--+--   putStrLn "\n===== Train disambiguation model ====="+--   disamb <- D.train disambConf trainG'IO evalG'IO+--   return $ Concraft tagset guessNum guesser disamb+--+--+-- ---------------------+-- -- Temporary storage+-- ---------------------+--+--+-- -- | 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.+-- --+-- -- NOTE: (11/11/2017): it's just a dummy function right now, which does+-- -- not use disk storage at all.+-- --+-- withTemp+--   -- :: (FromJSON w, ToJSON w)+--   :: P.Tagset+--   -> FilePath                     -- ^ Directory to create the file in+--   -> String                       -- ^ Template for `Temp.withTempFile`+--   -> [Sent w t]                   -- ^ Input dataset+--   -> (IO [Sent w t] -> IO a)      -- ^ Handler+--   -> IO a+-- withTemp _      _   _    [] handler = handler (return [])+-- withTemp tagset dir tmpl xs handler =+--   Temp.withTempFile dir tmpl $ \tmpPath tmpHandle -> do+--     hClose tmpHandle+--     let txtSent = X.mapSent $ P.showTag tagset+--         tagSent = X.mapSent $ P.parseTag tagset+--     handler (return xs)+++---------------------+-- Pruning+---------------------+++-- | Prune the disambiguation model: discard model features with absolute values+-- (in log-domain) lower than the given threshold.+prune :: Double -> Concraft t -> Concraft t+prune x concraft =+    let disamb' = D.prune x (disamb concraft)+    in  concraft { disamb = disamb' }

@@ -89,7 +89,7 @@     $ sent   where     schema  = fromConf schemaConf-    split   = P.split tiers+    split   = \t -> P.split tiers t Nothing     embed   = unSplit split  @@ -105,7 +105,7 @@         | y <- X.interps word ]  --- | Combine `disamb` with `include`. +-- | Combine `disamb` with `include`. disambSent :: X.Word w => Disamb -> X.Sent w T.Tag -> X.Sent w T.Tag disambSent = include . disamb @@ -121,7 +121,7 @@     $ sent   where     schema  = fromConf schemaConf-    split   = P.split tiers+    split   = \t -> P.split tiers t Nothing     embed w = X.mkWMap . zip (X.interps w)  @@ -161,7 +161,7 @@     return $ Disamb tiersT schemaConfT crf   where     schema = fromConf schemaConfT-    split  = P.split tiersT+    split  = \t -> P.split tiersT t Nothing  -- Improve disamb model. train ReTrainConf{..} trainData evalData = do@@ -173,7 +173,7 @@   where     Disamb{..} = initDmb     schema = fromConf schemaConf-    split  = P.split tiers+    split  = \t -> P.split tiers t Nothing   -- | Schematized data from the plain file.

@@ -23,31 +23,46 @@ data Tier = Tier {     -- | Does it include the part of speech?       withPos   :: Bool+    -- | End-of-sentence marker.+    , withEos   :: Bool     -- | Tier grammatical attributes.-    , withAtts  :: S.Set TP.Attr }+    , withAtts  :: S.Set TP.Attr+    }  instance Binary Tier where-    put Tier{..} = put withPos >> put withAtts-    get = Tier <$> get <*> get+    put Tier{..} = put withPos >> put withEos >> put withAtts+    get = Tier <$> get <*> get <*> get  -- | An atomic part of morphosyntactic tag with optional POS. data Atom = Atom     { pos   :: Maybe TP.POS-    , atts  :: M.Map TP.Attr T.Text }-    deriving (Show, Eq, Ord)+    , atts  :: M.Map TP.Attr T.Text+    , eos   :: Maybe Bool+      -- ^ NOTE: could be simplified to Bool, but this way it's more readable+    } deriving (Show, Eq, Ord)  instance Binary Atom where-    put Atom{..} = put pos >> put atts-    get = Atom <$> get <*> get+    put Atom{..} = put pos >> put atts >> put eos+    get = Atom <$> get <*> get <*> get  -- | Select tier attributes.-select :: Tier -> TP.Tag -> Atom-select Tier{..} tag = Atom-    { pos   = if withPos then Just (TP.pos tag) else Nothing-    , atts  = M.filterWithKey (\k _ -> k `S.member` withAtts) (TP.atts tag) }+select+  :: Tier       -- ^ The tier+  -> TP.Tag     -- ^ The positional tag+  -> Maybe Bool -- ^ (Maybe) end-of-sentence marker+  -> Atom+select Tier{..} tag eos = Atom+    { pos  = if withPos then Just (TP.pos tag) else Nothing+    , atts = M.filterWithKey (\k _ -> k `S.member` withAtts) (TP.atts tag)+    , eos  = if withEos then eos else Nothing+    }  -- | Split the positional tag.-split :: [Tier] -> TP.Tag -> [Atom]-split tiers tag =-    [ select tier tag+split+  :: [Tier]     -- ^ The tiers+  -> TP.Tag     -- ^ The positional tag+  -> Maybe Bool -- ^ (Maybe) end-of-sentence marker+  -> [Atom]+split tiers tag eos =+    [ select tier tag eos     | tier <- tiers ]

@@ -17,13 +17,22 @@ encodePar = BC.unlines . map encode  decodePar :: FromJSON w => BC.ByteString -> [Sent w T.Text]-decodePar = +decodePar =     let getRight (Right x) = x         getRight (Left e)  = error $ "error in decodePar: " ++ e     in  map (getRight . eitherDecode') . BC.lines  writePar :: ToJSON w => FilePath -> [Sent w T.Text] -> IO () writePar path = BC.writeFile path . encodePar+-- writePar path xs = do+--   putStrLn $ "Writing JSON to: " ++ path+--   BC.putStrLn (encodePar xs)+--   BC.writeFile path (encodePar xs)  readPar :: FromJSON w => FilePath -> IO [Sent w T.Text] readPar = fmap decodePar . BC.readFile+-- readPar path = do+--   putStrLn $ "Reading JSON from: " ++ path+--   cs <- BC.readFile path+--   BC.putStrLn cs+--   return (decodePar cs)

@@ -6,7 +6,7 @@ ( -- * Types   Guesser (..)- + -- * Guessing , guess , include@@ -30,10 +30,13 @@  import qualified Control.Monad.Ox as Ox import qualified Data.CRF.Chain1.Constrained as CRF+-- import qualified Data.CRF.Chain1.Constrained.DAG as CRF import qualified Numeric.SGD as SGD  import NLP.Concraft.Schema hiding (schematize) import qualified NLP.Concraft.Morphosyntax as X+-- import           NLP.Concraft.DAG.Schema hiding (schematize)+-- import qualified NLP.Concraft.DAG.Morphosyntax as X   -- | A guessing model.@@ -56,7 +59,7 @@     v = V.fromList sent     n = V.length v     obs = S.fromList . Ox.execOx . schema v-    lbs i +    lbs i         | X.oov w  = S.empty         | otherwise = X.interpsSet w         where w = v V.! i@@ -89,7 +92,7 @@         ++ zip xs [0, 0 ..]  --- | Combine `guess` with `include`. +-- | Combine `guess` with `include`. guessSent :: (X.Word w, Ord t)           => Int -> Guesser t           -> X.Sent w t -> X.Sent w t@@ -99,7 +102,7 @@  -- | Method of constructing the default set of labels (R0). data R0T-    = AnyInterps        -- ^ See `CRF.anyInterps` +    = AnyInterps        -- ^ See `CRF.anyInterps`     | AnyChosen         -- ^ See `CRF.anyChosen`     | OovChosen         -- ^ See `CRF.oovChosen`     deriving (Show, Eq, Ord, Enum, Typeable, Data)

@@ -8,7 +8,7 @@   module NLP.Concraft.Morphosyntax-( +( -- * Segment   Seg (..) , mapSeg@@ -25,12 +25,11 @@ , mapSentO  -- * Weighted collection-, WMap (unWMap)-, mapWMap-, mkWMap+, module NLP.Concraft.Morphosyntax.WMap ) where  +import           Prelude hiding (Word) import           Control.Applicative ((<$>), (<*>)) import           Control.Arrow (first) import           Data.Aeson@@ -40,7 +39,9 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as L +import           NLP.Concraft.Morphosyntax.WMap + -------------------------- -- Segment --------------------------@@ -51,9 +52,8 @@     -- | A word represented by the segment.  Typically it will be     -- an instance of the `Word` class.       word  :: w-    -- | A set of interpretations.  To each interpretation-    -- a weight of appropriateness within the context-    -- is assigned.+    -- | A set of interpretations. To each interpretation a weight of+    -- appropriateness within the context is assigned.     , tags  :: WMap t }     deriving (Show) @@ -66,7 +66,7 @@ instance FromJSON w => FromJSON (Seg w T.Text) where     parseJSON (Object v) = Seg         <$> v .: "word"-        <*> (WMap <$> v .: "tags")+        <*> (mkWMap <$> v .: "tags")     parseJSON _ = error "parseJSON (segment): absurd"  @@ -92,7 +92,7 @@  class Word a where     -- | Orthographic form.-    orth    :: a -> T.Text +    orth    :: a -> T.Text     -- | Out-of-vocabulary (OOV) word.     oov     :: a -> Bool @@ -127,22 +127,3 @@ mapSentO f x =     let segs' = mapSent f (segs x)     in  x { segs = segs' }--------------------------- Weighted collection--------------------------- | A set with a non-negative weight assigned to each of--- its elements.-newtype WMap a = WMap { unWMap :: M.Map a Double }-    deriving (Show, Eq, Ord, Binary)----- | Make a weighted collection.  Negative elements will be ignored.-mkWMap :: Ord a => [(a, Double)] -> WMap a-mkWMap = WMap . M.fromListWith (+) . filter ((>=0).snd)----- | Map function over weighted collection elements. -mapWMap :: Ord b => (a -> b) -> WMap a -> WMap b-mapWMap f = mkWMap . map (first f) . M.toList . unWMap

@@ -15,6 +15,7 @@ ) where   +import           Prelude hiding (Word) import           Data.List (foldl') import qualified Data.Set as S import qualified Data.Map as M

@@ -10,6 +10,7 @@ ) where  +import           Prelude hiding (Word) import           Control.Applicative ((<|>)) import           Data.Maybe (fromJust) import           Data.List (find)

@@ -0,0 +1,59 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+++module NLP.Concraft.Morphosyntax.WMap+( WMap (unWMap)+, fromMap+, mapWMap+, mkWMap+, trim+) where+++import           Control.Arrow (first)+import           Data.Binary (Binary)+import           Data.Ord (comparing)+import           Data.List (sortBy)+import qualified Data.Map as M+++----------------------+-- Weighted collection+----------------------+++-- | A set with a non-negative weight assigned to each of+-- its elements.+newtype WMap a = WMap { unWMap :: M.Map a Double }+    deriving (Show, Eq, Ord, Binary)+++-- | Create WMap from a map.+fromMap :: M.Map a Double -> WMap a+fromMap = WMap+++-- | Make a weighted collection.  Negative elements will be ignored.+mkWMap :: Ord a => [(a, Double)] -> WMap a+mkWMap = WMap . M.fromListWith (+) . filter ((>=0).snd)+++-- | Map function over weighted collection elements.+mapWMap :: Ord b => (a -> b) -> WMap a -> WMap b+mapWMap f = mkWMap . map (first f) . M.toList . unWMap+++--------------------------+-- Trimming+--------------------------+++-- | Trim down the set of potential labels to `k` most probable ones.+trim :: (Ord a) => Int -> WMap a -> WMap a+trim k+  = mkWMap+  . take k+  . reverse+  . sortBy (comparing snd)+  . M.toList+  . unWMap