crf-chain1 0.2.2 → 0.2.3

raw patch · 26 files changed

+1231/−1213 lines, 26 filesdep +data-lens-lightdep +vector-binary-instancesdep −data-lensdep −vector-binarydep ~basedep ~monad-codecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: data-lens-light, vector-binary-instances

Dependencies removed: data-lens, vector-binary

Dependency ranges changed: base, monad-codec

API changes (from Hackage documentation)

Files

• Data/CRF/Chain1.hs +0/−47
• Data/CRF/Chain1/DP.hs +0/−43
• Data/CRF/Chain1/Dataset/Codec.hs +0/−134
• Data/CRF/Chain1/Dataset/External.hs +0/−43
• Data/CRF/Chain1/Dataset/Internal.hs +0/−79
• Data/CRF/Chain1/Feature.hs +0/−86
• Data/CRF/Chain1/Feature/Hidden.hs +0/−66
• Data/CRF/Chain1/Feature/Present.hs +0/−56
• Data/CRF/Chain1/Inference.hs +0/−275
• Data/CRF/Chain1/Model.hs +0/−224
• Data/CRF/Chain1/Train.hs +0/−90
• Data/CRF/Chain1/Util.hs +0/−12
• README.md +1/−0
• crf-chain1.cabal +57/−58
• src/Data/CRF/Chain1.hs +49/−0
• src/Data/CRF/Chain1/DP.hs +43/−0
• src/Data/CRF/Chain1/Dataset/Codec.hs +148/−0
• src/Data/CRF/Chain1/Dataset/External.hs +45/−0
• src/Data/CRF/Chain1/Dataset/Internal.hs +79/−0
• src/Data/CRF/Chain1/Feature.hs +86/−0
• src/Data/CRF/Chain1/Feature/Hidden.hs +66/−0
• src/Data/CRF/Chain1/Feature/Present.hs +56/−0
• src/Data/CRF/Chain1/Inference.hs +275/−0
• src/Data/CRF/Chain1/Model.hs +224/−0
• src/Data/CRF/Chain1/Train.hs +90/−0
• src/Data/CRF/Chain1/Util.hs +12/−0

@@ -1,47 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | The module provides first-order, linear-chain conditional random fields--- (CRFs).------ Important feature of the implemented flavour of CRFs is that transition--- features which are not included in the CRF model are considered to have--- probability of 0. --- It is particularly useful when the training material determines the set--- of possible label transitions (e.g. when using the IOB encoding method).--- Furthermore, this design decision makes the implementation much faster--- for sparse datasets.--module Data.CRF.Chain1-(--- * Data types-  Word-, Sent-, Dist (unDist)-, mkDist-, WordL-, annotate-, SentL---- * CRF-, CRF (..)--- ** Training-, train--- ** Tagging-, tag---- * Feature selection-, hiddenFeats-, presentFeats-) where--import Data.CRF.Chain1.Dataset.External-import Data.CRF.Chain1.Dataset.Codec-import Data.CRF.Chain1.Feature.Present-import Data.CRF.Chain1.Feature.Hidden-import Data.CRF.Chain1.Train-import qualified Data.CRF.Chain1.Inference as I---- | 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]-tag CRF{..} = decodeLabels codec . I.tag model . encodeSent codec

@@ -1,43 +0,0 @@-module Data.CRF.Chain1.DP-( table-, flexible2-, flexible3-) where--import qualified Data.Array as A-import Data.Array ((!))-import Data.Ix (range)--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' !)) -           $ range bounds--down1 :: A.Ix i => (i, i) -> (i -> e) -> i -> e-down1 bounds f = (!) down' where-    down' = A.listArray bounds-          $ map f-          $ range bounds--down2 :: (A.Ix i, A.Ix j) => (j, j) -> (j -> (i, i)) -> (j -> i -> e)-      -> j -> i -> e-down2 bounds1 bounds2 f = (!) down' where-    down' = A.listArray bounds1-        [ 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-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 ]

@@ -1,134 +0,0 @@-module Data.CRF.Chain1.Dataset.Codec-( Codec-, CodecM--, encodeWord'Cu-, encodeWord'Cn-, encodeSent'Cu-, encodeSent'Cn-, encodeSent--, encodeWordL'Cu-, encodeWordL'Cn-, encodeSentL'Cu-, encodeSentL'Cn-, encodeSentL--, decodeLabel-, decodeLabels--, mkCodec-, encodeData-, encodeDataL-) where--import Control.Applicative ((<$>), (<*>), pure)-import Data.Maybe (catMaybes)-import Data.Lens.Common (fstLens, sndLens)-import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.Vector as V-import qualified Control.Monad.Codec as C--import Data.CRF.Chain1.Dataset.Internal-import Data.CRF.Chain1.Dataset.External---- | A codec.  The first component is used to encode observations--- of type a, the second one is used to encode labels of type b.-type Codec a b = (C.AtomCodec a, C.AtomCodec b)---- | Type synonym for the codec monad.  It is important to notice that by a--- codec we denote here a structure of two 'C.AtomCodec's while in the--- monad-codec package it denotes a monad.-type CodecM a b c = C.Codec (Codec a b) c---- | Encode the labeled word and update the codec.-encodeWordL'Cu :: (Ord a, Ord b) => WordL a b -> CodecM a b (X, Y)-encodeWordL'Cu word = do-    x <- mkX . map Ob <$>-        mapM (C.encode' fstLens) (S.toList $ fst word)-    y <- mkY <$> sequence-    	[ (,) <$> (Lb <$> C.encode sndLens lb) <*> pure pr-	| (lb, pr) <- (M.toList . unDist) (snd word) ]-    return (x, y)---- | Encodec the labeled word and do *not* update the codec.--- If the label is not in the codec, use the default value.-encodeWordL'Cn :: (Ord a, Ord b) => Int -> WordL a b -> CodecM a b (X, Y)-encodeWordL'Cn i word = do-    x <- mkX . map Ob . catMaybes <$>-        mapM (C.maybeEncode fstLens) (S.toList $ fst word)-    y <- mkY <$> sequence-    	[ (,) <$> encodeL i lb <*> pure pr-	| (lb, pr) <- (M.toList . unDist) (snd word) ]-    return (x, y)-  where-    encodeL j y = Lb . maybe j id <$> C.maybeEncode sndLens y---- | Encode the word and update the codec.-encodeWord'Cu :: Ord a => Word a -> CodecM a b X-encodeWord'Cu word =-    mkX . map Ob <$> mapM (C.encode' fstLens) (S.toList word)---- | Encode the word and do *not* update the codec.-encodeWord'Cn :: Ord a => Word a -> CodecM a b X-encodeWord'Cn word = -    mkX . map Ob . catMaybes <$> mapM (C.maybeEncode fstLens) (S.toList word)---- | Encode the labeled sentence and update the codec.-encodeSentL'Cu :: (Ord a, Ord b) => SentL a b -> CodecM a b (Xs, Ys)-encodeSentL'Cu sent = do-    ps <- mapM encodeWordL'Cu sent-    return (V.fromList (map fst ps), V.fromList (map snd ps))---- | 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) => b -> SentL a b -> CodecM a b (Xs, Ys)-encodeSentL'Cn def sent = do-    i <- C.maybeEncode sndLens def >>= \mi -> case mi of-        Just _i -> return _i-        Nothing -> error "encodeWordL'Cn: default label not in the codec"-    ps <- mapM (encodeWordL'Cn i) sent-    return (V.fromList (map fst ps), V.fromList (map snd ps))---- | 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) => b -> Codec a b -> SentL a b -> (Xs, Ys)-encodeSentL def codec = C.evalCodec codec . encodeSentL'Cn def---- | Encode the sentence and update the codec.-encodeSent'Cu :: Ord a => Sent a -> CodecM a b Xs-encodeSent'Cu = fmap V.fromList . mapM encodeWord'Cu---- | Encode the sentence and do *not* update the codec.-encodeSent'Cn :: Ord a => Sent a -> CodecM a b Xs-encodeSent'Cn = fmap V.fromList . mapM encodeWord'Cn---- | Encode the sentence using the given codec.-encodeSent :: Ord a => Codec a b -> Sent a -> Xs-encodeSent codec = C.evalCodec codec . encodeSent'Cn---- | Create the codec on the basis of the labeled dataset, return the--- resultant codec and the encoded dataset.-mkCodec :: (Ord a, Ord b) => [SentL a b] -> (Codec a b, [(Xs, Ys)])-mkCodec =-    let swap (x, y) = (y, x)-    in  swap . C.runCodec (C.empty, C.empty) . mapM encodeSentL'Cu---- | Encode the labeled dataset using the codec.  Substitute the default--- label for any label not present in the codec.-encodeDataL :: (Ord a, Ord b) => b -> Codec a b -> [SentL a b] -> [(Xs, Ys)]-encodeDataL def codec = C.evalCodec codec . mapM (encodeSentL'Cn def)---- | Encode the dataset with the codec.-encodeData :: Ord a => Codec a b -> [Sent a] -> [Xs]-encodeData codec = map (encodeSent codec)---- | Decode the label.-decodeLabel :: Ord b => Codec a b -> Lb -> b-decodeLabel codec x = C.evalCodec codec $ C.decode sndLens (unLb x)---- | Decode the sequence of labels.-decodeLabels :: Ord b => Codec a b -> [Lb] -> [b]-decodeLabels codec xs = C.evalCodec codec $-    sequence [C.decode sndLens (unLb x) | x <- xs]

@@ -1,43 +0,0 @@-module Data.CRF.Chain1.Dataset.External-( Word-, Sent-, Dist (unDist)-, mkDist-, WordL-, annotate-, SentL-) where--import qualified Data.Set as S-import qualified Data.Map as M---- | A Word is represented by a set of observations.-type Word a = S.Set a---- | A sentence of words.-type Sent a = [Word a]---- | A probability distribution defined over elements of type a.--- All elements not included in the map have probability equal--- to 0.-newtype Dist a = Dist { unDist :: M.Map a Double }---- | Construct the probability distribution.-mkDist :: Ord a => [(a, Double)] -> Dist a-mkDist =-    Dist . normalize . M.fromListWith (+)-  where-    normalize dist =-        let z = sum (M.elems dist)-        in  fmap (/z) dist---- | A WordL is a labeled word, i.e. a word with probability distribution--- defined over labels.-type WordL a b = (Word a, Dist b)---- | Annotate the word with the label.-annotate :: Word a -> b -> WordL a b-annotate w x = (w, Dist (M.singleton x 1))---- | A sentence of labeled words.-type SentL a b = [WordL a b]

@@ -1,79 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}---module Data.CRF.Chain1.Dataset.Internal-( Ob (..)-, Lb (..)--, X (..)-, mkX-, unX-, Xs--, Y (..)-, mkY-, unY-, Ys-) where----- import Data.Vector.Generic.Base--- import Data.Vector.Generic.Mutable-import Data.Binary (Binary)-import Data.Ix (Ix)-import qualified Data.Vector as V-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 |]----- | A label.-newtype Lb = Lb { unLb :: Int }-    deriving ( Show, Read, Eq, Ord, Binary, Num, Ix )-derivingUnbox "Lb" [t| Lb -> Int |] [| unLb |] [| Lb |]----- | Simple word represented by a list of its observations.-newtype X = X { _unX :: U.Vector Ob }-    deriving (Show, Read, Eq, Ord)---- | X constructor.-mkX :: [Ob] -> X-mkX = X . U.fromList-{-# INLINE mkX #-}---- | X deconstructor symetric to mkX.-unX :: X -> [Ob]-unX = U.toList . _unX-{-# INLINE unX #-}---- | Sentence of words.-type Xs = V.Vector X---- | Probability distribution over labels. -newtype Y = Y { _unY :: U.Vector (Lb, Double) }-    deriving (Show, Read, Eq, Ord)---- | Y constructor.-mkY :: [(Lb, Double)] -> Y-mkY = Y . U.fromList-{-# INLINE mkY #-}---- | Y deconstructor symetric to mkY.-unY :: Y -> [(Lb, Double)]-unY = U.toList . _unY-{-# INLINE unY #-}---- | Sentence of Y (label choices).-type Ys = V.Vector Y

@@ -1,86 +0,0 @@-module Data.CRF.Chain1.Feature-( Feature (..)-, isSFeat-, isTFeat-, isOFeat-, featuresIn-) where--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.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)]-trFeats ys 0 =-    [ (SFeature x, L.logFloat px)-    | (x, px) <- unY (ys V.! 0) ]-trFeats ys k =-    [ (TFeature x y, L.logFloat px * L.logFloat py)-    | (x, px) <- unY (ys V.! k)-    , (y, py) <- unY (ys V.! (k-1)) ]---- | Observation features with assigned probabilities for a given position.-obFeats :: Xs -> Ys -> Int -> [(Feature, L.LogFloat)]-obFeats xs ys k =-    [ (OFeature o x, L.logFloat px)-    | (x, px) <- unY (ys V.! k)-    , o       <- unX (xs V.! k) ]---- | All features with assigned probabilities for given position.-features :: Xs -> Ys -> Int -> [(Feature, L.LogFloat)]-features xs ys k = trFeats ys k ++ obFeats xs ys k---- | All features with assigned probabilities in given labeled sentence.-featuresIn :: Xs -> Ys -> [(Feature, L.LogFloat)]-featuresIn xs ys = concatMap (features xs ys) [0 .. V.length xs - 1]

