crf-chain2-generic 0.1.1 → 0.3.0

raw patch · 14 files changed

+626/−446 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/CRF/Chain2/Generic/Base.hs +0/−91
• Data/CRF/Chain2/Generic/Codec.hs +200/−0
• Data/CRF/Chain2/Generic/External.hs +4/−2
• Data/CRF/Chain2/Generic/FeatMap.hs +11/−0
• Data/CRF/Chain2/Generic/FeatMap/Map.hs +20/−0
• Data/CRF/Chain2/Generic/Inference.hs +25/−18
• Data/CRF/Chain2/Generic/Internal.hs +155/−8
• Data/CRF/Chain2/Generic/Model.hs +39/−56
• Data/CRF/Chain2/Generic/Train.hs +11/−7
• Data/CRF/Chain2/Pair.hs +35/−15
• Data/CRF/Chain2/Pair/Base.hs +7/−6
• Data/CRF/Chain2/Pair/Codec.hs +36/−237
• Data/CRF/Chain2/Pair/FeatMap.hs +73/−0
• crf-chain2-generic.cabal +10/−6

@@ -1,91 +0,0 @@-module Data.CRF.Chain2.Generic.Base-( AVec (unAVec)-, mkAVec-, AVec2 (unAVec2)-, mkAVec2--, X (_unX, _unR)-, Xs-, mkX-, unX-, unR-, lbAt--, Y (_unY)-, Ys-, mkY-, unY--, LbIx-) where--import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.Vector as V---- | An index of the label.-type LbIx = Int--newtype AVec a = AVec { unAVec :: V.Vector a }-    deriving (Show, Read, Eq, Ord)---- | Smart AVec constructor which ensures that the--- underlying vector is strictly ascending.-mkAVec :: Ord a => [a] -> AVec a-mkAVec = AVec . V.fromList . S.toAscList  . S.fromList -{-# INLINE mkAVec #-}--newtype AVec2 a b = AVec2 { unAVec2 :: V.Vector (a, b) }-    deriving (Show, Read, Eq, Ord)---- | Smart AVec constructor which ensures that the--- underlying vector is strictly ascending with respect--- to fst values.-mkAVec2 :: Ord a => [(a, b)] -> AVec2 a b-mkAVec2 = AVec2 . V.fromList . M.toAscList  . M.fromList -{-# INLINE mkAVec2 #-}---- | A word represented by a list of its observations--- and a list of its potential label interpretations.-data X o t = X-    { _unX :: AVec o-    , _unR :: AVec t }-    deriving (Show, Read, Eq, Ord)---- | Sentence of words.-type Xs o t = V.Vector (X o t)---- | X constructor.-mkX :: (Ord o, Ord t) => [o] -> [t] -> X o t-mkX x r  = X (mkAVec x) (mkAVec r)-{-# INLINE mkX #-}---- | List of observations.-unX :: X o t -> [o]-unX = V.toList . unAVec . _unX-{-# INLINE unX #-}---- | List of potential labels.-unR :: X o t -> [t]-unR = V.toList . unAVec . _unR-{-# INLINE unR #-}--lbAt :: X o t -> LbIx -> t-lbAt x = (unAVec (_unR x) V.!)-{-# INLINE lbAt #-}--newtype Y t = Y { _unY :: AVec2 t Double }-    deriving (Show, Read, Eq, Ord)---- | Y constructor.-mkY :: Ord t => [(t, Double)] -> Y t-mkY = Y . mkAVec2-{-# INLINE mkY #-}---- | Y deconstructor symetric to mkY.-unY :: Y t -> [(t, Double)]-unY = V.toList . unAVec2 . _unY-{-# INLINE unY #-}---- | Sentence of Y (label choices).-type Ys t = V.Vector (Y t)

@@ -0,0 +1,200 @@+{-# LANGUAGE RecordWildCards #-}++module Data.CRF.Chain2.Generic.Codec+( CodecM+, Codec (..)++, encodeWord'Cu+, encodeWord'Cn+, encodeSent'Cu+, encodeSent'Cn+, encodeSent++, encodeWordL'Cu+, encodeWordL'Cn+, encodeSentL'Cu+, encodeSentL'Cn+, encodeSentL++, decodeLabel+, decodeLabels+, unJust++, mkCodec+, encodeData+, encodeDataL+) where++import Control.Applicative (pure, (<$>), (<*>))+import Data.Maybe (catMaybes)+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.Chain2.Generic.Internal+import Data.CRF.Chain2.Generic.External++-- | A codec monad.+type CodecM c a = C.Codec c a++-- | An abstract codec representation with external observation type+-- 'a', external label type 'b', codec data type 'c', internal+-- observation type 'o' and internal label type 'e'.+data Codec a b c o e = Codec {+    -- | Empty codec.+      empty     :: c+    -- | Encode the observation and update the codec+    -- (only in the encoding direction).+    , encodeObU :: a -> CodecM c o+    -- | Encode the observation and do *not* update the codec.+    , encodeObN :: a -> CodecM c (Maybe o)+    -- | Encode the label and update the codec.+    , encodeLbU :: b -> CodecM c e+    -- | Encode the label and do *not* update the codec.+    -- In case the label is not a member of the codec,+    -- return the label code assigned to Nothing label.+    , encodeLbN :: b -> CodecM c e+    -- | Decode the label within the codec monad.+    , decodeLbC :: e -> CodecM c (Maybe b)+    -- | Is label a member of the codec?+    , hasLabel  :: c -> b -> Bool }++-- | Encode the labeled word and update the codec.+encodeWordL'Cu+    :: (Ord e, Ord o) => Codec a b c o e+    -> WordL a b -> CodecM c (X o e, Y e)+encodeWordL'Cu Codec{..} (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 . unDist) choice ]+    return (x, y)++-- | Encodec the labeled word and do *not* update the codec.+encodeWordL'Cn+    :: (Ord e, Ord o) => Codec a b c o e+    -> WordL a b -> CodecM c (X o e, Y e)+encodeWordL'Cn Codec{..} (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 . unDist) choice ]+    return (x, y)++-- | Encode the word and update the codec.+encodeWord'Cu+    :: (Ord e, Ord o) => Codec a b c o e+    -> Word a b -> CodecM c (X o e)+encodeWord'Cu Codec{..} 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 e, Ord o) => Codec a b c o e+    -> Word a b -> CodecM c (X o e)+encodeWord'Cn Codec{..} 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 e, Ord o) => Codec a b c o e+    -> SentL a b -> CodecM c (Xs o e, Ys e)+encodeSentL'Cu cdc sent = do+    ps <- mapM (encodeWordL'Cu cdc) 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 e, Ord o) => Codec a b c o e+    -> SentL a b -> CodecM c (Xs o e, Ys e)+encodeSentL'Cn cdc sent = do+    ps <- mapM (encodeWordL'Cn cdc) 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 e, Ord o) => Codec a b c o e+    -> c -> SentL a b -> (Xs o e, Ys e)+encodeSentL cdc cdcData = C.evalCodec cdcData . encodeSentL'Cn cdc++-- | Encode the sentence and update the codec.+encodeSent'Cu+    :: (Ord e, Ord o) => Codec a b c o e+    -> Sent a b -> CodecM c (Xs o e)+encodeSent'Cu cdc = fmap V.fromList . mapM (encodeWord'Cu cdc)++-- | Encode the sentence and do *not* update the codec.+encodeSent'Cn+    :: (Ord e, Ord o) => Codec a b c o e+    -> Sent a b -> CodecM c (Xs o e)+encodeSent'Cn cdc = fmap V.fromList . mapM (encodeWord'Cn cdc)++-- | Encode the sentence using the given codec.+encodeSent+    :: (Ord e, Ord o) => Codec a b c o e+    -> c -> Sent a b -> Xs o e+encodeSent cdc cdcData = C.evalCodec cdcData . encodeSent'Cn cdc++-- | Create the codec on the basis of the labeled dataset, return the+-- resultant codec and the encoded dataset.+mkCodec+    :: (Ord e, Ord o) => Codec a b c o e+    -> [SentL a b] -> (c, [(Xs o e, Ys e)])+mkCodec cdc+    = swap+    . C.runCodec (empty cdc)+    . mapM (encodeSentL'Cu cdc)+  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 e, Ord o) => Codec a b c o e+    -> c -> [SentL a b] -> [(Xs o e, Ys e)]+encodeDataL cdc cdcData = C.evalCodec cdcData . mapM (encodeSentL'Cn cdc)++-- | Encode the dataset with the codec.+encodeData+    :: (Ord e, Ord o) => Codec a b c o e+    -> c -> [Sent a b] -> [Xs o e]+encodeData cdc cdcData = map (encodeSent cdc cdcData)++-- | Decode the label.+decodeLabel :: Codec a b c o e -> c -> e -> Maybe b+decodeLabel cdc cdcData = C.evalCodec cdcData . decodeLbC cdc++-- | Decode the sequence of labels.+decodeLabels :: Codec a b c o e -> c -> [e] -> [Maybe b]+decodeLabels cdc cdcData = C.evalCodec cdcData . mapM (decodeLbC cdc)++-- | Return the label when 'Just' or one of the unknown values+-- when 'Nothing'.+unJust :: Codec a b c o e -> c -> Word a b -> Maybe b -> b+unJust _ _ _ (Just x) = x+unJust cdc cdcData word Nothing = case allUnk of+    (x:_)   -> x+    []      -> error "unJust: Nothing and all values known"+  where+    allUnk = filter (not . hasLabel cdc cdcData) (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,3 +1,5 @@+-- | External data representation.+ module Data.CRF.Chain2.Generic.External ( Word (obs, lbs) , mkWord@@ -11,8 +13,7 @@ import qualified Data.Set as S import qualified Data.Map as M --- | A word with 'a' representing the observation type and 'b' representing--- the compound label type.+-- | A word consists of a set of observations and a set of potential labels. data Word a b = Word {     -- | Set of observations.       obs   :: S.Set a@@ -27,6 +28,7 @@     | S.null _lbs   = error "mkWord: empty set of potential labels"     | otherwise     = Word _obs _lbs +-- | A sentence of words. type Sent a b = [Word a b]  -- | A probability distribution defined over elements of type a.

@@ -0,0 +1,11 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Data.CRF.Chain2.Generic.FeatMap+( FeatMap (..)+) where++import Data.CRF.Chain2.Generic.Internal++class FeatMap m f where+    featIndex   :: f -> m f -> Maybe FeatIx+    mkFeatMap   :: [(f, FeatIx)] -> m f

@@ -0,0 +1,20 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.CRF.Chain2.Generic.FeatMap.Map+( FeatMap (..)+) where++import Data.Binary (Binary)+import qualified Data.Map as M++import Data.CRF.Chain2.Generic.Internal+import qualified Data.CRF.Chain2.Generic.FeatMap as C++newtype FeatMap f = FeatMap { unFeatMap :: M.Map f FeatIx }+    deriving (Show, Eq, Ord, Binary)++instance Ord f => C.FeatMap FeatMap f where+    featIndex x (FeatMap m) = M.lookup x m+    mkFeatMap = FeatMap . M.fromList

@@ -20,7 +20,8 @@ import Control.Parallel (par, pseq) import GHC.Conc (numCapabilities) -import Data.CRF.Chain2.Generic.Base+import Data.CRF.Chain2.Generic.Internal+import Data.CRF.Chain2.Generic.FeatMap import Data.CRF.Chain2.Generic.Model import Data.CRF.Chain2.Generic.Util (partition) import qualified Data.CRF.Chain2.Generic.DP as DP@@ -33,12 +34,14 @@  type ProbArray = LbIx -> LbIx -> LbIx -> L.LogFloat -computePsi :: Ord f => Model o t f -> Xs o t -> Int -> LbIx -> L.LogFloat+computePsi+    :: FeatMap m f => Model m o t f+    -> Xs o t -> Int -> LbIx -> L.LogFloat computePsi crf xs i = (A.!) $ A.array (0, lbNum xs i - 1)     [ (k, onWord crf xs i k)     | k <- lbIxs xs i ] -forward :: Ord f => AccF -> Model o t f -> Xs o t -> ProbArray+forward :: FeatMap m f => AccF -> Model m o t f -> Xs o t -> ProbArray forward acc crf sent = alpha where     alpha = DP.flexible3 (-1, V.length sent - 1)                 (\i   -> (0, lbNum sent i - 1))@@ -51,7 +54,7 @@             * onTransition crf sent i j k h             | h <- lbIxs sent (i - 2) ] -backward :: Ord f => AccF -> Model o t f -> Xs o t -> ProbArray+backward :: FeatMap m f => AccF -> Model m o t f -> Xs o t -> ProbArray backward acc crf sent = beta where     beta = DP.flexible3 (0, V.length sent)                (\i   -> (0, lbNum sent (i - 1) - 1))@@ -74,10 +77,10 @@     , j <- lbIxs sent (n - 2) ]     where n = V.length sent -zx :: Ord f => Model o t f -> Xs o t -> L.LogFloat+zx :: FeatMap m f => Model m o t f -> Xs o t -> L.LogFloat zx crf = zxBeta . backward sum crf -zx' :: Ord f => Model o t f -> Xs o t -> L.LogFloat+zx' :: FeatMap m f => Model m o t f -> Xs o t -> L.LogFloat zx' crf sent = zxAlpha sum sent (forward sum crf sent)  argmax :: (Ord b) => (a -> b) -> [a] -> (a, b)@@ -86,7 +89,7 @@               | v1 > v2 = (x1, v1)               | otherwise = (x2, v2) -tagIxs :: Ord f => Model o t f -> Xs o t -> [Int]+tagIxs :: FeatMap m f => Model m o t f -> Xs o t -> [Int] tagIxs crf sent = collectMaxArg (0, 0, 0) [] mem where     mem = DP.flexible3 (0, V.length sent)                        (\i   -> (0, lbNum sent (i - 1) - 1))@@ -104,12 +107,12 @@                   | h == -1 = reverse acc                   | otherwise = collectMaxArg (i + 1, h, j) (h:acc) mem -tag :: Ord f => Model o t f -> Xs o t -> [t]+tag :: FeatMap m f => Model m o t f -> Xs o t -> [t] tag crf sent =     let ixs = tagIxs crf sent     in  [lbAt x i | (x, i) <- zip (V.toList sent) ixs] -probs :: Ord f => Model o t f -> Xs o t -> [[L.LogFloat]]+probs :: FeatMap m f => Model m o t f -> Xs o t -> [[L.LogFloat]] probs crf sent =     let alpha = forward maximum crf sent         beta = backward maximum crf sent@@ -122,7 +125,7 @@     in  [ normalize [m1 i k | k <- lbIxs sent i]         | i <- [0 .. V.length sent - 1] ] -marginals :: Ord f => Model o t f -> Xs o t -> [[L.LogFloat]]+marginals :: FeatMap m f => Model m o t f -> Xs o t -> [[L.LogFloat]] marginals crf sent =     let alpha = forward sum crf sent         beta = backward sum crf sent@@ -130,7 +133,9 @@           | k <- lbIxs sent i ]         | i <- [0 .. V.length sent - 1] ] -goodAndBad :: (Eq t, Ord f) => Model o t f -> Xs o t -> Ys t -> (Int, Int)+goodAndBad+    :: (Eq t, FeatMap m f) => Model m o t f+    -> Xs o t -> Ys t -> (Int, Int) goodAndBad crf xs ys =     foldl gather (0, 0) $ zip labels labels'   where@@ -144,13 +149,15 @@         | x == y = (good + 1, bad)         | otherwise = (good, bad + 1) -goodAndBad' :: (Eq t, Ord f) => Model o t f -> [(Xs o t, Ys t)] -> (Int, Int)+goodAndBad'+    :: (Eq t, FeatMap m f) => Model m o t f+    -> [(Xs o t, Ys t)] -> (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 :: (Eq t, Ord f) => Model o t f -> [(Xs o t, Ys t)] -> Double+accuracy :: (Eq t, FeatMap m f) => Model m o t f -> [(Xs o t, Ys t)] -> Double accuracy crf dataset =     let k = numCapabilities     	parts = partition k dataset@@ -160,7 +167,7 @@     in  fromIntegral good / fromIntegral (good + bad)  prob3-    :: Ord f => Model o t f -> ProbArray -> ProbArray -> Xs o t+    :: FeatMap m f => Model m o t f -> ProbArray -> ProbArray -> Xs o t     -> Int -> (LbIx -> L.LogFloat) -> LbIx -> LbIx -> LbIx     -> L.LogFloat prob3 crf alpha beta sent k psiMem x y z =@@ -169,21 +176,21 @@ {-# INLINE prob3 #-}  prob2-    :: Model o t f -> ProbArray -> ProbArray+    :: Model m o t f -> ProbArray -> ProbArray     -> Xs o t -> Int -> LbIx -> LbIx -> L.LogFloat prob2 _ alpha beta _ k x y =     alpha k x y * beta (k + 1) x y / zxBeta beta {-# INLINE prob2 #-}  prob1-    :: Model o t f -> ProbArray -> ProbArray+    :: Model m o t f -> ProbArray -> ProbArray     -> Xs o t -> Int -> LbIx -> L.LogFloat prob1 crf alpha beta sent k x = sum     [ prob2 crf alpha beta sent k x y     | y <- lbIxs sent (k - 1) ]  expectedFeaturesOn-    :: Ord f => Model o t f -> ProbArray -> ProbArray+    :: FeatMap m f => Model m o t f -> ProbArray -> ProbArray     -> Xs o t -> Int -> [(f, L.LogFloat)] expectedFeaturesOn crf alpha beta sent k =     fs3 ++ fs1@@ -203,7 +210,7 @@           obFs = obFeatsOn (featGen crf) sent k           trFs = trFeatsOn (featGen crf) sent k -expectedFeatures :: Ord f => Model o t f -> Xs o t -> [(f, L.LogFloat)]+expectedFeatures :: FeatMap m f => Model m o t f -> Xs o t -> [(f, L.LogFloat)] expectedFeatures crf sent =     -- force parallel computation of alpha and beta tables     zx1 `par` zx2 `pseq` zx1 `pseq` concat

@@ -1,27 +1,174 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Internal core data types.+ module Data.CRF.Chain2.Generic.Internal-( lbNum+(+-- * Input element (word)+  X (_unX, _unR)+, Xs+, mkX+, unX+, unR++-- * Output element (choice)+, Y (_unY)+, Ys+, mkY+, unY++-- * Indexing+, lbAt , lbOn+, lbNum , lbIxs++-- * Feature index++, FeatIx (..)++-- * Auxiliary+, LbIx+, AVec (unAVec)+, mkAVec+, AVec2 (unAVec2)+, mkAVec2 ) where +import Data.Binary (Binary)+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Array.Unboxed as A import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Generic.Base as G+import qualified Data.Vector.Generic.Mutable as G -import Data.CRF.Chain2.Generic.Base+-- | An index of the label.+type LbIx = Int +-- | An ascending vector of distinct elements.+newtype AVec a = AVec { unAVec :: V.Vector a }+    deriving (Show, Eq, Ord)++-- | Smart AVec constructor which ensures that the+-- underlying vector is strictly ascending.+mkAVec :: Ord a => [a] -> AVec a+mkAVec = AVec . V.fromList . S.toAscList  . S.fromList +{-# INLINE mkAVec #-}++-- | An ascending vector of distinct elements with respect+-- to 'fst' values.+newtype AVec2 a b = AVec2 { unAVec2 :: V.Vector (a, b) }+    deriving (Show, Eq, Ord)++-- | Smart AVec constructor which ensures that the+-- underlying vector is strictly ascending with respect+-- to fst values.+mkAVec2 :: Ord a => [(a, b)] -> AVec2 a b+mkAVec2 = AVec2 . V.fromList . M.toAscList  . M.fromList +{-# INLINE mkAVec2 #-}++-- | A word represented by a list of its observations+-- and a list of its potential label interpretations.+data X o t = X {+    -- | A vector of observations.+      _unX :: AVec o+    -- | A vector of potential labels.+    , _unR :: AVec t }+    deriving (Show, Eq, Ord)++-- | Sentence of words.+type Xs o t = V.Vector (X o t)++-- | X constructor.+mkX :: (Ord o, Ord t) => [o] -> [t] -> X o t+mkX x r  = X (mkAVec x) (mkAVec r)+{-# INLINE mkX #-}++-- | List of observations.+unX :: X o t -> [o]+unX = V.toList . unAVec . _unX+{-# INLINE unX #-}++-- | List of potential labels.+unR :: X o t -> [t]+unR = V.toList . unAVec . _unR+{-# INLINE unR #-}++-- | Vector of chosen labels together with+-- corresponding probabilities.+newtype Y t = Y { _unY :: AVec2 t Double }+    deriving (Show, Eq, Ord)++-- | Y constructor.+mkY :: Ord t => [(t, Double)] -> Y t+mkY = Y . mkAVec2+{-# INLINE mkY #-}++-- | Y deconstructor symetric to mkY.+unY :: Y t -> [(t, Double)]+unY = V.toList . unAVec2 . _unY+{-# INLINE unY #-}++-- | Sentence of Y (label choices).+type Ys t = V.Vector (Y t)++-- | Potential label at the given position.+lbAt :: X o t -> LbIx -> t+lbAt x = (unAVec (_unR x) V.!)+{-# INLINE lbAt #-}+ lbVec :: Xs o t -> Int -> AVec t lbVec xs = _unR . (xs V.!) {-# INLINE lbVec #-} --- | Number of potential labels on the given position of the sentence.+-- | Number of potential labels at the given position of the sentence.+lbNumI :: Xs o t -> Int -> Int+lbNumI xs = V.length . unAVec . lbVec xs+{-# INLINE lbNumI #-}++-- | Potential label at the given position and at the given index.+lbOnI :: Xs o t -> Int -> LbIx -> t+lbOnI xs = (V.!) . unAVec . lbVec xs+{-# INLINE lbOnI #-}++-- | List of label indices at the given position.+lbIxsI :: Xs o t -> Int -> [LbIx]+lbIxsI xs i = [0 .. lbNum xs i - 1]+{-# INLINE lbIxsI #-}++-- | Number of potential labels at the given position of the sentence.+-- Function extended to indices outside the positions' domain. lbNum :: Xs o t -> Int -> Int-lbNum xs = V.length . unAVec . lbVec xs+lbNum xs i+    | i < 0 || i >= n   = 1+    | otherwise         = lbNumI xs i+  where+    n = V.length xs {-# INLINE lbNum #-} --- | Potential label on the given vector position.-lbOn :: Xs o t -> Int -> LbIx -> t-lbOn xs = (V.!) . unAVec . lbVec xs+-- | Potential label at the given position and at the given index.+-- Return Nothing for positions outside the domain.+lbOn :: Xs o t -> Int -> LbIx -> Maybe t+lbOn xs i+    | i < 0 || i >= n   = const Nothing+    | otherwise         = Just . lbOnI xs i+  where+    n = V.length xs {-# INLINE lbOn #-} +-- | List of label indices at the given position.  Function extended to+-- indices outside the positions' domain. lbIxs :: Xs o t -> Int -> [LbIx]-lbIxs xs i = [0 .. lbNum xs i - 1]+lbIxs xs i+    | i < 0 || i >= n   = [0]+    | otherwise         = lbIxsI xs i+  where+    n = V.length xs {-# INLINE lbIxs #-}++-- | A feature index.  To every model feature a unique index is assigned.+newtype FeatIx = FeatIx { unFeatIx :: Int }+    deriving ( Show, Eq, Ord, Binary, A.IArray A.UArray+             , G.Vector U.Vector, G.MVector U.MVector, U.Unbox )

@@ -1,9 +1,11 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}  module Data.CRF.Chain2.Generic.Model-( FeatIx (..)-, FeatGen (..)+( FeatGen (..)+, FeatSel+, selectPresent+, selectHidden , Model (..) , mkModel , Core (..)@@ -27,20 +29,12 @@ import Data.Binary (Binary, put, get) import Data.Vector.Binary () import qualified Data.Set as S-import qualified Data.Map as M import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U-import qualified Data.Vector.Generic.Base as G-import qualified Data.Vector.Generic.Mutable as G import qualified Data.Number.LogFloat as L -import Data.CRF.Chain2.Generic.Base-import qualified Data.CRF.Chain2.Generic.Internal as I---- | 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 )+import Data.CRF.Chain2.Generic.Internal+import Data.CRF.Chain2.Generic.FeatMap  -- | Feature generation specification. data FeatGen o t f = FeatGen@@ -50,27 +44,27 @@     , trFeats3  :: t -> t -> t -> [f] }  -- | A conditional random field.-data Model o t f = Model+data Model m o t f = Model     { values    :: U.Vector Double-    , ixMap     :: M.Map f FeatIx+    , ixMap     :: m f     , featGen   :: FeatGen o t f }  -- | A core of the model with no feature generation function. -- Unlike the 'Model', the core can be serialized. -data Core f = Core+data Core m f = Core     { valuesC   :: U.Vector Double-    , ixMapC    :: M.Map f FeatIx }+    , ixMapC    :: m f } -instance (Ord f, Binary f) => Binary (Core f) where+instance Binary (m f) => Binary (Core m f) where     put Core{..} = put valuesC >> put ixMapC     get = Core <$> get <*> get  -- | Extract the model core.-core :: Model o t f -> Core f+core :: Model m o t f -> Core m f core Model{..} = Core values ixMap  -- | Construct model with the given core and feature generation function.-withCore :: Core f -> FeatGen o t f -> Model o t f+withCore :: Core m f -> FeatGen o t f -> Model m o t f withCore Core{..} ftGen = Model valuesC ixMapC ftGen  -- | Features present in the dataset element together with corresponding@@ -117,30 +111,43 @@         , v <- lbIxs xs $ i - 1         , w <- lbIxs xs $ i - 2 ] --- | FINISH: Dodać ekstrację liczby cech ze zbioru danych,--- zmienić funkcję mkModel.-mkModel :: Ord f => FeatGen o t f -> [Xs o t] -> Model o t f-mkModel fg dataset = Model+-- | A feature selection function type.+type FeatSel o t f = FeatGen o t f -> Xs o t -> Ys t -> [f]++-- | The 'presentFeats' adapted to fit feature selection specs.+selectPresent :: FeatSel o t f+selectPresent fg xs = map fst . presentFeats fg xs++-- | The 'hiddenFeats' adapted to fit feature selection specs.+selectHidden :: FeatSel o t f+selectHidden fg xs _ = hiddenFeats fg xs++mkModel+    :: (Ord f, FeatMap m f)+    => FeatGen o t f -> FeatSel o t f+    -> [(Xs o t, Ys t)] -> Model m o t f+mkModel fg ftSel dataset = Model     { values    = U.replicate (S.size fs) 0.0      , ixMap     =         let featIxs = map FeatIx [0..]             featLst = S.toList fs-        in  M.fromList (zip featLst featIxs)+        in  mkFeatMap (zip featLst featIxs)     , featGen   = fg }   where-    fs = S.fromList $ concatMap (hiddenFeats fg) dataset+    fs = S.fromList $ concatMap select dataset+    select = uncurry (ftSel fg)  -- | Potential assigned to the feature -- exponential of the -- corresonding parameter.-phi :: Ord f => Model o t f -> f -> L.LogFloat-phi Model{..} ft = case M.lookup ft ixMap of+phi :: FeatMap m f => Model m o t f -> f -> L.LogFloat+phi Model{..} ft = case featIndex ft ixMap of     Just ix -> L.logToLogFloat (values U.! unFeatIx ix)     Nothing -> L.logToLogFloat (0 :: Float) {-# INLINE phi #-}  -- | Index of the feature.-index :: Ord f => Model o t f -> f -> Maybe FeatIx-index Model{..} ft = M.lookup ft ixMap+index :: FeatMap m f => Model m o t f -> f -> Maybe FeatIx+index Model{..} ft = featIndex ft ixMap {-# INLINE index #-}  obFeatsOn :: FeatGen o t f -> Xs o t -> Int -> LbIx -> [f]@@ -168,38 +175,14 @@     doIt _ _ _                      = [] {-# INLINE trFeatsOn #-} -onWord :: Ord f => Model o t f -> Xs o t -> Int -> LbIx -> L.LogFloat+onWord :: FeatMap m f => Model m o t f -> Xs o t -> Int -> LbIx -> L.LogFloat onWord crf xs i u =     product . map (phi crf) $ obFeatsOn (featGen crf) xs i u {-# INLINE onWord #-}  onTransition-    :: Ord f => Model o t f -> Xs o t -> Int+    :: FeatMap m f => Model m o t f -> Xs o t -> Int     -> LbIx -> LbIx -> LbIx -> L.LogFloat onTransition crf xs i u w v =     product . map (phi crf) $ trFeatsOn (featGen crf) xs i u w v {-# INLINE onTransition #-}--lbNum :: Xs o t -> Int -> Int-lbNum xs i-    | i < 0 || i >= n   = 1-    | otherwise         = I.lbNum xs i-  where-    n = V.length xs-{-# INLINE lbNum #-}--lbOn :: Xs o t -> Int -> LbIx -> Maybe t-lbOn xs i-    | i < 0 || i >= n   = const Nothing-    | otherwise         = Just . I.lbOn xs i-  where-    n = V.length xs-{-# INLINE lbOn #-}--lbIxs :: Xs o t -> Int -> [LbIx]-lbIxs xs i-    | i < 0 || i >= n   = [0]-    | otherwise         = I.lbIxs xs i-  where-    n = V.length xs-{-# INLINE lbIxs #-}

@@ -13,7 +13,8 @@ import qualified Numeric.SGD as SGD import qualified Numeric.SGD.LogSigned as L -import Data.CRF.Chain2.Generic.Base+import Data.CRF.Chain2.Generic.Internal+import Data.CRF.Chain2.Generic.FeatMap import Data.CRF.Chain2.Generic.External (SentL) import Data.CRF.Chain2.Generic.Model import Data.CRF.Chain2.Generic.Inference (expectedFeatures, accuracy)@@ -29,26 +30,29 @@ -- on the evaluation part every full iteration over the training part. -- TODO: Add custom feature extraction function. train-    :: (Ord a, Ord b, Eq t, Ord f)+    :: (Ord a, Ord b, Eq t, Ord f, FeatMap m f)     => SGD.SgdArgs                  -- ^ Args for SGD     -> CodecSpec a b c o t          -- ^ Codec specification     -> FeatGen o t f                -- ^ Feature generation+    -> FeatSel o t f                -- ^ Feature selection     -> IO [SentL a b]               -- ^ Training data 'IO' action     -> Maybe (IO [SentL a b])       -- ^ Maybe evalation data-    -> IO (c, Model o t f)          -- ^ Resulting codec and model-train sgdArgs CodecSpec{..} ftGen trainIO evalIO'Maybe = do+    -> IO (c, Model m o t f)        -- ^ Resulting codec and model+train sgdArgs CodecSpec{..} ftGen ftSel trainIO evalIO'Maybe = do     hSetBuffering stdout NoBuffering     (codec, trainData) <- mkCodec <$> trainIO     evalDataM <- case evalIO'Maybe of         Just evalIO -> Just . encode codec <$> evalIO         Nothing     -> return Nothing-    let crf = mkModel ftGen (map fst trainData)+    let crf = mkModel ftGen ftSel trainData     para <- SGD.sgdM sgdArgs         (notify sgdArgs crf trainData evalDataM)         (gradOn crf) (V.fromList trainData) (values crf)     return (codec, crf { values = para }) -gradOn :: Ord f => Model o t f -> SGD.Para -> (Xs o t, Ys t) -> SGD.Grad+gradOn+    :: FeatMap m f => Model m o t f+    -> SGD.Para -> (Xs o t, Ys t) -> SGD.Grad gradOn crf para (xs, ys) = SGD.fromLogList $     [ (ix, L.fromPos val)     | (ft, val) <- presentFeats (featGen curr) xs ys@@ -60,7 +64,7 @@     curr = crf { values = para }  notify-    :: (Eq t, Ord f) => SGD.SgdArgs -> Model o t f -> [(Xs o t, Ys t)]+    :: (Eq t, FeatMap m f) => SGD.SgdArgs -> Model m o t f -> [(Xs o t, Ys t)]     -> Maybe [(Xs o t, Ys t)] -> SGD.Para -> Int -> IO () notify SGD.SgdArgs{..} crf trainData evalDataM para k      | doneTotal k == doneTotal (k - 1) = putStr "."

@@ -3,6 +3,7 @@ module Data.CRF.Chain2.Pair (  -- * Data types+-- ** External   Word (..) , mkWord , Sent@@ -10,6 +11,12 @@ , mkDist , WordL , SentL+-- * Internal+, Ob (..)+, Lb1 (..)+, Lb2 (..)+, Lb+, Feat (..)  -- * CRF , CRF (..)@@ -17,63 +24,76 @@ , train -- ** Tagging , tag++-- * Feature selection+, FeatSel+, selectHidden+, selectPresent ) where  import Control.Applicative ((<$>), (<*>))  import Data.Binary (Binary, get, put) import qualified Numeric.SGD as SGD -import Data.CRF.Chain2.Generic.Model (Model, core, withCore)+import Data.CRF.Chain2.Generic.Model+    (Model, FeatSel, selectHidden, selectPresent, core, withCore)+import Data.CRF.Chain2.Generic.Codec import Data.CRF.Chain2.Generic.External import qualified Data.CRF.Chain2.Generic.Inference as I import qualified Data.CRF.Chain2.Generic.Train as T  import Data.CRF.Chain2.Pair.Base-import Data.CRF.Chain2.Pair.Codec+import Data.CRF.Chain2.Pair.FeatMap+import Data.CRF.Chain2.Pair.Codec (codec, CodecData)  data CRF a b c = CRF-    { codec :: Codec a b c-    , model :: Model Ob Lb Feat }+    { codecData :: CodecData a b c+    , model     :: Model FeatMap Ob Lb Feat }  instance (Ord a, Ord b, Ord c, Binary a, Binary b, Binary c)     => Binary (CRF a b c) where-    put CRF{..} = put codec >> put (core model)+    put CRF{..} = put codecData >> put (core model)     get = CRF <$> get <*> do         _core <- get         return $ withCore _core featGen -codecSpec :: (Ord a, Ord b, Ord c) => T.CodecSpec a (b, c) (Codec a b c) Ob Lb+codecSpec+    :: (Ord a, Ord b, Ord c)+    => T.CodecSpec a (b, c) (CodecData a b c) Ob Lb codecSpec = T.CodecSpec-    { T.mkCodec = mkCodec-    , T.encode  = encodeDataL }+    { T.mkCodec = mkCodec codec+    , T.encode  = encodeDataL codec }  -- | Train the CRF using the stochastic gradient descent method. -- 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: Add custom feature extraction function.+-- Use the provided feature selection function to determine model+-- features. train     :: (Ord a, Ord b, Ord c)     => SGD.SgdArgs                  -- ^ Args for SGD+    -> FeatSel Ob Lb Feat           -- ^ Feature selection     -> IO [SentL a (b, c)]          -- ^ Training data 'IO' action     -> Maybe (IO [SentL a (b, c)])  -- ^ Maybe evalation data     -> IO (CRF a b c)               -- ^ Resulting codec and model-train sgdArgs trainIO evalIO'Maybe = do-    (_codec, _model) <- T.train+train sgdArgs featSel trainIO evalIO'Maybe = do+    (_codecData, _model) <- T.train         sgdArgs         codecSpec         featGen+        featSel         trainIO         evalIO'Maybe-    return $ CRF _codec _model+    return $ CRF _codecData _model  -- | Find the most probable label sequence. tag :: (Ord a, Ord b, Ord c) => CRF a b c -> Sent a (b, c) -> [(b, c)] tag CRF{..} sent-    = onWords . decodeLabels codec-    . I.tag model . encodeSent codec+    = onWords . decodeLabels codec codecData+    . I.tag model . encodeSent codec codecData     $ sent   where     onWords xs =-        [ unJust codec word x+        [ unJust codec codecData word x         | (word, x) <- zip sent xs ]

@@ -10,24 +10,25 @@ ) where  import Control.Applicative ((<$>), (<*>)) +import Data.Ix (Ix) import Data.Binary (Binary, get, put, Put, Get)  import Data.CRF.Chain2.Generic.Model (FeatGen(..)) -newtype Ob  = Ob  { unOb  :: Int } deriving (Show, Eq, Ord, Binary)-newtype Lb1 = Lb1 { unLb1 :: Int } deriving (Show, Eq, Ord, Binary)-newtype Lb2 = Lb2 { unLb2 :: Int } deriving (Show, Eq, Ord, Binary)+newtype Ob  = Ob  { unOb  :: Int } deriving (Show, Eq, Ord, Ix, Binary)+newtype Lb1 = Lb1 { unLb1 :: Int } deriving (Show, Eq, Ord, Ix, Binary)+newtype Lb2 = Lb2 { unLb2 :: Int } deriving (Show, Eq, Ord, Ix, Binary) type Lb = (Lb1, Lb2)  data Feat-    = OFeat'1   {-# UNPACK #-} !Ob  {-# UNPACK #-} !Lb1-    | OFeat'2   {-# UNPACK #-} !Ob  {-# UNPACK #-} !Lb2-    | TFeat3'1  {-# UNPACK #-} !Lb1 {-# UNPACK #-} !Lb1 {-# UNPACK #-} !Lb1+    = TFeat3'1  {-# UNPACK #-} !Lb1 {-# UNPACK #-} !Lb1 {-# UNPACK #-} !Lb1     | TFeat3'2  {-# UNPACK #-} !Lb2 {-# UNPACK #-} !Lb2 {-# UNPACK #-} !Lb2     | TFeat2'1  {-# UNPACK #-} !Lb1 {-# UNPACK #-} !Lb1     | TFeat2'2  {-# UNPACK #-} !Lb2 {-# UNPACK #-} !Lb2     | TFeat1'1  {-# UNPACK #-} !Lb1     | TFeat1'2  {-# UNPACK #-} !Lb2+    | OFeat'1   {-# UNPACK #-} !Ob  {-# UNPACK #-} !Lb1+    | OFeat'2   {-# UNPACK #-} !Ob  {-# UNPACK #-} !Lb2     deriving (Show, Eq, Ord)  instance Binary Feat where

@@ -1,48 +1,25 @@ module Data.CRF.Chain2.Pair.Codec-( Codec-, CodecM+( CodecData , obMax , lb1Max , lb2Max--, encodeWord'Cu-, encodeWord'Cn-, encodeSent'Cu-, encodeSent'Cn-, encodeSent--, encodeWordL'Cu-, encodeWordL'Cn-, encodeSentL'Cu-, encodeSentL'Cn-, encodeSentL--, decodeLabel-, decodeLabels-, unJust--, mkCodec-, encodeData-, encodeDataL+, codec ) where -import Control.Applicative (pure, (<$>), (<*>))+import Control.Applicative ((<$>), (<*>)) import Control.Comonad.Trans.Store (store)-import Data.Maybe (fromJust, catMaybes)+import Data.Maybe (fromJust) import Data.Lens.Common (Lens(..))-import qualified Data.Set as S import qualified Data.Map as M-import qualified Data.Vector as V import qualified Control.Monad.Codec as C +import Data.CRF.Chain2.Generic.Codec (Codec(..)) import Data.CRF.Chain2.Pair.Base-import Data.CRF.Chain2.Generic.Base-import Data.CRF.Chain2.Generic.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, -- third -- labels of type c from the third level.-type Codec a b c =+type CodecData a b c =     ( C.AtomCodec a     , C.AtomCodec (Maybe b)     , C.AtomCodec (Maybe c) )@@ -69,225 +46,47 @@ _3Lens = Lens $ \(a, b, c) -> store (\c' -> (a, b, c')) c  -- | The maximum internal observation included in the codec.-obMax :: Codec a b c -> Ob+obMax :: CodecData a b c -> Ob obMax =     let idMax m = M.size m - 1     in  Ob . idMax . C.to . _1  -- | The maximum internal label included in the codec.-lb1Max :: Codec a b c -> Lb1+lb1Max :: CodecData a b c -> Lb1 lb1Max =     let idMax m = M.size m - 1     in  Lb1 . idMax . C.to . _2  -- | The maximum internal label included in the codec.-lb2Max :: Codec a b c -> Lb2+lb2Max :: CodecData a b c -> Lb2 lb2Max =     let idMax m = M.size m - 1     in  Lb2 . idMax . C.to . _3 --- | 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, Ord c) => Codec a b c-empty =-    ( C.empty-    , C.execCodec C.empty (C.encode C.idLens Nothing)-    , C.execCodec C.empty (C.encode C.idLens Nothing) )---- | Type synonym for the codec monad.  It is important to notice that by a--- codec we denote here a structure of three 'C.AtomCodec's while in the--- monad-codec package it denotes a monad.-type CodecM a b c d = C.Codec (Codec a b c) d---- | Encode the observation and update the codec (only in the encoding--- direction).-encodeObU :: Ord a => a -> CodecM a b c Ob-encodeObU = fmap Ob . C.encode' _1Lens---- | Encode the observation and do *not* update the codec.-encodeObN :: Ord a => a -> CodecM a b c (Maybe Ob)-encodeObN = fmap (fmap Ob) . C.maybeEncode _1Lens---- | Encode the label and update the codec.-encodeLbU :: (Ord b, Ord c) => (b, c) -> CodecM a b c Lb-encodeLbU (x, y) = do-    x' <- C.encode _2Lens (Just x)-    y' <- C.encode _3Lens (Just y)-    return (Lb1 x', Lb2 y')---- | Encode the label and do *not* update the codec.-encodeLbN :: (Ord b, Ord c) => (b, c) -> CodecM a b c Lb-encodeLbN (x, y) = do-    x' <- C.maybeEncode _2Lens (Just x) >>= \mx -> case mx of-        Just x' -> return x'-        Nothing -> fromJust <$> C.maybeEncode _2Lens Nothing-    y' <- C.maybeEncode _3Lens (Just y) >>= \my -> case my of-        Just y' -> return y'-        Nothing -> fromJust <$> C.maybeEncode _3Lens Nothing-    return (Lb1 x', Lb2 y')---- | Encode the labeled word and update the codec.-encodeWordL'Cu-    :: (Ord a, Ord b, Ord c)-    => WordL a (b, c)-    -> CodecM a b c (X Ob Lb, Y Lb)-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 . unDist) choice ]-    return (x, y)---- | Encodec the labeled word and do *not* update the codec.-encodeWordL'Cn-    :: (Ord a, Ord b, Ord c)-    => WordL a (b, c)-    -> CodecM a b c (X Ob Lb, Y Lb)-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 . unDist) choice ]-    return (x, y)---- | Encode the word and update the codec.-encodeWord'Cu-    :: (Ord a, Ord b, Ord c)-    => Word a (b, c)-    -> CodecM a b c (X Ob Lb)-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, Ord c)-    => Word a (b, c)-    -> CodecM a b c (X Ob Lb)-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, Ord c)-    => SentL a (b, c)-    -> CodecM a b c (Xs Ob Lb, Ys Lb)-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, Ord c)-    => SentL a (b, c)-    -> CodecM a b c (Xs Ob Lb, Ys Lb)-encodeSentL'Cn sent = do-    ps <- mapM (encodeWordL'Cn) 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, Ord c) => Codec a b c-    -> SentL a (b, c) -> (Xs Ob Lb, Ys Lb)-encodeSentL codec = C.evalCodec codec . encodeSentL'Cn---- | Encode the sentence and update the codec.-encodeSent'Cu-    :: (Ord a, Ord b, Ord c) => Sent a (b, c)-    -> CodecM a b c (Xs Ob Lb)-encodeSent'Cu = fmap V.fromList . mapM encodeWord'Cu---- | Encode the sentence and do *not* update the codec.-encodeSent'Cn-    :: (Ord a, Ord b, Ord c) => Sent a (b, c)-    -> CodecM a b c (Xs Ob Lb)-encodeSent'Cn = fmap V.fromList . mapM encodeWord'Cn---- | Encode the sentence using the given codec.-encodeSent-    :: (Ord a, Ord b, Ord c) => Codec a b c-    -> Sent a (b, c) -> Xs Ob Lb-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, Ord c) => [SentL a (b, c)]-    -> (Codec a b c, [(Xs Ob Lb, Ys Lb)])-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, Ord c) => Codec a b c-    -> [SentL a (b, c)] -> [(Xs Ob Lb, Ys Lb)]-encodeDataL codec = C.evalCodec codec . mapM encodeSentL'Cn---- | Encode the dataset with the codec.-encodeData-    :: (Ord a, Ord b, Ord c) => Codec a b c-    -> [Sent a (b, c)] -> [Xs Ob Lb]-encodeData codec = map (encodeSent codec)---- | Decode the label within the codec monad.-decodeLabel'C-    :: (Ord b, Ord c) => Lb-    -> CodecM a b c (Maybe (b, c))-decodeLabel'C (x, y) = do-    x' <- C.decode _2Lens (unLb1 x)-    y' <- C.decode _3Lens (unLb2 y)-    return $ (,) <$> x' <*> y'---- | Decode the label.-decodeLabel :: (Ord b, Ord c) => Codec a b c -> Lb -> Maybe (b, c)-decodeLabel codec = C.evalCodec codec . decodeLabel'C---- | Decode the sequence of labels.-decodeLabels :: (Ord b, Ord c) => Codec a b c -> [Lb] -> [Maybe (b, c)]-decodeLabels codec = C.evalCodec codec . mapM decodeLabel'C--hasLabel :: (Ord b, Ord c) => Codec a b c -> (b, c) -> Bool-hasLabel codec (x, y)-    =  M.member (Just x) (C.to $ _2 codec)-    && M.member (Just y) (C.to $ _3 codec)-{-# INLINE hasLabel #-}---- | Return the label when 'Just' or one of the unknown values--- when 'Nothing'.-unJust-    :: (Ord b, Ord c) => Codec a b c-    -> Word a (b, c) -> Maybe (b, c)-    -> (b, c)-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+codec :: (Ord a, Ord b, Ord c) => Codec a (b, c) (CodecData a b c) Ob Lb+codec = Codec+    { empty = +        ( C.empty+        , C.execCodec C.empty (C.encode C.idLens Nothing)+        , C.execCodec C.empty (C.encode C.idLens Nothing) )+    , encodeObU = fmap Ob . C.encode' _1Lens+    , encodeObN = fmap (fmap Ob) . C.maybeEncode _1Lens+    , encodeLbU = \ (x, y) -> do+        x' <- C.encode _2Lens (Just x)+        y' <- C.encode _3Lens (Just y)+        return (Lb1 x', Lb2 y')+    , encodeLbN = \ (x, y) -> do+        x' <- C.maybeEncode _2Lens (Just x) >>= \mx -> case mx of+            Just x' -> return x'+            Nothing -> fromJust <$> C.maybeEncode _2Lens Nothing+        y' <- C.maybeEncode _3Lens (Just y) >>= \my -> case my of+            Just y' -> return y'+            Nothing -> fromJust <$> C.maybeEncode _3Lens Nothing+        return (Lb1 x', Lb2 y')+    , decodeLbC = \ (x, y) -> do+        x' <- C.decode _2Lens (unLb1 x)+        y' <- C.decode _3Lens (unLb2 y)+        return $ (,) <$> x' <*> y'+    , hasLabel = \ cdcData (x, y)+        -> M.member (Just x) (C.to $ _2 cdcData)+        && M.member (Just y) (C.to $ _3 cdcData) }

@@ -0,0 +1,73 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}++module Data.CRF.Chain2.Pair.FeatMap+( FeatMap (..)+) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (guard)+import Data.List (foldl1')+import Data.Maybe (catMaybes)+import Data.Ix (Ix, inRange, range)+import Data.Binary (Binary, put, get)+import qualified Data.Array.Unboxed as A+import qualified Data.Map as M++import Data.CRF.Chain2.Pair.Base+import Data.CRF.Chain2.Generic.Internal (FeatIx(..))+import qualified Data.CRF.Chain2.Generic.FeatMap as C++-- | Dummy feature index.+dummy :: FeatIx+dummy = FeatIx (-1)+{-# INLINE dummy #-}++data FeatMap a = FeatMap+    { trMap3'1  :: A.UArray (Lb1, Lb1, Lb1) FeatIx+    , trMap3'2  :: A.UArray (Lb2, Lb2, Lb2) FeatIx+    , otherMap  :: M.Map Feat FeatIx }++(!?) :: (Ix i, A.IArray a b) => a i b -> i -> Maybe b+m !? x = if inRange (A.bounds m) x+    then Just (m A.! x)+    else Nothing+{-# INLINE (!?) #-}++instance C.FeatMap FeatMap Feat where+    featIndex (TFeat3'1 x y z) (FeatMap m _ _)  = do+        ix <- m !? (x, y, z)+        guard (ix /= dummy)+        return ix+    featIndex (TFeat3'2 x y z) (FeatMap _ m _)  = do+        ix <- m !? (x, y, z)+        guard (ix /= dummy)+        return ix+    featIndex x (FeatMap _ _ m)                 = M.lookup x m+    mkFeatMap xs = FeatMap+        (mkArray (catMaybes $ map getTFeat3'1 xs))+        (mkArray (catMaybes $ map getTFeat3'2 xs))+        (M.fromList (filter (isOther . fst) xs))+      where+        getTFeat3'1 (TFeat3'1 x y z, v) = Just ((x, y, z), v)+        getTFeat3'1 _                   = Nothing+        getTFeat3'2 (TFeat3'2 x y z, v) = Just ((x, y, z), v)+        getTFeat3'2 _                   = Nothing+        isOther (TFeat3'1 _ _ _)        = False+        isOther (TFeat3'2 _ _ _)        = False+        isOther _                       = True+        mkArray ys =+            let p = foldl1' updateMin (map fst ys)+                q = foldl1' updateMax (map fst ys)+                updateMin (x, y, z) (x', y', z') =+                    (min x x', min y y', min z z')+                updateMax (x, y, z) (x', y', z') =+                    (max x x', max y y', max z z')+                zeroed pq = A.array pq [(k, dummy) | k <- range pq]+            in  zeroed (p, q) A.// ys++instance Binary (FeatMap Feat) where+    put FeatMap{..} = put trMap3'1 >> put trMap3'2 >> put otherMap+    get = FeatMap <$> get <*> get <*> get

@@ -1,12 +1,13 @@ name:               crf-chain2-generic-version:            0.1.1+version:            0.3.0 synopsis:           Second-order, generic, constrained, linear conditional random fields description:     The library provides implementation of the second-order, linear     conditional random fields (CRFs) with position-wise constraints-    imposed over label values.  It provides a generic framework for+    imposed over label values.  It also provides a generic framework for     defining custom feature data types and feature generation-    functions.+    functions (see "Data.CRF.Chain2.Generic") together with+    some concrete model examples (e.g. "Data.CRF.Chain2.Pair"). license:            BSD3 license-file:       LICENSE cabal-version:      >= 1.6@@ -34,18 +35,21 @@       , sgd >= 0.2.2 && < 0.3      exposed-modules:-        Data.CRF.Chain2.Generic.Base+        Data.CRF.Chain2.Generic.Internal+      , Data.CRF.Chain2.Generic.FeatMap+      , Data.CRF.Chain2.Generic.FeatMap.Map       , Data.CRF.Chain2.Generic.External       , Data.CRF.Chain2.Generic.Model       , Data.CRF.Chain2.Generic.Inference       , Data.CRF.Chain2.Generic.Train+      , Data.CRF.Chain2.Generic.Codec       , Data.CRF.Chain2.Pair.Base+      , Data.CRF.Chain2.Pair.FeatMap       , Data.CRF.Chain2.Pair.Codec       , Data.CRF.Chain2.Pair      other-modules:-        Data.CRF.Chain2.Generic.Internal-      , Data.CRF.Chain2.Generic.DP+        Data.CRF.Chain2.Generic.DP       , Data.CRF.Chain2.Generic.Util              ghc-options: -Wall -O2