crf-chain1-constrained 0.1.2 → 0.2.0

raw patch · 27 files changed

+1356/−1331 lines, 27 filesdep ~sgdPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: sgd

API changes (from Hackage documentation)

Files

• Data/CRF/Chain1/Constrained.hs +0/−60
• Data/CRF/Chain1/Constrained/DP.hs +0/−43
• Data/CRF/Chain1/Constrained/Dataset/Codec.hs +0/−213
• Data/CRF/Chain1/Constrained/Dataset/External.hs +0/−58
• Data/CRF/Chain1/Constrained/Dataset/Internal.hs +0/−111
• Data/CRF/Chain1/Constrained/Feature.hs +0/−86
• Data/CRF/Chain1/Constrained/Feature/Hidden.hs +0/−59
• Data/CRF/Chain1/Constrained/Feature/Present.hs +0/−56
• Data/CRF/Chain1/Constrained/Inference.hs +0/−247
• Data/CRF/Chain1/Constrained/Intersect.hs +0/−42
• Data/CRF/Chain1/Constrained/Model.hs +0/−234
• Data/CRF/Chain1/Constrained/Train.hs +0/−108
• Data/CRF/Chain1/Constrained/Util.hs +0/−12
• crf-chain1-constrained.cabal +4/−2
• src/Data/CRF/Chain1/Constrained.hs +60/−0
• src/Data/CRF/Chain1/Constrained/DP.hs +43/−0
• src/Data/CRF/Chain1/Constrained/Dataset/Codec.hs +207/−0
• src/Data/CRF/Chain1/Constrained/Dataset/External.hs +58/−0
• src/Data/CRF/Chain1/Constrained/Dataset/Internal.hs +119/−0
• src/Data/CRF/Chain1/Constrained/Feature.hs +86/−0
• src/Data/CRF/Chain1/Constrained/Feature/Hidden.hs +59/−0
• src/Data/CRF/Chain1/Constrained/Feature/Present.hs +56/−0
• src/Data/CRF/Chain1/Constrained/Inference.hs +247/−0
• src/Data/CRF/Chain1/Constrained/Intersect.hs +42/−0
• src/Data/CRF/Chain1/Constrained/Model.hs +234/−0
• src/Data/CRF/Chain1/Constrained/Train.hs +129/−0
• src/Data/CRF/Chain1/Constrained/Util.hs +12/−0

@@ -1,60 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | The module provides first-order, linear-chain conditional random fields--- (CRFs) with position-wide constraints over label values.--module Data.CRF.Chain1.Constrained-(--- * Data types-  Word (..)-, unknown-, Sent-, Prob (unProb)-, mkProb-, WordL-, SentL---- * CRF-, CRF (..)--- ** Training-, train--- ** Tagging-, tag-, tagK---- * Feature selection-, hiddenFeats-, presentFeats-) where--import Data.CRF.Chain1.Constrained.Dataset.External-import Data.CRF.Chain1.Constrained.Dataset.Codec-import Data.CRF.Chain1.Constrained.Feature.Present-import Data.CRF.Chain1.Constrained.Feature.Hidden-import Data.CRF.Chain1.Constrained.Train-import qualified Data.CRF.Chain1.Constrained.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 -> [b]-tag CRF{..} sent-    = onWords . decodeLabels codec-    . I.tag model . encodeSent codec-    $ sent-  where-    onWords xs =-        [ unJust codec word x-        | (word, x) <- zip sent xs ]---- | Determine the most probable label sets of the given size (at maximum)--- for each position in the input sentence.-tagK :: (Ord a, Ord b) => Int -> CRF a b -> Sent a b -> [[b]]-tagK k CRF{..} sent-    = onWords . map decodeChoice-    . I.tagK k model . encodeSent codec-    $ sent-  where-    decodeChoice = decodeLabels codec . map fst-    onWords xss =-        [ take k $ unJusts codec word xs-        | (word, xs) <- zip sent xss ]