@@ -1,66 +0,0 @@--- | The module provides feature selection functions which extract--- hidden features, i.e. all features which can be constructed --- (by means of cartesian product) on the basis of the set of--- observations and the set of labels.--- For example, the list of hidden observation features can--- be defined as 'OFeature' '<$>' os '<*>' xs, where os is a--- list of all observations and xs is a list of all labels.------ You can mix functions defined here with the selection functions--- from the "Data.CRF.Chain1.Feature.Present" module.--module Data.CRF.Chain1.Feature.Hidden-( hiddenFeats-, hiddenOFeats-, hiddenTFeats-, hiddenSFeats-) where--import qualified Data.Set as S-import qualified Data.Vector as V--import Data.CRF.Chain1.Dataset.Internal-import Data.CRF.Chain1.Feature---- | Hidden 'OFeature's which can be constructed based on the dataset.-hiddenOFeats :: [(Xs, Ys)] -> [Feature]-hiddenOFeats ds =-    [ OFeature o x-    | o <- collectObs ds-    , x <- collectLbs ds ]---- | Hidden 'TFeature's which can be constructed based on the dataset.-hiddenTFeats :: [(Xs, Ys)] -> [Feature]-hiddenTFeats ds =-    let xs = collectLbs ds-    in  [TFeature x y | x <- xs, y <- xs]---- | Hidden 'SFeature's which can be constructed based on the dataset.-hiddenSFeats :: [(Xs, Ys)] -> [Feature]-hiddenSFeats = map SFeature . collectLbs---- | Hidden 'Feature's of all types which can be constructed--- based on the dataset.-hiddenFeats :: [(Xs, Ys)] -> [Feature]-hiddenFeats ds-    =  hiddenOFeats ds-    ++ hiddenTFeats ds-    ++ hiddenSFeats ds--collectObs :: [(Xs, Ys)] -> [Ob]-collectObs = nub . concatMap (sentObs . fst)--collectLbs :: [(Xs, Ys)] -> [Lb]-collectLbs = nub . concatMap (sentLbs . snd)--sentObs :: Xs -> [Ob]-sentObs = concatMap unX . V.toList--sentLbs :: Ys -> [Lb]-sentLbs = concatMap lbsAll . V.toList--lbsAll :: Y -> [Lb]-lbsAll = map fst . unY--nub :: Ord a => [a] -> [a]-nub = S.toList . S.fromList

@@ -1,56 +0,0 @@--- | The module provides feature selection functions which extract--- features present in the dataset, i.e. features which directly occure--- the dataset.------ You can mix functions defined here with the selection functions--- from the "Data.CRF.Chain1.Feature.Hidden" module.--module Data.CRF.Chain1.Feature.Present-( presentFeats-, presentOFeats-, presentTFeats-, presentSFeats-) where--import qualified Data.Vector as V--import Data.CRF.Chain1.Dataset.Internal-import Data.CRF.Chain1.Feature---- | 'OFeature's which occur in the dataset.-presentOFeats :: [(Xs, Ys)] -> [Feature]-presentOFeats ds =-    concatMap sentOFeats ds-  where-    sentOFeats (xs, ys) = concatMap oFeatsOn (zip (V.toList xs) (V.toList ys))-    oFeatsOn (x, choice) =-        [ OFeature o y-        | o <- unX x-        , y <- lbs choice ]---- | 'TFeature's which occur in the dataset.-presentTFeats :: [(a, Ys)] -> [Feature]-presentTFeats ds =-    concatMap (sentTFeats.snd) ds-  where-    sentTFeats ys = concatMap (tFeatsOn ys) [1 .. V.length ys - 1]-    tFeatsOn ys k =-        [ TFeature x y-        | x <- lbs (ys V.! k)-        , y <- lbs (ys V.! (k-1)) ]---- | 'SFeature's which occur in the dataset.-presentSFeats :: [(a, Ys)] -> [Feature]-presentSFeats ds =-    let sentSFeats s = [SFeature x | x <- lbs (s V.! 0)] -    in  concatMap (sentSFeats.snd) ds---- | 'Feature's of all kinds which occur in the dataset.-presentFeats :: [(Xs, Ys)] -> [Feature]-presentFeats ds-    =  presentOFeats ds-    ++ presentTFeats ds-    ++ presentSFeats ds--lbs :: Y -> [Lb]-lbs = map fst . unY

