crf-chain1-constrained 0.3.2 → 0.4.0

raw patch · 20 files changed

+1872/−202 lines, 20 filesdep +data-memocombinatorsdep +pedestrian-dagdep ~arraydep ~binarydep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: data-memocombinators, pedestrian-dag

Dependency ranges changed: array, binary, containers, data-lens, parallel, random, sgd, vector, vector-binary

API changes (from Hackage documentation)

Files

• crf-chain1-constrained.cabal +29/−15
• src/Data/CRF/Chain1/Constrained.hs +1/−0
• src/Data/CRF/Chain1/Constrained/Core.hs +188/−0
• src/Data/CRF/Chain1/Constrained/DAG.hs +117/−0
• src/Data/CRF/Chain1/Constrained/DAG/Dataset/Codec.hs +109/−0
• src/Data/CRF/Chain1/Constrained/DAG/Dataset/External.hs +24/−0
• src/Data/CRF/Chain1/Constrained/DAG/Feature.hs +63/−0
• src/Data/CRF/Chain1/Constrained/DAG/Feature/Hidden.hs +72/−0
• src/Data/CRF/Chain1/Constrained/DAG/Feature/Present.hs +71/−0
• src/Data/CRF/Chain1/Constrained/DAG/Inference.hs +532/−0
• src/Data/CRF/Chain1/Constrained/DAG/Probs.hs +207/−0
• src/Data/CRF/Chain1/Constrained/DAG/Train.hs +274/−0
• src/Data/CRF/Chain1/Constrained/DP.hs +22/−11
• src/Data/CRF/Chain1/Constrained/Dataset/Codec.hs +2/−0
• src/Data/CRF/Chain1/Constrained/Dataset/External.hs +37/−13
• src/Data/CRF/Chain1/Constrained/Dataset/Internal.hs +74/−110
• src/Data/CRF/Chain1/Constrained/Feature.hs +3/−48
• src/Data/CRF/Chain1/Constrained/Inference.hs +4/−4
• src/Data/CRF/Chain1/Constrained/Intersect.hs +42/−0
• src/Data/CRF/Chain1/Constrained/Model.hs +1/−1

@@ -1,5 +1,5 @@ name:               crf-chain1-constrained-version:            0.3.2+version:            0.4.0 synopsis:           First-order, constrained, linear-chain conditional random fields description:     The library provides efficient implementation of the first-order,@@ -8,11 +8,11 @@     .     It is strongly related to the simpler     <http://hackage.haskell.org/package/crf-chain1>-    library where constraints are not taken into account and all-    features which are not included in the CRF model are considered to have-    probability of 0.  Here, on the other hand, such features do not influence-    the overall probability of the (sentence, labels) pair - they are-    assigned the default potential of 0.+    library where constraints are not taken into account and all features+    which are not included in the CRF model are considered to have+    probability of 0.  Here, on the other hand, such features do not+    influence the overall probability of the (sentence, labels) pair+    - they are assigned the default potential of 0.     .     Efficient algorithm for determining marginal probabilities of individual     labels is provided.@@ -37,21 +37,24 @@      build-depends:         base                >= 4        && < 5-      , containers-      , vector-      , array-      , random-      , parallel+      , containers          >= 0.4      && < 0.6+      , vector              >= 0.10     && < 0.13+      , array               >= 0.4      && < 0.6+      , random              >= 1.0      && < 1.2+      , parallel            >= 3.2      && < 3.3       , logfloat            >= 0.12.1   && < 0.14       , monad-codec         >= 0.2      && < 0.3-      , binary-      , vector-binary-      , data-lens-      , sgd                 >= 0.3.2    && < 0.4+      , binary              >= 0.5      && < 0.9+      , vector-binary       >= 0.1      && < 0.2+      , data-lens           >= 2.10     && < 2.12+      , sgd                 >= 0.4.0    && < 0.5       , vector-th-unbox     >= 0.2.1    && < 0.3+      , pedestrian-dag      >= 0.2      && < 0.3+      , data-memocombinators >= 0.5      && < 0.6      exposed-modules:         Data.CRF.Chain1.Constrained+      , Data.CRF.Chain1.Constrained.Core       , Data.CRF.Chain1.Constrained.Dataset.Internal       , Data.CRF.Chain1.Constrained.Dataset.External       , Data.CRF.Chain1.Constrained.Dataset.Codec@@ -61,6 +64,17 @@       , Data.CRF.Chain1.Constrained.Model       , Data.CRF.Chain1.Constrained.Inference       , Data.CRF.Chain1.Constrained.Train++      , Data.CRF.Chain1.Constrained.DAG+      -- , Data.CRF.Chain1.Constrained.DAG.Dataset.Internal+      , Data.CRF.Chain1.Constrained.DAG.Dataset.External+      , Data.CRF.Chain1.Constrained.DAG.Dataset.Codec+      , Data.CRF.Chain1.Constrained.DAG.Feature+      , Data.CRF.Chain1.Constrained.DAG.Feature.Present+      , Data.CRF.Chain1.Constrained.DAG.Feature.Hidden+      , Data.CRF.Chain1.Constrained.DAG.Inference+      , Data.CRF.Chain1.Constrained.DAG.Probs+      , Data.CRF.Chain1.Constrained.DAG.Train      other-modules:         Data.CRF.Chain1.Constrained.DP

@@ -25,6 +25,7 @@ , module Data.CRF.Chain1.Constrained.Feature.Hidden ) where +import Prelude hiding (Word) import Data.CRF.Chain1.Constrained.Dataset.External import Data.CRF.Chain1.Constrained.Dataset.Codec import Data.CRF.Chain1.Constrained.Feature.Present

@@ -0,0 +1,188 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+++module Data.CRF.Chain1.Constrained.Core+(+-- * Basic Types+  Ob (..)+, Lb (..)++, X (..)+, mkX+, unX+, unR++, Y (..)+, mkY+, unY++, AVec (..)+, fromList+, fromSet++-- * Features+, Feature (..)+, isSFeat+, isTFeat+, isOFeat+) where+++import Control.Applicative ((<*>), (<$>))+-- import Data.Vector.Generic.Base+-- import Data.Vector.Generic.Mutable+import Data.Vector.Binary ()+import Data.Binary (Binary, Get, get, put, putWord8, getWord8)+import Data.Ix (Ix)+import qualified Data.Set as S+-- import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import           Data.Vector.Unboxed.Deriving+-- import qualified Data.Number.LogFloat as L+++----------------------------------------------+-- Basic Types+----------------------------------------------+++-- | An observation.+newtype Ob = Ob { unOb :: Int }+    deriving ( Show, Read, Eq, Ord, Binary )+--           GeneralizedNewtypeDeriving doesn't work for this in 7.8.2:+--           , Vector U.Vector, MVector U.MVector, U.Unbox )+derivingUnbox "Ob" [t| Ob -> Int |] [| unOb |] [| Ob |]++-- | A label.+newtype Lb = Lb { unLb :: Int }+    deriving ( Show, Read, Eq, Ord, Binary, Num, Ix )+derivingUnbox "Lb" [t| Lb -> Int |] [| unLb |] [| Lb |]++-- | An ascending vector of unique elements.+newtype AVec a = AVec { unAVec :: U.Vector a }+    deriving (Show, Read, Eq, Ord, Binary)++-- | Smart AVec constructor which ensures that the+-- underlying vector satisfies the AVec properties.+fromList :: (Ord a, U.Unbox a) => [a] -> AVec a+fromList = fromSet . S.fromList +{-# INLINE fromList #-}++-- | Smart AVec constructor which ensures that the+-- underlying vector satisfies the AVec properties.+fromSet :: (Ord a, U.Unbox a) => S.Set a -> AVec a+fromSet = AVec . U.fromList . S.toAscList+{-# INLINE fromSet #-}++-- | A word represented by a list of its observations+-- and a list of its potential label interpretations.+data X+    -- | The word with default set of potential interpretations.+    = X { _unX :: AVec Ob }+    -- | The word with restricted set of potential labels.+    | R { _unX :: AVec Ob+        , _unR :: AVec Lb }+    deriving (Show, Read, Eq, Ord)++instance Binary X where+    put X{..} = putWord8 0 >> put _unX+    put R{..} = putWord8 1 >> put _unX >> put _unR+    get = getWord8 >>= \i -> case i of+        0   -> X <$> get+        _   -> R <$> get <*> get++-- | X constructor.+mkX :: [Ob] -> [Lb] -> X+mkX x [] = X (fromList x)+mkX x r  = R (fromList x) (fromList r)+{-# INLINE mkX #-}++-- | List of observations.+unX :: X -> [Ob]+unX = U.toList . unAVec . _unX+{-# INLINE unX #-}++-- | List of potential labels.+unR :: AVec Lb -> X -> [Lb]+unR r0 X{..} = U.toList . unAVec $ r0+unR _  R{..} = U.toList . unAVec $ _unR+{-# INLINE unR #-}+++-- | Probability distribution over labels.  We assume, that when y is+-- a member of chosen labels list it is also a member of the list+-- potential labels for corresponding 'X' word.+-- TODO: Perhaps we should substitute 'Lb's with label indices+-- corresponding to labels from the vector of potential labels?+-- FIXME: The type definition is incorrect (see 'fromList' definition),+-- it should be something like AVec2.+newtype Y = Y { _unY :: AVec (Lb, Double) }+    deriving (Show, Read, Eq, Ord, Binary)++-- | Y constructor.+mkY :: [(Lb, Double)] -> Y+mkY = Y . fromList+{-# INLINE mkY #-}++-- | Y deconstructor symetric to mkY.+unY :: Y -> [(Lb, Double)]+unY = U.toList . unAVec . _unY+{-# INLINE unY #-}+++----------------------------------------------+-- Features+----------------------------------------------+++-- | A Feature is either an observation feature OFeature o x, which+-- models relation between observation o and label x assigned to+-- the same word, or a transition feature TFeature x y (SFeature x+-- for the first position in the sentence), which models relation+-- between two subsequent labels, x (on i-th position) and y+-- (on (i-1)-th positoin).+data Feature+    = SFeature+        {-# UNPACK #-} !Lb+    | TFeature+        {-# UNPACK #-} !Lb+        {-# UNPACK #-} !Lb+    | OFeature+        {-# UNPACK #-} !Ob+        {-# UNPACK #-} !Lb+    deriving (Show, Eq, Ord)++instance Binary Feature where+    put (SFeature x)   = put (0 :: Int) >> put x+    put (TFeature x y) = put (1 :: Int) >> put (x, y)+    put (OFeature o x) = put (2 :: Int) >> put (o, x)+    get = do+        k <- get :: Get Int+        case k of+            0 -> SFeature <$> get+            1 -> TFeature <$> get <*> get+            2 -> OFeature <$> get <*> get+	    _ -> error "Binary Feature: unknown identifier"+++-- | Is it a 'SFeature'?+isSFeat :: Feature -> Bool+isSFeat (SFeature _) = True+isSFeat _            = False+{-# INLINE isSFeat #-}++-- | Is it an 'OFeature'?+isOFeat :: Feature -> Bool+isOFeat (OFeature _ _) = True+isOFeat _              = False+{-# INLINE isOFeat #-}++-- | Is it a 'TFeature'?+isTFeat :: Feature -> Bool+isTFeat (TFeature _ _) = True+isTFeat _              = False+{-# INLINE isTFeat #-}

