diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,10 @@ +-*-change-log-*- + +0.14.0 Oct 2018 + * Rely on `fastTag` from the `crf-chain2-tiers` library + +0.13.0 Sep 2018 + * Slightly optimize guessing + +0.12.0 Sep 2018 + * Add support for a tag blacklist (guessing) diff --git a/concraft.cabal b/concraft.cabal --- a/concraft.cabal +++ b/concraft.cabal @@ -1,5 +1,5 @@ name: concraft -version: 0.9.4 +version: 0.14.2 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, IPI PAN author: Jakub Waszczuk maintainer: waszczuk.kuba@gmail.com stability: experimental @@ -15,6 +15,8 @@ homepage: http://zil.ipipan.waw.pl/Concraft build-type: Simple +extra-source-files: changelog + Flag buildAnaTool Description: Build model analysis tool Default: False @@ -26,26 +28,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.6 && < 0.7 + , crf-chain2-tiers >= 0.6 && < 0.7 , 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 +59,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 diff --git a/src/NLP/Concraft.hs b/src/NLP/Concraft.hs --- a/src/NLP/Concraft.hs +++ b/src/NLP/Concraft.hs @@ -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) @@ -34,7 +35,7 @@ import NLP.Concraft.Morphosyntax import NLP.Concraft.Analysis -import NLP.Concraft.Format.Temp +-- import NLP.Concraft.Format.Temp import qualified Data.Tagset.Positional as P import qualified NLP.Concraft.Guess as G import qualified NLP.Concraft.Disamb as D @@ -229,9 +230,27 @@ -> IO a withTemp _ _ _ [] handler = handler (return []) withTemp tagset dir tmpl xs handler = - Temp.withTempFile dir tmpl $ \tmpPath tmpHandle -> do + 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) + let _txtSent = mapSent $ P.showTag tagset + _tagSent = mapSent $ P.parseTag tagset + -- 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) diff --git a/src/NLP/Concraft/Analysis.hs b/src/NLP/Concraft/Analysis.hs --- a/src/NLP/Concraft/Analysis.hs +++ b/src/NLP/Concraft/Analysis.hs @@ -15,6 +15,7 @@ ) where +import Prelude hiding (Word) import qualified Control.Monad.LazyIO as LazyIO import qualified Data.Text.Lazy as L diff --git a/src/NLP/Concraft/DAG/Disamb.hs b/src/NLP/Concraft/DAG/Disamb.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/DAG/Disamb.hs @@ -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 (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 ] diff --git a/src/NLP/Concraft/DAG/DisambSeg.hs b/src/NLP/Concraft/DAG/DisambSeg.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/DAG/DisambSeg.hs @@ -0,0 +1,321 @@ +{-# 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 (..) + + +-- * Disambiguation +, disamb + +-- -- * 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 Control.Monad (guard) +import Data.Binary (put, get, Put, Get) +import Data.Maybe (maybeToList) +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.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. +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 + getTags = X.fromMap . choice + -- below we mix the chosen and the potential interpretations together + choice w = M.unionWith (+) + (CRF.unProb . snd $ w) + -- (M.fromList . map (,0) . interps $ w) + (M.fromSet (const 0) . interps $ w) + -- interps = S.toList . CRF.lbs . fst + interps = CRF.lbs . fst + + +-- | Determine 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) + + +-------------------------- +-- Disambiguation +-------------------------- + + +-- -- | Perform disambiguation. +-- disamb :: (X.Word w, Ord t) => Disamb t -> X.Sent w t -> DAG () (X.WMap t) +-- disamb probTyp dmb = fmap X.tags . probsSent probTyp dmb + + +-- | Perform disambiguation. +disamb :: (X.Word w, Ord t) => Disamb t -> X.Sent w t -> DAG () (M.Map t Bool) +disamb dmb srcSent + = injectDmb + . disambCRF dmb + $ srcSent + where + injectDmb newSent = + let doit (target, src) = M.fromList $ do + tag <- X.interps src + let tag' = split (tiers dmb) (simplify dmb tag) + isDmb = Just tag' == target + return (tag, isDmb) + in fmap doit (DAG.zipE newSent srcSent) + + +-- | Perform disambiguation (CRF level). +disambCRF :: + (X.Word w, Ord t) + => Disamb t + -> X.Sent w t + -> DAG () (Maybe [P.Atom]) +disambCRF dmb + = CRF.tag (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 splitIt = + map onSent + where + onSent sent = + let xs = fmap (X.mapSeg splitIt) (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) diff --git a/src/NLP/Concraft/DAG/Guess.hs b/src/NLP/Concraft/DAG/Guess.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/DAG/Guess.hs @@ -0,0 +1,402 @@ +{-# 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) + -- TODO: with `complexify`, `unkTagSet` is not needed anymore! + , simplify :: t -> s + -- ^ A tag simplification function + , complexify :: s -> t + -- ^ NEW: instead of an `unkTagSet`, a function which makes a complex tag + -- out of a simple tag. + -- + -- WARNING: we assume, that this function does not conflate simplified + -- tags, i.e., tag to tags of type `s` cannot lead to one and the same + -- complex tag of type `t`. + } + + +-- 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, Ord t) + => (t -> s) + -> (s -> t) + -> Get (Guesser t s) +getGuesser smp cpx = + Guesser <$> get <*> get <*> get <*> get <*> pure smp <*> pure cpx + + +-- -------------------------- +-- -- 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) + => CRF.Config s + -> Guesser t s + -> X.Sent w t + -> DAG () (X.WMap t) +marginals cfg gsr = fmap X.tags . marginalsSent cfg gsr + + +-- | Replace the probabilities of the sentence labels with the marginal probabilities +-- stemming from the model. +marginalsSent + :: (X.Word w, Ord t, Ord s) + => CRF.Config s + -> Guesser t s + -> X.Sent w t + -> X.Sent w t +marginalsSent cfg gsr sent + = (\new -> inject gsr new sent) + . fmap tags + . marginalsCRF cfg gsr + $ sent + where + tags = X.fromMap . 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) + (M.fromSet (const 0) . interps $ w) + interps = 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) + => CRF.Config s + -> Guesser t s + -> X.Sent w t + -> CRF.SentL Ob s +marginalsCRF cfg gsr dag0 = + let schema = fromConf (schemaConf gsr) + dag = X.mapSent (simplify gsr) dag0 + in CRF.marginals cfg (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) + | X.oov (X.word src) = + let newTags = X.fromMap $ M.fromAscList + [ (complexify gsr tag, prob) + | (tag, prob) <- M.toAscList (X.unWMap target) ] + in src {X.tags = newTags} + | otherwise = + let oldTags = 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) ] +-- injectWMap gsr newSpl src = X.fromMap $ M.fromAscList +-- [ (complexify gsr smp, prob) +-- | (smp, prob) <- M.toAscList (X.unWMap newSpl) ] + + +-- -------------------------- +-- -- ??? +-- -------------------------- +-- +-- +-- +-- -- -- | 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 + -- | Label complexification function + , complexifyLabel :: s -> t + -- | Strip the label from irrelevant information. Used to determine the + -- set of possible tags for unknown words. + -- TODO: we don't need this with `complexify` anymore!? + , 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 + complexifyLabel + + +-- | 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 ] + + +-- | Compute the default `X.WMap` for unknown tags. +compUnkWMap :: Ord t => S.Set t -> X.WMap t +compUnkWMap = X.mkWMap . map (,0) . S.toList diff --git a/src/NLP/Concraft/DAG/Morphosyntax.hs b/src/NLP/Concraft/DAG/Morphosyntax.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/DAG/Morphosyntax.hs @@ -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' } diff --git a/src/NLP/Concraft/DAG/Morphosyntax/Accuracy.hs b/src/NLP/Concraft/DAG/Morphosyntax/Accuracy.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/DAG/Morphosyntax/Accuracy.hs @@ -0,0 +1,306 @@ +{-# 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. +-- WARNING: the `dagProb` is most likely not correct, see the `crf-chain1-constrained` +-- library for a correct version. +-- 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 diff --git a/src/NLP/Concraft/DAG/Morphosyntax/Ambiguous.hs b/src/NLP/Concraft/DAG/Morphosyntax/Ambiguous.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/DAG/Morphosyntax/Ambiguous.hs @@ -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 diff --git a/src/NLP/Concraft/DAG/Schema.hs b/src/NLP/Concraft/DAG/Schema.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/DAG/Schema.hs @@ -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:_) = Just x + mayHead [] = Nothing + mayTail = mayHead . reverse diff --git a/src/NLP/Concraft/DAG/Segmentation.hs b/src/NLP/Concraft/DAG/Segmentation.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/DAG/Segmentation.hs @@ -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 diff --git a/src/NLP/Concraft/DAGSeg.hs b/src/NLP/Concraft/DAGSeg.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/DAGSeg.hs @@ -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 + +-- * Disambiguation / best paths +, disamb +, 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 (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 qualified Data.CRF.Chain1.Constrained.DAG as CRF + +-- import NLP.Concraft.Analysis +-- import NLP.Concraft.Format.Temp +import qualified NLP.Concraft.DAG.Morphosyntax as X +import NLP.Concraft.DAG.Morphosyntax (Sent) +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 + , disamber :: 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 disamber + + +-- | 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 -> P.Tag -> t) + -- ^ Guesser complexification function + -> (P.Tagset -> t -> D.Tag) + -- ^ Segmentation/disamb simplification function (TODO: two different + -- simplification functions?) + -> Get (Concraft t) +getModel gsrSmp gsrCpx dmbSmp = do + comp <- get + when (comp /= modelVersion) $ error $ + "Incompatible model version: " ++ comp ++ + ", expected: " ++ modelVersion + tagset <- get + Concraft tagset <$> get + <*> G.getGuesser (gsrSmp tagset) (gsrCpx 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 -> P.Tag -> t) + -- ^ Guesser complexification function + -> (P.Tagset -> t -> D.Tag) + -- ^ Disamb simplification function + -> FilePath + -> IO (Concraft t) +loadModel gsrSmp gsrCpx dmbSmp path = do + -- x <- Binary.decode . GZip.decompress <$> BL.readFile path + x <- runGet (getModel gsrSmp gsrCpx 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 + + +---------------------- +-- Disambiguation +---------------------- + + +-- | 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 = + [ tak + | (tak, 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 = + [ tak + | (tak, 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, 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) + + +-- | Determine max probabilities corresponding to individual tags w.r.t. the +-- disambiguation model. +disamb :: (X.Word w, Ord t) => D.Disamb t -> Sent w t -> Anno t Bool +disamb dmb = D.disamb dmb + + +---------------------- +-- Marginals and Probs +---------------------- + + +-- | Determine marginal probabilities corresponding to individual tags w.r.t. +-- the guessing model. +guessMarginals + :: (X.Word w, Ord t) + => CRF.Config P.Tag + -> G.Guesser t P.Tag + -> Sent w t + -> Anno t Double +guessMarginals cfg gsr = fmap X.unWMap . G.marginals cfg gsr + + +-- | Determine marginal probabilities corresponding to individual tags w.r.t. +-- the disambiguation model. +disambMarginals :: (X.Word w, Ord t) => D.Disamb t -> Sent w t -> Anno t Double +disambMarginals = disambProbs D.Marginals + + +-- | Determine max probabilities corresponding to individual tags w.r.t. the +-- disambiguation 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 + -> CRF.Config P.Tag + -> G.Guesser t P.Tag + -> Sent w t + -> Sent w t +guessSent k cfg gsr sent = + insertGuessed (fmap (trimMap k) (guessMarginals cfg 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 + -> CRF.Config P.Tag + -> G.Guesser t P.Tag + -> Sent w t + -> Anno t Double +guess k cfg gsr sent = + extract . trimOOV k $ replace (guessMarginals cfg 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 + -> CRF.Config P.Tag + -> Concraft t + -> Sent w t + -> Anno t Double +tag k cfg crf = disambMarginals (disamber crf) . guessSent k cfg (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 disamber' = D.prune x (disamber concraft) + in concraft { disamber = disamber' } diff --git a/src/NLP/Concraft/Disamb.hs b/src/NLP/Concraft/Disamb.hs --- a/src/NLP/Concraft/Disamb.hs +++ b/src/NLP/Concraft/Disamb.hs @@ -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. diff --git a/src/NLP/Concraft/Disamb/Positional.hs b/src/NLP/Concraft/Disamb/Positional.hs --- a/src/NLP/Concraft/Disamb/Positional.hs +++ b/src/NLP/Concraft/Disamb/Positional.hs @@ -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 ] diff --git a/src/NLP/Concraft/Format/Temp.hs b/src/NLP/Concraft/Format/Temp.hs --- a/src/NLP/Concraft/Format/Temp.hs +++ b/src/NLP/Concraft/Format/Temp.hs @@ -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) diff --git a/src/NLP/Concraft/Guess.hs b/src/NLP/Concraft/Guess.hs --- a/src/NLP/Concraft/Guess.hs +++ b/src/NLP/Concraft/Guess.hs @@ -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) diff --git a/src/NLP/Concraft/Morphosyntax.hs b/src/NLP/Concraft/Morphosyntax.hs --- a/src/NLP/Concraft/Morphosyntax.hs +++ b/src/NLP/Concraft/Morphosyntax.hs @@ -8,7 +8,7 @@ module NLP.Concraft.Morphosyntax -( +( -- * Segment Seg (..) , mapSeg @@ -25,22 +25,23 @@ , 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 Control.Arrow (first) import Data.Aeson -import Data.Binary (Binary) +-- 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 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 diff --git a/src/NLP/Concraft/Morphosyntax/Accuracy.hs b/src/NLP/Concraft/Morphosyntax/Accuracy.hs --- a/src/NLP/Concraft/Morphosyntax/Accuracy.hs +++ b/src/NLP/Concraft/Morphosyntax/Accuracy.hs @@ -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 diff --git a/src/NLP/Concraft/Morphosyntax/Align.hs b/src/NLP/Concraft/Morphosyntax/Align.hs --- a/src/NLP/Concraft/Morphosyntax/Align.hs +++ b/src/NLP/Concraft/Morphosyntax/Align.hs @@ -10,6 +10,7 @@ ) where +import Prelude hiding (Word) import Control.Applicative ((<|>)) import Data.Maybe (fromJust) import Data.List (find) diff --git a/src/NLP/Concraft/Morphosyntax/WMap.hs b/src/NLP/Concraft/Morphosyntax/WMap.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Morphosyntax/WMap.hs @@ -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