@@ -1,275 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}---- Inference with CRFs.--module Data.CRF.Chain1.Inference-( tag-, marginals-, accuracy-, expectedFeaturesIn-, zx-, zx'-) where--import Control.Applicative ((<$>), (<*>), pure)-import Data.Maybe (catMaybes)-import Data.List (maximumBy)-import Data.Function (on)-import qualified Data.Array as A-import qualified Data.Vector as V--import Control.Parallel.Strategies (rseq, parMap)-import Control.Parallel (par, pseq)-import GHC.Conc (numCapabilities)-import qualified Data.Number.LogFloat as L--import qualified Data.CRF.Chain1.DP as DP-import Data.CRF.Chain1.Util (partition)-import Data.CRF.Chain1.Dataset.Internal-import Data.CRF.Chain1.Model--type ProbArray = Int -> Lb -> L.LogFloat-type AccF = [L.LogFloat] -> L.LogFloat---- | Compute the table of potential products associated with --- observation features for the given sentence position.-computePsi :: Model -> Xs -> Int -> Lb -> L.LogFloat-computePsi crf xs i = (A.!) $ A.accumArray (*) 1 bounds-    [ (x, valueL crf ix)-    | ob <- unX (xs V.! i)-    , (x, ix) <- obIxs crf ob ]-  where-    bounds = (Lb 0, Lb $ lbNum crf - 1)---- | Forward table computation.-forward :: AccF -> Model -> Xs -> ProbArray-forward acc crf sent = DP.flexible2-    (0, V.length sent) wordBounds-    (\t k -> withMem (computePsi crf sent k) t k)-  where-    wordBounds k-        | k == V.length sent = (Lb 0, Lb 0)-        | otherwise = (Lb 0, Lb $ lbNum crf - 1)-    -- | Forward table equation, where k is current position, x is a label-    -- on current position and psi is a psi table computed for current-    -- position.-    -- FIXME: null sentence?-    withMem psi alpha k x-        | k == 0 = psi x * sgValue crf x -        | k == V.length sent = acc-            [ alpha (k - 1) y-            | y <- lbSet crf ]-        | otherwise = acc-            [ alpha (k - 1) y * psi x * valueL crf ix-            | (y, ix) <- prevIxs crf x ]---- | Backward table computation.-backward :: AccF -> Model -> Xs -> ProbArray-backward acc crf sent = DP.flexible2-    (0, V.length sent) wordBounds-    (\t k -> withMem (computePsi crf sent k) t k)-  where-    wordBounds k-        | k == 0    = (Lb 0, Lb 0)-        | otherwise = (Lb 0, Lb $ lbNum crf - 1)-    -- | Backward table equation, where k is current position, y is a label-    -- on previous, k-1, position and psi is a psi table computed for current-    -- position.-    withMem psi beta k y-        | k == V.length sent = 1-        | k == 0    = acc-            [ beta (k + 1) x * psi x * valueL crf ix-            | (x, ix) <- sgIxs crf ]-        | otherwise = acc-            [ beta (k + 1) x * psi x * valueL crf ix-            | (x, ix) <- nextIxs crf y ]--zxBeta :: ProbArray -> L.LogFloat-zxBeta beta = beta 0 0--zxAlpha :: Xs -> ProbArray -> L.LogFloat-zxAlpha sent alpha = alpha (V.length sent) 0---- | Normalization factor computed for the 'Xs' sentence using the--- backward computation.-zx :: Model -> Xs -> L.LogFloat-zx crf = zxBeta . backward sum crf---- | Normalization factor computed for the 'Xs' sentence using the--- forward computation.-zx' :: Model -> Xs -> L.LogFloat-zx' crf sent = zxAlpha sent (forward sum crf sent)-----------------------------------------------------------------argmax :: Ord b => (a -> Maybe b) -> [a] -> Maybe (a, b)-argmax _ [] = Nothing-argmax f xs-    | null ys   = Nothing-    | otherwise = Just $ foldl1 choice ys-  where-    ys = catMaybes $ map (\x -> (,) <$> pure x <*> f x) xs-    choice (x1, v1) (x2, v2)-        | v1 > v2 = (x1, v1)-        | otherwise = (x2, v2)---- | Determine the most probable label sequence given the context of the--- CRF model and the sentence.-tag :: Model -> Xs -> [Lb]-tag crf sent = collectMaxArg (0, 0) [] $ DP.flexible2-    (0, V.length sent) wordBounds-    (\t k -> withMem (computePsi crf sent k) t k)-  where-    n = V.length sent--    wordBounds k-        | k == 0    = (Lb 0, Lb 0)-        | otherwise = (Lb 0, Lb $ lbNum crf - 1)--    withMem psi mem k y-        | k == n    = Just (-1, 1)  -- -1 is a dummy value-        | k == 0    = prune <$> argmax eval (sgIxs crf)-        | otherwise = prune <$> argmax eval (nextIxs crf y)-      where-        eval (x, ix) = do-            v <- snd <$> mem (k + 1) x-            return $ v * psi x * valueL crf ix-        prune ((x, _ix), v) = (x, v)--    collectMaxArg (i, j) acc mem-        | i < n     = collect (mem i j)-        | otherwise = reverse acc-      where-        collect (Just (h, _)) = collectMaxArg (i + 1, h) (h:acc) mem-        collect Nothing       = error "tag.collect: Nothing"---- | Tag probabilities with respect to marginal distributions.-marginals :: Model -> Xs -> [[(Lb, L.LogFloat)]]-marginals crf sent =-    let alpha = forward sum crf sent-        beta = backward sum crf sent-    in  [ [ (x, prob1 alpha beta k x)-          | x <- lbSet crf ]-        | k <- [0 .. V.length sent - 1] ]---- tagProbs :: Sent s => Model -> s -> [[Double]]--- tagProbs crf sent =---     let alpha = forward maximum crf sent---         beta = backward maximum crf sent---         normalize vs =---             let d = - logSum vs---             in map (+d) vs---         m1 k x = alpha k x + beta (k + 1) x---     in  [ map exp $ normalize [m1 i k | k <- interpIxs sent i]---         | i <- [0 .. V.length sent - 1] ]--- --- -- tag probabilities with respect to--- -- marginal distributions--- tagProbs' :: Sent s => Model -> s -> [[Double]]--- tagProbs' crf sent =---     let alpha = forward logSum crf sent---         beta = backward logSum crf sent---     in  [ [ exp $ prob1 crf alpha beta sent i k---           | k <- interpIxs sent i ]---         | i <- [0 .. V.length sent - 1] ]--goodAndBad :: Model -> Xs -> Ys -> (Int, Int)-goodAndBad crf sent labels =-    foldl gather (0, 0) (zip labels' labels'')-  where-    labels' = [ fst . maximumBy (compare `on` snd) $ unY (labels V.! i)-              | i <- [0 .. V.length labels - 1] ]-    labels'' = tag crf sent-    gather (good, bad) (x, y)-        | x == y = (good + 1, bad)-        | otherwise = (good, bad + 1)--goodAndBad' :: Model -> [(Xs, Ys)] -> (Int, Int)-goodAndBad' crf dataset =-    let add (g, b) (g', b') = (g + g', b + b')-    in  foldl add (0, 0) [goodAndBad crf x y | (x, y) <- dataset]---- | Compute the accuracy of the model with respect to the labeled dataset.-accuracy :: Model -> [(Xs, Ys)] -> Double-accuracy crf dataset =-    let k = numCapabilities-    	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')-    in  fromIntegral good / fromIntegral (good + bad)-------------------------------------------------------------------- prob :: L.Vect t Int => Model -> Sent Int t -> Double--- prob crf sent =---     sum [ phiOn crf sent k---         | k <- [0 .. (length sent) - 1] ]---     - zx' crf sent--- --- -- TODO: Wziac pod uwage "Regularization Variance" !--- cll :: Model -> [Sentence] -> Double--- cll crf dataset = sum [prob crf sent | sent <- dataset]---- prob2 :: SentR s => Model -> ProbArray -> ProbArray -> s---       -> Int -> Lb -> Lb -> Double--- prob2 crf alpha beta sent k x y---     = alpha (k - 1) y + beta (k + 1) x---     + phi crf (observationsOn sent k) a b---     - zxBeta beta---   where---     a = interp sent k       x---     b = interp sent (k - 1) y--prob2 :: Model -> ProbArray -> ProbArray -> Int -> (Lb -> L.LogFloat)-      -> Lb -> Lb -> 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---- prob1 :: SentR s => Model -> ProbArray -> ProbArray---       -> s -> Int -> Label -> Double--- prob1 crf alpha beta sent k x = logSum---     [ prob2 crf alpha beta sent k x y---     | y <- interpIxs sent (k - 1) ]--prob1 :: ProbArray -> ProbArray -> Int -> Lb -> L.LogFloat-prob1 alpha beta k x =-    alpha k x * beta (k + 1) x / zxBeta beta--expectedFeaturesOn-    :: Model -> ProbArray -> ProbArray -> Xs-    -> Int -> [(FeatIx, L.LogFloat)]-expectedFeaturesOn crf alpha beta sent k =-    tFeats ++ oFeats-  where-    psi = computePsi crf sent k-    pr1 = prob1     alpha beta k-    pr2 = prob2 crf alpha beta k psi--    oFeats = [ (ix, pr1 x) -             | o <- unX (sent V.! k)-             , (x, ix) <- obIxs crf o ]--    tFeats-        | k == 0 = -            [ (ix, pr1 x) -            | (x, ix) <- sgIxs crf ]-        | otherwise =-            [ (ix, pr2 x y ix) -            | x <- lbSet crf-            , (y, ix) <- prevIxs crf x ]---- | 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 :: Model -> Xs -> [(FeatIx, L.LogFloat)]-expectedFeaturesIn crf sent = zxF `par` zxB `pseq` zxF `pseq`-    concat [expectedOn k | k <- [0 .. V.length sent - 1] ]-  where-    expectedOn = expectedFeaturesOn crf alpha beta sent-    alpha = forward sum crf sent-    beta = backward sum crf sent-    zxF = zxAlpha sent alpha-    zxB = zxBeta beta