@@ -0,0 +1,117 @@++{-# LANGUAGE RecordWildCards #-}++-- | The module provides first-order, linear-chain conditional random fields+-- (CRFs) with position-wide constraints over label values.++module Data.CRF.Chain1.Constrained.DAG+(+-- * Data types+  Word (..)+, unknown+, Sent+, Prob (unProb)+, mkProb+, WordL (word, choice)+, mkWordL+, SentL++-- ** Tagging+, tag+, marginals+-- , tagK++-- * Modules+, module Data.CRF.Chain1.Constrained.DAG.Train+, module Data.CRF.Chain1.Constrained.DAG.Feature.Present+, module Data.CRF.Chain1.Constrained.DAG.Feature.Hidden+) where++import           Prelude hiding (Word)+import qualified Data.Vector as V+import qualified Data.Number.LogFloat as L++-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG+import qualified Data.DAG as DAG+import           Data.DAG (DAG)++-- import           Data.CRF.Chain1.Constrained.Dataset.External+import           Data.CRF.Chain1.Constrained.DAG.Dataset.External+-- import           Data.CRF.Chain1.Constrained.DAG.Dataset.External (WordL(..))+import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Codec as C+import           Data.CRF.Chain1.Constrained.Dataset.Codec (decodeLabel, unJust)+import           Data.CRF.Chain1.Constrained.DAG.Feature.Present+import           Data.CRF.Chain1.Constrained.DAG.Feature.Hidden+import           Data.CRF.Chain1.Constrained.DAG.Train+import qualified Data.CRF.Chain1.Constrained.DAG.Inference as I+import qualified Data.CRF.Chain1.Constrained.Dataset.Internal as Int+++-- | Determine the most probable label sequence within the context of the+-- given sentence using the model provided by the 'CRF'.+tag :: (Ord a, Ord b) => CRF a b -> Sent a b -> DAG () b+tag CRF{..} sent+    = onWords+    . fmap (decodeLabel codec)+    . I.tag model+    . C.encodeSent codec+    $ sent+  where+    -- handle unknown labels; otherwise, the type of `tag`s result+    -- would be `DAG () (Maybe b)`+    onWords labeled =+      fmap f labeledSent+      where+        f = uncurry (unJust codec)+        labeledSent = DAG.zipE sent labeled+++-- | Tag with marginal probabilities. For known words (i.e., with `lbs`+-- non-empty), their known potential interpretations are assigned some+-- probabilities (other interpretations are not considered.  For unknown+-- words (i.e., with empty `lbs`), all interpretations are considered+-- (up to the way the set of all interpretations is constructed).+-- In particular, if no interpretation with probability > 0 is found+-- for an unknown word, its set of chosen labels will remain empty.+marginals :: (Ord a, Ord b) => CRF a b -> Sent a b -> SentL a b+marginals CRF{..} sent+  = fmap decodeChosen+  . DAG.zipE sent+  . I.marginals model+  . C.encodeSent codec+  $ sent+  where+    decodeChosen (word, chosen) =+      mkWordL word prob+      where+        prob = mkProb+          [ (decode word x, L.fromLogFloat p)+          |  (x, p) <- chosen ]+    decode word = unJust codec word . decodeLabel codec+++-- -- | Determine the most probable label sets of the given size (at maximum)+-- -- for each position in the input sentence.+-- tagK :: (Ord a, Ord b) => Int -> CRF a b -> Sent a b -> [[b]]+-- tagK k CRF{..} sent+--     = onWords . map decodeChoice+--     . DAG.toListProv+--     . I.tagK k model+--     . dagSent+--     . encodeSent codec+--     $ sent+--   where+--     decodeChoice = decodeLabels codec . map fst+--     onWords xss =+--         [ take k $ unJusts codec word xs+--         | (word, xs) <- zip sent xss ]+--+--+-- ------------------------------------------------------+-- -- Dataset conversion (Provisional)+-- ------------------------------------------------------+--+--+-- -- | Convert the sequential representation to DAG-based one.+-- dagSent :: Int.Xs -> DAG.DAG () Int.X+-- dagSent = DAG.fromList . V.toList

@@ -0,0 +1,109 @@+module Data.CRF.Chain1.Constrained.DAG.Dataset.Codec+(+  module Data.CRF.Chain1.Constrained.Dataset.Codec++, Xs+, XYs++, encodeSent'Cu+, encodeSent'Cn+, encodeSent++, encodeSentL'Cu+, encodeSentL'Cn+, encodeSentL++, encodeData+, encodeDataL++, mkCodec+) where+++import           Prelude hiding (Word)+-- import qualified Data.Foldable as F+import qualified Data.Traversable as T++import           Data.DAG (DAG)+-- import Data.CRF.Chain1.Constrained.DAG.Dataset.Internal+import qualified Data.CRF.Chain1.Constrained.Dataset.Internal as I+import           Data.CRF.Chain1.Constrained.DAG.Dataset.External+import qualified Data.CRF.Chain1.Constrained.Dataset.Codec as C+import           Data.CRF.Chain1.Constrained.Dataset.Codec hiding+  (encodeSent'Cu, encodeSent'Cn, encodeSent, encodeSentL'Cu, encodeSentL'Cn,+  encodeSentL, encodeData, encodeDataL, mkCodec)+import           Control.Monad.Codec (evalCodec, execCodec)+++-- | Utility types.+type Xs = DAG () I.X+-- type Ys = DAG () I.Y+type XYs = DAG () (I.X, I.Y)+++-------------------------------------+-- Normal sentences+-------------------------------------+++-- | Encode the sentence and update the codec.+encodeSent'Cu :: (Ord a, Ord b) => Sent a b -> C.CodecM a b Xs+encodeSent'Cu = T.mapM C.encodeWord'Cu+++-- | Encode the sentence and do *not* update the codec.+encodeSent'Cn :: (Ord a, Ord b) => Sent a b -> C.CodecM a b Xs+encodeSent'Cn = T.mapM C.encodeWord'Cn+++-- | Encode the sentence using the given codec.+encodeSent :: (Ord a, Ord b) => C.Codec a b -> Sent a b -> Xs+encodeSent codec = evalCodec codec . encodeSent'Cn+++-------------------------------------+-- Labeled sentences+-------------------------------------+++-- | Encode the labeled sentence and update the codec.+encodeSentL'Cu :: (Ord a, Ord b) => SentL a b -> C.CodecM a b XYs+encodeSentL'Cu = T.mapM C.encodeWordL'Cu+++-- | Encode the labeled sentence and do *not* update the codec. Substitute the+-- default label for any label not present in the codec.+encodeSentL'Cn :: (Ord a, Ord b) => SentL a b -> C.CodecM a b XYs+encodeSentL'Cn = T.mapM C.encodeWordL'Cn+++-- | Encode the labeled sentence with the given codec.  Substitute the+-- default label for any label not present in the codec.+encodeSentL :: (Ord a, Ord b) => C.Codec a b -> SentL a b -> XYs+encodeSentL codec = evalCodec codec . encodeSentL'Cn+++-------------------------------------+-- Datasets+-------------------------------------+++-- | Encode the labeled dataset using the codec.  Substitute the default+-- label for any label not present in the codec.+encodeDataL :: (Ord a, Ord b) => C.Codec a b -> [SentL a b] -> [XYs]+encodeDataL = map . encodeSentL+++-- | Encode the dataset with the codec.+encodeData :: (Ord a, Ord b) => C.Codec a b -> [Sent a b] -> [Xs]+encodeData = map . encodeSent+++-------------------------------------+-- Creation+-------------------------------------+++-- | Create codec on the basis of the labeled dataset.+mkCodec :: (Ord a, Ord b) => [SentL a b] -> Codec a b+mkCodec = execCodec empty . mapM_ encodeSentL'Cu

@@ -0,0 +1,24 @@+module Data.CRF.Chain1.Constrained.DAG.Dataset.External+( Sent+, SentL+, module Data.CRF.Chain1.Constrained.Dataset.External+) where+++import           Prelude hiding (Word)+-- import qualified Data.Set as S+-- import qualified Data.Map as M++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           Data.CRF.Chain1.Constrained.Dataset.External hiding (Sent, SentL)+++-- | A sentence (DAG) of words.+type Sent a b = DAG () (Word a b)+++-- | A sentence (DAG) of labeled words.+type SentL a b = DAG () (WordL a b)

@@ -0,0 +1,63 @@+module Data.CRF.Chain1.Constrained.DAG.Feature+( featuresIn+, features+) where+++import qualified Data.Number.LogFloat as L++-- import           Data.CRF.Chain1.Constrained.DAG.Dataset.Internal (EdgeID, DAG)+-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG+import           Data.DAG (EdgeID, DAG)+import qualified Data.DAG as DAG++import           Data.CRF.Chain1.Constrained.Core (X, Y, Feature)+import qualified Data.CRF.Chain1.Constrained.Core as C+++-- | Transition features with assigned probabilities for given position.+trFeats :: EdgeID -> DAG a (X, Y) -> [(Feature, L.LogFloat)]+trFeats edgeID dag =+  doit+  where+    edgeLabel = DAG.edgeLabel edgeID dag+    prevEdges = DAG.prevEdges edgeID dag+    doit+      | null prevEdges =+        [ (C.SFeature x, L.logFloat px)+        | (x, px) <- C.unY (snd edgeLabel) ]+      | otherwise =+        [ (C.TFeature x y, L.logFloat px * L.logFloat py)+        | (x, px) <- C.unY (snd edgeLabel)+        , prevEdgeID <- prevEdges+        , let prevEdgeLabel = DAG.edgeLabel prevEdgeID dag+        , (y, py) <- C.unY (snd prevEdgeLabel) ]+++-- | Observation features with assigned probabilities for a given position.+obFeats :: EdgeID -> DAG a (X, Y) -> [(Feature, L.LogFloat)]+obFeats edgeID dag =+    [ (C.OFeature o x, L.logFloat px)+    | let edgeLabel = DAG.edgeLabel edgeID dag+    , (x, px) <- C.unY (snd edgeLabel)+    , o       <- C.unX (fst edgeLabel) ]+++-- | Return the list of features with the corresponding probabilities+-- corresponding to the given DAG edge.+features :: EdgeID -> DAG a (X, Y) -> [(Feature, L.LogFloat)]+features edgeID dag = trFeats edgeID dag ++ obFeats edgeID dag+++-- | Return the list of features, together with the corresponding probabilities+-- (specified in the dataset), in the labeled DAG.+--+-- WARNING: this function is unsuitable to compute the potential of a given (X,+-- Y) pair w.r.t. to a CRF model for at least two reasons:+-- * The parameters (second elements of the output list) are not from the model.+-- * More importantly, the function does not take into account the potential labels+--   of the OOV words.+featuresIn :: DAG a (X, Y) -> [(Feature, L.LogFloat)]+featuresIn dag = concat+  [ features edgeID dag+  | edgeID <- DAG.dagEdges dag ]

@@ -0,0 +1,72 @@+-- | The module provides feature selection functions which extract+-- hidden features, i.e. all features which can be constructed+-- on the basis of observations and potential labels (constraints)+-- corresponding to individual words.+--+-- You can mix functions defined here with the selection functions+-- from the "Data.CRF.Chain1.Constrained.Feature.Present" module.++module Data.CRF.Chain1.Constrained.DAG.Feature.Hidden+( hiddenFeats+, hiddenOFeats+, hiddenTFeats+, hiddenSFeats+) where++import           Data.DAG (DAG)+import qualified Data.DAG as DAG++import           Data.CRF.Chain1.Constrained.Core (AVec, X, Y, Lb, Feature)+import qualified Data.CRF.Chain1.Constrained.Core as C++-- import Data.CRF.Chain1.Constrained.Dataset.Internal+-- import Data.CRF.Chain1.Constrained.Feature++-- | Hidden 'OFeature's which can be constructed based on the dataset.+-- The default set of potential interpretations is used for all unknown words.+hiddenOFeats :: AVec Lb -> [DAG a X] -> [Feature]+hiddenOFeats r0 ds =+  concatMap oFeats ds+  where+    oFeats dag = concatMap (oFeatsOn dag) (DAG.dagEdges dag)+    oFeatsOn dag edgeID =+      [ C.OFeature o x+      | let label = DAG.edgeLabel edgeID dag+      , o <- C.unX label+      , x <- C.unR r0 label ]+++-- | Hidden 'TFeature's which can be constructed based on the dataset.+-- The default set of potential interpretations is used for all unknown words.+hiddenTFeats :: AVec Lb -> [DAG a X] -> [Feature]+hiddenTFeats r0 ds =+  concatMap tFeats ds+  where+    tFeats dag =+      [ C.TFeature x y+      | i <- DAG.dagEdges dag+      , x <- C.unR r0 $ DAG.edgeLabel i dag+      , j <- DAG.prevEdges i dag+      , y <- C.unR r0 $ DAG.edgeLabel j dag ]+++-- | Hidden 'SFeature's which can be constructed based on the dataset.+-- The default set of potential interpretations is used for all unknown words.+hiddenSFeats :: AVec Lb -> [DAG a X] -> [Feature]+hiddenSFeats r0 ds =+  concatMap sFeats ds+  where+    sFeats dag =+      [ C.SFeature x+      | i <- DAG.dagEdges dag+      , x <- C.unR r0 $ DAG.edgeLabel i dag ]+++-- | Hidden 'Feature's of all types which can be constructed+-- on the basis of the dataset.  The default set of potential+-- interpretations is used for all unknown words.+hiddenFeats :: AVec Lb -> [DAG a X] -> [Feature]+hiddenFeats r0 ds+    =  hiddenOFeats r0 ds+    ++ hiddenTFeats r0 ds+    ++ hiddenSFeats r0 ds

@@ -0,0 +1,71 @@+-- | The module provides feature selection functions which extract+-- features present in the dataset, i.e. features which directly occure+-- the dataset.+++module Data.CRF.Chain1.Constrained.DAG.Feature.Present+( presentFeats+, presentOFeats+, presentTFeats+, presentSFeats+) where+++import           Data.DAG (DAG)+import qualified Data.DAG as DAG+-- import           Data.CRF.Chain1.Constrained.DAG.Dataset.Internal (DAG)+-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG++import           Data.CRF.Chain1.Constrained.Core (X, Y, Lb, Feature)+import qualified Data.CRF.Chain1.Constrained.Core as C+++-- | 'OFeature's which occur in the dataset.+presentOFeats :: [DAG a (X, Y)] -> [Feature]+presentOFeats =+  concatMap sentOFeats+  where+    sentOFeats dag =+      [ C.OFeature o x+      | edgeID <- DAG.dagEdges dag+      , let edgeLabel = DAG.edgeLabel edgeID dag+      , o <- C.unX (fst edgeLabel)+      , x <- lbs (snd edgeLabel) ]+++-- | 'TFeature's which occur in the dataset.+presentTFeats :: [DAG a Y] -> [Feature]+presentTFeats =+  concatMap sentTFeats+  where+    sentTFeats dag =+      [ C.TFeature x y+      | edgeID <- DAG.dagEdges dag+      , x <- lbs (DAG.edgeLabel edgeID dag)+      , prevEdgeID <- DAG.prevEdges edgeID dag+      , y <- lbs (DAG.edgeLabel prevEdgeID dag) ]+++-- | 'SFeature's which occur in the given dataset.+presentSFeats :: [DAG a Y] -> [Feature]+presentSFeats =+  concatMap sentSFeats+  where+    sentSFeats dag =+      [ C.SFeature x+      | edgeID <- DAG.dagEdges dag+      , DAG.isInitialEdge edgeID dag+      , x <- lbs (DAG.edgeLabel edgeID dag) ]+++-- | 'Feature's of all kinds which occur in the given dataset.+presentFeats :: [DAG a (X, Y)] -> [Feature]+presentFeats ds+    =  presentOFeats ds+    ++ presentTFeats (map (fmap snd) ds)+    ++ presentSFeats (map (fmap snd) ds)+++-- | Retrieve the domain of the given probability distribution.+lbs :: Y -> [Lb]+lbs = map fst . C.unY

@@ -0,0 +1,532 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+++-- | Inference with CRFs.+++module Data.CRF.Chain1.Constrained.DAG.Inference+( tag+, tagK+, marginals+, accuracy+, expectedFeaturesIn+, zx+, zx'++-- , probability+-- , likelihood++-- * Internals+, computePsi+) where+++import Control.Applicative ((<$>))+import Data.Maybe (catMaybes)+import Data.List (maximumBy, sort, sortBy)+import Data.Function (on)+import qualified Data.Set as S+import qualified Data.Array as A+-- import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Foldable as F++import Control.Parallel.Strategies (rseq, parMap)+import Control.Parallel (par, pseq)+import GHC.Conc (numCapabilities)+import qualified Data.Number.LogFloat as L++-- import           Data.CRF.Chain1.Constrained.DAG.Dataset.Internal (EdgeID, DAG)+-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG+import           Data.DAG (EdgeID, DAG)+import qualified Data.DAG as DAG++import qualified Data.CRF.Chain1.Constrained.DP as DP+import           Data.CRF.Chain1.Constrained.Util (partition)+import qualified Data.CRF.Chain1.Constrained.Model as Md++import           Data.CRF.Chain1.Constrained.Core (X, Y, Lb, AVec)+import qualified Data.CRF.Chain1.Constrained.Core as C+import qualified Data.CRF.Chain1.Constrained.Intersect as I++import           Data.CRF.Chain1.Constrained.DAG.Feature (featuresIn)++import Debug.Trace (trace)+++---------------------------------------------+-- Util Types+---------------------------------------------+++-- | TODO.+type LbIx       = Int+++-- | The probability array assigns some probability to each label (represented+-- by its index) which can be assigned to a given edge (represented by its+-- `EdgeID`).+type ProbArray  = EdgeID -> LbIx -> L.LogFloat+++---------------------------------------------+-- Summing+---------------------------------------------+++-- -- | Numerically safer summing.+-- safeSum :: (Ord a, Num a) => [a] -> a+-- -- safeSum = sum . sort+-- safeSum = sum+-- {-#INLINE safeSum #-}+++-- | Numerically safer summing.+safeSum :: [L.LogFloat] -> L.LogFloat+safeSum [] = 0+safeSum xs = L.sum xs+{-#INLINE safeSum #-}+++---------------------------------------------+-- Some basic functions.+---------------------------------------------+++-- | Vector of potential labels on the given edge of the sentence.+lbVec :: Md.Model -> DAG a X -> EdgeID -> AVec Lb+lbVec crf dag edgeID = case DAG.edgeLabel edgeID dag of+  C.X _   -> (Md.r0 crf)+  C.R _ r -> r+{-# INLINE lbVec #-}+++-- | Number of potential labels on the given edge of the sentence.+lbNum :: Md.Model -> DAG a X -> EdgeID -> Int+lbNum crf dag = (U.length . C.unAVec) . lbVec crf dag+{-# INLINE lbNum #-}+++-- | Potential label on the given vector position.+lbOn :: Md.Model -> X -> LbIx -> Lb+lbOn crf (C.X _)   = (C.unAVec (Md.r0 crf) U.!)+lbOn _   (C.R _ r) = (C.unAVec r U.!)+{-# INLINE lbOn #-}+++-- | Potential labels on the given sentence edge (as in `lbVec`), accompanied+-- with the corresponding indexes. I.e., each label `Lb` is accompanied with a+-- number, from [0..], corresponding to its index in the vector of labels+-- obtained with `lbVec`.+lbIxs :: Md.Model -> DAG a X -> EdgeID -> [(LbIx, Lb)]+lbIxs crf dag = zip [0..] . U.toList . C.unAVec . lbVec crf dag+{-# INLINE lbIxs #-}+++---------------------------------------------+-- A bit more complex stuff.+---------------------------------------------+++-- | Compute the table of potential products associated with observation+-- features for the given sentence edge.+computePsi :: Md.Model -> DAG a X -> EdgeID -> LbIx -> L.LogFloat+computePsi crf dag i = (A.!) $ A.accumArray (*) 1 bounds+    [ (k, Md.valueL crf ix)+    | ob <- C.unX (DAG.edgeLabel i dag)+    , (k, ix) <- I.intersect (Md.obIxs crf ob) (lbVec crf dag i) ]+  where+    bounds = (0, lbNum crf dag i - 1)+++-- | Equivalent to `computePsi`, but memoizes additionally on `EdgeID`s.+computePsi'+  :: Md.Model -> DAG a X+  -> EdgeID -> LbIx+  -> L.LogFloat+computePsi' crf dag =+  (array A.!)+  where+    bounds = (DAG.minEdge dag, DAG.maxEdge dag)+    array = A.array bounds+      [ (i, computePsi crf dag i)+      | i <- A.range bounds ]+++-- | Forward table computation.+forward :: Md.Model -> DAG a X -> ProbArray+forward crf dag = alpha where+  alpha = DP.flexible2 bounds boundsOn+    (\t i -> withMem (computePsi crf dag i) t i)+  bounds = (DAG.minEdge dag, DAG.maxEdge dag + 1)+  boundsOn i+    | i == snd bounds = (0, 0)+    | otherwise = (0, lbNum crf dag i - 1)+  -- set of initial edges+  initialSet = S.fromList+    [ i+    | i <- DAG.dagEdges dag+    , DAG.isInitialEdge i dag ]+  withMem psi alpha i+    | i == snd bounds = const u'+    | i `S.member` initialSet = \j ->+        let x = lbOn crf (DAG.edgeLabel i dag) j+        in  psi j * Md.sgValue crf x+    | otherwise = \j ->+        let x = lbOn crf (DAG.edgeLabel i dag) j+        in  psi j * ((u - v x) + w x)+    where+      u = safeSum+        [ alpha iMinus1 k+        | iMinus1 <- DAG.prevEdges i dag+        , (k, _) <- lbIxs crf dag iMinus1 ]+      v x = safeSum+        [ alpha iMinus1 k+        | iMinus1 <- DAG.prevEdges i dag+        , (k, _) <- I.intersect (Md.prevIxs crf x) (lbVec crf dag iMinus1) ]+      w x = safeSum+        [ alpha iMinus1 k * Md.valueL crf ix+        | iMinus1 <- DAG.prevEdges i dag+        , (k, ix) <- I.intersect (Md.prevIxs crf x) (lbVec crf dag iMinus1) ]+      -- Note that if `i == snd bounds` then `i` does not refer to any existing+      -- edge, hence the need to introduce `u'` which does almost the same thing+      -- as `u`.+      u' = safeSum+        [ alpha iMinus1 k+        | iMinus1 <- DAG.dagEdges dag+        , DAG.isFinalEdge iMinus1 dag+        , (k, _) <- lbIxs crf dag iMinus1 ]+++-- | Backward table computation.+backward :: Md.Model -> DAG a X -> ProbArray+backward crf dag = beta where+  beta = DP.flexible2 bounds boundsOn withMem+  bounds = (DAG.minEdge dag - 1, DAG.maxEdge dag)+  boundsOn i+    | i == fst bounds = (0, 0)+    | otherwise = (0, lbNum crf dag i - 1)+  psi = computePsi' crf dag+  -- set of final edges+  finalSet = S.fromList+    [ i+    | i <- DAG.dagEdges dag+    , DAG.isFinalEdge i dag ]+  withMem beta i+    | i `S.member` finalSet = const 1+    | i == fst bounds = const $ safeSum+      [ beta iPlus1 k * psi iPlus1 k+        * Md.sgValue crf (lbOn crf (DAG.edgeLabel iPlus1 dag) k)+      | iPlus1 <- DAG.dagEdges dag+      , DAG.isInitialEdge iPlus1 dag+      , (k, _) <- lbIxs crf dag iPlus1 ]+    | otherwise = \j ->+        let y = lbOn crf (DAG.edgeLabel i dag) j+        in  (u - v y) + w y+    where+      -- Note that here `i` is an identifier of the current DAG edge.+      -- Instead of simply adding `1` to `i` (i.e., `i + 1`),+      -- we need to find the identifiers of the succeeding edges.+      u = safeSum+        [ beta iPlus1 k * psi iPlus1 k+        | iPlus1 <- DAG.nextEdges i dag+        , (k, _ ) <- lbIxs crf dag iPlus1 ]+      -- `y` is the label on position `i`, we are looking for+      -- matching labels on the position `i+1`.+      v y = safeSum+        [ beta iPlus1 k * psi iPlus1 k+        | iPlus1 <- DAG.nextEdges i dag+        , (k, _ ) <- I.intersect (Md.nextIxs crf y) (lbVec crf dag iPlus1) ]+      -- `y` is the label on position `i`, we are looking for+      -- matching labels on the position `i+1`.+      w y = safeSum+        [ beta iPlus1 k * psi iPlus1 k * Md.valueL crf ix+        | iPlus1 <- DAG.nextEdges i dag+        , (k, ix) <- I.intersect (Md.nextIxs crf y) (lbVec crf dag iPlus1) ]+++-- | Normalization factor computed for the 'Xs' sentence using the+-- forward computation.+zx' :: Md.Model -> DAG a X -> L.LogFloat+zx' crf dag = zxAlpha dag (forward crf dag)++zxAlpha :: DAG a b -> ProbArray -> L.LogFloat+zxAlpha dag alpha = alpha (DAG.maxEdge dag + 1) 0+++-- | Normalization factor computed for the 'Xs' sentence using the+-- backward computation.+zx :: Md.Model -> DAG a X -> L.LogFloat+zx crf dag = zxBeta dag (backward crf dag)++zxBeta :: DAG a b -> ProbArray -> L.LogFloat+zxBeta dag beta = beta (DAG.minEdge dag - 1) 0+++-- prob1 :: ProbArray -> ProbArray -> Int -> LbIx -> L.LogFloat+-- prob1 alpha beta k x =+--     alpha k x * beta (k + 1) x / zxBeta beta+-- {-# INLINE prob1 #-}++-- | Probability of chosing the given edge and the corresponding label.+edgeProb1+  :: DAG a b+  -- ^ The underlying sentence DAG+  -> ProbArray+  -- ^ Forward probability table+  -> ProbArray+  -- ^ Backward probability table+  -> EdgeID+  -- ^ ID of the edge in the underlying DAG+  -> LbIx+  -- ^ Index of the label of the edge represented by the `EdgeID`+  -> L.LogFloat+edgeProb1 dag alpha beta k x+  -- alpha k x * beta k x / zxBeta dag beta+  | any isInf [up1, up2, down] =+      error $ "edgeProb1: infinite -- " ++ show [up1, up2, down, down'] -- ++ "; " ++ show (k, x)+  | otherwise = up1 * up2 / down+  where+    isInf x = isInfinite (L.logFromLogFloat x :: Double)+    up1 = alpha k x+    up2 = beta k x+    down = zxBeta dag beta+    down' = zxAlpha dag alpha+{-# INLINE edgeProb1 #-}+++-- | Probability of chosing the given pair of edges and the corresponding labels.+edgeProb2+  :: Md.Model+  -- ^ CRF model+  -> DAG a b+  -- ^ The underlying sentence DAG+  -> ProbArray+  -- ^ Forward computation table+  -> ProbArray+  -- ^ Backward computation table+  -> (EdgeID -> LbIx -> L.LogFloat)+  -- ^ Psi computation+  -> (EdgeID, LbIx)+  -- ^ First edge and the corresponding label index+  -> (EdgeID, LbIx)+  -- ^ Succeeding edge and the corresponding label index+  -> Md.FeatIx+  -- ^ TODO (NO IDEA!); Hypo: index of the transition feature corresponding+  -- to the transition between the first and the succeeding edge+  -> L.LogFloat+edgeProb2 crf dag alpha beta psi (kEdgeID, xLbIx) (lEdgeID, yLbIx) ix+  -- = alpha kEdgeID xLbIx * beta lEdgeID yLbIx+  -- -- * psi lEdgeID yLbIx * Md.valueL crf ix / zxBeta dag beta+  | any isInf [up1, up2, up3, up4, down] =+      error $ "edgeProb2: infinite -- " ++ show [up1, up2, up3, up4, down, down']+  | otherwise = up1 * up2 * up3 * up4 / down+  where+    isInf x = isInfinite (L.logFromLogFloat x :: Double)+    up1 = alpha kEdgeID xLbIx+    up2 = beta lEdgeID yLbIx+    up3 = psi lEdgeID yLbIx+    up4 = Md.valueL crf ix+    down = zxBeta dag beta+    down' = zxAlpha dag alpha+{-# INLINE edgeProb2 #-}+++-- prob2 :: Model -> ProbArray -> ProbArray -> Int -> (LbIx -> L.LogFloat)+--       -> LbIx -> LbIx -> FeatIx -> L.LogFloat+-- prob2 crf alpha beta k psi x y ix+--     = alpha (k - 1) y * beta (k + 1) x+--     * psi x * valueL crf ix / zxBeta beta+-- {-# INLINE prob2 #-}+++-- | Tag potential labels with marginal distributions.+-- marginals :: Md.Model -> DAG a X -> [[(Lb, L.LogFloat)]]+marginals :: Md.Model -> DAG a X -> DAG a [(Lb, L.LogFloat)]+marginals crf dag+  | not (zx1 `almostEq` zx2) = trace warning margs+  | otherwise = margs+  where+    margs = DAG.mapE label dag+    warning =+      "[marginals] normalization factors differ significantly: "+      ++ show (L.logFromLogFloat zx1, L.logFromLogFloat zx2)+    label edgeID _ =+      [ (lab, prob1 edgeID labID)+      | (labID, lab) <- lbIxs crf dag edgeID ]+    prob1 = edgeProb1 dag alpha beta+    alpha = forward crf dag+    beta = backward crf dag+    zx1 = zxAlpha dag alpha+    zx2 = zxBeta dag beta+++-- | Get (at most) k best tags for each word and return them in+-- descending order.  TODO: Tagging with respect to marginal+-- distributions might not be the best idea.  Think of some+-- more elegant method.+tagK :: Int -> Md.Model -> DAG a X -> DAG a [(Lb, L.LogFloat)]+tagK k crf dag = fmap+    ( take k+    . reverse+    . sortBy (compare `on` snd)+    ) (marginals crf dag)+++-- | Find the most probable label sequence (with probabilities of individual+-- lables determined with respect to marginal distributions) satisfying the+-- constraints imposed over label values.+tag :: Md.Model -> DAG a X -> DAG a Lb+tag crf = fmap (fst . head) . (tagK 1 crf)+++expectedFeaturesOn+  :: Md.Model+  -- ^ CRF model+  -> DAG a X+  -- ^ The underlying sentence DAG+  -> ProbArray+  -- ^ Forward computation table+  -> ProbArray+  -- ^ Backward computation table+  -> EdgeID+  -- ^ ID of an edge of the underlying DAG+  -> [(Md.FeatIx, L.LogFloat)]+expectedFeaturesOn crf dag alpha beta iEdgeID =+  tFeats ++ oFeats+  where+    prob1 = edgeProb1 dag alpha beta iEdgeID+    oFeats = [ (ix, prob1 k)+             | ob <- C.unX (DAG.edgeLabel iEdgeID dag)+             , (k, ix) <- I.intersect (Md.obIxs crf ob) (lbVec crf dag iEdgeID) ]++    -- TODO: Move `psi` to `expectedFeatureIn`+    psi = computePsi' crf dag -- iEdgeID+    prob2 = edgeProb2 crf dag alpha beta psi+    tFeats+        | DAG.isInitialEdge iEdgeID dag = catMaybes+          [ (, prob1 k) <$> Md.featToIx crf (C.SFeature x)+          | (k, x) <- lbIxs crf dag iEdgeID ]+        | otherwise =+          [ (ix, prob2 (iMinus1, l) (iEdgeID, k) ix)+          | (k,  x) <- lbIxs crf dag iEdgeID+          , iMinus1 <- DAG.prevEdges iEdgeID dag+          , (l, ix) <- I.intersect (Md.prevIxs crf x) (lbVec crf dag iMinus1) ]+++-- | A list of features (represented by feature indices) defined within+-- the context of the sentence accompanied by expected probabilities+-- determined on the basis of the model.+--+-- One feature can occur multiple times in the output list.+expectedFeaturesIn+  :: Md.Model+  -> DAG a X+  -> [(Md.FeatIx, L.LogFloat)]+expectedFeaturesIn crf dag = zxF `par` zxB `pseq` zxF `pseq`+    -- concat [expectedOn k | k <- [0 .. V.length xs - 1] ]+    concat [expectedOn edgeID | edgeID <- DAG.dagEdges dag]+  where+    expectedOn = expectedFeaturesOn crf dag alpha beta+    alpha = forward crf dag+    beta = backward crf dag+    zxF = zxAlpha dag alpha+    zxB = zxBeta dag beta+++-- goodAndBad :: Md.Model -> DAG a X -> DAG b Y -> (Int, Int)+goodAndBad :: Md.Model -> DAG a (X, Y) -> (Int, Int)+goodAndBad crf dag =+    F.foldl' gather (0, 0) $ DAG.zipE labels labels'+  where+    xs = fmap fst dag+    ys = fmap snd dag+    labels = fmap (best . C.unY) ys+    best zs+        | null zs   = Nothing+        | otherwise = Just . fst $ maximumBy (compare `on` snd) zs+    labels' = fmap Just $ tag crf xs+    gather (good, bad) (x, y)+        | x == y = (good + 1, bad)+        | otherwise = (good, bad + 1)+++goodAndBad' :: Md.Model -> [DAG a (X, Y)] -> (Int, Int)+goodAndBad' crf dataset =+    let add (g, b) (g', b') = (g + g', b + b')+    in  F.foldl' add (0, 0) [goodAndBad crf x | x <- dataset]+++-- | Compute the accuracy of the model with respect to the labeled dataset.+accuracy :: Md.Model -> [DAG a (X, Y)] -> Double+accuracy crf dataset =+    let k = numCapabilities+    	parts = partition k dataset+        xs = parMap rseq (goodAndBad' crf) parts+        (good, bad) = F.foldl' add (0, 0) xs+        add (g, b) (g', b') = (g + g', b + b')+    in  fromIntegral good / fromIntegral (good + bad)+++---------------------------------------------+-- Probability and likelihood+---------------------------------------------+++-- -- | Log-likelihood of the given dataset.+-- likelihood :: Md.Model -> [DAG a (X, Y)] -> L.LogFloat+-- -- likelihood crf = L.product . map (probability crf)+-- -- likelihood crf = probability crf . head+-- likelihood crf = maximum . map (probability crf)+--+--+-- -- | The conditional probability of the dag in log-domain.+-- probability :: Md.Model -> DAG a (X, Y) -> L.LogFloat+-- probability crf dag = normFactor+-- --   | potential > normFactor =+-- --       error $ "[probability] potential greater than normFactor: "+-- --       ++ show (potential, normFactor)+-- --   | otherwise = potential / normFactor+--   where+--     potential = L.product+--       [ Md.valueL crf (Md.featToJustIx crf feat)+--       | (feat, _val) <- featuresIn dag ]+--     normFactor = zx crf (fmap fst dag)+++-- -- | Features w.r.t. a given edge.+-- features+--   :: Md.Model+--   -> EdgeID  -- ^ ID of an edge of the DAG+--   -> DAG a (X, Y)+--   -> [Md.FeatIx]+-- features crf edgeID dag =+--   where+--     oFeats = [ (ix, prob1 k)+--              | ob <- C.unX (DAG.edgeLabel iEdgeID dag)+--              , (k, ix) <- I.intersect (Md.obIxs crf ob) (lbVec crf dag iEdgeID) ]+++---------------------------------------------+-- Utils+---------------------------------------------+++almostEq :: L.LogFloat -> L.LogFloat -> Bool+almostEq x0 y0+  | isZero x && isZero y = True+  | otherwise = 1.0 - eps < z && z < 1.0 + eps+  where+    x = L.logFromLogFloat x0+    y = L.logFromLogFloat y0+    z = x / y+++isZero :: (Fractional t, Ord t) => t -> Bool+isZero x = abs x < eps+++-- | A very small number.+eps :: Fractional t => t+eps = 0.000001

@@ -0,0 +1,207 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+++-- | For probability-related computations.+++module Data.CRF.Chain1.Constrained.DAG.Probs+( probability+, likelihood+, parLikelihood+) where+++import Control.Applicative ((<$>))+import Data.Maybe (catMaybes)+import Data.List (maximumBy, sort, sortBy)+import Data.Function (on)+import qualified Data.Set as S+import qualified Data.Array as A+-- import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Foldable as F++import Control.Parallel.Strategies (rseq, parMap)+import Control.Parallel (par, pseq)+import GHC.Conc (numCapabilities)+import qualified Data.Number.LogFloat as L++-- import           Data.CRF.Chain1.Constrained.DAG.Dataset.Internal (EdgeID, DAG)+-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG+import           Data.DAG (EdgeID, DAG)+import qualified Data.DAG as DAG++import qualified Data.CRF.Chain1.Constrained.DP as DP+import           Data.CRF.Chain1.Constrained.Util (partition)+import qualified Data.CRF.Chain1.Constrained.Model as Md++import           Data.CRF.Chain1.Constrained.Core (X, Y, Lb, AVec)+import qualified Data.CRF.Chain1.Constrained.Core as C+import qualified Data.CRF.Chain1.Constrained.Intersect as I++import           Data.CRF.Chain1.Constrained.DAG.Feature (featuresIn)+import qualified Data.CRF.Chain1.Constrained.DAG.Inference as Inf+++---------------------------------------------+-- Util Types+---------------------------------------------+++-- | Label index.+type LbIx = Int+++-- | The probability array assigns some probability to each label (represented+-- by its index) which can be assigned to a given edge (represented by its+-- `EdgeID`).+type ProbArray  = EdgeID -> LbIx -> L.LogFloat+++--------------------------------------------+-- Basic stuff+---------------------------------------------+++-- | Vector of labels and the corresponding probabilities on the given edge of+-- the sentence.+lbVec :: Md.Model -> DAG a (X, Y) -> EdgeID -> AVec (Lb, Double)+lbVec crf dag edgeID =+  case DAG.edgeLabel edgeID dag of+    (_, y) -> C._unY y+{-# INLINE lbVec #-}+++-- | Number of potential labels on the given edge of the sentence.+lbNum :: Md.Model -> DAG a (X, Y) -> EdgeID -> Int+lbNum crf dag = U.length . C.unAVec . lbVec crf dag+{-# INLINE lbNum #-}+++-- | Label on the given edge and on the given position.+lbOn :: Md.Model -> DAG a (X, Y) -> EdgeID -> LbIx -> (Lb, Double)+lbOn crf dag = (U.!) . C.unAVec . lbVec crf dag+{-# INLINE lbOn #-}+++-- | Labels on the given sentence edge (as in `lbVec`), accompanied with the+-- corresponding indexes. I.e., each label `Lb` (and its probability) is+-- accompanied with a number, from [0..], corresponding to its index in the+-- vector of labels obtained with `lbVec`.+lbIxs :: Md.Model -> DAG a (X, Y) -> EdgeID -> [(LbIx, (Lb, Double))]+lbIxs crf dag = zip [0..] . U.toList . C.unAVec . lbVec crf dag+{-# INLINE lbIxs #-}+++---------------------------------------------+-- A bit more complex stuff+---------------------------------------------+++-- | Compute the table of potential products associated with+-- * the observation features for the given sentence edge,+-- * the probabilities assigned to different labels.+computePsi :: Md.Model -> DAG a (X, Y) -> EdgeID -> LbIx -> L.LogFloat+computePsi crf dag edgeID+  = (A.!)+  . A.accumArray (*) 1 bounds+  $ proTab ++ obsTab+  where+    bounds = (0, lbNum crf dag edgeID - 1)+    obsTab =+      [ (lbIx, Md.valueL crf featIx)+      | ob <- (C.unX . fst) (DAG.edgeLabel edgeID dag)+      , (lbIx, featIx) <-+          I.intersect (Md.obIxs crf ob) (xify $ lbVec crf dag edgeID) ]+    proTab =+      [ (lbIx, L.logFloat prob)+      | (lbIx, (_lb, prob)) <- lbIxs crf dag edgeID ]+++-- | An alternative forward computation which takes the probabilities assigned+-- to different lables into account (at the level of the `psi` function).+forward :: Md.Model -> DAG a (X, Y) -> ProbArray+forward crf dag = alpha where+  alpha = DP.flexible2 bounds boundsOn+    (\t i -> withMem (computePsi crf dag i) t i)+  bounds = (DAG.minEdge dag, DAG.maxEdge dag + 1)+  boundsOn i+    | i == snd bounds = (0, 0)+    | otherwise = (0, lbNum crf dag i - 1)+  -- set of initial edges+  initialSet = S.fromList+    [ i+    | i <- DAG.dagEdges dag+    , DAG.isInitialEdge i dag ]+  withMem psi alpha i+    | i == snd bounds = const u'                    -- <= TO CHECK+    | i `S.member` initialSet = \j ->+        let (x, _) = lbOn crf dag i j+        in  psi j * Md.sgValue crf x+    | otherwise = \j ->+        let (x, _) = lbOn crf dag i j+        in  psi j * ((u - v x) + w x)+    where+      u = safeSum+        [ alpha iMinus1 k+        | iMinus1 <- DAG.prevEdges i dag+        , (k, _) <- lbIxs crf dag iMinus1 ]+      v x = safeSum+        [ alpha iMinus1 k+        | iMinus1 <- DAG.prevEdges i dag+        , (k, _) <-+            I.intersect (Md.prevIxs crf x) (xify $ lbVec crf dag iMinus1) ]+      w x = safeSum+        [ alpha iMinus1 k * Md.valueL crf ix+        | iMinus1 <- DAG.prevEdges i dag+        , (k, ix) <- I.intersect (Md.prevIxs crf x) (xify $ lbVec crf dag iMinus1) ]+      -- Note that if `i == snd bounds` then `i` does not refer to any existing+      -- edge, hence the need to introduce `u'` which does almost the same thing+      -- as `u`.+      u' = safeSum+        [ alpha iMinus1 k+        | iMinus1 <- DAG.dagEdges dag+        , DAG.isFinalEdge iMinus1 dag+        , (k, _) <- lbIxs crf dag iMinus1 ]+++-- | Probability of the given DAG in the given model.+probability :: Md.Model -> DAG a (X, Y) -> L.LogFloat+probability crf dag =+  zxAlpha (forward crf dag) / normFactor+  where+    zxAlpha alpha = alpha (DAG.maxEdge dag + 1) 0+    normFactor = Inf.zx crf (fmap fst dag)+++-- | Log-likelihood of the given dataset (parallelized version).+parLikelihood :: Md.Model -> [DAG a (X, Y)] -> L.LogFloat+parLikelihood crf dataset =+  let k = numCapabilities+      parts = partition k dataset+      probs = parMap rseq (likelihood crf) parts+  in  L.product probs+++-- | Log-likelihood of the given dataset (no parallelization).+likelihood :: Md.Model -> [DAG a (X, Y)] -> L.LogFloat+likelihood crf = L.product . map (probability crf)+++---------------------------------------------+-- Utils+---------------------------------------------+++-- | X-ify the given ascending vector.+xify :: (U.Unbox x, U.Unbox y) => C.AVec (x, y) -> C.AVec x+xify = C.AVec . U.map fst . C.unAVec+{-# INLINE xify #-}+++-- | Numerically safer summing.+safeSum :: [L.LogFloat] -> L.LogFloat+safeSum [] = 0+safeSum xs = L.sum xs+{-#INLINE safeSum #-}

@@ -0,0 +1,274 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-}+++-- | Provisional training module which works on sequential external data+-- but transforms it to DAG internal data form.+++module Data.CRF.Chain1.Constrained.DAG.Train+(+-- * Model+  CRF (..)++-- * Training+, train++-- * R0 construction+, oovChosen+, anyChosen+, anyInterps++-- * Utils+, dagProb+) where+++import Control.Applicative ((<$>), (<*>))+import qualified Control.Arrow as Arr+import Control.Monad (when)+import System.IO (hSetBuffering, stdout, BufferMode (..))+import Data.Binary (Binary, put, get)+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Foldable as F+import qualified Numeric.SGD.Momentum as SGD+import qualified Data.Number.LogFloat as LogFloat+import qualified Numeric.SGD.LogSigned as L+import qualified Data.MemoCombinators as Memo++-- import           Data.CRF.Chain1.Constrained.DAG.Dataset.Internal (DAG)+-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG+import           Data.DAG (DAG)+import qualified Data.DAG as DAG++import           Data.CRF.Chain1.Constrained.Core (X, Y, Lb, AVec, Feature)+import qualified Data.CRF.Chain1.Constrained.Core as C+import qualified Data.CRF.Chain1.Constrained.Model as Md+import qualified Data.CRF.Chain1.Constrained.Dataset.Internal as Int++import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Codec as Cd+import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.External as E++-- import           Data.CRF.Chain1.Constrained.Model+--     (Model (..), mkModel, FeatIx (..), featToJustInt)+-- import           Data.CRF.Chain1.Constrained.Dataset.External+--     (SentL, WordL (..), lbs, unknown, unProb)++import           Data.CRF.Chain1.Constrained.DAG.Feature (featuresIn)+import qualified Data.CRF.Chain1.Constrained.DAG.Inference as I -- (accuracy, expectedFeaturesIn)+import qualified Data.CRF.Chain1.Constrained.DAG.Probs as P -- (accuracy, expectedFeaturesIn)+++-- | A conditional random field model with additional codec used for+-- data encoding.+data CRF a b = CRF {+    -- | The codec is used to transform data into internal representation,+    -- where each observation and each label is represented by a unique+    -- integer number.+    codec :: Cd.Codec a b,+    -- | The actual model, which is a map from 'Feature's to potentials.+    model :: Md.Model }+++instance (Ord a, Ord b, Binary a, Binary b) => Binary (CRF a b) where+    put CRF{..} = put codec >> put model+    get = CRF <$> get <*> get+++-- | Train the CRF using the stochastic gradient descent method.+--+-- The resulting model will contain features extracted with the user supplied+-- extraction function.  You can use the functions provided by the+-- "Data.CRF.Chain1.Constrained.Feature.Present" and+-- "Data.CRF.Chain1.Constrained.Feature.Hidden"+-- modules for this purpose.+--+-- You also have to supply R0 construction method (e.g. `oovChosen`)+-- which determines the contents of the default set of labels.+train+    :: (Ord a, Ord b)+    => SGD.SgdArgs                          -- ^ Args for SGD+    -> Bool                                 -- ^ Store dataset on a disk+    -> ([E.SentL a b] -> S.Set b)           -- ^ R0 construction+    -> (AVec Lb -> [DAG () (X, Y)] -> [Feature]) -- ^ Feature selection+    -> IO [E.SentL a b]                     -- ^ Training data 'IO' action+    -> IO [E.SentL a b]                     -- ^ Evaluation data+    -> IO (CRF a b)                         -- ^ Resulting model+train sgdArgs onDisk mkR0 featSel trainIO evalIO = do+    hSetBuffering stdout NoBuffering++    -- Create codec and encode the training dataset+    codec <- Cd.mkCodec <$> trainIO+    trainData_ <- Cd.encodeDataL codec <$> trainIO+    let trainLenOld = length trainData_+        trainData0 = verifyDataset trainData_+        trainLenNew = length trainData0+    -- mapM_ print $ map dagProb trainData_+    when (trainLenNew < trainLenOld) $ do+      putStrLn $ "Discarded "+        ++ show (trainLenOld - trainLenNew) ++ "/" ++ show trainLenOld+        ++  " elements from the training dataset"+    SGD.withData onDisk trainData0 $ \trainData -> do++    -- Encode the evaluation dataset+    evalData_ <- Cd.encodeDataL codec <$> evalIO+    SGD.withData onDisk evalData_ $ \evalData -> do++    -- A default set of labels+    r0 <- Cd.encodeLabels codec . S.toList . mkR0 <$> trainIO++    -- A set of features+    feats <- featSel r0 <$> SGD.loadData trainData++    -- Train the model+    let model = (Md.mkModel (Cd.obMax codec) (Cd.lbMax codec) feats) { Md.r0 = r0 }+    para <- SGD.sgd sgdArgs+        (notify sgdArgs model trainData evalData)+        (gradOn model) trainData (Md.values model)+    return $ CRF codec (model { Md.values = para })+++gradOn :: Md.Model -> SGD.Para -> DAG a (X, Y) -> SGD.Grad+gradOn model para dag = SGD.fromLogList $+    [ (Md.featToJustInt curr feat, L.fromPos val)+    | (feat, val) <- featuresIn dag ] +++    [ (ix, L.fromNeg val)+    | (Md.FeatIx ix, val) <- I.expectedFeaturesIn curr (fmap fst dag) ]+  where+    curr = model { Md.values = para }+++notify+    :: SGD.SgdArgs -> Md.Model+    -> SGD.Dataset (DAG a (X, Y))     -- ^ Training dataset+    -> SGD.Dataset (DAG a (X, Y))     -- ^ Evaluation dataset+    -> SGD.Para -> Int -> IO ()+notify SGD.SgdArgs{..} model trainData evalData para k+  | doneTotal k == doneTotal (k - 1) = putStr "."+  | otherwise = do+      putStrLn "" >> report para+--       report $ U.map (*50.0) para+--       report $ U.map (*10.0) para+--       report $ U.map (*2.0) para+--       report $ U.map (*0.9) para+--       report $ U.map (*0.5) para+--       report $ U.map (*0.1) para+  where+    report para = do+      let crf = model {Md.values = para}+      llh <- show+        . LogFloat.logFromLogFloat+        . P.parLikelihood crf+        <$> SGD.loadData trainData+      acc <-+        if SGD.size evalData > 0+        then show . I.accuracy crf <$> SGD.loadData evalData+        else return "#"+      putStrLn $ "[" ++ show (doneTotal k) ++ "] stats:"+      putStrLn $ "min(params) = " ++ show (U.minimum para)+      putStrLn $ "max(params) = " ++ show (U.maximum para)+      putStrLn $ "log(likelihood(train)) = " ++ llh+      putStrLn $ "acc(eval) = " ++ acc+    doneTotal :: Int -> Int+    doneTotal = floor . done+    done :: Int -> Double+    done i+        = fromIntegral (i * batchSize)+        / fromIntegral trainSize+    trainSize = SGD.size trainData+++------------------------------------------------------+-- Verification+------------------------------------------------------+++-- | Compute the probability of the DAG, based on the probabilities assigned to+-- different edges and their labels.+dagProb :: DAG a (X, Y) -> Double+dagProb dag = sum+  [ fromEdge edgeID+  | edgeID <- DAG.dagEdges dag+  , DAG.isInitialEdge edgeID dag ]+  where+    fromEdge =+      Memo.wrap DAG.EdgeID DAG.unEdgeID Memo.integral fromEdge'+    fromEdge' edgeID+      = edgeProb edgeID+      * fromNode (DAG.endsWith edgeID dag)+    edgeProb edgeID =+      let (_x, y) = DAG.edgeLabel edgeID dag+      in  sum . map snd $ C.unY y+    fromNode nodeID =+      case DAG.outgoingEdges nodeID dag of+        [] -> 1+        xs -> sum (map fromEdge xs)+++-- | Filter out the sentences with `dagProb` < 1.+verifyDataset :: [DAG a (X, Y)] -> [DAG a (X, Y)]+verifyDataset =+  filter verify+  where+    verify dag =+      let p = dagProb dag+      in  p >= 1 - eps && p <= 1 + eps+    eps = 1e-9+++------------------------------------------------------+-- Expectation maximization+------------------------------------------------------+++-- TODO:+++-- ------------------------------------------------------+-- -- Dataset conversion (provisional?)+-- ------------------------------------------------------+--+--+-- -- | Convert the sequential representation to DAG-based one.+-- dagSent :: (Int.Xs, Int.Ys) -> DAG () (X, Y)+-- dagSent (xs, ys) = DAG.fromList (zip (V.toList xs) (V.toList ys))+--+--+-- -- | Convert the sequential representation to DAG-based one.+-- dagData :: [(Int.Xs, Int.Ys)] -> [DAG () (X, Y)]+-- dagData = map dagSent+++------------------------------------------------------+-- R0 construction+------------------------------------------------------+++-- | Collect labels assigned to OOV words.+oovChosen :: Ord b => [E.SentL a b] -> S.Set b+oovChosen =+  collect onWord+  where+    onWord x+      | E.unknown (E.word x) = M.keys . E.unProb . E.choice $ x+      | otherwise = []+++-- | Collect labels assigned to words in a dataset.+anyChosen :: Ord b => [E.SentL a b] -> S.Set b+anyChosen = collect $ M.keys . E.unProb . E.choice+++-- | Collect interpretations (also labels assigned) of words in a dataset.+anyInterps :: Ord b => [E.SentL a b] -> S.Set b+anyInterps = S.union+    <$> collect (S.toList . E.lbs . E.word)+    <*> anyChosen+++-- | Collect labels given function which selects labels from a word.+collect :: Ord b => (E.WordL a b -> [b]) -> [E.SentL a b] -> S.Set b+collect onWord = S.fromList . concatMap (F.concatMap onWord)

@@ -1,7 +1,7 @@ module Data.CRF.Chain1.Constrained.DP ( table , flexible2-, flexible3+-- , flexible3 ) where  import qualified Data.Array as A@@ -11,7 +11,7 @@ table :: A.Ix i => (i, i) -> ((i -> e) -> i -> e) -> A.Array i e table bounds f = table' where     table' = A.listArray bounds-           $ map (f (table' !)) +           $ map (f (table' !))            $ range bounds  down1 :: A.Ix i => (i, i) -> (i -> e) -> i -> e@@ -27,17 +27,28 @@         [ down1 (bounds2 i) (f i)         | i <- range bounds1 ] -flexible2 :: (A.Ix i, A.Ix j) => (j, j) -> (j -> (i, i))  -          -> ((j -> i -> e) -> j -> i -> e) -> j -> i -> e+-- | 2-dimensional computation using dynamic programming.+flexible2+  :: (A.Ix i, A.Ix j)+  => (j, j)+     -- ^ Bounds of the 1st dimension+  -> (j -> (i, i))+     -- ^ Bounds of the 2st dimension, depending on the position+     -- in the 1st dimension+  -> ((j -> i -> e) -> j -> i -> e)+     -- ^ How to compute the value of the table on (j, i) already having the+     -- table partially constructed for lower (j', i') indices.+  -> (j -> i -> e)+     -- ^ The resulting memoized, 2-dimensional table flexible2 bounds1 bounds2 f = (!) flex where     flex = A.listArray bounds1         [ down1 (bounds2 i) (f (flex !) i)         | i <- range bounds1 ] -flexible3 :: (A.Ix j, A.Ix i, A.Ix k) => (k, k) -> (k -> (j, j))-          -> (k -> j -> (i, i)) -> ((k -> j -> i -> e) -> k -> j -> i -> e)-           -> k -> j -> i -> e-flexible3 bounds1 bounds2 bounds3 f = (!) flex where-    flex = A.listArray bounds1-        [ down2 (bounds2 i) (bounds3 i) (f (flex !) i)-        | i <- range bounds1 ]+-- flexible3 :: (A.Ix j, A.Ix i, A.Ix k) => (k, k) -> (k -> (j, j))+--           -> (k -> j -> (i, i)) -> ((k -> j -> i -> e) -> k -> j -> i -> e)+--            -> k -> j -> i -> e+-- flexible3 bounds1 bounds2 bounds3 f = (!) flex where+--     flex = A.listArray bounds1+--         [ down2 (bounds2 i) (bounds3 i) (f (flex !) i)+--         | i <- range bounds1 ]

@@ -3,6 +3,7 @@  module Data.CRF.Chain1.Constrained.Dataset.Codec ( Codec+, empty , CodecM , obMax , lbMax@@ -30,6 +31,7 @@ , unJusts ) where +import Prelude hiding (Word) import Control.Applicative ((<$>), (<*>), pure) import Data.Maybe (catMaybes, fromJust) import Data.Lens.Common (fstLens, sndLens)

@@ -9,6 +9,7 @@ , SentL ) where +import           Prelude hiding (Word) import qualified Data.Set as S import qualified Data.Map as M @@ -37,17 +38,31 @@ newtype Prob a = Prob { unProb :: M.Map a Double }     deriving (Show, Eq, Ord) ++-- -- | Construct the probability distribution.+-- mkProb :: Ord a => [(a, Double)] -> Prob a+-- mkProb =+--     Prob . normalize . M.fromListWith (+) . filter ((>0).snd)+--   where+--     normalize dist+--         | M.null dist  =+--             error "mkProb: no elements with positive probability"+--         | otherwise     =+--             let z = sum (M.elems dist)+--             in  fmap (/z) dist++ -- | Construct the probability distribution.+--+-- Normalization is not performed because, when working with DAGs, the+-- probability of a specific DAG edge can be lower than 1 (in particular, it can+-- be 0).+--+-- Elements with probability 0 cab be filtered out since information that a+-- given label is a potential interpretation of the given word/edge is preserved+-- at the level of the `Word` mkProb :: Ord a => [(a, Double)] -> Prob a-mkProb =-    Prob . normalize . M.fromListWith (+) . filter ((>0).snd)-  where-    normalize dist -        | M.null dist  =-            error "mkProb: no elements with positive probability"-        | otherwise     =-            let z = sum (M.elems dist)-            in  fmap (/z) dist+mkProb = Prob . M.fromListWith (+) . filter ((>0).snd)   -- | A WordL is a labeled word, i.e. a word with probability distribution@@ -59,10 +74,19 @@     , choice    :: Prob b }  --- | Ensure, that every label from the distribution domain is a member--- of the set of potential labels corresponding to the word.-mkWordL :: Word a b -> Prob b -> WordL a b-mkWordL = WordL+-- | Ensure, that every label from the distribution domain is a member of the+-- set of potential labels corresponding to the word.+mkWordL :: (Ord b) => Word a b -> Prob b -> WordL a b+mkWordL wd cs+--   | S.null chosen && S.null (lbs wd) =+--     error "mkWordL: no labels assigned to the word"+--     <- the above condition can actualy happen it the model does not+--        find any probable label for a given word.+  | S.null (lbs wd) = WordL wd cs+  | chosen `S.isSubsetOf` lbs wd = WordL wd cs+  | otherwise = error "mkWordL: chosen labels outside of `lbs`"+  where+    chosen = M.keysSet (unProb cs)   -- | A sentence of labeled words.

@@ -1,124 +1,88 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}+-- {-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- {-# LANGUAGE RecordWildCards #-}+-- {-# LANGUAGE TemplateHaskell #-}+-- {-# LANGUAGE MultiParamTypeClasses #-}+-- {-# LANGUAGE TypeFamilies #-}  module Data.CRF.Chain1.Constrained.Dataset.Internal-( Ob (..)-, Lb (..)--, X (..)-, mkX-, unX-, unR-, Xs--, Y (..)-, mkY-, unY+( Xs , Ys--, AVec (unAVec)-, fromList-, fromSet+, module Data.CRF.Chain1.Constrained.Core ) where -import Control.Applicative ((<$>), (<*>))-import Data.Vector.Generic.Base-import Data.Vector.Generic.Mutable-import Data.Binary (Binary, get, put, putWord8, getWord8)-import Data.Vector.Binary ()-import Data.Ix (Ix)-import qualified Data.Set as S+-- import Control.Applicative ((<$>), (<*>))+-- import Data.Vector.Generic.Base+-- import Data.Vector.Generic.Mutable+-- import Data.Binary (Binary, get, put, putWord8, getWord8)+-- import Data.Vector.Binary ()+-- import Data.Ix (Ix)+-- import qualified Data.Set as S import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as U-import           Data.Vector.Unboxed.Deriving+-- import qualified Data.Vector.Unboxed as U+-- import           Data.Vector.Unboxed.Deriving --- | An observation.-newtype Ob = Ob { unOb :: Int }-    deriving ( Show, Read, Eq, Ord, Binary )---           GeneralizedNewtypeDeriving doesn't work for this in 7.8.2:---           , Vector U.Vector, MVector U.MVector, U.Unbox )-derivingUnbox "Ob" [t| Ob -> Int |] [| unOb |] [| Ob |]+import Data.CRF.Chain1.Constrained.Core --- | A label.-newtype Lb = Lb { unLb :: Int }-    deriving ( Show, Read, Eq, Ord, Binary, Num, Ix )-derivingUnbox "Lb" [t| Lb -> Int |] [| unLb |] [| Lb |] --- | Ascending vector of unique interger elements.-newtype AVec a = AVec { unAVec :: U.Vector a }-    deriving (Show, Read, Eq, Ord, Binary)---- | Smart AVec constructor which ensures that the--- underlying vector satisfies the AVec properties.-fromList :: (Ord a, U.Unbox a) => [a] -> AVec a-fromList = fromSet . S.fromList -{-# INLINE fromList #-}---- | Smart AVec constructor which ensures that the--- underlying vector satisfies the AVec properties.-fromSet :: (Ord a, U.Unbox a) => S.Set a -> AVec a-fromSet = AVec . U.fromList . S.toList -{-# INLINE fromSet #-}---- | A word represented by a list of its observations--- and a list of its potential label interpretations.-data X-    -- | The word with default set of potential interpretations.-    = X { _unX :: AVec Ob }-    -- | The word with custom set of potential labels.-    | R { _unX :: AVec Ob-        , _unR :: AVec Lb }-    deriving (Show, Read, Eq, Ord)--instance Binary X where-    put X{..} = putWord8 0 >> put _unX-    put R{..} = putWord8 1 >> put _unX >> put _unR-    get = getWord8 >>= \i -> case i of-        0   -> X <$> get-        _   -> R <$> get <*> get---- | X constructor.-mkX :: [Ob] -> [Lb] -> X-mkX x [] = X (fromList x)-mkX x r  = R (fromList x) (fromList r)-{-# INLINE mkX #-}---- | List of observations.-unX :: X -> [Ob]-unX = U.toList . unAVec . _unX-{-# INLINE unX #-}---- | List of potential labels.-unR :: AVec Lb -> X -> [Lb]-unR r0 X{..} = U.toList . unAVec $ r0-unR _  R{..} = U.toList . unAVec $ _unR-{-# INLINE unR #-}- -- | Sentence of words. type Xs = V.Vector X --- | Probability distribution over labels.  We assume, that when y is--- a member of chosen labels list it is also a member of the list--- potential labels for corresponding 'X' word.--- TODO: Perhaps we should substitute 'Lb's with label indices--- corresponding to labels from the vector of potential labels?--- FIXME: The type definition is incorrect (see 'fromList' definition),--- it should be something like AVec2.-newtype Y = Y { _unY :: AVec (Lb, Double) }-    deriving (Show, Read, Eq, Ord, Binary)---- | Y constructor.-mkY :: [(Lb, Double)] -> Y-mkY = Y . fromList-{-# INLINE mkY #-}---- | Y deconstructor symetric to mkY.-unY :: Y -> [(Lb, Double)]-unY = U.toList . unAVec . _unY-{-# INLINE unY #-}- -- | Sentence of Y (label choices). type Ys = V.Vector Y+++------------------------------------------------------------------+-- DAG representation+------------------------------------------------------------------+--+-- Naming proposals:+-- * lattice+-- * word-lattice       <- może za bardzo kojarzy się z czymś innym?+--                         ale z drugiej strony, chyba kojarz się+--                         właśnie z tym co trzeba, ew. sugeruje trochę+--                         inną funkcjonalność (jaką?) niż ja zamierzam+--                         udostępnić.+-- * word-dag+-- * edge-dag+--+-- First of all, nodes represent division places of the input text+-- (i.e., they point to places *between* two adjacent characters).+--+-- Therefore, segments (or tokens) are represented by graph edges.+-- An edge consists of:+-- * An analysis of the corresponding segment,+-- * Nodes (or their identifiers) between which the edge spans.+--+-- Query operations available on DAGs:+-- * Return nodes with respect to the topological order (in both+--   directions?)+-- * List all edges (in/out)going from the particular node.+--+-- It should be possible to make something like a context-sensitive+-- fmap, which will make it possible to:+-- * Translate individual edge values to feature vectors,+--   WARNING: there are several strategies of how observations for the,+--   previous edge (for example) are determined, since there may be+--   several candidates for a previous edge!+-- * Translate edge values to forward/backward probabilities.+--+-- Misc operations:+-- * Join DAG with a particular path of words (morphological analysis+--   will result with a DAG, while disambiguated sentence is just+--   a sequence of morphosyntactic tags refering to a particular path+--   in the DAG), or more general:+-- * Join DAG with a DAG.+--+-- Other considerations:+-- * Do we want to represent spaces on the level of word lattices?+--   Not necessarily.  On the other hand, it should be possible+--   to store a word-with-spaces in an edge -- why not? -- and+--   restore the original sentence from the lattice.  Wouldn't+--   that be nice?+--   Since node represents a position between two segments, it can+--   be also explicitly stated if there is a space between these two+--   segments, and what kind of space is that.  Yep, it makes sense!+-- * Potential morphosyntactic analyses of a sentence can be represented+--   as a DAG.  The same goes for chosen interpretations -- they can also+--   be represented as a DAG with potentials (probabilities?) assigned+--   to each label on every edge.

@@ -6,59 +6,14 @@ , featuresIn ) where -import Data.Binary (Binary, Get, put, get)-import Control.Applicative ((<*>), (<$>))++-- import Data.Binary (Binary, Get, put, get)+-- import Control.Applicative ((<*>), (<$>)) import qualified Data.Vector as V import qualified Data.Number.LogFloat as L  import Data.CRF.Chain1.Constrained.Dataset.Internal --- | A Feature is either an observation feature OFeature o x, which--- models relation between observation o and label x assigned to--- the same word, or a transition feature TFeature x y (SFeature x--- for the first position in the sentence), which models relation--- between two subsequent labels, x (on i-th position) and y--- (on (i-1)-th positoin).-data Feature-    = SFeature-        {-# UNPACK #-} !Lb-    | TFeature-        {-# UNPACK #-} !Lb-        {-# UNPACK #-} !Lb-    | OFeature-        {-# UNPACK #-} !Ob-        {-# UNPACK #-} !Lb-    deriving (Show, Eq, Ord)--instance Binary Feature where-    put (SFeature x)   = put (0 :: Int) >> put x-    put (TFeature x y) = put (1 :: Int) >> put (x, y)-    put (OFeature o x) = put (2 :: Int) >> put (o, x)-    get = do-        k <- get :: Get Int-        case k of-            0 -> SFeature <$> get-            1 -> TFeature <$> get <*> get-            2 -> OFeature <$> get <*> get-	    _ -> error "Binary Feature: unknown identifier"---- | Is it a 'SFeature'?-isSFeat :: Feature -> Bool-isSFeat (SFeature _) = True-isSFeat _            = False-{-# INLINE isSFeat #-}---- | Is it an 'OFeature'?-isOFeat :: Feature -> Bool-isOFeat (OFeature _ _) = True-isOFeat _              = False-{-# INLINE isOFeat #-}---- | Is it a 'TFeature'?-isTFeat :: Feature -> Bool-isTFeat (TFeature _ _) = True-isTFeat _              = False-{-# INLINE isTFeat #-}  -- | Transition features with assigned probabilities for given position. trFeats :: Ys -> Int -> [(Feature, L.LogFloat)]

@@ -60,7 +60,7 @@ lbIxs crf xs = zip [0..] . U.toList . unAVec . lbVec crf xs {-# INLINE lbIxs #-} --- | Compute the table of potential products associated with +-- | Compute the table of potential products associated with -- observation features for the given sentence position. computePsi :: Model -> Xs -> Int -> LbIx -> L.LogFloat computePsi crf xs i = (A.!) $ A.accumArray (*) 1 bounds@@ -202,7 +202,7 @@ accuracy :: Model -> [(Xs, Ys)] -> Double accuracy crf dataset =     let k = numCapabilities-    	parts = partition k dataset+        parts = partition k dataset         xs = parMap rseq (goodAndBad' crf) parts         (good, bad) = foldl add (0, 0) xs         add (g, b) (g', b') = (g + g', b + b')@@ -218,7 +218,7 @@     pr1 = prob1     alpha beta i     pr2 = prob2 crf alpha beta i psi -    oFeats = [ (ix, pr1 k) +    oFeats = [ (ix, pr1 k)              | o <- unX (xs V.! i)              , (k, ix) <- intersect (obIxs crf o) (lbVec crf xs i) ] @@ -233,7 +233,7 @@  -- | A list of features (represented by feature indices) defined within -- the context of the sentence accompanied by expected probabilities--- determined on the basis of the model. +-- determined on the basis of the model. -- -- One feature can occur multiple times in the output list. expectedFeaturesIn :: Model -> Xs -> [(FeatIx, L.LogFloat)]

@@ -1,15 +1,18 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} + module Data.CRF.Chain1.Constrained.Intersect ( intersect ) where + import qualified Data.Vector.Unboxed as U  import Data.CRF.Chain1.Constrained.Dataset.Internal (Lb, AVec, unAVec) import Data.CRF.Chain1.Constrained.Model (FeatIx) + -- | Assumption: both input list are given in an ascending order. intersect     :: AVec (Lb, FeatIx)    -- ^ Vector of (label, features index) pairs@@ -26,6 +29,7 @@     n = U.length ys     m = U.length xs + merge :: U.Vector (Lb, FeatIx) -> U.Vector Lb -> [(Int, FeatIx)] merge xs ys = doIt 0 0   where@@ -40,3 +44,41 @@       where         (x, ix) = xs `U.unsafeIndex` i         y = ys `U.unsafeIndex` j+++---------------------------------------------+-- Alternative version+---------------------------------------------+++-- -- | Assumption: both input list are given in an ascending order.+-- intersect'+--     :: AVec (Lb, FeatIx)    -- ^ Vector of (label, features index) pairs+--     -> AVec (Lb, Prob)      -- ^ Vector of labels+--     -- | Intersection of arguments: vector indices from the second list+--     -- and feature indices from the first list.+--     -> [(Int, FeatIx)]+-- intersect' xs' ys'+--     | n == 0 || m == 0 = []+--     | otherwise = merge xs ys+--   where+--     xs = unAVec xs'+--     ys = unAVec ys'+--     n = U.length ys+--     m = U.length xs+--+--+-- merge :: U.Vector (Lb, FeatIx) -> U.Vector Lb -> [(Int, FeatIx)]+-- merge xs ys = doIt 0 0+--   where+--     m = U.length xs+--     n = U.length ys+--     doIt i j+--         | i >= m || j >= n = []+--         | otherwise = case compare x y of+--             EQ -> (j, ix) : doIt (i+1) (j+1)+--             LT -> doIt (i+1) j+--             GT -> doIt i (j+1)+--       where+--         (x, ix) = xs `U.unsafeIndex` i+--         y = ys `U.unsafeIndex` j

@@ -73,7 +73,7 @@     -- if feature is not present in the model.     , sgIxsV 	:: U.Vector FeatIx     -- | Set of labels for the given observation which, together with the-    -- observation, constitute an observation feature of the model. +    -- observation, constitute an observation feature of the model.     , obIxsV    :: V.Vector (AVec LbIx)     -- | Set of ,,previous'' labels for the value of the ,,current'' label.     -- Both labels constitute a transition feature present in the the model.