packages feed

crf-chain1 (empty) → 0.2.0

raw patch · 15 files changed

+1216/−0 lines, 15 filesdep +arraydep +basedep +binarysetup-changed

Dependencies added: array, base, binary, containers, data-lens, logfloat, monad-codec, parallel, random, sgd, vector, vector-binary

Files

+ Data/CRF/Chain1.hs view
@@ -0,0 +1,47 @@+{-# 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
+ Data/CRF/Chain1/DP.hs view
@@ -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 ]
+ Data/CRF/Chain1/Dataset/Codec.hs view
@@ -0,0 +1,134 @@+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]
+ Data/CRF/Chain1/Dataset/External.hs view
@@ -0,0 +1,43 @@+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]
+ Data/CRF/Chain1/Dataset/Internal.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++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++-- | An observation.+newtype Ob = Ob { unOb :: Int }+    deriving ( Show, Read, Eq, Ord, Binary+             , Vector U.Vector, MVector U.MVector, U.Unbox )++-- | A label.+newtype Lb = Lb { unLb :: Int }+    deriving ( Show, Read, Eq, Ord, Binary+             , Vector U.Vector, MVector U.MVector, U.Unbox+	     , Num, Ix )++-- | 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
+ Data/CRF/Chain1/Feature.hs view
@@ -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]
+ Data/CRF/Chain1/Feature/Hidden.hs view
@@ -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
+ Data/CRF/Chain1/Feature/Present.hs view
@@ -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
+ Data/CRF/Chain1/Inference.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE FlexibleContexts #-}++-- Inference with CRFs.++module Data.CRF.Chain1.Inference+( tag+, accuracy+, expectedFeaturesIn+, zx+, zx'+) where++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 -> b) -> [a] -> (a, b)+argmax _ [] = error "argmax: null list"+argmax f xs =+    foldl1 choice $ map (\x -> (x, f x)) xs+  where+    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+    wordBounds k+        | k == 0    = (Lb 0, Lb 0)+        | otherwise = (Lb 0, Lb $ lbNum crf - 1)++    withMem psi mem k y+        | k == V.length sent = (-1, 1)+        | k == 0    = prune . argmax eval $ sgIxs crf+        | otherwise = prune . argmax eval $ nextIxs crf y+      where+        eval (x, ix) = (snd $ mem (k + 1) x) * psi x * valueL crf ix+        prune ((x, _ix), v) = (x, v)++    collectMaxArg (i, j) acc mem =+        collect (mem i j)+      where+        collect (h, _)+            | h == -1   = reverse acc+            | otherwise = collectMaxArg (i + 1, h) (h:acc) mem++-- 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
+ Data/CRF/Chain1/Model.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | 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.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 )++-- | 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+        -- FIXME: shoule not be -Infinity? It looks like it doesn't+        -- matter much for know, because that value is ignored anyway,+        -- but the SFeature which is not a member of the model+        -- should have probability of 0.+        -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
+ Data/CRF/Chain1/Train.hs view
@@ -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) ++ "] f = " ++ show x)+    | otherwise =+        putStrLn ("\n" ++ "[" ++ show (doneTotal k) ++ "] f = #")+  where+    doneTotal :: Int -> Int+    doneTotal = floor . done+    done :: Int -> Double+    done i+        = fromIntegral (i * batchSize)+        / fromIntegral trainSize+    trainSize = length trainData
+ Data/CRF/Chain1/Util.hs view
@@ -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)
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2012, IPI PAN+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ crf-chain1.cabal view
@@ -0,0 +1,61 @@+name:               crf-chain1+version:            0.2.0+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+      , data-lens+      , sgd >= 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++    other-modules:+        Data.CRF.Chain1.DP+        Data.CRF.Chain1.Util++    ghc-options: -Wall -O2++source-repository head+    type: git+    location: git://github.com/kawu/crf-chain1.git