@@ -1,224 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}---- | Internal implementation of the CRF model.--module Data.CRF.Chain1.Model-( FeatIx (..)-, Model (..)-, mkModel-, lbSet-, valueL-, featToIx-, featToInt-, sgValue-, sgIxs-, obIxs-, nextIxs-, prevIxs-) where--import Control.Applicative ((<$>), (<*>))-import Data.List (groupBy, sort)-import Data.Function (on)-import Data.Binary-import Data.Vector.Binary ()-import qualified Data.Vector.Generic.Base as G-import qualified Data.Vector.Generic.Mutable as G-import qualified Data.Set as Set-import qualified Data.Map as M-import qualified Data.Vector.Unboxed as U-import qualified Data.Vector as V-import qualified Data.Number.LogFloat as L-import           Data.Vector.Unboxed.Deriving--import Data.CRF.Chain1.Dataset.Internal-import Data.CRF.Chain1.Feature---- | A feature index.  To every model feature a unique index is assigned.-newtype FeatIx = FeatIx { unFeatIx :: Int }-    deriving ( Show, Eq, Ord, Binary) -             -- , G.Vector U.Vector, G.MVector U.MVector, U.Unbox )-derivingUnbox "FeatIx" [t| FeatIx -> Int |] [| unFeatIx |] [| FeatIx |]---- | A label and a feature index determined by that label.-type LbIx   = (Lb, FeatIx)--dummyFeatIx :: FeatIx-dummyFeatIx = FeatIx (-1)--isDummy :: FeatIx -> Bool-isDummy (FeatIx ix) = ix < 0--notDummy :: FeatIx -> Bool-notDummy = not . isDummy---- | The model is realy a map from features to potentials, but for the sake--- of efficiency the internal representation is more complex.-data Model = Model {-    -- | Value (potential) of the model for feature index.-      values    :: U.Vector Double-    -- | A map from features to feature indices-    , ixMap     :: M.Map Feature FeatIx-    -- | Number of labels. The label set is of the {0, 1, .., lbNum - 1}-    -- form, which is guaranteed by the codec.-    , lbNum 	:: Int-    -- | Singular feature index for the given label.  Index is equall to -1-    -- 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. -    , obIxsV    :: V.Vector (U.Vector LbIx)-    -- | Set of ,,previous'' labels for the value of the ,,current'' label.-    -- Both labels constitute a transition feature present in the the model.-    , prevIxsV  :: V.Vector (U.Vector LbIx)-    -- | Set of ,,next'' labels for the value of the ,,current'' label.-    -- Both labels constitute a transition feature present in the the model.-    , nextIxsV  :: V.Vector (U.Vector LbIx) }--instance Binary Model where-    put crf = do-        put $ values crf-        put $ ixMap crf-        put $ lbNum crf-        put $ sgIxsV crf-        put $ obIxsV crf-        put $ prevIxsV crf-        put $ nextIxsV crf-    get = Model <$> get <*> get <*> get <*> get <*> get <*> get <*> get---- | Construct CRF model from associations list.  There should be--- no repetition of features in the input list.-fromList :: [(Feature, Double)] -> Model-fromList fs =-    let featLbs (SFeature x) = [x]-    	featLbs (OFeature _ x) = [x]-        featLbs (TFeature x y) = [x, y]-        featObs (OFeature o _) = [o]-        featObs _ = []--        _ixMap = M.fromList $ zip-            (map fst fs)-            (map FeatIx [0..])-    -        _obSet  = nub $ concatMap (featObs . fst) fs-        _obNum = length _obSet-        _lbSet = nub $ concatMap (featLbs . fst) fs-        _lbNum = length _lbSet--        sFeats = [feat | (feat, _val) <- fs, isSFeat feat]-        tFeats = [feat | (feat, _val) <- fs, isTFeat feat]-        oFeats = [feat | (feat, _val) <- fs, isOFeat feat]-        -        _sgIxsV = sgVects _lbNum-            [ (unLb x, featToIx crf feat)-            | feat@(SFeature x) <- sFeats ]--        _prevIxsV = adjVects _lbNum-            [ (unLb x, (y, featToIx crf feat))-            | feat@(TFeature x y) <- tFeats ]--        _nextIxsV = adjVects _lbNum-            [ (unLb y, (x, featToIx crf feat))-            | feat@(TFeature x y) <- tFeats ]--        _obIxsV = adjVects _obNum-            [ (unOb o, (x, featToIx crf feat))-            | feat@(OFeature o x) <- oFeats ]--        -- | Adjacency vectors.-        adjVects n xs =-            V.replicate n (U.fromList []) V.// update-          where-            update = map mkVect $ groupBy ((==) `on` fst) $ sort xs-            mkVect (y:ys) = (fst y, U.fromList $ sort $ map snd (y:ys))-            mkVect [] = error "mkVect: null list"--        sgVects n xs = U.replicate n dummyFeatIx U.// xs--        _values = U.replicate (length fs) 0.0-            U.// [ (featToInt crf feat, val)-                 | (feat, val) <- fs ]--        checkSet set cont = if set == [0 .. length set - 1]-            then cont-            else error "Model.fromList: basic assumption not fulfilled"--        crf = Model _values _ixMap _lbNum _sgIxsV _obIxsV _prevIxsV _nextIxsV-    in  checkSet (map unLb _lbSet)-      . checkSet (map unOb _obSet)-      $ crf---- | Construct the model from the list of features.  All parameters will be--- set to 0.  There may be repetitions in the input list.-mkModel :: [Feature] -> Model-mkModel fs =-    let fSet = Set.fromList fs-        fs'  = Set.toList fSet-        vs   = replicate (Set.size fSet) 0.0-    in  fromList (zip fs' vs)---- | List of labels [0 .. 'lbNum' - 1].-lbSet :: Model -> [Lb]-lbSet crf = map Lb [0 .. lbNum crf - 1]---- | Model potential defined for the given feature interpreted as a--- number in logarithmic domain.-valueL :: Model -> FeatIx -> L.LogFloat-valueL crf (FeatIx i) = L.logToLogFloat (values crf U.! i)-{-# INLINE valueL #-}---- | Determine the index for the given feature.-featToIx :: Model -> Feature -> FeatIx-featToIx crf feat = ixMap crf M.! feat-{-# INLINE featToIx #-}---- | Same as 'featToIx' but immediately unwrap the feature index to--- integer value.-featToInt :: Model -> Feature -> Int-featToInt crf = unFeatIx . featToIx crf-{-# INLINE featToInt #-}---- | Potential value (in log domain) of the singular feature with the--- given label.  The value defaults to 0 when the feature is not a--- member of the model.-sgValue :: Model -> Lb -> L.LogFloat-sgValue crf (Lb x) = -    case unFeatIx (sgIxsV crf U.! x) of-        -1 -> 0		-        ix -> L.logToLogFloat (values crf U.! ix)---- | List of labels which can be located on the first position of--- a sentence together with feature indices determined by them.-sgIxs :: Model -> [LbIx]-sgIxs crf-    = filter (notDummy . snd)-    . zip (map Lb [0..])-    . U.toList $ sgIxsV crf-{-# INLINE sgIxs #-}---- | List of labels which constitute a valid feature in combination with--- the given observation accompanied by feature indices determined by--- these labels.-obIxs :: Model -> Ob -> [LbIx]-obIxs crf x = U.toList (obIxsV crf V.! unOb x)-{-# INLINE obIxs #-}---- | List of ,,next'' labels which constitute a valid feature in combination--- with the ,,current'' label accompanied by feature indices determined by--- ,,next'' labels.-nextIxs :: Model -> Lb -> [LbIx]-nextIxs crf x = U.toList (nextIxsV crf V.! unLb x)-{-# INLINE nextIxs #-}---- | List of ,,previous'' labels which constitute a valid feature in--- combination with the ,,current'' label accompanied by feature indices--- determined by ,,previous'' labels.-prevIxs :: Model -> Lb -> [LbIx]-prevIxs crf x = U.toList (prevIxsV crf V.! unLb x)-{-# INLINE prevIxs #-}--nub :: Ord a => [a] -> [a] -nub = Set.toList . Set.fromList

@@ -1,90 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE PatternGuards #-}--module Data.CRF.Chain1.Train-( CRF (..)-, train-) where--import Control.Applicative ((<$>), (<*>))-import System.IO (hSetBuffering, stdout, BufferMode (..))-import Data.Binary (Binary, put, get)-import qualified Data.Vector as V-import qualified Numeric.SGD as SGD-import qualified Numeric.SGD.LogSigned as L--import Data.CRF.Chain1.Dataset.Internal-import Data.CRF.Chain1.Dataset.External (SentL)-import Data.CRF.Chain1.Dataset.Codec (mkCodec, Codec, encodeDataL)-import Data.CRF.Chain1.Feature (Feature, featuresIn)-import Data.CRF.Chain1.Model (Model (..), mkModel, FeatIx (..), featToInt)-import Data.CRF.Chain1.Inference (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 :: Codec a b,-    -- | The actual model, which is a map from 'Feature's to potentials.-    model :: 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.Feature.Present"--- and "Data.CRF.Chain1.Feature.Hidden" modules for this purpose.--- When the evaluation data 'IO' action is 'Just', the iterative--- training process will notify the user about the current accuracy--- on the evaluation part every full iteration over the training part.-train-    :: (Ord a, Ord b)-    => SGD.SgdArgs                  -- ^ Args for SGD-    -> IO [SentL a b]               -- ^ Training data 'IO' action-    -> Maybe (b, IO [SentL a b])    -- ^ Default label and evalation data-    -> ([(Xs, Ys)] -> [Feature])    -- ^ Feature selection-    -> IO (CRF a b)                 -- ^ Resulting model-train sgdArgs trainIO evalIO'Maybe extractFeats = do-    hSetBuffering stdout NoBuffering-    (_codec, trainData) <- mkCodec <$> trainIO-    evalDataM <- case evalIO'Maybe of-        Just (x, evalIO) -> Just . encodeDataL x _codec <$> evalIO-        Nothing -> return Nothing-    let crf  = mkModel (extractFeats trainData)-    para <- SGD.sgdM sgdArgs-        (notify sgdArgs crf trainData evalDataM)-        (gradOn crf) (V.fromList trainData) (values crf)-    return $ CRF _codec (crf { values = para })--gradOn :: Model -> SGD.Para -> (Xs, Ys) -> SGD.Grad-gradOn crf para (xs, ys) = SGD.fromLogList $-    [ (featToInt curr feat, L.fromPos val)-    | (feat, val) <- featuresIn xs ys ] ++-    [ (ix, L.fromNeg val)-    | (FeatIx ix, val) <- expectedFeaturesIn curr xs ]-  where-    curr = crf { values = para }--notify-    :: SGD.SgdArgs -> Model -> [(Xs, Ys)] -> Maybe [(Xs, Ys)]-    -> SGD.Para -> Int -> IO ()-notify SGD.SgdArgs{..} crf trainData evalDataM para k -    | doneTotal k == doneTotal (k - 1) = putStr "."-    | Just dataSet <- evalDataM = do-        let x = accuracy (crf { values = para }) dataSet-        putStrLn ("\n" ++ "[" ++ show (doneTotal k) ++ "] acc = " ++ show x)-    | otherwise =-        putStrLn ("\n" ++ "[" ++ show (doneTotal k) ++ "] acc = #")-  where-    doneTotal :: Int -> Int-    doneTotal = floor . done-    done :: Int -> Double-    done i-        = fromIntegral (i * batchSize)-        / fromIntegral trainSize-    trainSize = length trainData

@@ -1,12 +0,0 @@-module Data.CRF.Chain1.Util-( partition-) where--import Data.List (transpose)--partition :: Int -> [a] -> [[a]]-partition n =-    transpose . group n-  where-    group _ [] = []-    group k xs = take k xs : (group k $ drop k xs)

@@ -0,0 +1,1 @@+Efficient, first-order, linear-chain conditional random fields.