@@ -1,43 +0,0 @@-module Data.CRF.Chain1.Constrained.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,213 +0,0 @@-module Data.CRF.Chain1.Constrained.Dataset.Codec-( Codec-, CodecM-, obMax-, lbMax--, encodeWord'Cu-, encodeWord'Cn-, encodeSent'Cu-, encodeSent'Cn-, encodeSent--, encodeWordL'Cu-, encodeWordL'Cn-, encodeSentL'Cu-, encodeSentL'Cn-, encodeSentL--, encodeLabels-, decodeLabel-, decodeLabels--, mkCodec-, encodeData-, encodeDataL-, unJust-, unJusts-) where--import Control.Applicative ((<$>), (<*>), pure)-import Data.Maybe (catMaybes, fromJust)-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.Constrained.Dataset.Internal-import Data.CRF.Chain1.Constrained.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 (Maybe b))---- | The maximum internal observation included in the codec.-obMax :: Codec a b -> Ob-obMax =-    let idMax m = M.size m - 1-    in  Ob . idMax . C.to . fst---- | The maximum internal label included in the codec.-lbMax :: Codec a b -> Lb-lbMax =-    let idMax m = M.size m - 1-    in  Lb . idMax . C.to . snd---- | The empty codec.  The label part is initialized with Nothing--- member, which represents unknown labels.  It is taken on account--- in the model implementation because it is assigned to the--- lowest label code and the model assumes that the set of labels--- is of the {0, ..., 'lbMax'} form.-empty :: Ord b => Codec a b-empty =-    let withNo = C.execCodec C.empty (C.encode C.idLens Nothing)-    in  (C.empty, withNo)---- | 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 observation and update the codec (only in the encoding--- direction).-encodeObU :: Ord a => a -> CodecM a b Ob-encodeObU = fmap Ob . C.encode' fstLens---- | Encode the observation and do *not* update the codec.-encodeObN :: Ord a => a -> CodecM a b (Maybe Ob)-encodeObN = fmap (fmap Ob) . C.maybeEncode fstLens---- | Encode the label and update the codec.-encodeLbU :: Ord b => b -> CodecM a b Lb-encodeLbU = fmap Lb . C.encode sndLens . Just---- | Encode the label and do *not* update the codec.-encodeLbN :: Ord b => b -> CodecM a b Lb-encodeLbN x = do-    my <- C.maybeEncode sndLens (Just x)-    Lb <$> ( case my of-        Just y  -> return y-        Nothing -> fromJust <$> C.maybeEncode sndLens Nothing )---- | 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, choice) = do-    x' <- mapM encodeObU (S.toList (obs word))-    r' <- mapM encodeLbU (S.toList (lbs word))-    let x = mkX x' r'-    y  <- mkY <$> sequence-    	[ (,) <$> encodeLbU lb <*> pure pr-	| (lb, pr) <- (M.toList . unProb) choice ]-    return (x, y)---- | Encodec the labeled word and do *not* update the codec.-encodeWordL'Cn :: (Ord a, Ord b) => WordL a b -> CodecM a b (X, Y)-encodeWordL'Cn (word, choice) = do-    x' <- catMaybes <$> mapM encodeObN (S.toList (obs word))-    r' <- mapM encodeLbN (S.toList (lbs word))-    let x = mkX x' r'-    y  <- mkY <$> sequence-    	[ (,) <$> encodeLbN lb <*> pure pr-	| (lb, pr) <- (M.toList . unProb) choice ]-    return (x, y)---- | Encode the word and update the codec.-encodeWord'Cu :: (Ord a, Ord b) => Word a b -> CodecM a b X-encodeWord'Cu word = do-    x' <- mapM encodeObU (S.toList (obs word))-    r' <- mapM encodeLbU (S.toList (lbs word))-    return $ mkX x' r'---- | Encode the word and do *not* update the codec.-encodeWord'Cn :: (Ord a, Ord b) => Word a b -> CodecM a b X-encodeWord'Cn word = do-    x' <- catMaybes <$> mapM encodeObN (S.toList (obs word))-    r' <- mapM encodeLbN (S.toList (lbs word))-    return $ mkX x' r'---- | 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) => SentL a b -> CodecM a b (Xs, Ys)-encodeSentL'Cn sent = do-    ps <- mapM (encodeWordL'Cn) sent-    return (V.fromList (map fst ps), V.fromList (map snd ps))---- | Encode labels into an ascending vector of distinct label codes.-encodeLabels :: Ord b => Codec a b -> [b] -> AVec Lb-encodeLabels codec = fromList . C.evalCodec codec . mapM encodeLbN---- | 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) => Codec a b -> SentL a b -> (Xs, Ys)-encodeSentL codec = C.evalCodec codec . encodeSentL'Cn---- | Encode the sentence and update the codec.-encodeSent'Cu :: (Ord a, Ord b) => Sent a b -> 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, Ord b) => Sent a b -> CodecM a b Xs-encodeSent'Cn = fmap V.fromList . mapM encodeWord'Cn---- | Encode the sentence using the given codec.-encodeSent :: (Ord a, Ord b) => Codec a b -> Sent a b -> 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-    = swap-    . C.runCodec empty-    . mapM encodeSentL'Cu-  where-    swap (x, y) = (y, x)---- | Encode the labeled dataset using the codec.  Substitute the default--- label for any label not present in the codec.-encodeDataL :: (Ord a, Ord b) => Codec a b -> [SentL a b] -> [(Xs, Ys)]-encodeDataL codec = C.evalCodec codec . mapM encodeSentL'Cn---- | Encode the dataset with the codec.-encodeData :: (Ord a, Ord b) => Codec a b -> [Sent a b] -> [Xs]-encodeData codec = map (encodeSent codec)---- | Decode the label.-decodeLabel :: Ord b => Codec a b -> Lb -> Maybe b-decodeLabel codec x = C.evalCodec codec $ C.decode sndLens (unLb x)---- | Decode the sequence of labels.-decodeLabels :: Ord b => Codec a b -> [Lb] -> [Maybe b]-decodeLabels codec xs = C.evalCodec codec $-    sequence [C.decode sndLens (unLb x) | x <- xs]--hasLabel :: Ord b => Codec a b -> b -> Bool-hasLabel codec x = M.member (Just x) (C.to $ snd codec)-{-# INLINE hasLabel #-}---- | Return the label when 'Just' or one of the unknown values--- when 'Nothing'.-unJust :: Ord b => Codec a b -> Word a b -> Maybe b -> b-unJust _ _ (Just x) = x-unJust codec word Nothing = case allUnk of-    (x:_)   -> x-    []      -> error "unJust: Nothing and all values known"-  where-    allUnk = filter (not . hasLabel codec) (S.toList $ lbs word)---- | Replace 'Nothing' labels with all unknown labels from--- the set of potential interpretations.-unJusts :: Ord b => Codec a b -> Word a b -> [Maybe b] -> [b]-unJusts codec word xs =-    concatMap deJust xs-  where-    allUnk = filter (not . hasLabel codec) (S.toList $ lbs word)-    deJust (Just x) = [x]-    deJust Nothing  = allUnk

@@ -1,58 +0,0 @@-module Data.CRF.Chain1.Constrained.Dataset.External-( Word (..)-, unknown-, Sent-, Prob (unProb)-, mkProb-, WordL-, SentL-) where--import qualified Data.Set as S-import qualified Data.Map as M---- | A Word is represented by a set of observations--- and a set of potential interpretation labels.--- When the set of potential labels is empty the word--- is considered to be unknown and the default potential--- set is used in its place.-data Word a b = Word-    { obs   :: S.Set a  -- ^ The set of observations-    , lbs   :: S.Set b  -- ^ The set of potential interpretations.-    } deriving (Show, Eq, Ord)---- | The word is considered to be unknown when the set of potential--- labels is empty.-unknown :: Word a b -> Bool-unknown word = S.size (lbs word) == 0-{-# INLINE unknown #-}---- | A sentence of words.-type Sent a b = [Word a b]---- | A probability distribution defined over elements of type a.--- All elements not included in the map have probability equal--- to 0.-newtype Prob a = Prob { unProb :: M.Map a Double }-    deriving (Show, Eq, Ord)---- | Construct the probability distribution.-mkProb :: Ord a => [(a, Double)] -> Prob a-mkProb =-    Prob . normalize . M.fromListWith (+) . filter ((>0).snd)-  where-    normalize dist -        | M.null dist  =-            error "mkProb: no elements with positive probability"-        | otherwise     =-            let z = sum (M.elems dist)-            in  fmap (/z) dist---- | A WordL is a labeled word, i.e. a word with probability distribution--- defined over labels.  We assume that every label from the distribution--- domain is a member of the set of potential labels corresponding to the--- word.  TODO: Ensure the assumption using the smart constructor.-type WordL a b = (Word a b, Prob b)---- | A sentence of labeled words.-type SentL a b = [WordL a b]

@@ -1,111 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards #-}--module Data.CRF.Chain1.Constrained.Dataset.Internal-( Ob (..)-, Lb (..)--, X (..)-, mkX-, unX-, unR-, Xs--, Y (..)-, mkY-, unY-, Ys--, AVec (unAVec)-, fromList-, fromSet-) where--import Data.Vector.Generic.Base-import Data.Vector.Generic.Mutable-import Data.Binary (Binary)-import Data.Vector.Binary ()-import Data.Ix (Ix)-import qualified Data.Set as S-import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as U---- | 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 )---- | Ascending vector of unique interger elements.-newtype AVec a = AVec { unAVec :: U.Vector a }-    deriving (Show, Read, Eq, Ord, Binary)---- | Smart AVec constructor which ensures that the--- underlying vector satisfies the AVec properties.-fromList :: (Ord a, U.Unbox a) => [a] -> AVec a-fromList = fromSet . S.fromList -{-# INLINE fromList #-}---- | Smart AVec constructor which ensures that the--- underlying vector satisfies the AVec properties.-fromSet :: (Ord a, U.Unbox a) => S.Set a -> AVec a-fromSet = AVec . U.fromList . S.toList -{-# INLINE fromSet #-}---- | A word represented by a list of its observations--- and a list of its potential label interpretations.-data X-    -- | The word with default set of potential interpretations.-    = X { _unX :: AVec Ob }-    -- | The word with custom set of potential labels.-    | R { _unX :: AVec Ob-        , _unR :: AVec Lb }-    deriving (Show, Read, Eq, Ord)---- | X constructor.-mkX :: [Ob] -> [Lb] -> X-mkX x [] = X (fromList x)-mkX x r  = R (fromList x) (fromList r)-{-# INLINE mkX #-}---- | List of observations.-unX :: X -> [Ob]-unX = U.toList . unAVec . _unX-{-# INLINE unX #-}---- | List of potential labels.-unR :: AVec Lb -> X -> [Lb]-unR r0 X{..} = U.toList . unAVec $ r0-unR _  R{..} = U.toList . unAVec $ _unR-{-# INLINE unR #-}---- | Sentence of words.-type Xs = V.Vector X---- | Probability distribution over labels.  We assume, that when y is--- a member of chosen labels list it is also a member of the list--- potential labels for corresponding 'X' word.--- TODO: Perhaps we should substitute 'Lb's with label indices--- corresponding to labels from the vector of potential labels?--- FIXME: The type definition is incorrect (see 'fromList' definition),--- it should be something like AVec2.-newtype Y = Y { _unY :: AVec (Lb, Double) }-    deriving (Show, Read, Eq, Ord)---- | Y constructor.-mkY :: [(Lb, Double)] -> Y-mkY = Y . fromList-{-# INLINE mkY #-}---- | Y deconstructor symetric to mkY.-unY :: Y -> [(Lb, Double)]-unY = U.toList . unAVec . _unY-{-# INLINE unY #-}---- | Sentence of Y (label choices).-type Ys = V.Vector Y

@@ -1,86 +0,0 @@-module Data.CRF.Chain1.Constrained.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.Constrained.Dataset.Internal---- | A Feature is either an observation feature OFeature o x, which--- models relation between observation o and label x assigned to--- the same word, or a transition feature TFeature x y (SFeature x--- for the first position in the sentence), which models relation--- between two subsequent labels, x (on i-th position) and y--- (on (i-1)-th positoin).-data Feature-    = SFeature-        {-# UNPACK #-} !Lb-    | TFeature-        {-# UNPACK #-} !Lb-        {-# UNPACK #-} !Lb-    | OFeature-        {-# UNPACK #-} !Ob-        {-# UNPACK #-} !Lb-    deriving (Show, Eq, Ord)--instance Binary Feature where-    put (SFeature x)   = put (0 :: Int) >> put x-    put (TFeature x y) = put (1 :: Int) >> put (x, y)-    put (OFeature o x) = put (2 :: Int) >> put (o, x)-    get = do-        k <- get :: Get Int-        case k of-            0 -> SFeature <$> get-            1 -> TFeature <$> get <*> get-            2 -> OFeature <$> get <*> get-	    _ -> error "Binary Feature: unknown identifier"---- | Is it a 'SFeature'?-isSFeat :: Feature -> Bool-isSFeat (SFeature _) = True-isSFeat _            = False-{-# INLINE isSFeat #-}---- | Is it an 'OFeature'?-isOFeat :: Feature -> Bool-isOFeat (OFeature _ _) = True-isOFeat _              = False-{-# INLINE isOFeat #-}---- | Is it a 'TFeature'?-isTFeat :: Feature -> Bool-isTFeat (TFeature _ _) = True-isTFeat _              = False-{-# INLINE isTFeat #-}---- | Transition features with assigned probabilities for given position.-trFeats :: Ys -> Int -> [(Feature, L.LogFloat)]-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,59 +0,0 @@--- | The module provides feature selection functions which extract--- hidden features, i.e. all features which can be constructed --- on the basis of observations and potential labels (constraints)--- corresponding to individual words.------ You can mix functions defined here with the selection functions--- from the "Data.CRF.Chain1.Constrained.Feature.Present" module.--module Data.CRF.Chain1.Constrained.Feature.Hidden-( hiddenFeats-, hiddenOFeats-, hiddenTFeats-, hiddenSFeats-) where--import qualified Data.Vector as V--import Data.CRF.Chain1.Constrained.Dataset.Internal-import Data.CRF.Chain1.Constrained.Feature---- | Hidden 'OFeature's which can be constructed based on the dataset.--- The default set of potential interpretations is used for all unknown words.-hiddenOFeats :: AVec Lb -> [(Xs, b)] -> [Feature]-hiddenOFeats r0 ds =-    concatMap f ds-  where-    f = concatMap oFeats . V.toList . fst-    oFeats x =-        [ OFeature o y-        | o <- unX x-        , y <- unR r0 x ]---- | Hidden 'TFeature's which can be constructed based on the dataset.--- The default set of potential interpretations is used for all unknown words.-hiddenTFeats :: AVec Lb -> [(Xs, b)] -> [Feature]-hiddenTFeats r0 ds =-    concatMap (tFeats . fst) ds-  where-    tFeats xs = concatMap (tFeatsOn xs) [1 .. V.length xs - 1]-    tFeatsOn xs k =-        [ TFeature x y-        | x <- unR r0 (xs V.! k)-        , y <- unR r0 (xs V.! (k-1)) ]---- | Hidden 'SFeature's which can be constructed based on the dataset.--- The default set of potential interpretations is used for all unknown words.-hiddenSFeats :: AVec Lb -> [(Xs, b)] -> [Feature]-hiddenSFeats r0 ds =-    let sFeats xs = [SFeature x | x <- unR r0 (xs V.! 0)]-    in  concatMap (sFeats . fst) ds---- | Hidden 'Feature's of all types which can be constructed--- on the basis of the dataset.  The default set of potential--- interpretations is used for all unknown words.-hiddenFeats :: AVec Lb -> [(Xs, b)] -> [Feature]-hiddenFeats r0 ds-    =  hiddenOFeats r0 ds-    ++ hiddenTFeats r0 ds-    ++ hiddenSFeats r0 ds

@@ -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.Constrained.Feature.Hidden" module.--module Data.CRF.Chain1.Constrained.Feature.Present-( presentFeats-, presentOFeats-, presentTFeats-, presentSFeats-) where--import qualified Data.Vector as V--import Data.CRF.Chain1.Constrained.Dataset.Internal-import Data.CRF.Chain1.Constrained.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,247 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections #-}---- Inference with CRFs.--module Data.CRF.Chain1.Constrained.Inference-( tag-, tagK-, marginals-, accuracy-, expectedFeaturesIn-, zx-, zx'-) where--import Control.Applicative ((<$>))-import Data.Maybe (catMaybes)-import Data.List (maximumBy, sortBy)-import Data.Function (on)-import qualified Data.Array as A-import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as U--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.Constrained.DP as DP-import Data.CRF.Chain1.Constrained.Util (partition)-import Data.CRF.Chain1.Constrained.Dataset.Internal-import Data.CRF.Chain1.Constrained.Feature (Feature(..))-import Data.CRF.Chain1.Constrained.Model-import Data.CRF.Chain1.Constrained.Intersect--type LbIx       = Int-type ProbArray  = Int -> LbIx -> L.LogFloat---- Some basic definitions.---- | Vector of potential labels on the given position of the sentence.-lbVec :: Model -> Xs -> Int -> AVec Lb-lbVec crf xs k = case xs V.! k of-    X _     -> (r0 crf)-    R _ r   -> r-{-# INLINE lbVec #-}---- | Number of potential labels on the given position of the sentence.-lbNum :: Model -> Xs -> Int -> Int-lbNum crf xs = (U.length . unAVec) . lbVec crf xs-{-# INLINE lbNum #-}---- | Potential label on the given vector position.-lbOn :: Model -> X -> Int -> Lb-lbOn crf (X _)   = (unAVec (r0 crf) U.!)-lbOn _   (R _ r) = (unAVec r U.!)-{-# INLINE lbOn #-}--lbIxs :: Model -> Xs -> Int -> [(Int, Lb)]-lbIxs crf xs = zip [0..] . U.toList . unAVec . lbVec crf xs-{-# INLINE lbIxs #-}---- | Compute the table of potential products associated with --- observation features for the given sentence position.-computePsi :: Model -> Xs -> Int -> LbIx -> L.LogFloat-computePsi crf xs i = (A.!) $ A.accumArray (*) 1 bounds-    [ (k, valueL crf ix)-    | ob <- unX (xs V.! i)-    , (k, ix) <- intersect (obIxs crf ob) (lbVec crf xs i) ]-  where-    bounds = (0, lbNum crf xs i - 1)---- | Forward table computation.-forward :: Model -> Xs -> ProbArray-forward crf xs = alpha where-    alpha = DP.flexible2 (0, V.length xs) bounds-        (\t i -> withMem (computePsi crf xs i) t i)-    bounds i-        | i == V.length xs = (0, 0)-        | otherwise = (0, lbNum crf xs i - 1)-    withMem psi alpha i-        | i == V.length xs = const u-        | i == 0 = \j ->-            let x = lbOn crf (xs V.! i) j-            in  psi j * sgValue crf x-        | otherwise = \j ->-            let x = lbOn crf (xs V.! i) j-            in  psi j * ((u - v x) + w x)-      where-        u = sum-            [ alpha (i-1) k-            | (k, _) <- lbIxs crf xs (i-1) ]-        v x = sum-            [ alpha (i-1) k-            | (k, _) <- intersect (prevIxs crf x) (lbVec crf xs (i-1)) ]-        w x = sum-            [ alpha (i-1) k * valueL crf ix-            | (k, ix) <- intersect (prevIxs crf x) (lbVec crf xs (i-1)) ]---- | Backward table computation.-backward :: Model -> Xs -> ProbArray-backward crf xs = beta where-    beta = DP.flexible2 (0, V.length xs) bounds-        (\t i -> withMem (computePsi crf xs i) t i)-    bounds i-        | i == 0    = (0, 0)-        | otherwise = (0, lbNum crf xs (i-1) - 1)-    withMem psi beta i-        | i == V.length xs = const 1-        | i == 0 = const $ sum-            [ beta (i+1) k * psi k-            * sgValue crf (lbOn crf (xs V.! i) k)-            | (k, _) <- lbIxs crf xs i ]-        | otherwise = \j ->-            let y = lbOn crf (xs V.! (i-1)) j-            in  (u - v y) + w y-      where-        u = sum-            [ beta (i+1) k * psi k-            | (k, _ ) <- lbIxs crf xs i ]-        v y = sum-            [ beta (i+1) k * psi k-            | (k, _ ) <- intersect (nextIxs crf y) (lbVec crf xs i) ]-        w y = sum-            [ beta (i+1) k * psi k * valueL crf ix-            | (k, ix) <- intersect (nextIxs crf y) (lbVec crf xs i) ]--zxBeta :: ProbArray -> L.LogFloat-zxBeta beta = beta 0 0--zxAlpha :: Xs -> ProbArray -> L.LogFloat-zxAlpha xs alpha = alpha (V.length xs) 0---- | Normalization factor computed for the 'Xs' sentence using the--- backward computation.-zx :: Model -> Xs -> L.LogFloat-zx crf = zxBeta . backward crf---- | Normalization factor computed for the 'Xs' sentence using the--- forward computation.-zx' :: Model -> Xs -> L.LogFloat-zx' crf sent = zxAlpha sent (forward crf sent)---- | Tag probabilities with respect to marginal distributions.-marginals :: Model -> Xs -> [[(Lb, L.LogFloat)]]-marginals crf xs =-    let alpha = forward crf xs-        beta = backward crf xs-    in  [ [ (x, prob1 alpha beta i k)-          | (k, x) <- lbIxs crf xs i ]-        | i <- [0 .. V.length xs - 1] ]---- | Get (at most) k best tags for each word and return them in--- descending order.  TODO: Tagging with respect to marginal--- distributions might not be the best idea.  Think of some--- more elegant method.-tagK :: Int -> Model -> Xs -> [[(Lb, L.LogFloat)]]-tagK k crf xs = map-    ( take k-    . reverse-    . sortBy (compare `on` snd)-    ) (marginals crf xs)---- | Find the most probable label sequence (with probabilities of individual--- lables determined with respect to marginal distributions) satisfying the--- constraints imposed over label values.-tag :: Model -> Xs -> [Lb]-tag crf = map (fst . head) . (tagK 1 crf)--prob1 :: ProbArray -> ProbArray -> Int -> LbIx -> L.LogFloat-prob1 alpha beta k x =-    alpha k x * beta (k + 1) x / zxBeta beta-{-# INLINE prob1 #-}--prob2 :: Model -> ProbArray -> ProbArray -> Int -> (LbIx -> L.LogFloat)-      -> LbIx -> LbIx -> FeatIx -> L.LogFloat-prob2 crf alpha beta k psi x y ix-    = alpha (k - 1) y * beta (k + 1) x-    * psi x * valueL crf ix / zxBeta beta-{-# INLINE prob2 #-}--goodAndBad :: Model -> Xs -> Ys -> (Int, Int)-goodAndBad crf xs ys =-    foldl gather (0, 0) $ zip labels labels'-  where-    labels  = [ (best . unY) (ys V.! i)-              | i <- [0 .. V.length ys - 1] ]-    best zs-        | null zs   = Nothing-        | otherwise = Just . fst $ maximumBy (compare `on` snd) zs-    labels' = map Just $ tag crf xs-    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)--expectedFeaturesOn-    :: Model -> ProbArray -> ProbArray -> Xs-    -> Int -> [(FeatIx, L.LogFloat)]-expectedFeaturesOn crf alpha beta xs i =-    tFeats ++ oFeats-  where-    psi = computePsi crf xs i-    pr1 = prob1     alpha beta i-    pr2 = prob2 crf alpha beta i psi--    oFeats = [ (ix, pr1 k) -             | o <- unX (xs V.! i)-             , (k, ix) <- intersect (obIxs crf o) (lbVec crf xs i) ]--    tFeats-        | i == 0 = catMaybes-            [ (, pr1 k) <$> featToIx crf (SFeature x)-            | (k, x) <- lbIxs crf xs i ]-        | otherwise =-            [ (ix, pr2 k l ix)-            | (k,  x) <- lbIxs crf xs i-            , (l, ix) <- intersect (prevIxs crf x) (lbVec crf xs (i-1)) ]---- | 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 xs = zxF `par` zxB `pseq` zxF `pseq`-    concat [expectedOn k | k <- [0 .. V.length xs - 1] ]-  where-    expectedOn = expectedFeaturesOn crf alpha beta xs-    alpha = forward crf xs-    beta = backward crf xs-    zxF = zxAlpha xs alpha-    zxB = zxBeta beta

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

@@ -1,234 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Internal implementation of the CRF model.--module Data.CRF.Chain1.Constrained.Model-( FeatIx (..)-, Model (..)-, mkModel-, valueL-, featToIx-, featToJustIx-, featToJustInt-, sgValue-, sgIxs-, obIxs-, nextIxs-, prevIxs-) where--import Control.Applicative ((<$>), (<*>))-import Data.Maybe (fromJust)-import Data.List (groupBy, sort)-import Data.Function (on)-import Data.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.Constrained.Feature-import Data.CRF.Chain1.Constrained.Dataset.Internal hiding (fromList)-import qualified Data.CRF.Chain1.Constrained.Dataset.Internal as A---- | 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)-{-# INLINE dummyFeatIx #-}--isDummy :: FeatIx -> Bool-isDummy (FeatIx ix) = ix < 0-{-# INLINE isDummy #-}--notDummy :: FeatIx -> Bool-notDummy = not . isDummy-{-# INLINE notDummy #-}---- | 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-    -- | Default set of potential labels.-    , r0        :: AVec Lb-    -- | 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 (AVec 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 (AVec 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 (AVec LbIx) }--instance Binary Model where-    put crf = do-        put $ values crf-        put $ ixMap crf-        put $ r0 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 the associations list.  We assume that--- the set of labels is of the {0, 1, .. 'lbMax'} form and, similarly,--- the set of observations is of the {0, 1, .. 'obMax'} form.--- There should be no repetition of features in the input list.--- TODO: We can change this function to take M.Map Feature Double.-fromList :: Ob -> Lb -> [(Feature, Double)] -> Model-fromList obMax' lbMax' fs =-    let _ixMap = M.fromList $ zip-            (map fst fs)-            (map FeatIx [0..])-    -        sFeats = [feat | (feat, _val) <- fs, isSFeat feat]-        tFeats = [feat | (feat, _val) <- fs, isTFeat feat]-        oFeats = [feat | (feat, _val) <- fs, isOFeat feat]--        obMax = unOb obMax'-        lbMax = unLb lbMax'-        _r0   = A.fromList (map Lb [0 .. lbMax])-        -- obMax = (unOb . maximum . Set.toList . obSet) (map fst fs)-        -- lbs   = (Set.toList . lbSet) (map fst fs)-        -- lbMax = (unLb . maximum) lbs-        -- _r0   = A.fromList lbs-        -        _sgIxsV = sgVects lbMax-            [ (unLb x, featToJustIx crf feat)-            | feat@(SFeature x) <- sFeats ]--        _prevIxsV = adjVects lbMax-            [ (unLb x, (y, featToJustIx crf feat))-            | feat@(TFeature x y) <- tFeats ]--        _nextIxsV = adjVects lbMax-            [ (unLb y, (x, featToJustIx crf feat))-            | feat@(TFeature x y) <- tFeats ]--        _obIxsV = adjVects obMax-            [ (unOb o, (x, featToJustIx crf feat))-            | feat@(OFeature o x) <- oFeats ]--        -- | Adjacency vectors.-        adjVects n xs =-            V.replicate (n + 1) (A.fromList []) V.// update-          where-            update = map mkVect $ groupBy ((==) `on` fst) $ sort xs-            mkVect (y:ys) = (fst y, A.fromList $ map snd (y:ys))-            mkVect [] = error "mkVect: null list"--        sgVects n xs = U.replicate (n + 1) dummyFeatIx U.// xs--        _values = U.replicate (length fs) 0.0-            U.// [ (featToJustInt crf feat, val)-                 | (feat, val) <- fs ]-        crf = Model _values _ixMap _r0 _sgIxsV _obIxsV _prevIxsV _nextIxsV-    in  crf---- -- | Compute the set of observations.--- obSet :: [Feature] -> Set.Set Ob--- obSet =---     Set.fromList . concatMap toObs---   where---     toObs (OFeature o _) = [o]---     toObs _              = []--- --- -- | Compute the set of labels.--- lbSet :: [Feature] -> Set.Set Lb--- lbSet =---     Set.fromList . concatMap toLbs---   where---     toLbs (SFeature x)   = [x]---     toLbs (OFeature _ x) = [x]---     toLbs (TFeature x y) = [x, y]---- | Construct the model from the list of features.  All parameters will be--- set to 0.  There can be repetitions in the input list.--- We assume that the set of labels is of the {0, 1, .. 'lbMax'} form and,--- similarly, the set of observations is of the {0, 1, .. 'obMax'} form.-mkModel :: Ob -> Lb -> [Feature] -> Model-mkModel obMax lbMax fs =-    let fSet = Set.fromList fs-        fs'  = Set.toList fSet-        vs   = replicate (Set.size fSet) 0.0-    in  fromList obMax lbMax (zip fs' vs)---- | 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 index for the given feature.-featToIx :: Model -> Feature -> Maybe FeatIx-featToIx crf feat = M.lookup feat (ixMap crf)-{-# INLINE featToIx #-}---- | Determine index for the given feature.  Throw error when--- the feature is not a member of the model. -featToJustIx :: Model -> Feature -> FeatIx-featToJustIx _crf = fromJust . featToIx _crf-{-# INLINE featToJustIx #-}---- | Determine index for the given feature and return it as an integer.--- Throw error when the feature is not a member of the model.-featToJustInt :: Model -> Feature -> Int-featToJustInt _crf = unFeatIx . featToJustIx _crf-{-# INLINE featToJustInt #-}---- | Potential value (in log domain) of the singular feature with the--- given label.  The value defaults to 1 (0 in log domain) 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-        -- TODO: Is the value correct?-        -1 -> L.logToLogFloat (0 :: Float)-        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 -> AVec LbIx-obIxs crf x = 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 -> AVec LbIx-nextIxs crf x = 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 -> AVec LbIx-prevIxs crf x = prevIxsV crf V.! unLb x-{-# INLINE prevIxs #-}

@@ -1,108 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE PatternGuards #-}--module Data.CRF.Chain1.Constrained.Train-( CRF (..)-, train-) where--import Control.Applicative ((<$>), (<*>))-import System.IO (hSetBuffering, stdout, BufferMode (..))-import Data.Binary (Binary, put, get)-import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.Vector as V-import qualified Numeric.SGD as SGD-import qualified Numeric.SGD.LogSigned as L--import Data.CRF.Chain1.Constrained.Dataset.Internal-import Data.CRF.Chain1.Constrained.Dataset.External (SentL, unknown, unProb)-import Data.CRF.Chain1.Constrained.Dataset.Codec-    (mkCodec, Codec, obMax, lbMax, encodeDataL, encodeLabels)-import Data.CRF.Chain1.Constrained.Feature (Feature, featuresIn)-import Data.CRF.Chain1.Constrained.Model-    (Model (..), mkModel, FeatIx (..), featToJustInt)-import Data.CRF.Chain1.Constrained.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.--- TODO: Accept custom r0 construction function.-train-    :: (Ord a, Ord b)-    => SGD.SgdArgs                  -- ^ Args for SGD-    -> IO [SentL a b]               -- ^ Training data 'IO' action-    -> Maybe (IO [SentL a b])       -- ^ Maybe evalation data-    -> (AVec Lb -> [(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-    _r0 <- encodeLabels _codec . S.toList . unkSet <$> trainIO-    evalDataM <- case evalIO'Maybe of-        Just evalIO -> Just . encodeDataL _codec <$> evalIO-        Nothing     -> return Nothing-    let feats = extractFeats _r0 trainData-        crf = (mkModel (obMax _codec) (lbMax _codec) feats) { r0 = _r0 }-    para <- SGD.sgdM sgdArgs-        (notify sgdArgs crf trainData evalDataM)-        (gradOn crf) (V.fromList trainData) (values crf)-    return $ CRF _codec (crf { values = para })---- | Collect labels assigned to unknown words (with empty list--- of potential interpretations).-unkSet :: Ord b => [SentL a b] -> S.Set b-unkSet =-    S.fromList . concatMap onSent-  where-    onSent = concatMap onWord-    onWord word-        | unknown (fst word)    = M.keys . unProb . snd $ word-        | otherwise             = []--gradOn :: Model -> SGD.Para -> (Xs, Ys) -> SGD.Grad-gradOn crf para (xs, ys) = SGD.fromLogList $-    [ (featToJustInt 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

@@ -1,12 +0,0 @@-module Data.CRF.Chain1.Constrained.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)

@@ -1,5 +1,5 @@ name:               crf-chain1-constrained-version:            0.1.2+version:            0.2.0 synopsis:           First-order, constrained, linear-chain conditional random fields description:     The library provides efficient implementation of the first-order,@@ -33,6 +33,8 @@ build-type:         Simple  library+    hs-source-dirs: src+     build-depends:         base >= 4 && < 5       , containers@@ -45,7 +47,7 @@       , binary       , vector-binary       , data-lens-      , sgd >= 0.2.1 && < 0.3+      , sgd >= 0.3 && < 0.4      exposed-modules:         Data.CRF.Chain1.Constrained

@@ -0,0 +1,60 @@+{-# LANGUAGE RecordWildCards #-}++-- | The module provides first-order, linear-chain conditional random fields+-- (CRFs) with position-wide constraints over label values.++module Data.CRF.Chain1.Constrained+(+-- * Data types+  Word (..)+, unknown+, Sent+, Prob (unProb)+, mkProb+, WordL+, SentL++-- * CRF+, CRF (..)+-- ** Training+, train+-- ** Tagging+, tag+, tagK++-- * Feature selection+, hiddenFeats+, presentFeats+) where++import Data.CRF.Chain1.Constrained.Dataset.External+import Data.CRF.Chain1.Constrained.Dataset.Codec+import Data.CRF.Chain1.Constrained.Feature.Present+import Data.CRF.Chain1.Constrained.Feature.Hidden+import Data.CRF.Chain1.Constrained.Train+import qualified Data.CRF.Chain1.Constrained.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 -> [b]+tag CRF{..} sent+    = onWords . decodeLabels codec+    . I.tag model . encodeSent codec+    $ sent+  where+    onWords xs =+        [ unJust codec word x+        | (word, x) <- zip sent xs ]++-- | Determine the most probable label sets of the given size (at maximum)+-- for each position in the input sentence.+tagK :: (Ord a, Ord b) => Int -> CRF a b -> Sent a b -> [[b]]+tagK k CRF{..} sent+    = onWords . map decodeChoice+    . I.tagK k model . encodeSent codec+    $ sent+  where+    decodeChoice = decodeLabels codec . map fst+    onWords xss =+        [ take k $ unJusts codec word xs+        | (word, xs) <- zip sent xss ]

@@ -0,0 +1,43 @@+module Data.CRF.Chain1.Constrained.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,207 @@+module Data.CRF.Chain1.Constrained.Dataset.Codec+( Codec+, CodecM+, obMax+, lbMax++, encodeWord'Cu+, encodeWord'Cn+, encodeSent'Cu+, encodeSent'Cn+, encodeSent++, encodeWordL'Cu+, encodeWordL'Cn+, encodeSentL'Cu+, encodeSentL'Cn+, encodeSentL++, encodeLabels+, decodeLabel+, decodeLabels++, mkCodec+, encodeData+, encodeDataL+, unJust+, unJusts+) where++import Control.Applicative ((<$>), (<*>), pure)+import Data.Maybe (catMaybes, fromJust)+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.Constrained.Dataset.Internal+import Data.CRF.Chain1.Constrained.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 (Maybe b))++-- | The maximum internal observation included in the codec.+obMax :: Codec a b -> Ob+obMax =+    let idMax m = M.size m - 1+    in  Ob . idMax . C.to . fst++-- | The maximum internal label included in the codec.+lbMax :: Codec a b -> Lb+lbMax =+    let idMax m = M.size m - 1+    in  Lb . idMax . C.to . snd++-- | The empty codec.  The label part is initialized with Nothing+-- member, which represents unknown labels.  It is taken on account+-- in the model implementation because it is assigned to the+-- lowest label code and the model assumes that the set of labels+-- is of the {0, ..., 'lbMax'} form.+empty :: Ord b => Codec a b+empty =+    let withNo = C.execCodec C.empty (C.encode C.idLens Nothing)+    in  (C.empty, withNo)++-- | 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 observation and update the codec (only in the encoding+-- direction).+encodeObU :: Ord a => a -> CodecM a b Ob+encodeObU = fmap Ob . C.encode' fstLens++-- | Encode the observation and do *not* update the codec.+encodeObN :: Ord a => a -> CodecM a b (Maybe Ob)+encodeObN = fmap (fmap Ob) . C.maybeEncode fstLens++-- | Encode the label and update the codec.+encodeLbU :: Ord b => b -> CodecM a b Lb+encodeLbU = fmap Lb . C.encode sndLens . Just++-- | Encode the label and do *not* update the codec.+encodeLbN :: Ord b => b -> CodecM a b Lb+encodeLbN x = do+    my <- C.maybeEncode sndLens (Just x)+    Lb <$> ( case my of+        Just y  -> return y+        Nothing -> fromJust <$> C.maybeEncode sndLens Nothing )++-- | 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, choice) = do+    x' <- mapM encodeObU (S.toList (obs word))+    r' <- mapM encodeLbU (S.toList (lbs word))+    let x = mkX x' r'+    y  <- mkY <$> sequence+    	[ (,) <$> encodeLbU lb <*> pure pr+	| (lb, pr) <- (M.toList . unProb) choice ]+    return (x, y)++-- | Encodec the labeled word and do *not* update the codec.+encodeWordL'Cn :: (Ord a, Ord b) => WordL a b -> CodecM a b (X, Y)+encodeWordL'Cn (word, choice) = do+    x' <- catMaybes <$> mapM encodeObN (S.toList (obs word))+    r' <- mapM encodeLbN (S.toList (lbs word))+    let x = mkX x' r'+    y  <- mkY <$> sequence+    	[ (,) <$> encodeLbN lb <*> pure pr+	| (lb, pr) <- (M.toList . unProb) choice ]+    return (x, y)++-- | Encode the word and update the codec.+encodeWord'Cu :: (Ord a, Ord b) => Word a b -> CodecM a b X+encodeWord'Cu word = do+    x' <- mapM encodeObU (S.toList (obs word))+    r' <- mapM encodeLbU (S.toList (lbs word))+    return $ mkX x' r'++-- | Encode the word and do *not* update the codec.+encodeWord'Cn :: (Ord a, Ord b) => Word a b -> CodecM a b X+encodeWord'Cn word = do+    x' <- catMaybes <$> mapM encodeObN (S.toList (obs word))+    r' <- mapM encodeLbN (S.toList (lbs word))+    return $ mkX x' r'++-- | 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) => SentL a b -> CodecM a b (Xs, Ys)+encodeSentL'Cn sent = do+    ps <- mapM (encodeWordL'Cn) sent+    return (V.fromList (map fst ps), V.fromList (map snd ps))++-- | Encode labels into an ascending vector of distinct label codes.+encodeLabels :: Ord b => Codec a b -> [b] -> AVec Lb+encodeLabels codec = fromList . C.evalCodec codec . mapM encodeLbN++-- | 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) => Codec a b -> SentL a b -> (Xs, Ys)+encodeSentL codec = C.evalCodec codec . encodeSentL'Cn++-- | Encode the sentence and update the codec.+encodeSent'Cu :: (Ord a, Ord b) => Sent a b -> 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, Ord b) => Sent a b -> CodecM a b Xs+encodeSent'Cn = fmap V.fromList . mapM encodeWord'Cn++-- | Encode the sentence using the given codec.+encodeSent :: (Ord a, Ord b) => Codec a b -> Sent a b -> Xs+encodeSent codec = C.evalCodec codec . encodeSent'Cn++-- | Create codec on the basis of the labeled dataset.+mkCodec :: (Ord a, Ord b) => [SentL a b] -> Codec a b+mkCodec = C.execCodec 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) => Codec a b -> [SentL a b] -> [(Xs, Ys)]+encodeDataL = map . encodeSentL++-- | Encode the dataset with the codec.+encodeData :: (Ord a, Ord b) => Codec a b -> [Sent a b] -> [Xs]+encodeData = map . encodeSent++-- | Decode the label.+decodeLabel :: Ord b => Codec a b -> Lb -> Maybe b+decodeLabel codec x = C.evalCodec codec $ C.decode sndLens (unLb x)++-- | Decode the sequence of labels.+decodeLabels :: Ord b => Codec a b -> [Lb] -> [Maybe b]+decodeLabels codec xs = C.evalCodec codec $+    sequence [C.decode sndLens (unLb x) | x <- xs]++hasLabel :: Ord b => Codec a b -> b -> Bool+hasLabel codec x = M.member (Just x) (C.to $ snd codec)+{-# INLINE hasLabel #-}++-- | Return the label when 'Just' or one of the unknown values+-- when 'Nothing'.+unJust :: Ord b => Codec a b -> Word a b -> Maybe b -> b+unJust _ _ (Just x) = x+unJust codec word Nothing = case allUnk of+    (x:_)   -> x+    []      -> error "unJust: Nothing and all values known"+  where+    allUnk = filter (not . hasLabel codec) (S.toList $ lbs word)++-- | Replace 'Nothing' labels with all unknown labels from+-- the set of potential interpretations.+unJusts :: Ord b => Codec a b -> Word a b -> [Maybe b] -> [b]+unJusts codec word xs =+    concatMap deJust xs+  where+    allUnk = filter (not . hasLabel codec) (S.toList $ lbs word)+    deJust (Just x) = [x]+    deJust Nothing  = allUnk

@@ -0,0 +1,58 @@+module Data.CRF.Chain1.Constrained.Dataset.External+( Word (..)+, unknown+, Sent+, Prob (unProb)+, mkProb+, WordL+, SentL+) where++import qualified Data.Set as S+import qualified Data.Map as M++-- | A Word is represented by a set of observations+-- and a set of potential interpretation labels.+-- When the set of potential labels is empty the word+-- is considered to be unknown and the default potential+-- set is used in its place.+data Word a b = Word+    { obs   :: S.Set a  -- ^ The set of observations+    , lbs   :: S.Set b  -- ^ The set of potential interpretations.+    } deriving (Show, Eq, Ord)++-- | The word is considered to be unknown when the set of potential+-- labels is empty.+unknown :: Word a b -> Bool+unknown word = S.size (lbs word) == 0+{-# INLINE unknown #-}++-- | A sentence of words.+type Sent a b = [Word a b]++-- | A probability distribution defined over elements of type a.+-- All elements not included in the map have probability equal+-- to 0.+newtype Prob a = Prob { unProb :: M.Map a Double }+    deriving (Show, Eq, Ord)++-- | Construct the probability distribution.+mkProb :: Ord a => [(a, Double)] -> Prob a+mkProb =+    Prob . normalize . M.fromListWith (+) . filter ((>0).snd)+  where+    normalize dist +        | M.null dist  =+            error "mkProb: no elements with positive probability"+        | otherwise     =+            let z = sum (M.elems dist)+            in  fmap (/z) dist++-- | A WordL is a labeled word, i.e. a word with probability distribution+-- defined over labels.  We assume that every label from the distribution+-- domain is a member of the set of potential labels corresponding to the+-- word.  TODO: Ensure the assumption using the smart constructor.+type WordL a b = (Word a b, Prob b)++-- | A sentence of labeled words.+type SentL a b = [WordL a b]

@@ -0,0 +1,119 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}++module Data.CRF.Chain1.Constrained.Dataset.Internal+( Ob (..)+, Lb (..)++, X (..)+, mkX+, unX+, unR+, Xs++, Y (..)+, mkY+, unY+, Ys++, AVec (unAVec)+, fromList+, fromSet+) where++import Control.Applicative ((<$>), (<*>))+import Data.Vector.Generic.Base+import Data.Vector.Generic.Mutable+import Data.Binary (Binary, get, put, putWord8, getWord8)+import Data.Vector.Binary ()+import Data.Ix (Ix)+import qualified Data.Set as S+import 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 )++-- | Ascending vector of unique interger elements.+newtype AVec a = AVec { unAVec :: U.Vector a }+    deriving (Show, Read, Eq, Ord, Binary)++-- | Smart AVec constructor which ensures that the+-- underlying vector satisfies the AVec properties.+fromList :: (Ord a, U.Unbox a) => [a] -> AVec a+fromList = fromSet . S.fromList +{-# INLINE fromList #-}++-- | Smart AVec constructor which ensures that the+-- underlying vector satisfies the AVec properties.+fromSet :: (Ord a, U.Unbox a) => S.Set a -> AVec a+fromSet = AVec . U.fromList . S.toList +{-# INLINE fromSet #-}++-- | A word represented by a list of its observations+-- and a list of its potential label interpretations.+data X+    -- | The word with default set of potential interpretations.+    = X { _unX :: AVec Ob }+    -- | The word with custom set of potential labels.+    | R { _unX :: AVec Ob+        , _unR :: AVec Lb }+    deriving (Show, Read, Eq, Ord)++instance Binary X where+    put X{..} = putWord8 0 >> put _unX+    put R{..} = putWord8 1 >> put _unX >> put _unR+    get = getWord8 >>= \i -> case i of+        0   -> X <$> get+        _   -> R <$> get <*> get++-- | X constructor.+mkX :: [Ob] -> [Lb] -> X+mkX x [] = X (fromList x)+mkX x r  = R (fromList x) (fromList r)+{-# INLINE mkX #-}++-- | List of observations.+unX :: X -> [Ob]+unX = U.toList . unAVec . _unX+{-# INLINE unX #-}++-- | List of potential labels.+unR :: AVec Lb -> X -> [Lb]+unR r0 X{..} = U.toList . unAVec $ r0+unR _  R{..} = U.toList . unAVec $ _unR+{-# INLINE unR #-}++-- | Sentence of words.+type Xs = V.Vector X++-- | Probability distribution over labels.  We assume, that when y is+-- a member of chosen labels list it is also a member of the list+-- potential labels for corresponding 'X' word.+-- TODO: Perhaps we should substitute 'Lb's with label indices+-- corresponding to labels from the vector of potential labels?+-- FIXME: The type definition is incorrect (see 'fromList' definition),+-- it should be something like AVec2.+newtype Y = Y { _unY :: AVec (Lb, Double) }+    deriving (Show, Read, Eq, Ord, Binary)++-- | Y constructor.+mkY :: [(Lb, Double)] -> Y+mkY = Y . fromList+{-# INLINE mkY #-}++-- | Y deconstructor symetric to mkY.+unY :: Y -> [(Lb, Double)]+unY = U.toList . unAVec . _unY+{-# INLINE unY #-}++-- | Sentence of Y (label choices).+type Ys = V.Vector Y

@@ -0,0 +1,86 @@+module Data.CRF.Chain1.Constrained.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.Constrained.Dataset.Internal++-- | A Feature is either an observation feature OFeature o x, which+-- models relation between observation o and label x assigned to+-- the same word, or a transition feature TFeature x y (SFeature x+-- for the first position in the sentence), which models relation+-- between two subsequent labels, x (on i-th position) and y+-- (on (i-1)-th positoin).+data Feature+    = SFeature+        {-# UNPACK #-} !Lb+    | TFeature+        {-# UNPACK #-} !Lb+        {-# UNPACK #-} !Lb+    | OFeature+        {-# UNPACK #-} !Ob+        {-# UNPACK #-} !Lb+    deriving (Show, Eq, Ord)++instance Binary Feature where+    put (SFeature x)   = put (0 :: Int) >> put x+    put (TFeature x y) = put (1 :: Int) >> put (x, y)+    put (OFeature o x) = put (2 :: Int) >> put (o, x)+    get = do+        k <- get :: Get Int+        case k of+            0 -> SFeature <$> get+            1 -> TFeature <$> get <*> get+            2 -> OFeature <$> get <*> get+	    _ -> error "Binary Feature: unknown identifier"++-- | Is it a 'SFeature'?+isSFeat :: Feature -> Bool+isSFeat (SFeature _) = True+isSFeat _            = False+{-# INLINE isSFeat #-}++-- | Is it an 'OFeature'?+isOFeat :: Feature -> Bool+isOFeat (OFeature _ _) = True+isOFeat _              = False+{-# INLINE isOFeat #-}++-- | Is it a 'TFeature'?+isTFeat :: Feature -> Bool+isTFeat (TFeature _ _) = True+isTFeat _              = False+{-# INLINE isTFeat #-}++-- | Transition features with assigned probabilities for given position.+trFeats :: Ys -> Int -> [(Feature, L.LogFloat)]+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,59 @@+-- | The module provides feature selection functions which extract+-- hidden features, i.e. all features which can be constructed +-- on the basis of observations and potential labels (constraints)+-- corresponding to individual words.+--+-- You can mix functions defined here with the selection functions+-- from the "Data.CRF.Chain1.Constrained.Feature.Present" module.++module Data.CRF.Chain1.Constrained.Feature.Hidden+( hiddenFeats+, hiddenOFeats+, hiddenTFeats+, hiddenSFeats+) where++import qualified Data.Vector as V++import Data.CRF.Chain1.Constrained.Dataset.Internal+import Data.CRF.Chain1.Constrained.Feature++-- | Hidden 'OFeature's which can be constructed based on the dataset.+-- The default set of potential interpretations is used for all unknown words.+hiddenOFeats :: AVec Lb -> [(Xs, b)] -> [Feature]+hiddenOFeats r0 ds =+    concatMap f ds+  where+    f = concatMap oFeats . V.toList . fst+    oFeats x =+        [ OFeature o y+        | o <- unX x+        , y <- unR r0 x ]++-- | Hidden 'TFeature's which can be constructed based on the dataset.+-- The default set of potential interpretations is used for all unknown words.+hiddenTFeats :: AVec Lb -> [(Xs, b)] -> [Feature]+hiddenTFeats r0 ds =+    concatMap (tFeats . fst) ds+  where+    tFeats xs = concatMap (tFeatsOn xs) [1 .. V.length xs - 1]+    tFeatsOn xs k =+        [ TFeature x y+        | x <- unR r0 (xs V.! k)+        , y <- unR r0 (xs V.! (k-1)) ]++-- | Hidden 'SFeature's which can be constructed based on the dataset.+-- The default set of potential interpretations is used for all unknown words.+hiddenSFeats :: AVec Lb -> [(Xs, b)] -> [Feature]+hiddenSFeats r0 ds =+    let sFeats xs = [SFeature x | x <- unR r0 (xs V.! 0)]+    in  concatMap (sFeats . fst) ds++-- | Hidden 'Feature's of all types which can be constructed+-- on the basis of the dataset.  The default set of potential+-- interpretations is used for all unknown words.+hiddenFeats :: AVec Lb -> [(Xs, b)] -> [Feature]+hiddenFeats r0 ds+    =  hiddenOFeats r0 ds+    ++ hiddenTFeats r0 ds+    ++ hiddenSFeats r0 ds

@@ -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.Constrained.Feature.Hidden" module.++module Data.CRF.Chain1.Constrained.Feature.Present+( presentFeats+, presentOFeats+, presentTFeats+, presentSFeats+) where++import qualified Data.Vector as V++import Data.CRF.Chain1.Constrained.Dataset.Internal+import Data.CRF.Chain1.Constrained.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,247 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}++-- Inference with CRFs.++module Data.CRF.Chain1.Constrained.Inference+( tag+, tagK+, marginals+, accuracy+, expectedFeaturesIn+, zx+, zx'+) where++import Control.Applicative ((<$>))+import Data.Maybe (catMaybes)+import Data.List (maximumBy, sortBy)+import Data.Function (on)+import qualified Data.Array as A+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U++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.Constrained.DP as DP+import Data.CRF.Chain1.Constrained.Util (partition)+import Data.CRF.Chain1.Constrained.Dataset.Internal+import Data.CRF.Chain1.Constrained.Feature (Feature(..))+import Data.CRF.Chain1.Constrained.Model+import Data.CRF.Chain1.Constrained.Intersect++type LbIx       = Int+type ProbArray  = Int -> LbIx -> L.LogFloat++-- Some basic definitions.++-- | Vector of potential labels on the given position of the sentence.+lbVec :: Model -> Xs -> Int -> AVec Lb+lbVec crf xs k = case xs V.! k of+    X _     -> (r0 crf)+    R _ r   -> r+{-# INLINE lbVec #-}++-- | Number of potential labels on the given position of the sentence.+lbNum :: Model -> Xs -> Int -> Int+lbNum crf xs = (U.length . unAVec) . lbVec crf xs+{-# INLINE lbNum #-}++-- | Potential label on the given vector position.+lbOn :: Model -> X -> Int -> Lb+lbOn crf (X _)   = (unAVec (r0 crf) U.!)+lbOn _   (R _ r) = (unAVec r U.!)+{-# INLINE lbOn #-}++lbIxs :: Model -> Xs -> Int -> [(Int, Lb)]+lbIxs crf xs = zip [0..] . U.toList . unAVec . lbVec crf xs+{-# INLINE lbIxs #-}++-- | Compute the table of potential products associated with +-- observation features for the given sentence position.+computePsi :: Model -> Xs -> Int -> LbIx -> L.LogFloat+computePsi crf xs i = (A.!) $ A.accumArray (*) 1 bounds+    [ (k, valueL crf ix)+    | ob <- unX (xs V.! i)+    , (k, ix) <- intersect (obIxs crf ob) (lbVec crf xs i) ]+  where+    bounds = (0, lbNum crf xs i - 1)++-- | Forward table computation.+forward :: Model -> Xs -> ProbArray+forward crf xs = alpha where+    alpha = DP.flexible2 (0, V.length xs) bounds+        (\t i -> withMem (computePsi crf xs i) t i)+    bounds i+        | i == V.length xs = (0, 0)+        | otherwise = (0, lbNum crf xs i - 1)+    withMem psi alpha i+        | i == V.length xs = const u+        | i == 0 = \j ->+            let x = lbOn crf (xs V.! i) j+            in  psi j * sgValue crf x+        | otherwise = \j ->+            let x = lbOn crf (xs V.! i) j+            in  psi j * ((u - v x) + w x)+      where+        u = sum+            [ alpha (i-1) k+            | (k, _) <- lbIxs crf xs (i-1) ]+        v x = sum+            [ alpha (i-1) k+            | (k, _) <- intersect (prevIxs crf x) (lbVec crf xs (i-1)) ]+        w x = sum+            [ alpha (i-1) k * valueL crf ix+            | (k, ix) <- intersect (prevIxs crf x) (lbVec crf xs (i-1)) ]++-- | Backward table computation.+backward :: Model -> Xs -> ProbArray+backward crf xs = beta where+    beta = DP.flexible2 (0, V.length xs) bounds+        (\t i -> withMem (computePsi crf xs i) t i)+    bounds i+        | i == 0    = (0, 0)+        | otherwise = (0, lbNum crf xs (i-1) - 1)+    withMem psi beta i+        | i == V.length xs = const 1+        | i == 0 = const $ sum+            [ beta (i+1) k * psi k+            * sgValue crf (lbOn crf (xs V.! i) k)+            | (k, _) <- lbIxs crf xs i ]+        | otherwise = \j ->+            let y = lbOn crf (xs V.! (i-1)) j+            in  (u - v y) + w y+      where+        u = sum+            [ beta (i+1) k * psi k+            | (k, _ ) <- lbIxs crf xs i ]+        v y = sum+            [ beta (i+1) k * psi k+            | (k, _ ) <- intersect (nextIxs crf y) (lbVec crf xs i) ]+        w y = sum+            [ beta (i+1) k * psi k * valueL crf ix+            | (k, ix) <- intersect (nextIxs crf y) (lbVec crf xs i) ]++zxBeta :: ProbArray -> L.LogFloat+zxBeta beta = beta 0 0++zxAlpha :: Xs -> ProbArray -> L.LogFloat+zxAlpha xs alpha = alpha (V.length xs) 0++-- | Normalization factor computed for the 'Xs' sentence using the+-- backward computation.+zx :: Model -> Xs -> L.LogFloat+zx crf = zxBeta . backward crf++-- | Normalization factor computed for the 'Xs' sentence using the+-- forward computation.+zx' :: Model -> Xs -> L.LogFloat+zx' crf sent = zxAlpha sent (forward crf sent)++-- | Tag probabilities with respect to marginal distributions.+marginals :: Model -> Xs -> [[(Lb, L.LogFloat)]]+marginals crf xs =+    let alpha = forward crf xs+        beta = backward crf xs+    in  [ [ (x, prob1 alpha beta i k)+          | (k, x) <- lbIxs crf xs i ]+        | i <- [0 .. V.length xs - 1] ]++-- | Get (at most) k best tags for each word and return them in+-- descending order.  TODO: Tagging with respect to marginal+-- distributions might not be the best idea.  Think of some+-- more elegant method.+tagK :: Int -> Model -> Xs -> [[(Lb, L.LogFloat)]]+tagK k crf xs = map+    ( take k+    . reverse+    . sortBy (compare `on` snd)+    ) (marginals crf xs)++-- | Find the most probable label sequence (with probabilities of individual+-- lables determined with respect to marginal distributions) satisfying the+-- constraints imposed over label values.+tag :: Model -> Xs -> [Lb]+tag crf = map (fst . head) . (tagK 1 crf)++prob1 :: ProbArray -> ProbArray -> Int -> LbIx -> L.LogFloat+prob1 alpha beta k x =+    alpha k x * beta (k + 1) x / zxBeta beta+{-# INLINE prob1 #-}++prob2 :: Model -> ProbArray -> ProbArray -> Int -> (LbIx -> L.LogFloat)+      -> LbIx -> LbIx -> FeatIx -> L.LogFloat+prob2 crf alpha beta k psi x y ix+    = alpha (k - 1) y * beta (k + 1) x+    * psi x * valueL crf ix / zxBeta beta+{-# INLINE prob2 #-}++goodAndBad :: Model -> Xs -> Ys -> (Int, Int)+goodAndBad crf xs ys =+    foldl gather (0, 0) $ zip labels labels'+  where+    labels  = [ (best . unY) (ys V.! i)+              | i <- [0 .. V.length ys - 1] ]+    best zs+        | null zs   = Nothing+        | otherwise = Just . fst $ maximumBy (compare `on` snd) zs+    labels' = map Just $ tag crf xs+    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)++expectedFeaturesOn+    :: Model -> ProbArray -> ProbArray -> Xs+    -> Int -> [(FeatIx, L.LogFloat)]+expectedFeaturesOn crf alpha beta xs i =+    tFeats ++ oFeats+  where+    psi = computePsi crf xs i+    pr1 = prob1     alpha beta i+    pr2 = prob2 crf alpha beta i psi++    oFeats = [ (ix, pr1 k) +             | o <- unX (xs V.! i)+             , (k, ix) <- intersect (obIxs crf o) (lbVec crf xs i) ]++    tFeats+        | i == 0 = catMaybes+            [ (, pr1 k) <$> featToIx crf (SFeature x)+            | (k, x) <- lbIxs crf xs i ]+        | otherwise =+            [ (ix, pr2 k l ix)+            | (k,  x) <- lbIxs crf xs i+            , (l, ix) <- intersect (prevIxs crf x) (lbVec crf xs (i-1)) ]++-- | 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 xs = zxF `par` zxB `pseq` zxF `pseq`+    concat [expectedOn k | k <- [0 .. V.length xs - 1] ]+  where+    expectedOn = expectedFeaturesOn crf alpha beta xs+    alpha = forward crf xs+    beta = backward crf xs+    zxF = zxAlpha xs alpha+    zxB = zxBeta beta

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

@@ -0,0 +1,234 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Internal implementation of the CRF model.++module Data.CRF.Chain1.Constrained.Model+( FeatIx (..)+, Model (..)+, mkModel+, valueL+, featToIx+, featToJustIx+, featToJustInt+, sgValue+, sgIxs+, obIxs+, nextIxs+, prevIxs+) where++import Control.Applicative ((<$>), (<*>))+import Data.Maybe (fromJust)+import Data.List (groupBy, sort)+import Data.Function (on)+import Data.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.Constrained.Feature+import Data.CRF.Chain1.Constrained.Dataset.Internal hiding (fromList)+import qualified Data.CRF.Chain1.Constrained.Dataset.Internal as A++-- | 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)+{-# INLINE dummyFeatIx #-}++isDummy :: FeatIx -> Bool+isDummy (FeatIx ix) = ix < 0+{-# INLINE isDummy #-}++notDummy :: FeatIx -> Bool+notDummy = not . isDummy+{-# INLINE notDummy #-}++-- | 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+    -- | Default set of potential labels.+    , r0        :: AVec Lb+    -- | 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 (AVec 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 (AVec 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 (AVec LbIx) }++instance Binary Model where+    put crf = do+        put $ values crf+        put $ ixMap crf+        put $ r0 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 the associations list.  We assume that+-- the set of labels is of the {0, 1, .. 'lbMax'} form and, similarly,+-- the set of observations is of the {0, 1, .. 'obMax'} form.+-- There should be no repetition of features in the input list.+-- TODO: We can change this function to take M.Map Feature Double.+fromList :: Ob -> Lb -> [(Feature, Double)] -> Model+fromList obMax' lbMax' fs =+    let _ixMap = M.fromList $ zip+            (map fst fs)+            (map FeatIx [0..])+    +        sFeats = [feat | (feat, _val) <- fs, isSFeat feat]+        tFeats = [feat | (feat, _val) <- fs, isTFeat feat]+        oFeats = [feat | (feat, _val) <- fs, isOFeat feat]++        obMax = unOb obMax'+        lbMax = unLb lbMax'+        _r0   = A.fromList (map Lb [0 .. lbMax])+        -- obMax = (unOb . maximum . Set.toList . obSet) (map fst fs)+        -- lbs   = (Set.toList . lbSet) (map fst fs)+        -- lbMax = (unLb . maximum) lbs+        -- _r0   = A.fromList lbs+        +        _sgIxsV = sgVects lbMax+            [ (unLb x, featToJustIx crf feat)+            | feat@(SFeature x) <- sFeats ]++        _prevIxsV = adjVects lbMax+            [ (unLb x, (y, featToJustIx crf feat))+            | feat@(TFeature x y) <- tFeats ]++        _nextIxsV = adjVects lbMax+            [ (unLb y, (x, featToJustIx crf feat))+            | feat@(TFeature x y) <- tFeats ]++        _obIxsV = adjVects obMax+            [ (unOb o, (x, featToJustIx crf feat))+            | feat@(OFeature o x) <- oFeats ]++        -- | Adjacency vectors.+        adjVects n xs =+            V.replicate (n + 1) (A.fromList []) V.// update+          where+            update = map mkVect $ groupBy ((==) `on` fst) $ sort xs+            mkVect (y:ys) = (fst y, A.fromList $ map snd (y:ys))+            mkVect [] = error "mkVect: null list"++        sgVects n xs = U.replicate (n + 1) dummyFeatIx U.// xs++        _values = U.replicate (length fs) 0.0+            U.// [ (featToJustInt crf feat, val)+                 | (feat, val) <- fs ]+        crf = Model _values _ixMap _r0 _sgIxsV _obIxsV _prevIxsV _nextIxsV+    in  crf++-- -- | Compute the set of observations.+-- obSet :: [Feature] -> Set.Set Ob+-- obSet =+--     Set.fromList . concatMap toObs+--   where+--     toObs (OFeature o _) = [o]+--     toObs _              = []+-- +-- -- | Compute the set of labels.+-- lbSet :: [Feature] -> Set.Set Lb+-- lbSet =+--     Set.fromList . concatMap toLbs+--   where+--     toLbs (SFeature x)   = [x]+--     toLbs (OFeature _ x) = [x]+--     toLbs (TFeature x y) = [x, y]++-- | Construct the model from the list of features.  All parameters will be+-- set to 0.  There can be repetitions in the input list.+-- We assume that the set of labels is of the {0, 1, .. 'lbMax'} form and,+-- similarly, the set of observations is of the {0, 1, .. 'obMax'} form.+mkModel :: Ob -> Lb -> [Feature] -> Model+mkModel obMax lbMax fs =+    let fSet = Set.fromList fs+        fs'  = Set.toList fSet+        vs   = replicate (Set.size fSet) 0.0+    in  fromList obMax lbMax (zip fs' vs)++-- | 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 index for the given feature.+featToIx :: Model -> Feature -> Maybe FeatIx+featToIx crf feat = M.lookup feat (ixMap crf)+{-# INLINE featToIx #-}++-- | Determine index for the given feature.  Throw error when+-- the feature is not a member of the model. +featToJustIx :: Model -> Feature -> FeatIx+featToJustIx _crf = fromJust . featToIx _crf+{-# INLINE featToJustIx #-}++-- | Determine index for the given feature and return it as an integer.+-- Throw error when the feature is not a member of the model.+featToJustInt :: Model -> Feature -> Int+featToJustInt _crf = unFeatIx . featToJustIx _crf+{-# INLINE featToJustInt #-}++-- | Potential value (in log domain) of the singular feature with the+-- given label.  The value defaults to 1 (0 in log domain) 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+        -- TODO: Is the value correct?+        -1 -> L.logToLogFloat (0 :: Float)+        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 -> AVec LbIx+obIxs crf x = 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 -> AVec LbIx+nextIxs crf x = 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 -> AVec LbIx+prevIxs crf x = prevIxsV crf V.! unLb x+{-# INLINE prevIxs #-}

@@ -0,0 +1,129 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PatternGuards #-}+++module Data.CRF.Chain1.Constrained.Train+( CRF (..)+, train+) where+++import Control.Applicative ((<$>), (<*>))+import System.IO (hSetBuffering, stdout, BufferMode (..))+import Data.Binary (Binary, put, get)+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Numeric.SGD as SGD+import qualified Numeric.SGD.LogSigned as L++import Data.CRF.Chain1.Constrained.Dataset.Internal+import Data.CRF.Chain1.Constrained.Dataset.External (SentL, unknown, unProb)+import Data.CRF.Chain1.Constrained.Dataset.Codec+    (mkCodec, Codec, obMax, lbMax, encodeDataL, encodeLabels)+import Data.CRF.Chain1.Constrained.Feature (Feature, featuresIn)+import Data.CRF.Chain1.Constrained.Model+    (Model (..), mkModel, FeatIx (..), featToJustInt)+import Data.CRF.Chain1.Constrained.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.+-- TODO: Accept custom r0 construction function.+train+    :: (Ord a, Ord b)+    => SGD.SgdArgs                  -- ^ Args for SGD+    -> Bool                         -- ^ Store dataset on a disk+    -> IO [SentL a b]               -- ^ Training data 'IO' action+    -> IO [SentL a b]               -- ^ Evaluation data+    -> (AVec Lb -> [(Xs, Ys)] -> [Feature])     -- ^ Feature selection+    -> IO (CRF a b)                 -- ^ Resulting model+train sgdArgs onDisk trainIO evalIO extractFeats = do+    hSetBuffering stdout NoBuffering++    -- Create codec and encode the training dataset+    codec <- mkCodec <$> trainIO+    trainData_ <- encodeDataL codec <$> trainIO+    SGD.withData onDisk trainData_ $ \trainData -> do++    -- Encode the evaluation dataset+    evalData_ <- encodeDataL codec <$> evalIO+    SGD.withData onDisk evalData_ $ \evalData -> do++    -- A default set of labels+    r0 <- encodeLabels codec . S.toList . unkSet <$> trainIO++    -- A set of features+    feats <- extractFeats r0 <$> SGD.loadData trainData++    -- Train the model+    let model = (mkModel (obMax codec) (lbMax codec) feats) { r0 = r0 }+    para <- SGD.sgd sgdArgs+        (notify sgdArgs model trainData evalData)+        (gradOn model) trainData (values model)+    return $ CRF codec (model { values = para })+++-- | Collect labels assigned to unknown words (with empty list+-- of potential interpretations).+unkSet :: Ord b => [SentL a b] -> S.Set b+unkSet =+    S.fromList . concatMap onSent+  where+    onSent = concatMap onWord+    onWord word+        | unknown (fst word)    = M.keys . unProb . snd $ word+        | otherwise             = []+++gradOn :: Model -> SGD.Para -> (Xs, Ys) -> SGD.Grad+gradOn model para (xs, ys) = SGD.fromLogList $+    [ (featToJustInt curr feat, L.fromPos val)+    | (feat, val) <- featuresIn xs ys ] +++    [ (ix, L.fromNeg val)+    | (FeatIx ix, val) <- expectedFeaturesIn curr xs ]+  where+    curr = model { values = para }+++notify+    :: SGD.SgdArgs -> Model+    -> SGD.Dataset (Xs, Ys)     -- ^ Training dataset+    -> SGD.Dataset (Xs, Ys)     -- ^ Evaluation dataset+    -> SGD.Para -> Int -> IO ()+notify SGD.SgdArgs{..} model trainData evalData para k+    | doneTotal k == doneTotal (k - 1) = putStr "."+    | SGD.size evalData > 0 = do+        x <- accuracy (model { values = para }) <$> SGD.loadData evalData+        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 = SGD.size trainData

@@ -0,0 +1,12 @@+module Data.CRF.Chain1.Constrained.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)