@@ -1,62 +1,61 @@-name:               crf-chain1-version:            0.2.2-synopsis:           First-order, linear-chain conditional random fields-description:-    The library provides efficient implementation of the first-order,-    linear-chain conditional random fields (CRFs).-    .-    Important feature of the implemented flavour of CRFs is that transition-    features which are not included in the CRF model are considered to have-    probability of 0. -    It is particularly useful when the training material determines the set-    of possible label transitions (e.g. when using the IOB encoding method).-    Furthermore, this design decision makes the implementation much faster-    for sparse datasets.-license:            BSD3-license-file:       LICENSE-cabal-version:      >= 1.6-copyright:          Copyright (c) 2012 IPI PAN-author:             Jakub Waszczuk-maintainer:         waszczuk.kuba@gmail.com-stability:          experimental-category:           Math-homepage:           https://github.com/kawu/crf-chain1-build-type:         Simple--library-    build-depends:-        base >= 4 && < 5-      , containers-      , vector-      , array-      , random-      , parallel-      , logfloat-      , monad-codec         >= 0.2     && < 0.3-      , binary-      , vector-binary       >= 0.1     && < 0.2-      , data-lens-      , sgd                 >= 0.2.1    && < 0.3-      , vector-th-unbox     >= 0.2.1    && < 0.3--    exposed-modules:-        Data.CRF.Chain1-      , Data.CRF.Chain1.Dataset.Internal-      , Data.CRF.Chain1.Dataset.External-      , Data.CRF.Chain1.Dataset.Codec-      , Data.CRF.Chain1.Feature-      , Data.CRF.Chain1.Feature.Present-      , Data.CRF.Chain1.Feature.Hidden-      , Data.CRF.Chain1.Model-      , Data.CRF.Chain1.Inference-      , Data.CRF.Chain1.Train+cabal-version: 1.12 -    other-modules:-        Data.CRF.Chain1.DP-        Data.CRF.Chain1.Util+-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 50e9f0ceac68e2f16698eb87a6a43c29aab1842212ccfc3b88ca65e85f3da3dd -    ghc-options: -Wall -O2+name:           crf-chain1+version:        0.2.3+synopsis:       First-order, linear-chain conditional random fields+description:    Please see the README on GitHub at <https://github.com/kawu/crf-chain1#readme>+category:       Math+homepage:       https://github.com/kawu/crf-chain1#readme+bug-reports:    https://github.com/kawu/crf-chain1/issues+author:         Jakub Waszczuk+maintainer:     waszczuk.kuba@gmail.com+copyright:      2012-2019 IPI PAN, Jakub Waszczuk+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md  source-repository head-    type: git-    location: git://github.com/kawu/crf-chain1.git+  type: git+  location: https://github.com/kawu/crf-chain1++library+  exposed-modules:+      Data.CRF.Chain1+      Data.CRF.Chain1.Dataset.Codec+      Data.CRF.Chain1.Dataset.External+      Data.CRF.Chain1.Dataset.Internal+      Data.CRF.Chain1.DP+      Data.CRF.Chain1.Feature+      Data.CRF.Chain1.Feature.Hidden+      Data.CRF.Chain1.Feature.Present+      Data.CRF.Chain1.Inference+      Data.CRF.Chain1.Model+      Data.CRF.Chain1.Train+      Data.CRF.Chain1.Util+  other-modules:+      Paths_crf_chain1+  hs-source-dirs:+      src+  build-depends:+      array+    , base >=4.7 && <5+    , binary+    , containers+    , data-lens-light+    , logfloat+    , monad-codec >=0.2.1 && <0.3+    , parallel+    , random+    , sgd >=0.2.1 && <0.3+    , vector+    , vector-binary-instances+    , vector-th-unbox >=0.2.1 && <0.3+  default-language: Haskell2010

@@ -0,0 +1,49 @@+{-# LANGUAGE RecordWildCards #-}++-- | The module provides first-order, linear-chain conditional random fields+-- (CRFs).+--+-- Important feature of the implemented flavour of CRFs is that transition+-- features which are not included in the CRF model are considered to have+-- probability of 0. +-- It is particularly useful when the training material determines the set+-- of possible label transitions (e.g. when using the IOB encoding method).+-- Furthermore, this design decision makes the implementation much faster+-- for sparse datasets.++module Data.CRF.Chain1+(+-- * Data types+  Word+, Sent+, Dist (unDist)+, mkDist+, WordL+, annotate+, SentL++-- * CRF+, CRF (..)+-- ** Training+, train+-- ** Tagging+, tag++-- * Feature selection+, hiddenFeats+, presentFeats+) where++import Prelude hiding (Word)++import Data.CRF.Chain1.Dataset.External+import Data.CRF.Chain1.Dataset.Codec+import Data.CRF.Chain1.Feature.Present+import Data.CRF.Chain1.Feature.Hidden+import Data.CRF.Chain1.Train+import qualified Data.CRF.Chain1.Inference as I++-- | 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]+tag CRF{..} = decodeLabels codec . I.tag model . encodeSent codec

@@ -0,0 +1,43 @@+module Data.CRF.Chain1.DP+( table+, flexible2+, flexible3+) where++import qualified Data.Array as A+import Data.Array ((!))+import Data.Ix (range)++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' !)) +           $ range bounds++down1 :: A.Ix i => (i, i) -> (i -> e) -> i -> e+down1 bounds f = (!) down' where+    down' = A.listArray bounds+          $ map f+          $ range bounds++down2 :: (A.Ix i, A.Ix j) => (j, j) -> (j -> (i, i)) -> (j -> i -> e)+      -> j -> i -> e+down2 bounds1 bounds2 f = (!) down' where+    down' = A.listArray bounds1+        [ 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+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 ]

@@ -0,0 +1,148 @@+module Data.CRF.Chain1.Dataset.Codec+( Codec+, CodecM++, encodeWord'Cu+, encodeWord'Cn+, encodeSent'Cu+, encodeSent'Cn+, encodeSent++, encodeWordL'Cu+, encodeWordL'Cn+, encodeSentL'Cu+, encodeSentL'Cn+, encodeSentL++, decodeLabel+, decodeLabels++, mkCodec+, encodeData+, encodeDataL+) where++import Prelude hiding (Word)++import Control.Applicative ((<$>), (<*>), pure)+import Data.Maybe (catMaybes)+-- import Data.Lens.Common (fstLens, sndLens)+import Data.Lens.Light (Lens, lens)+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Vector as V+import qualified Control.Monad.Codec as C++import Data.CRF.Chain1.Dataset.Internal+import Data.CRF.Chain1.Dataset.External++-- | A codec.  The first component is used to encode observations+-- of type a, the second one is used to encode labels of type b.+type Codec a b = (C.AtomCodec a, C.AtomCodec b)++-- | Type synonym for the codec monad.  It is important to notice that by a+-- codec we denote here a structure of two 'C.AtomCodec's while in the+-- monad-codec package it denotes a monad.+type CodecM a b c = C.Codec (Codec a b) c++-- | Encode the labeled word and update the codec.+encodeWordL'Cu :: (Ord a, Ord b) => WordL a b -> CodecM a b (X, Y)+encodeWordL'Cu word = do+    x <- mkX . map Ob <$>+        mapM (C.encode' fstLens) (S.toList $ fst word)+    y <- mkY <$> sequence+    	[ (,) <$> (Lb <$> C.encode sndLens lb) <*> pure pr+	| (lb, pr) <- (M.toList . unDist) (snd word) ]+    return (x, y)++-- | Encodec the labeled word and do *not* update the codec.+-- If the label is not in the codec, use the default value.+encodeWordL'Cn :: (Ord a, Ord b) => Int -> WordL a b -> CodecM a b (X, Y)+encodeWordL'Cn i word = do+    x <- mkX . map Ob . catMaybes <$>+        mapM (C.maybeEncode fstLens) (S.toList $ fst word)+    y <- mkY <$> sequence+    	[ (,) <$> encodeL i lb <*> pure pr+	| (lb, pr) <- (M.toList . unDist) (snd word) ]+    return (x, y)+  where+    encodeL j y = Lb . maybe j id <$> C.maybeEncode sndLens y++-- | Encode the word and update the codec.+encodeWord'Cu :: Ord a => Word a -> CodecM a b X+encodeWord'Cu word =+    mkX . map Ob <$> mapM (C.encode' fstLens) (S.toList word)++-- | Encode the word and do *not* update the codec.+encodeWord'Cn :: Ord a => Word a -> CodecM a b X+encodeWord'Cn word = +    mkX . map Ob . catMaybes <$> mapM (C.maybeEncode fstLens) (S.toList word)++-- | Encode the labeled sentence and update the codec.+encodeSentL'Cu :: (Ord a, Ord b) => SentL a b -> CodecM a b (Xs, Ys)+encodeSentL'Cu sent = do+    ps <- mapM encodeWordL'Cu sent+    return (V.fromList (map fst ps), V.fromList (map snd ps))++-- | 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) => b -> SentL a b -> CodecM a b (Xs, Ys)+encodeSentL'Cn def sent = do+    i <- C.maybeEncode sndLens def >>= \mi -> case mi of+        Just _i -> return _i+        Nothing -> error "encodeWordL'Cn: default label not in the codec"+    ps <- mapM (encodeWordL'Cn i) sent+    return (V.fromList (map fst ps), V.fromList (map snd ps))++-- | 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) => b -> Codec a b -> SentL a b -> (Xs, Ys)+encodeSentL def codec = C.evalCodec codec . encodeSentL'Cn def++-- | Encode the sentence and update the codec.+encodeSent'Cu :: Ord a => Sent a -> CodecM a b Xs+encodeSent'Cu = fmap V.fromList . mapM encodeWord'Cu++-- | Encode the sentence and do *not* update the codec.+encodeSent'Cn :: Ord a => Sent a -> CodecM a b Xs+encodeSent'Cn = fmap V.fromList . mapM encodeWord'Cn++-- | Encode the sentence using the given codec.+encodeSent :: Ord a => Codec a b -> Sent a -> Xs+encodeSent codec = C.evalCodec codec . encodeSent'Cn++-- | Create the codec on the basis of the labeled dataset, return the+-- resultant codec and the encoded dataset.+mkCodec :: (Ord a, Ord b) => [SentL a b] -> (Codec a b, [(Xs, Ys)])+mkCodec =+    let swap (x, y) = (y, x)+    in  swap . C.runCodec (C.empty, C.empty) . mapM encodeSentL'Cu++-- | Encode the labeled dataset using the codec.  Substitute the default+-- label for any label not present in the codec.+encodeDataL :: (Ord a, Ord b) => b -> Codec a b -> [SentL a b] -> [(Xs, Ys)]+encodeDataL def codec = C.evalCodec codec . mapM (encodeSentL'Cn def)++-- | Encode the dataset with the codec.+encodeData :: Ord a => Codec a b -> [Sent a] -> [Xs]+encodeData codec = map (encodeSent codec)++-- | Decode the label.+decodeLabel :: Ord b => Codec a b -> Lb -> b+decodeLabel codec x = C.evalCodec codec $ C.decode sndLens (unLb x)++-- | Decode the sequence of labels.+decodeLabels :: Ord b => Codec a b -> [Lb] -> [b]+decodeLabels codec xs = C.evalCodec codec $+    sequence [C.decode sndLens (unLb x) | x <- xs]+++-- * Stock lenses++fstLens :: Lens (a,b) a+-- fstLens = Lens $ \(a,b) -> store (\ a' -> (a', b)) a+fstLens = lens fst (\a' (a, b) -> (a', b))++sndLens :: Lens (a,b) b+-- sndLens = Lens $ \(a,b) -> store (\ b' -> (a, b')) b+sndLens = lens snd (\b' (a, b) -> (a, b'))

@@ -0,0 +1,45 @@+module Data.CRF.Chain1.Dataset.External+( Word+, Sent+, Dist (unDist)+, mkDist+, WordL+, annotate+, SentL+) where++import           Prelude hiding (Word)++import qualified Data.Set as S+import qualified Data.Map as M++-- | A Word is represented by a set of observations.+type Word a = S.Set a++-- | A sentence of words.+type Sent a = [Word a]++-- | A probability distribution defined over elements of type a.+-- All elements not included in the map have probability equal+-- to 0.+newtype Dist a = Dist { unDist :: M.Map a Double }++-- | Construct the probability distribution.+mkDist :: Ord a => [(a, Double)] -> Dist a+mkDist =+    Dist . normalize . M.fromListWith (+)+  where+    normalize dist =+        let z = sum (M.elems dist)+        in  fmap (/z) dist++-- | A WordL is a labeled word, i.e. a word with probability distribution+-- defined over labels.+type WordL a b = (Word a, Dist b)++-- | Annotate the word with the label.+annotate :: Word a -> b -> WordL a b+annotate w x = (w, Dist (M.singleton x 1))++-- | A sentence of labeled words.+type SentL a b = [WordL a b]

@@ -0,0 +1,79 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+++module Data.CRF.Chain1.Dataset.Internal+( Ob (..)+, Lb (..)++, X (..)+, mkX+, unX+, Xs++, Y (..)+, mkY+, unY+, Ys+) where+++-- import Data.Vector.Generic.Base+-- import Data.Vector.Generic.Mutable+import Data.Binary (Binary)+import Data.Ix (Ix)+import qualified Data.Vector as V+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 |]+++-- | A label.+newtype Lb = Lb { unLb :: Int }+    deriving ( Show, Read, Eq, Ord, Binary, Num, Ix )+derivingUnbox "Lb" [t| Lb -> Int |] [| unLb |] [| Lb |]+++-- | Simple word represented by a list of its observations.+newtype X = X { _unX :: U.Vector Ob }+    deriving (Show, Read, Eq, Ord)++-- | X constructor.+mkX :: [Ob] -> X+mkX = X . U.fromList+{-# INLINE mkX #-}++-- | X deconstructor symetric to mkX.+unX :: X -> [Ob]+unX = U.toList . _unX+{-# INLINE unX #-}++-- | Sentence of words.+type Xs = V.Vector X++-- | Probability distribution over labels. +newtype Y = Y { _unY :: U.Vector (Lb, Double) }+    deriving (Show, Read, Eq, Ord)++-- | Y constructor.+mkY :: [(Lb, Double)] -> Y+mkY = Y . U.fromList+{-# INLINE mkY #-}++-- | Y deconstructor symetric to mkY.+unY :: Y -> [(Lb, Double)]+unY = U.toList . _unY+{-# INLINE unY #-}++-- | Sentence of Y (label choices).+type Ys = V.Vector Y

@@ -0,0 +1,86 @@+module Data.CRF.Chain1.Feature+( Feature (..)+, isSFeat+, isTFeat+, isOFeat+, featuresIn+) where++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.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)]+trFeats ys 0 =+    [ (SFeature x, L.logFloat px)+    | (x, px) <- unY (ys V.! 0) ]+trFeats ys k =+    [ (TFeature x y, L.logFloat px * L.logFloat py)+    | (x, px) <- unY (ys V.! k)+    , (y, py) <- unY (ys V.! (k-1)) ]++-- | Observation features with assigned probabilities for a given position.+obFeats :: Xs -> Ys -> Int -> [(Feature, L.LogFloat)]+obFeats xs ys k =+    [ (OFeature o x, L.logFloat px)+    | (x, px) <- unY (ys V.! k)+    , o       <- unX (xs V.! k) ]++-- | All features with assigned probabilities for given position.+features :: Xs -> Ys -> Int -> [(Feature, L.LogFloat)]+features xs ys k = trFeats ys k ++ obFeats xs ys k++-- | All features with assigned probabilities in given labeled sentence.+featuresIn :: Xs -> Ys -> [(Feature, L.LogFloat)]+featuresIn xs ys = concatMap (features xs ys) [0 .. V.length xs - 1]

@@ -0,0 +1,66 @@+-- | The module provides feature selection functions which extract+-- hidden features, i.e. all features which can be constructed +-- (by means of cartesian product) on the basis of the set of+-- observations and the set of labels.+-- For example, the list of hidden observation features can+-- be defined as 'OFeature' '<$>' os '<*>' xs, where os is a+-- list of all observations and xs is a list of all labels.+--+-- You can mix functions defined here with the selection functions+-- from the "Data.CRF.Chain1.Feature.Present" module.++module Data.CRF.Chain1.Feature.Hidden+( hiddenFeats+, hiddenOFeats+, hiddenTFeats+, hiddenSFeats+) where++import qualified Data.Set as S+import qualified Data.Vector as V++import Data.CRF.Chain1.Dataset.Internal+import Data.CRF.Chain1.Feature++-- | Hidden 'OFeature's which can be constructed based on the dataset.+hiddenOFeats :: [(Xs, Ys)] -> [Feature]+hiddenOFeats ds =+    [ OFeature o x+    | o <- collectObs ds+    , x <- collectLbs ds ]++-- | Hidden 'TFeature's which can be constructed based on the dataset.+hiddenTFeats :: [(Xs, Ys)] -> [Feature]+hiddenTFeats ds =+    let xs = collectLbs ds+    in  [TFeature x y | x <- xs, y <- xs]++-- | Hidden 'SFeature's which can be constructed based on the dataset.+hiddenSFeats :: [(Xs, Ys)] -> [Feature]+hiddenSFeats = map SFeature . collectLbs++-- | Hidden 'Feature's of all types which can be constructed+-- based on the dataset.+hiddenFeats :: [(Xs, Ys)] -> [Feature]+hiddenFeats ds+    =  hiddenOFeats ds+    ++ hiddenTFeats ds+    ++ hiddenSFeats ds++collectObs :: [(Xs, Ys)] -> [Ob]+collectObs = nub . concatMap (sentObs . fst)++collectLbs :: [(Xs, Ys)] -> [Lb]+collectLbs = nub . concatMap (sentLbs . snd)++sentObs :: Xs -> [Ob]+sentObs = concatMap unX . V.toList++sentLbs :: Ys -> [Lb]+sentLbs = concatMap lbsAll . V.toList++lbsAll :: Y -> [Lb]+lbsAll = map fst . unY++nub :: Ord a => [a] -> [a]+nub = S.toList . S.fromList

@@ -0,0 +1,56 @@+-- | The module provides feature selection functions which extract+-- features present in the dataset, i.e. features which directly occure+-- the dataset.+--+-- You can mix functions defined here with the selection functions+-- from the "Data.CRF.Chain1.Feature.Hidden" module.++module Data.CRF.Chain1.Feature.Present+( presentFeats+, presentOFeats+, presentTFeats+, presentSFeats+) where++import qualified Data.Vector as V++import Data.CRF.Chain1.Dataset.Internal+import Data.CRF.Chain1.Feature++-- | 'OFeature's which occur in the dataset.+presentOFeats :: [(Xs, Ys)] -> [Feature]+presentOFeats ds =+    concatMap sentOFeats ds+  where+    sentOFeats (xs, ys) = concatMap oFeatsOn (zip (V.toList xs) (V.toList ys))+    oFeatsOn (x, choice) =+        [ OFeature o y+        | o <- unX x+        , y <- lbs choice ]++-- | 'TFeature's which occur in the dataset.+presentTFeats :: [(a, Ys)] -> [Feature]+presentTFeats ds =+    concatMap (sentTFeats.snd) ds+  where+    sentTFeats ys = concatMap (tFeatsOn ys) [1 .. V.length ys - 1]+    tFeatsOn ys k =+        [ TFeature x y+        | x <- lbs (ys V.! k)+        , y <- lbs (ys V.! (k-1)) ]++-- | 'SFeature's which occur in the dataset.+presentSFeats :: [(a, Ys)] -> [Feature]+presentSFeats ds =+    let sentSFeats s = [SFeature x | x <- lbs (s V.! 0)] +    in  concatMap (sentSFeats.snd) ds++-- | 'Feature's of all kinds which occur in the dataset.+presentFeats :: [(Xs, Ys)] -> [Feature]+presentFeats ds+    =  presentOFeats ds+    ++ presentTFeats ds+    ++ presentSFeats ds++lbs :: Y -> [Lb]+lbs = map fst . unY

@@ -0,0 +1,275 @@+{-# LANGUAGE FlexibleContexts #-}++-- Inference with CRFs.++module Data.CRF.Chain1.Inference+( tag+, marginals+, accuracy+, expectedFeaturesIn+, zx+, zx'+) where++import Control.Applicative ((<$>), (<*>), pure)+import Data.Maybe (catMaybes)+import Data.List (maximumBy)+import Data.Function (on)+import qualified Data.Array as A+import qualified Data.Vector as V++import Control.Parallel.Strategies (rseq, parMap)+import Control.Parallel (par, pseq)+import GHC.Conc (numCapabilities)+import qualified Data.Number.LogFloat as L++import qualified Data.CRF.Chain1.DP as DP+import Data.CRF.Chain1.Util (partition)+import Data.CRF.Chain1.Dataset.Internal+import Data.CRF.Chain1.Model++type ProbArray = Int -> Lb -> L.LogFloat+type AccF = [L.LogFloat] -> L.LogFloat++-- | Compute the table of potential products associated with +-- observation features for the given sentence position.+computePsi :: Model -> Xs -> Int -> Lb -> L.LogFloat+computePsi crf xs i = (A.!) $ A.accumArray (*) 1 bounds+    [ (x, valueL crf ix)+    | ob <- unX (xs V.! i)+    , (x, ix) <- obIxs crf ob ]+  where+    bounds = (Lb 0, Lb $ lbNum crf - 1)++-- | Forward table computation.+forward :: AccF -> Model -> Xs -> ProbArray+forward acc crf sent = DP.flexible2+    (0, V.length sent) wordBounds+    (\t k -> withMem (computePsi crf sent k) t k)+  where+    wordBounds k+        | k == V.length sent = (Lb 0, Lb 0)+        | otherwise = (Lb 0, Lb $ lbNum crf - 1)+    -- | Forward table equation, where k is current position, x is a label+    -- on current position and psi is a psi table computed for current+    -- position.+    -- FIXME: null sentence?+    withMem psi alpha k x+        | k == 0 = psi x * sgValue crf x +        | k == V.length sent = acc+            [ alpha (k - 1) y+            | y <- lbSet crf ]+        | otherwise = acc+            [ alpha (k - 1) y * psi x * valueL crf ix+            | (y, ix) <- prevIxs crf x ]++-- | Backward table computation.+backward :: AccF -> Model -> Xs -> ProbArray+backward acc crf sent = DP.flexible2+    (0, V.length sent) wordBounds+    (\t k -> withMem (computePsi crf sent k) t k)+  where+    wordBounds k+        | k == 0    = (Lb 0, Lb 0)+        | otherwise = (Lb 0, Lb $ lbNum crf - 1)+    -- | Backward table equation, where k is current position, y is a label+    -- on previous, k-1, position and psi is a psi table computed for current+    -- position.+    withMem psi beta k y+        | k == V.length sent = 1+        | k == 0    = acc+            [ beta (k + 1) x * psi x * valueL crf ix+            | (x, ix) <- sgIxs crf ]+        | otherwise = acc+            [ beta (k + 1) x * psi x * valueL crf ix+            | (x, ix) <- nextIxs crf y ]++zxBeta :: ProbArray -> L.LogFloat+zxBeta beta = beta 0 0++zxAlpha :: Xs -> ProbArray -> L.LogFloat+zxAlpha sent alpha = alpha (V.length sent) 0++-- | Normalization factor computed for the 'Xs' sentence using the+-- backward computation.+zx :: Model -> Xs -> L.LogFloat+zx crf = zxBeta . backward sum crf++-- | Normalization factor computed for the 'Xs' sentence using the+-- forward computation.+zx' :: Model -> Xs -> L.LogFloat+zx' crf sent = zxAlpha sent (forward sum crf sent)++--------------------------------------------------------------+argmax :: Ord b => (a -> Maybe b) -> [a] -> Maybe (a, b)+argmax _ [] = Nothing+argmax f xs+    | null ys   = Nothing+    | otherwise = Just $ foldl1 choice ys+  where+    ys = catMaybes $ map (\x -> (,) <$> pure x <*> f x) xs+    choice (x1, v1) (x2, v2)+        | v1 > v2 = (x1, v1)+        | otherwise = (x2, v2)++-- | Determine the most probable label sequence given the context of the+-- CRF model and the sentence.+tag :: Model -> Xs -> [Lb]+tag crf sent = collectMaxArg (0, 0) [] $ DP.flexible2+    (0, V.length sent) wordBounds+    (\t k -> withMem (computePsi crf sent k) t k)+  where+    n = V.length sent++    wordBounds k+        | k == 0    = (Lb 0, Lb 0)+        | otherwise = (Lb 0, Lb $ lbNum crf - 1)++    withMem psi mem k y+        | k == n    = Just (-1, 1)  -- -1 is a dummy value+        | k == 0    = prune <$> argmax eval (sgIxs crf)+        | otherwise = prune <$> argmax eval (nextIxs crf y)+      where+        eval (x, ix) = do+            v <- snd <$> mem (k + 1) x+            return $ v * psi x * valueL crf ix+        prune ((x, _ix), v) = (x, v)++    collectMaxArg (i, j) acc mem+        | i < n     = collect (mem i j)+        | otherwise = reverse acc+      where+        collect (Just (h, _)) = collectMaxArg (i + 1, h) (h:acc) mem+        collect Nothing       = error "tag.collect: Nothing"++-- | Tag probabilities with respect to marginal distributions.+marginals :: Model -> Xs -> [[(Lb, L.LogFloat)]]+marginals crf sent =+    let alpha = forward sum crf sent+        beta = backward sum crf sent+    in  [ [ (x, prob1 alpha beta k x)+          | x <- lbSet crf ]+        | k <- [0 .. V.length sent - 1] ]++-- tagProbs :: Sent s => Model -> s -> [[Double]]+-- tagProbs crf sent =+--     let alpha = forward maximum crf sent+--         beta = backward maximum crf sent+--         normalize vs =+--             let d = - logSum vs+--             in map (+d) vs+--         m1 k x = alpha k x + beta (k + 1) x+--     in  [ map exp $ normalize [m1 i k | k <- interpIxs sent i]+--         | i <- [0 .. V.length sent - 1] ]+-- +-- -- tag probabilities with respect to+-- -- marginal distributions+-- tagProbs' :: Sent s => Model -> s -> [[Double]]+-- tagProbs' crf sent =+--     let alpha = forward logSum crf sent+--         beta = backward logSum crf sent+--     in  [ [ exp $ prob1 crf alpha beta sent i k+--           | k <- interpIxs sent i ]+--         | i <- [0 .. V.length sent - 1] ]++goodAndBad :: Model -> Xs -> Ys -> (Int, Int)+goodAndBad crf sent labels =+    foldl gather (0, 0) (zip labels' labels'')+  where+    labels' = [ fst . maximumBy (compare `on` snd) $ unY (labels V.! i)+              | i <- [0 .. V.length labels - 1] ]+    labels'' = tag crf sent+    gather (good, bad) (x, y)+        | x == y = (good + 1, bad)+        | otherwise = (good, bad + 1)++goodAndBad' :: Model -> [(Xs, Ys)] -> (Int, Int)+goodAndBad' crf dataset =+    let add (g, b) (g', b') = (g + g', b + b')+    in  foldl add (0, 0) [goodAndBad crf x y | (x, y) <- dataset]++-- | Compute the accuracy of the model with respect to the labeled dataset.+accuracy :: Model -> [(Xs, Ys)] -> Double+accuracy crf dataset =+    let k = numCapabilities+    	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')+    in  fromIntegral good / fromIntegral (good + bad)++--------------------------------------------------------------++-- prob :: L.Vect t Int => Model -> Sent Int t -> Double+-- prob crf sent =+--     sum [ phiOn crf sent k+--         | k <- [0 .. (length sent) - 1] ]+--     - zx' crf sent+-- +-- -- TODO: Wziac pod uwage "Regularization Variance" !+-- cll :: Model -> [Sentence] -> Double+-- cll crf dataset = sum [prob crf sent | sent <- dataset]++-- prob2 :: SentR s => Model -> ProbArray -> ProbArray -> s+--       -> Int -> Lb -> Lb -> Double+-- prob2 crf alpha beta sent k x y+--     = alpha (k - 1) y + beta (k + 1) x+--     + phi crf (observationsOn sent k) a b+--     - zxBeta beta+--   where+--     a = interp sent k       x+--     b = interp sent (k - 1) y++prob2 :: Model -> ProbArray -> ProbArray -> Int -> (Lb -> L.LogFloat)+      -> Lb -> Lb -> 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++-- prob1 :: SentR s => Model -> ProbArray -> ProbArray+--       -> s -> Int -> Label -> Double+-- prob1 crf alpha beta sent k x = logSum+--     [ prob2 crf alpha beta sent k x y+--     | y <- interpIxs sent (k - 1) ]++prob1 :: ProbArray -> ProbArray -> Int -> Lb -> L.LogFloat+prob1 alpha beta k x =+    alpha k x * beta (k + 1) x / zxBeta beta++expectedFeaturesOn+    :: Model -> ProbArray -> ProbArray -> Xs+    -> Int -> [(FeatIx, L.LogFloat)]+expectedFeaturesOn crf alpha beta sent k =+    tFeats ++ oFeats+  where+    psi = computePsi crf sent k+    pr1 = prob1     alpha beta k+    pr2 = prob2 crf alpha beta k psi++    oFeats = [ (ix, pr1 x) +             | o <- unX (sent V.! k)+             , (x, ix) <- obIxs crf o ]++    tFeats+        | k == 0 = +            [ (ix, pr1 x) +            | (x, ix) <- sgIxs crf ]+        | otherwise =+            [ (ix, pr2 x y ix) +            | x <- lbSet crf+            , (y, ix) <- prevIxs crf x ]++-- | 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 :: Model -> Xs -> [(FeatIx, L.LogFloat)]+expectedFeaturesIn crf sent = zxF `par` zxB `pseq` zxF `pseq`+    concat [expectedOn k | k <- [0 .. V.length sent - 1] ]+  where+    expectedOn = expectedFeaturesOn crf alpha beta sent+    alpha = forward sum crf sent+    beta = backward sum crf sent+    zxF = zxAlpha sent alpha+    zxB = zxBeta beta

@@ -0,0 +1,224 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++-- | Internal implementation of the CRF model.++module Data.CRF.Chain1.Model+( FeatIx (..)+, Model (..)+, mkModel+, lbSet+, valueL+, featToIx+, featToInt+, sgValue+, sgIxs+, obIxs+, nextIxs+, prevIxs+) where++import Control.Applicative ((<$>), (<*>))+import Data.List (groupBy, sort)+import Data.Function (on)+import Data.Binary+import Data.Vector.Binary ()+import qualified Data.Vector.Generic.Base as G+import qualified Data.Vector.Generic.Mutable as G+import qualified Data.Set as Set+import qualified Data.Map as M+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector as V+import qualified Data.Number.LogFloat as L+import           Data.Vector.Unboxed.Deriving++import Data.CRF.Chain1.Dataset.Internal+import Data.CRF.Chain1.Feature++-- | A feature index.  To every model feature a unique index is assigned.+newtype FeatIx = FeatIx { unFeatIx :: Int }+    deriving ( Show, Eq, Ord, Binary) +             -- , G.Vector U.Vector, G.MVector U.MVector, U.Unbox )+derivingUnbox "FeatIx" [t| FeatIx -> Int |] [| unFeatIx |] [| FeatIx |]++-- | A label and a feature index determined by that label.+type LbIx   = (Lb, FeatIx)++dummyFeatIx :: FeatIx+dummyFeatIx = FeatIx (-1)++isDummy :: FeatIx -> Bool+isDummy (FeatIx ix) = ix < 0++notDummy :: FeatIx -> Bool+notDummy = not . isDummy++-- | The model is realy a map from features to potentials, but for the sake+-- of efficiency the internal representation is more complex.+data Model = Model {+    -- | Value (potential) of the model for feature index.+      values    :: U.Vector Double+    -- | A map from features to feature indices+    , ixMap     :: M.Map Feature FeatIx+    -- | Number of labels. The label set is of the {0, 1, .., lbNum - 1}+    -- form, which is guaranteed by the codec.+    , lbNum 	:: Int+    -- | Singular feature index for the given label.  Index is equall to -1+    -- 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. +    , obIxsV    :: V.Vector (U.Vector LbIx)+    -- | Set of ,,previous'' labels for the value of the ,,current'' label.+    -- Both labels constitute a transition feature present in the the model.+    , prevIxsV  :: V.Vector (U.Vector LbIx)+    -- | Set of ,,next'' labels for the value of the ,,current'' label.+    -- Both labels constitute a transition feature present in the the model.+    , nextIxsV  :: V.Vector (U.Vector LbIx) }++instance Binary Model where+    put crf = do+        put $ values crf+        put $ ixMap crf+        put $ lbNum crf+        put $ sgIxsV crf+        put $ obIxsV crf+        put $ prevIxsV crf+        put $ nextIxsV crf+    get = Model <$> get <*> get <*> get <*> get <*> get <*> get <*> get++-- | Construct CRF model from associations list.  There should be+-- no repetition of features in the input list.+fromList :: [(Feature, Double)] -> Model+fromList fs =+    let featLbs (SFeature x) = [x]+    	featLbs (OFeature _ x) = [x]+        featLbs (TFeature x y) = [x, y]+        featObs (OFeature o _) = [o]+        featObs _ = []++        _ixMap = M.fromList $ zip+            (map fst fs)+            (map FeatIx [0..])+    +        _obSet  = nub $ concatMap (featObs . fst) fs+        _obNum = length _obSet+        _lbSet = nub $ concatMap (featLbs . fst) fs+        _lbNum = length _lbSet++        sFeats = [feat | (feat, _val) <- fs, isSFeat feat]+        tFeats = [feat | (feat, _val) <- fs, isTFeat feat]+        oFeats = [feat | (feat, _val) <- fs, isOFeat feat]+        +        _sgIxsV = sgVects _lbNum+            [ (unLb x, featToIx crf feat)+            | feat@(SFeature x) <- sFeats ]++        _prevIxsV = adjVects _lbNum+            [ (unLb x, (y, featToIx crf feat))+            | feat@(TFeature x y) <- tFeats ]++        _nextIxsV = adjVects _lbNum+            [ (unLb y, (x, featToIx crf feat))+            | feat@(TFeature x y) <- tFeats ]++        _obIxsV = adjVects _obNum+            [ (unOb o, (x, featToIx crf feat))+            | feat@(OFeature o x) <- oFeats ]++        -- | Adjacency vectors.+        adjVects n xs =+            V.replicate n (U.fromList []) V.// update+          where+            update = map mkVect $ groupBy ((==) `on` fst) $ sort xs+            mkVect (y:ys) = (fst y, U.fromList $ sort $ map snd (y:ys))+            mkVect [] = error "mkVect: null list"++        sgVects n xs = U.replicate n dummyFeatIx U.// xs++        _values = U.replicate (length fs) 0.0+            U.// [ (featToInt crf feat, val)+                 | (feat, val) <- fs ]++        checkSet set cont = if set == [0 .. length set - 1]+            then cont+            else error "Model.fromList: basic assumption not fulfilled"++        crf = Model _values _ixMap _lbNum _sgIxsV _obIxsV _prevIxsV _nextIxsV+    in  checkSet (map unLb _lbSet)+      . checkSet (map unOb _obSet)+      $ crf++-- | Construct the model from the list of features.  All parameters will be+-- set to 0.  There may be repetitions in the input list.+mkModel :: [Feature] -> Model+mkModel fs =+    let fSet = Set.fromList fs+        fs'  = Set.toList fSet+        vs   = replicate (Set.size fSet) 0.0+    in  fromList (zip fs' vs)++-- | List of labels [0 .. 'lbNum' - 1].+lbSet :: Model -> [Lb]+lbSet crf = map Lb [0 .. lbNum crf - 1]++-- | Model potential defined for the given feature interpreted as a+-- number in logarithmic domain.+valueL :: Model -> FeatIx -> L.LogFloat+valueL crf (FeatIx i) = L.logToLogFloat (values crf U.! i)+{-# INLINE valueL #-}++-- | Determine the index for the given feature.+featToIx :: Model -> Feature -> FeatIx+featToIx crf feat = ixMap crf M.! feat+{-# INLINE featToIx #-}++-- | Same as 'featToIx' but immediately unwrap the feature index to+-- integer value.+featToInt :: Model -> Feature -> Int+featToInt crf = unFeatIx . featToIx crf+{-# INLINE featToInt #-}++-- | Potential value (in log domain) of the singular feature with the+-- given label.  The value defaults to 0 when the feature is not a+-- member of the model.+sgValue :: Model -> Lb -> L.LogFloat+sgValue crf (Lb x) = +    case unFeatIx (sgIxsV crf U.! x) of+        -1 -> 0		+        ix -> L.logToLogFloat (values crf U.! ix)++-- | List of labels which can be located on the first position of+-- a sentence together with feature indices determined by them.+sgIxs :: Model -> [LbIx]+sgIxs crf+    = filter (notDummy . snd)+    . zip (map Lb [0..])+    . U.toList $ sgIxsV crf+{-# INLINE sgIxs #-}++-- | List of labels which constitute a valid feature in combination with+-- the given observation accompanied by feature indices determined by+-- these labels.+obIxs :: Model -> Ob -> [LbIx]+obIxs crf x = U.toList (obIxsV crf V.! unOb x)+{-# INLINE obIxs #-}++-- | List of ,,next'' labels which constitute a valid feature in combination+-- with the ,,current'' label accompanied by feature indices determined by+-- ,,next'' labels.+nextIxs :: Model -> Lb -> [LbIx]+nextIxs crf x = U.toList (nextIxsV crf V.! unLb x)+{-# INLINE nextIxs #-}++-- | List of ,,previous'' labels which constitute a valid feature in+-- combination with the ,,current'' label accompanied by feature indices+-- determined by ,,previous'' labels.+prevIxs :: Model -> Lb -> [LbIx]+prevIxs crf x = U.toList (prevIxsV crf V.! unLb x)+{-# INLINE prevIxs #-}++nub :: Ord a => [a] -> [a] +nub = Set.toList . Set.fromList

@@ -0,0 +1,90 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PatternGuards #-}++module Data.CRF.Chain1.Train+( CRF (..)+, train+) where++import Control.Applicative ((<$>), (<*>))+import System.IO (hSetBuffering, stdout, BufferMode (..))+import Data.Binary (Binary, put, get)+import qualified Data.Vector as V+import qualified Numeric.SGD as SGD+import qualified Numeric.SGD.LogSigned as L++import Data.CRF.Chain1.Dataset.Internal+import Data.CRF.Chain1.Dataset.External (SentL)+import Data.CRF.Chain1.Dataset.Codec (mkCodec, Codec, encodeDataL)+import Data.CRF.Chain1.Feature (Feature, featuresIn)+import Data.CRF.Chain1.Model (Model (..), mkModel, FeatIx (..), featToInt)+import Data.CRF.Chain1.Inference (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 :: Codec a b,+    -- | The actual model, which is a map from 'Feature's to potentials.+    model :: 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.Feature.Present"+-- and "Data.CRF.Chain1.Feature.Hidden" modules for this purpose.+-- When the evaluation data 'IO' action is 'Just', the iterative+-- training process will notify the user about the current accuracy+-- on the evaluation part every full iteration over the training part.+train+    :: (Ord a, Ord b)+    => SGD.SgdArgs                  -- ^ Args for SGD+    -> IO [SentL a b]               -- ^ Training data 'IO' action+    -> Maybe (b, IO [SentL a b])    -- ^ Default label and evalation data+    -> ([(Xs, Ys)] -> [Feature])    -- ^ Feature selection+    -> IO (CRF a b)                 -- ^ Resulting model+train sgdArgs trainIO evalIO'Maybe extractFeats = do+    hSetBuffering stdout NoBuffering+    (_codec, trainData) <- mkCodec <$> trainIO+    evalDataM <- case evalIO'Maybe of+        Just (x, evalIO) -> Just . encodeDataL x _codec <$> evalIO+        Nothing -> return Nothing+    let crf  = mkModel (extractFeats trainData)+    para <- SGD.sgdM sgdArgs+        (notify sgdArgs crf trainData evalDataM)+        (gradOn crf) (V.fromList trainData) (values crf)+    return $ CRF _codec (crf { values = para })++gradOn :: Model -> SGD.Para -> (Xs, Ys) -> SGD.Grad+gradOn crf para (xs, ys) = SGD.fromLogList $+    [ (featToInt curr feat, L.fromPos val)+    | (feat, val) <- featuresIn xs ys ] +++    [ (ix, L.fromNeg val)+    | (FeatIx ix, val) <- expectedFeaturesIn curr xs ]+  where+    curr = crf { values = para }++notify+    :: SGD.SgdArgs -> Model -> [(Xs, Ys)] -> Maybe [(Xs, Ys)]+    -> SGD.Para -> Int -> IO ()+notify SGD.SgdArgs{..} crf trainData evalDataM para k +    | doneTotal k == doneTotal (k - 1) = putStr "."+    | Just dataSet <- evalDataM = do+        let x = accuracy (crf { values = para }) dataSet+        putStrLn ("\n" ++ "[" ++ show (doneTotal k) ++ "] acc = " ++ show x)+    | otherwise =+        putStrLn ("\n" ++ "[" ++ show (doneTotal k) ++ "] acc = #")+  where+    doneTotal :: Int -> Int+    doneTotal = floor . done+    done :: Int -> Double+    done i+        = fromIntegral (i * batchSize)+        / fromIntegral trainSize+    trainSize = length trainData

@@ -0,0 +1,12 @@+module Data.CRF.Chain1.Util+( partition+) where++import Data.List (transpose)++partition :: Int -> [a] -> [[a]]+partition n =+    transpose . group n+  where+    group _ [] = []+    group k xs = take k xs : (group k $ drop k xs)