crf-chain2-tiers 0.2.4 → 0.3.0

raw patch · 15 files changed

+1906/−323 lines, 15 filesdep +data-memocombinatorsdep +pedestrian-dagdep ~arraydep ~binarydep ~comonadPVP ok

version bump matches the API change (PVP)

Dependencies added: data-memocombinators, pedestrian-dag

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

API changes (from Hackage documentation)

Files

• crf-chain2-tiers.cabal +20/−10
• src/Data/CRF/Chain2/Tiers.hs +1/−1
• src/Data/CRF/Chain2/Tiers/Core.hs +298/−0
• src/Data/CRF/Chain2/Tiers/DAG.hs +325/−0
• src/Data/CRF/Chain2/Tiers/DAG/Dataset/Codec.hs +108/−0
• src/Data/CRF/Chain2/Tiers/DAG/Dataset/External.hs +20/−0
• src/Data/CRF/Chain2/Tiers/DAG/Feature.hs +289/−0
• src/Data/CRF/Chain2/Tiers/DAG/Inference.hs +520/−0
• src/Data/CRF/Chain2/Tiers/DAG/Probs.hs +246/−0
• src/Data/CRF/Chain2/Tiers/Dataset/Codec.hs +2/−0
• src/Data/CRF/Chain2/Tiers/Dataset/External.hs +22/−9
• src/Data/CRF/Chain2/Tiers/Dataset/Internal.hs +15/−196
• src/Data/CRF/Chain2/Tiers/Feature.hs +9/−86
• src/Data/CRF/Chain2/Tiers/Inference.hs +31/−3
• src/Data/CRF/Chain2/Tiers/Model.hs +0/−18

@@ -1,5 +1,5 @@ name:               crf-chain2-tiers-version:            0.2.4+version:            0.3.0 synopsis:           Second-order, tiered, constrained, linear conditional random fields description:     The library provides implementation of the second-order, linear@@ -23,21 +23,24 @@      build-depends:         base                    >= 4            && < 5-      , containers-      , array-      , vector-      , binary-      , vector-binary+      , containers              >= 0.4          && < 0.6+      , array                   >= 0.4          && < 0.6+      , vector                  >= 0.10         && < 0.13+      , binary                  >= 0.5          && < 0.9+      , vector-binary           >= 0.1          && < 0.2       , monad-codec             >= 0.2          && < 0.3-      , data-lens               >= 2.10.4       && < 2.11-      , comonad                 >= 4.0          && < 4.3+      , data-lens               >= 2.10.4       && < 2.12+      , comonad                 >= 4.0          && < 5.1       , logfloat                >= 0.12.1       && < 0.14-      , parallel-      , sgd                     >= 0.3.2        && < 0.4+      , parallel                >= 3.2          && < 3.3+      , sgd                     >= 0.4          && < 0.5       , vector-th-unbox         >= 0.2.1        && < 0.3+      , pedestrian-dag          >= 0.2          && < 0.3+      , data-memocombinators    >= 0.5          && < 0.6      exposed-modules:         Data.CRF.Chain2.Tiers+      , Data.CRF.Chain2.Tiers.Core       , Data.CRF.Chain2.Tiers.Dataset.Internal       , Data.CRF.Chain2.Tiers.Dataset.External       , Data.CRF.Chain2.Tiers.Dataset.Codec@@ -45,6 +48,13 @@       , Data.CRF.Chain2.Tiers.Model       , Data.CRF.Chain2.Tiers.Inference       , Data.CRF.Chain2.Tiers.Array++      , Data.CRF.Chain2.Tiers.DAG+      , Data.CRF.Chain2.Tiers.DAG.Feature+      , Data.CRF.Chain2.Tiers.DAG.Dataset.External+      , Data.CRF.Chain2.Tiers.DAG.Dataset.Codec+      , Data.CRF.Chain2.Tiers.DAG.Inference+      , Data.CRF.Chain2.Tiers.DAG.Probs      other-modules:         Data.CRF.Chain2.Tiers.Util

@@ -3,7 +3,7 @@   module Data.CRF.Chain2.Tiers-( +( -- * CRF   CRF (..) , size

@@ -0,0 +1,298 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+++-- | Internal core data types.+++module Data.CRF.Chain2.Tiers.Core+(+-- * Basic types+  Ob (..)+, mkOb, unOb+, Lb (..)+, mkLb, unLb+, FeatIx (..)+, mkFeatIx, unFeatIx+, CbIx++-- * Complex label+, Cb (..)+, mkCb+, unCb++-- * Input element (word)+, X (_unX, _unR)+, mkX+, unX+, unR+-- ** Indexing+, lbAt++-- * Output element (choice)+, Y (_unY)+, mkY+, unY++-- * Feature+, Feat (..)+-- ** Feature generation+, obFeats+, trFeats1+, trFeats2+, trFeats3+) where+++import           Control.Applicative ((<$>), (<*>))+import           Control.Arrow (second)++import           Data.Binary (Binary, put, get, putWord8, getWord8)+import           Data.Ix (Ix)+import           Data.Int (Int16, Int32)+import           Data.List (zip4)+import qualified Data.Array.Unboxed as A+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import           Data.Vector.Unboxed.Deriving+import qualified Data.Vector.Generic.Base as G+import qualified Data.Vector.Generic.Mutable as G+import qualified Data.Number.LogFloat as L+-- import qualified Data.Primitive.ByteArray as BA++import           Data.CRF.Chain2.Tiers.Array (Bounds)++----------------------------------------------------------------+-- Basic types+----------------------------------------------------------------+++-- | An observation.+newtype Ob = Ob { _unOb :: Int32 }+    deriving (Show, Eq, Ord, Binary)+--           GeneralizedNewtypeDeriving doesn't work for this in 7.8.2:+--           , G.Vector U.Vector, G.MVector U.MVector, U.Unbox )+derivingUnbox "Ob" [t| Ob -> Int32 |] [| _unOb |] [| Ob |]++-- | Smart observation constructor.+mkOb :: Int -> Ob+mkOb = Ob . fromIntegral+{-# INLINE mkOb #-}+++-- | Deconstract observation.+unOb :: Ob -> Int+unOb = fromIntegral . _unOb+{-# INLINE unOb #-}+++-- | An atomic label.+newtype Lb = Lb { _unLb :: Int16 }+    deriving (Show, Eq, Ord, Binary , Num, Ix, Bounds)+derivingUnbox "Lb" [t| Lb -> Int16 |] [| _unLb |] [| Lb |]+++-- | Smart label constructor.+mkLb :: Int -> Lb+mkLb = Lb . fromIntegral+{-# INLINE mkLb #-}+++-- | Deconstruct label.+unLb :: Lb -> Int+unLb = fromIntegral . _unLb+{-# INLINE unLb #-}+++-- | An index of the label.+type CbIx = Int+++-- | A feature index.  To every model feature a unique index is assigned.+newtype FeatIx = FeatIx { _unFeatIx :: Int32 }+    deriving (Show, Eq, Ord, Binary)+derivingUnbox "FeatIx" [t| FeatIx -> Int32 |] [| _unFeatIx |] [| FeatIx |]++-- | Smart feature index constructor.+mkFeatIx :: Int -> FeatIx+mkFeatIx = FeatIx . fromIntegral+{-# INLINE mkFeatIx #-}+++-- | Deconstract feature index.+unFeatIx :: FeatIx -> Int+unFeatIx = fromIntegral . _unFeatIx+{-# INLINE unFeatIx #-}+++----------------------------------------------------------------+-- Complex label+----------------------------------------------------------------+++-- TODO: Do we gain anything by representing the+-- complex label with a byte array?  Complex labels+-- should not be directly stored in a model, so if+-- there is something to gain here, its not obvious.+--+-- Perhaps a list representation would be sufficient?+++-- -- | A complex label is an array of atomic labels.+-- newtype Cb = Cb { unCb :: BA.ByteArray }+++-- | A complex label is a vector of atomic labels.+newtype Cb = Cb { _unCb :: U.Vector Lb }+    deriving (Show, Eq, Ord, Binary)+++-- | Smart complex label constructor.+mkCb :: [Lb] -> Cb+mkCb = Cb . U.fromList+++-- | Deconstract complex label.+unCb :: Cb -> [Lb]+unCb = U.toList . _unCb+++----------------------------------------------------------------+-- Internal dataset representation+----------------------------------------------------------------+++-- | A word is represented by a list of its observations+-- and a list of its potential label interpretations.+data X = X {+    -- | A set of observations.+      _unX :: U.Vector Ob+    -- | A vector of potential labels.+    , _unR :: V.Vector Cb }+    deriving (Show, Eq, Ord)+++instance Binary X where+    put X{..} = put _unX >> put _unR+    get = X <$> get <*> get+++-- | Smart `X` constructor.+mkX :: [Ob] -> [Cb] -> X+mkX x r = X (U.fromList x) (V.fromList r)+{-# INLINE mkX #-}+++-- | List of observations.+unX :: X -> [Ob]+unX = U.toList . _unX+{-# INLINE unX #-}+++-- | List of potential labels.+unR :: X -> [Cb]+unR = V.toList . _unR+{-# INLINE unR #-}+++-- | Potential label at the given position.+lbAt :: X -> CbIx -> Cb+lbAt x = (_unR x V.!)+{-# INLINE lbAt #-}+++-- | Vector of chosen labels together with corresponding probabilities in log+-- domain.+newtype Y = Y { _unY :: V.Vector (Cb, Double) }+    deriving (Show, Eq, Ord, Binary)+++-- | Y constructor.+mkY :: [(Cb, Double)] -> Y+mkY = Y . V.fromList . map (second log)+{-# INLINE mkY #-}+++-- | Y deconstructor symetric to mkY.+unY :: Y -> [(Cb, L.LogFloat)]+unY = map (second L.logToLogFloat) . V.toList . _unY+{-# INLINE unY #-}+++----------------------------------------------------------------+-- Feature+----------------------------------------------------------------+++-- | Feature; every feature is associated to a layer with `ln` identifier.+data Feat+    -- | Second-order transition feature.+    = TFeat3+        { x1    :: {-# UNPACK #-} !Lb+        , x2    :: {-# UNPACK #-} !Lb+        , x3    :: {-# UNPACK #-} !Lb+        , ln    :: {-# UNPACK #-} !Int }+    -- | First-order transition feature.+    | TFeat2+        { x1    :: {-# UNPACK #-} !Lb+        , x2    :: {-# UNPACK #-} !Lb+        , ln    :: {-# UNPACK #-} !Int }+    -- | Zero-order transition feature.+    | TFeat1+        { x1    :: {-# UNPACK #-} !Lb+        , ln    :: {-# UNPACK #-} !Int }+    -- | Observation feature.+    | OFeat+        { ob    :: {-# UNPACK #-} !Ob+        , x1    :: {-# UNPACK #-} !Lb+        , ln    :: {-# UNPACK #-} !Int }+    deriving (Show, Eq, Ord)+++instance Binary Feat where+    put (OFeat o x k)       = putWord8 0 >> put o >> put x >> put k+    put (TFeat3 x y z k)    = putWord8 1 >> put x >> put y >> put z >> put k+    put (TFeat2 x y k)      = putWord8 2 >> put x >> put y >> put k+    put (TFeat1 x k)        = putWord8 3 >> put x >> put k+    get = getWord8 >>= \i -> case i of+        0   -> OFeat  <$> get <*> get <*> get+        1   -> TFeat3 <$> get <*> get <*> get <*> get+        2   -> TFeat2 <$> get <*> get <*> get+        3   -> TFeat1 <$> get <*> get+        _   -> error "get feature: unknown code"+++----------------------------------------------------+-- Features generation+----------------------------------------------------+++-- | Generate observation features.+obFeats :: Ob -> Cb -> [Feat]+obFeats ob' xs =+    [ OFeat ob' x k+    | (x, k) <- zip (unCb xs) [0..] ]+++-- | Generate zero-order transition features.+trFeats1 :: Cb -> [Feat]+trFeats1 xs =+    [ TFeat1 x k+    | (x, k) <- zip (unCb xs) [0..] ]+++-- | Generate first-order transition features.+trFeats2 :: Cb -> Cb -> [Feat]+trFeats2 xs1 xs2 =+    [ TFeat2 x1' x2' k+    | (x1', x2', k) <- zip3 (unCb xs1) (unCb xs2) [0..] ]+++-- | Generate second-order transition features.+trFeats3 :: Cb -> Cb -> Cb -> [Feat]+trFeats3 xs1 xs2 xs3 =+    [ TFeat3 x1' x2' x3' k+    | (x1', x2', x3', k) <- zip4 (unCb xs1) (unCb xs2) (unCb xs3) [0..] ]

@@ -0,0 +1,325 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TupleSections #-}+++module Data.CRF.Chain2.Tiers.DAG+(+-- * CRF+  CRF (..)+, size+, prune++-- * Training+, train+-- , reTrain++-- * Tagging+-- , tag+, marginals+, I.ProbType (..)+, probs++-- * Dataset+, module Data.CRF.Chain2.Tiers.DAG.Dataset.External++-- * Feature selection+, Feat.FeatSel+, Feat.selectHidden+, Feat.selectPresent+) where+++import           Control.Applicative ((<$>), (<*>))+import           Control.Monad (when)++import           System.IO (hSetBuffering, stdout, BufferMode (..))+import           Data.Maybe (maybeToList)+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import           Data.Binary (Binary, get, put)+import qualified Data.Vector.Unboxed as U+import qualified Data.Number.LogFloat as LogFloat+import qualified Numeric.SGD.Momentum as SGD+import qualified Numeric.SGD.LogSigned as L+import qualified Data.MemoCombinators as Memo++import           Data.DAG (DAG)+import qualified Data.DAG as DAG++import           Data.CRF.Chain2.Tiers.Core (X, Y)+import qualified Data.CRF.Chain2.Tiers.Core as Core+import qualified Data.CRF.Chain2.Tiers.Model as Model+import           Data.CRF.Chain2.Tiers.Model (Model)+-- import qualified Data.CRF.Chain2.Tiers.DAG.Dataset.Internal as Int+-- import qualified Data.CRF.Chain2.Tiers.Dataset.External as Ext+import           Data.CRF.Chain2.Tiers.DAG.Dataset.External+import qualified Data.CRF.Chain2.Tiers.DAG.Dataset.Codec as Codec+import           Data.CRF.Chain2.Tiers.DAG.Dataset.Codec (Codec)+import qualified Data.CRF.Chain2.Tiers.DAG.Feature as Feat+import           Data.CRF.Chain2.Tiers.DAG.Feature (Feat, FeatSel)+import qualified Data.CRF.Chain2.Tiers.DAG.Inference as I+import qualified Data.CRF.Chain2.Tiers.DAG.Probs as P+++----------------------------------------------------+-- CRF model+----------------------------------------------------+++-- | CRF model data.+data CRF a b = CRF+    { numOfLayers   :: Int+    , codec         :: Codec a b+    , model         :: Model }+++instance (Ord a, Ord b, Binary a, Binary b) => Binary (CRF a b) where+    put CRF{..} = put numOfLayers >> put codec >> put model+    get = CRF <$> get <*> get <*> get+++-- | Compute size (number of features) of the model.+size :: CRF a b -> Int+size CRF{..} = M.size (Model.toMap model)+++-- | Discard model features with absolute values (in log-domain)+-- lower than the given threshold.+prune :: Double -> CRF a b -> CRF a b+prune x crf =  crf { model = newModel } where+    newModel = Model.fromMap . M.fromList $+        [ (feat, val)+        | (feat, val) <- M.toList $ Model.toMap (model crf)+        , abs (LogFloat.logFromLogFloat val) > x ]+++-- | Construct model from a dataset given a feature selection function.+mkModel :: (DAG a (X, Y) -> [Feat]) -> [DAG a (X, Y)] -> Model+mkModel featSel+  = Model.fromSet . S.fromList+  . concatMap featSel -- (map fst . Feat.presentFeats)+++----------------------------------------------------+-- Training+----------------------------------------------------+++-- | Train the CRF using the stochastic gradient descent method.+train+  :: (Ord a, Ord b)+  => Int                          -- ^ Number of layers (tiers)+  -> Feat.FeatSel ()              -- ^ Feature selection+  -> SGD.SgdArgs                  -- ^ SGD parameters+  -> Bool                         -- ^ Store dataset on a disk+  -> IO [SentL a b]               -- ^ Training data 'IO' action+  -> IO [SentL a b]               -- ^ Evaluation data+  -> IO (CRF a b)                 -- ^ Resulting model+train numOfLayers featSel sgdArgs onDisk trainIO evalIO = do+    hSetBuffering stdout NoBuffering++    -- Create codec and encode the training dataset+    codec <- Codec.mkCodec numOfLayers    <$> trainIO+    trainData_ <- Codec.encodeDataL codec <$> trainIO+    let trainLenOld = length trainData_+        trainData0 = verifyDataset trainData_+        trainLenNew = length trainData0+    -- mapM_ print $ map dagProb trainData_+    when (trainLenNew < trainLenOld) $ do+      putStrLn $ "Discarded "+        ++ show (trainLenOld - trainLenNew) ++ "/" ++ show trainLenOld+        ++  " elements from the training dataset"+    SGD.withData onDisk trainData0 $ \trainData -> do+    -- SGD.withData onDisk trainData_ $ \trainData -> do++    -- Encode the evaluation dataset+    evalData_ <- Codec.encodeDataL codec <$> evalIO+    SGD.withData onDisk evalData_ $ \evalData -> do++    -- Train the model+    model <- mkModel featSel <$> SGD.loadData trainData+    para  <- SGD.sgd sgdArgs+        (notify sgdArgs model trainData evalData)+        (gradOn model) trainData (Model.values model)+    return $ CRF numOfLayers codec model { Model.values = para }+++-- -- | Re-train the CRF using the stochastic gradient descent method.+-- reTrain+--     :: (Ord a, Ord b)+--     => CRF a b                      -- ^ Existing CRF model+--     -> SGD.SgdArgs                  -- ^ SGD parameters+--     -> Bool                         -- ^ Store dataset on a disk+--     -> IO [SentL a b]               -- ^ Training data 'IO' action+--     -> IO [SentL a b]               -- ^ Evaluation data+--     -> IO (CRF a b)                 -- ^ Resulting model+-- reTrain crf sgdArgs onDisk trainIO evalIO = do+--     hSetBuffering stdout NoBuffering+--+--     -- Encode the training dataset+--     trainData_ <- encodeDataL (codec crf) <$> trainIO+--     SGD.withData onDisk trainData_ $ \trainData -> do+--+--     -- Encode the evaluation dataset+--     evalData_ <- encodeDataL (codec crf) <$> evalIO+--     SGD.withData onDisk evalData_ $ \evalData -> do+--+--     -- Train the model+--     let model' = model crf+--     para  <- SGD.sgd sgdArgs+--         (notify sgdArgs model' trainData evalData)+--         (gradOn model') trainData (values model')+--     return $ crf { model = model' { values = para } }+++-- | Compute gradient on a dataset element.+gradOn :: Model -> SGD.Para -> DAG a (X, Y) -> SGD.Grad+-- gradOn model para (xs, ys) = SGD.fromLogList $+gradOn model para dag = SGD.fromLogList $+    [ (Core.unFeatIx ix, L.fromPos val)+    | (ft, val) <- Feat.presentFeats dag+    , ix <- maybeToList (Model.index curr ft) ] +++    [ (Core.unFeatIx ix, L.fromNeg val)+    | (ft, val) <- I.expectedFeaturesIn curr (fmap fst dag)+    , ix <- maybeToList (Model.index curr ft) ]+  where+    curr = model { Model.values = para }+++notify+    :: SGD.SgdArgs -> Model+    -> SGD.Dataset (DAG a (X, Y))         -- ^ Training dataset+    -> SGD.Dataset (DAG a (X, Y))         -- ^ Evaluaion dataset+    -> SGD.Para -> Int -> IO ()+notify SGD.SgdArgs{..} model trainData evalData para k+  | doneTotal k == doneTotal (k - 1) = putStr "."+  | otherwise = do+      putStrLn "" >> report para+--       report $ U.map (*50.0) para+--       report $ U.map (*10.0) para+--       report $ U.map (*2.0) para+--       report $ U.map (*0.9) para+--       report $ U.map (*0.5) para+--       report $ U.map (*0.1) para+  where++    report para = do+      let crf = model {Model.values = para}+      llh <- show+        . LogFloat.logFromLogFloat+        . P.parLikelihood crf+        <$> SGD.loadData trainData+      acc <-+        if SGD.size evalData > 0+        then show . I.accuracy crf <$> SGD.loadData evalData+        else return "#"+      putStrLn $ "[" ++ show (doneTotal k) ++ "] stats:"+      putStrLn $ "min(params) = " ++ show (U.minimum para)+      putStrLn $ "max(params) = " ++ show (U.maximum para)+      putStrLn $ "log(likelihood(train)) = " ++ llh+      putStrLn $ "acc(eval) = " ++ acc++--     report para = do+--       acc <-+--         if SGD.size evalData > 0+--         then show . I.accuracy (model { Model.values = para }) <$> SGD.loadData evalData+--         else return "#"+--       putStrLn $+--         "[" ++ show (doneTotal k) ++ "] acc = " ++ acc +++--         ", min(params) = " ++ show (U.minimum para) +++--         ", max(params) = " ++ show (U.maximum para)++    doneTotal :: Int -> Int+    doneTotal = floor . done+    done :: Int -> Double+    done i+        = fromIntegral (i * batchSize)+        / fromIntegral trainSize+    trainSize = SGD.size trainData++------------------------------------------------------+-- Verification+------------------------------------------------------+++-- | Compute the probability of the DAG, based on the probabilities assigned to+-- different edges and their labels.+dagProb :: DAG a (X, Y) -> Double+dagProb dag = sum+  [ fromEdge edgeID+  | edgeID <- DAG.dagEdges dag+  , DAG.isInitialEdge edgeID dag ]+  where+    fromEdge =+      Memo.wrap DAG.EdgeID DAG.unEdgeID Memo.integral fromEdge'+    fromEdge' edgeID+      = edgeProb edgeID+      * fromNode (DAG.endsWith edgeID dag)+    edgeProb edgeID =+      let (_x, y) = DAG.edgeLabel edgeID dag+      in  sum . map (LogFloat.fromLogFloat . snd) $ Core.unY y+    fromNode nodeID =+      case DAG.outgoingEdges nodeID dag of+        [] -> 1+        xs -> sum (map fromEdge xs)+++-- | Filter out sentences with `dagProb` different from 1.+verifyDataset :: [DAG a (X, Y)] -> [DAG a (X, Y)]+verifyDataset =+  filter verify+  where+    verify dag =+      let p = dagProb dag+      in  p >= 1 - eps && p <= 1 + eps+    eps = 1e-9+++----------------------------------------------------+-- Tagging+----------------------------------------------------+++-- -- | Find the most probable label sequence.+-- 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 ]+++-- | Tag labels with marginal probabilities.+marginals :: (Ord a, Ord b) => CRF a b -> Sent a b -> SentL a b+marginals CRF{..} sent+  = fmap decodeChosen+  . DAG.zipE sent+  . I.marginals' model+  . Codec.encodeSent codec+  $ sent+  where+    decodeChosen (word, chosen) = (word,) $ mkProb+      [ (decode word x, LogFloat.fromLogFloat p)+      | (x, p) <- chosen ]+      where+    decode word = Codec.unJust codec word . Codec.decodeLabel codec+++-- | Tag labels with marginal probabilities.+probs :: (Ord a, Ord b) => I.ProbType -> CRF a b -> Sent a b -> SentL a b+probs probTyp CRF{..} sent+  = fmap decodeChosen+  . DAG.zipE sent+  . I.probs' probTyp model+  . Codec.encodeSent codec+  $ sent+  where+    decodeChosen (word, chosen) = (word,) $ mkProb+      [ (decode word x, LogFloat.fromLogFloat p)+      | (x, p) <- chosen ]+      where+    decode word = Codec.unJust codec word . Codec.decodeLabel codec

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

@@ -0,0 +1,20 @@+module Data.CRF.Chain2.Tiers.DAG.Dataset.External+( Sent+, SentL+, module Data.CRF.Chain2.Tiers.Dataset.External+) where+++import Prelude hiding (Word)+import qualified Data.DAG as DAG+import           Data.DAG (DAG)++import           Data.CRF.Chain2.Tiers.Dataset.External hiding (Sent, SentL)+++-- | A sentence (DAG) of words.+type Sent a b = DAG () (Word a b)+++-- | A sentence (DAG) of labeled words.+type SentL a b = DAG () (WordL a b)

@@ -0,0 +1,289 @@+{-# LANGUAGE RecordWildCards #-}+++-- | Feature extraction module for DAG-aware CRFs.+++module Data.CRF.Chain2.Tiers.DAG.Feature+(+-- * Feature+  Feat (..)++-- * Featre extraction+-- ** Present features+, presentFeats+-- ** Hidden features+, EdgeIx (..)+, hiddenFeats+, obFeatsOn+, trFeatsOn++-- * Feature selection+, FeatSel+, selectPresent+, selectHidden++-- * Indexing+, lbNum+, lbIxs+, edgeIxs+, prevEdgeIxs+, nextEdgeIxs+, initialEdgeIxs+, finalEdgeIxs+) where+++import           Control.Applicative ((<$>))++import qualified Data.Number.LogFloat as L+import qualified Data.Vector as V+import           Data.Maybe (maybeToList)++import           Data.DAG (DAG, EdgeID)+import qualified Data.DAG as DAG++import           Data.CRF.Chain2.Tiers.Core (X, Y, Ob, Cb, CbIx, Feat)+import qualified Data.CRF.Chain2.Tiers.Core as C+++----------------------------------------------------+-- Present features+----------------------------------------------------+++-- | Observation features with probabilities for a given edge.+obFeats :: EdgeID -> DAG a (X, Y) -> [(Feat, L.LogFloat)]+obFeats edgeID dag =+  [ (ft, px)+  | let edgeLabel = DAG.edgeLabel edgeID dag+  , (x, px) <- C.unY (snd edgeLabel)+  , o       <- C.unX (fst edgeLabel)+  , ft      <- C.obFeats o x ]+++-- | Zero-order transition features with probabilities for a given edge.+trFeats1 :: EdgeID -> DAG a (X, Y) -> [(Feat, L.LogFloat)]+trFeats1 i dag =+  [ (ft, px)+  | null (prevEdges i) -- TODO: see ticket on Trello+  , (x, px) <- edgeLabel i+  , ft <- C.trFeats1 x ]+  where+    edgeLabel = C.unY . snd . flip DAG.edgeLabel dag+    prevEdges = flip DAG.prevEdges dag+++-- | First-order transition features with probabilities for a given edge.+trFeats2 :: EdgeID -> DAG a (X, Y) -> [(Feat, L.LogFloat)]+trFeats2 i dag =+  [ (ft, px * py)+  | (x, px) <- edgeLabel i+  , j <- prevEdges i+  , null (prevEdges j) -- TODO: see ticket on Trello+  , (y, py) <- edgeLabel j+  , ft <- C.trFeats2 x y ]+  where+    edgeLabel = C.unY . snd . flip DAG.edgeLabel dag+    prevEdges = flip DAG.prevEdges dag+++-- | Second-order transition features with probabilities for a given edge.+trFeats3 :: EdgeID -> DAG a (X, Y) -> [(Feat, L.LogFloat)]+trFeats3 i dag =+  [ (ft, px * py * pz)+  | (x, px) <- edgeLabel i+  , j <- prevEdges i+  , (y, py) <- edgeLabel j+  , k <- prevEdges j+  , (z, pz) <- edgeLabel k+  , ft <- C.trFeats3 x y z ]+  where+    edgeLabel = C.unY . snd . flip DAG.edgeLabel dag+    prevEdges = flip DAG.prevEdges dag+++-- | Present 'Feat'ures of all kinds occurring w.r.t. to the given edge.+presentFeatsOn :: EdgeID -> DAG a (X, Y) -> [(Feat, L.LogFloat)]+presentFeatsOn edgeID dag+  =  obFeats  edgeID dag+  ++ trFeats1 edgeID dag+  ++ trFeats2 edgeID dag+  ++ trFeats3 edgeID dag+++-- | Present 'Feat'ures of all kinds occurring in the given DAG.+presentFeats :: DAG a (X, Y) -> [(Feat, L.LogFloat)]+presentFeats dag = concat+  [ presentFeatsOn edgeID dag+  | edgeID <- DAG.dagEdges dag ]+++---------------------------------------------+-- Indexing+---------------------------------------------+++-- | List of observations on the given edge of the sentence.+obList :: DAG a X -> EdgeID -> [Ob]+obList dag i = C.unX $ DAG.edgeLabel i dag+{-# INLINE obList #-}+++-- | Vector of potential labels on the given edge of the sentence.+lbVec :: DAG a X -> EdgeID -> V.Vector Cb+lbVec dag i = C._unR $ DAG.edgeLabel i dag+{-# INLINE lbVec #-}+++-- | Number of potential labels at the given position of the sentence.+lbNum :: DAG a X -> EdgeID -> Int+lbNum dag = V.length . lbVec dag+{-# INLINE lbNum #-}+++-- | Potential label at the given position and at the given index.+lbOn :: DAG a X -> EdgeID -> CbIx -> Maybe Cb+lbOn dag = (V.!?) . lbVec dag+{-# INLINE lbOn #-}+++-- | List of label indices at the given edge.+lbIxs :: DAG a X -> EdgeID -> [CbIx]+lbIxs dag i = [0 .. lbNum dag i - 1]+{-# INLINE lbIxs #-}+++-- | The list of EdgeIx's corresponding to the given edge.+edgeIxs :: DAG a X -> EdgeID -> [EdgeIx]+edgeIxs dag i =+  [ EdgeIx {edgeID=i, lbIx=u}+  | u <- lbIxs dag i ]+++-- | The list of EdgeIx's corresponding to the previous edges.+-- If the argument edgeID is `Nothing` or if the list of previous+-- edges is empty, the result will be a singleton list containing+-- `Nothing` (which represents a special out-of-bounds EdgeIx).+prevEdgeIxs :: DAG a X -> Maybe EdgeID -> [Maybe EdgeIx]+prevEdgeIxs _ Nothing = [Nothing]+prevEdgeIxs dag (Just i)+  | null js = [Nothing]+  | otherwise = Just <$>+    [ EdgeIx {edgeID=j, lbIx=u}+    | j <- js, u <- lbIxs dag j ]+  where js = DAG.prevEdges i dag+++-- | Similar to `prevEdgeIxs` but returns the succeeding edges.+nextEdgeIxs :: DAG a X -> Maybe EdgeID -> [Maybe EdgeIx]+nextEdgeIxs _ Nothing = [Nothing]+nextEdgeIxs dag (Just i)+  | null js = [Nothing]+  | otherwise = Just <$>+    [ EdgeIx {edgeID=j, lbIx=u}+    | j <- js, u <- lbIxs dag j ]+  where js = DAG.nextEdges i dag+++-- | Obtain the list of initial EdgeIxs.+initialEdgeIxs :: DAG a X -> [EdgeIx]+initialEdgeIxs dag = concat+  [ edgeIxs dag i+  | i <- DAG.dagEdges dag+  , DAG.isInitialEdge i dag ]+++-- | Obtain the list of final EdgeIxs.+finalEdgeIxs :: DAG a X -> [EdgeIx]+finalEdgeIxs dag = concat+  [ edgeIxs dag i+  | i <- DAG.dagEdges dag+  , DAG.isFinalEdge i dag ]+++----------------------------------------------------+-- Hidden features+----------------------------------------------------+++-- | Edge with the corresponding label index.+data EdgeIx = EdgeIx+  { edgeID :: {-# UNPACK #-} !EdgeID+    -- ^ ID of an edge+  , lbIx   :: {-# UNPACK #-} !CbIx+    -- ^ Index of the corresponding complex label+  }+  deriving (Show, Eq, Ord)+++-- | Observation features on a given position and with respect+-- to a given label (determined by index).+obFeatsOn :: DAG a X -> EdgeIx -> [Feat]+obFeatsOn dag EdgeIx{..} = concat+  [ C.obFeats o e+  | e <- maybeToList $ lbOn dag edgeID lbIx+  , o <- obList dag edgeID ]+-- obFeatsOn :: DAG a X -> EdgeID -> CbIx -> [Feat]+-- obFeatsOn dag edgeID lbIx = concat+--   [ C.obFeats o e+--   | e <- maybeToList $ lbOn dag edgeID lbIx+--   , o <- obList dag edgeID ]+{-# INLINE obFeatsOn #-}+++-- | Transition features on a given position and with respect+-- to given labels (determined by indexes).+trFeatsOn+  :: DAG a X+  -> Maybe EdgeIx -- ^ Current EdgeIx+  -> Maybe EdgeIx -- ^ Previous EdgeIx+  -> Maybe EdgeIx -- ^ One before the previous EdgeIx+  -> [Feat]+trFeatsOn dag u' v' w' = doit+  (lbOn' =<< u')+  (lbOn' =<< v')+  (lbOn' =<< w')+  where+    lbOn' EdgeIx{..} = lbOn dag edgeID lbIx+    doit (Just u) (Just v) (Just w) = C.trFeats3 u v w+    doit (Just u) (Just v) _        = C.trFeats2 u v+    doit (Just u) _ _               = C.trFeats1 u+    doit _ _ _                      = []+{-# INLINE trFeatsOn #-}+++-- | Features hidden in the dataset element.+hiddenFeats :: DAG a X -> [Feat]+hiddenFeats dag =+  obFs ++ trFs+  where+    obFs = concat+      [ obFeatsOn dag u+      | i <- DAG.dagEdges dag+      , u <- edgeIxs dag i ]+    trFs = concat+      [ trFeatsOn dag u v w+      | i <- DAG.dagEdges dag+      , u <- Just <$> edgeIxs dag i+      , v <- prevEdgeIxs dag (edgeID <$> u)+      , w <- prevEdgeIxs dag (edgeID <$> v) ]+++----------------------------------------------------+-- Feature selection+----------------------------------------------------+++-- | A feature selection function type.+type FeatSel a = DAG a (X, Y) -> [Feat]+++-- | The 'presentFeats' adapted to fit feature selection specs.+selectPresent :: FeatSel a+selectPresent = map fst . presentFeats+++-- | The 'hiddenFeats' adapted to fit feature selection specs.+selectHidden :: FeatSel a+selectHidden = hiddenFeats . fmap fst

@@ -0,0 +1,520 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Rank2Types #-}+++module Data.CRF.Chain2.Tiers.DAG.Inference+( tag+, tag'+, tagK+, marginals+, marginals'+, ProbType (..)+, probs+, probs'+, accuracy+, expectedFeaturesIn+, zx+, zx'++-- * Internals (used by `Probs`) (TODO: move elsewhere)+, AccF+, ProbArray+, Pos (..)+, simplify+, complicate+-- ** Memoization+, memoProbArray+, memoEdgeIx+) where+++import           GHC.Conc (numCapabilities)++import           Control.Applicative ((<$>))+import qualified Control.Parallel as Par+import qualified Control.Parallel.Strategies as Par++import qualified Data.Number.LogFloat as L+import qualified Data.Vector as V+import qualified Data.Array as A+import qualified Data.Set as S+import           Data.Maybe (fromJust)+import qualified Data.MemoCombinators as Memo+import qualified Data.List as List+import           Data.Function (on)+import qualified Data.Foldable as F++import           Data.DAG (EdgeID, DAG)+import qualified Data.DAG as DAG++import qualified Data.CRF.Chain2.Tiers.Core as C+import           Data.CRF.Chain2.Tiers.Core (X, Y, Cb, CbIx)+import qualified Data.CRF.Chain2.Tiers.Model as Md+import           Data.CRF.Chain2.Tiers.Util (partition)+import           Data.CRF.Chain2.Tiers.DAG.Feature (EdgeIx(..))+import qualified Data.CRF.Chain2.Tiers.DAG.Feature as Ft+++---------------------------------------------+-- Util Types+---------------------------------------------+++-- | Accumulation function.+type AccF = [L.LogFloat] -> L.LogFloat+++-- | Position in the sentence.+data Pos+  = Beg        -- ^ Before the beginning of the sentence+  | Mid EdgeIx -- ^ Actual edge+  | End        -- ^ After the end of the sentence+  deriving (Show, Eq, Ord)+++-- | Simplify the position by conflating `Beg` and `End` to `Nothing`.+simplify :: Pos -> Maybe EdgeIx+simplify (Mid x) = Just x+simplify Beg = Nothing+simplify End = Nothing+++-- | Inverse operation of `simplify`, with the default position value.+complicate :: Pos -> Maybe EdgeIx -> Pos+complicate df Nothing = df+complicate _ (Just x) = Mid x+++-- | First argument represents the current EdgeIx (Nothing if out of bounds),+-- the next argument represents the previous EdgeIx.+type ProbArray = Pos -> Pos -> L.LogFloat+++---------------------------------------------+-- Memoization+---------------------------------------------+++memoProbArray :: DAG a b -> ProbArray -> ProbArray+memoProbArray dag =+  let memo = memoPos dag+  in  Memo.memo2 memo memo+++memoPos :: DAG a b -> Memo.Memo Pos+memoPos dag f =+  table (f Beg) (memo (f . Mid)) (f End)+  where+    memo = memoEdgeIx dag+    table b m e Beg = b+    table b m e (Mid x) = m x+    table b m e End = e+++memoEdgeIx :: DAG a b -> Memo.Memo EdgeIx+memoEdgeIx dag =+  Memo.wrap fromPair toPair memoPair+  where+    memoPair = Memo.pair memoEdgeID Memo.integral+    memoEdgeID = Memo.unsafeArrayRange (DAG.minEdge dag, DAG.maxEdge dag)+    fromPair (x, y) = EdgeIx x y+    toPair (EdgeIx x y) = (x, y)+++----------------------------------------------------+-- Potential+----------------------------------------------------+++-- | Observation potential on a given position and a+-- given label (identified by index).+onWord :: Md.Model -> DAG a X -> EdgeIx -> L.LogFloat+onWord crf dag+  = L.product+  . map (Md.phi crf)+  . Ft.obFeatsOn dag+{-# INLINE onWord #-}+++-- | Transition potential on a given position and a+-- given labels (identified by indexes).+onTransition+  :: Md.Model+  -> DAG a X+  -> Maybe EdgeIx+  -> Maybe EdgeIx+  -> Maybe EdgeIx+  -> L.LogFloat+onTransition crf dag u w v+  = L.product+  . map (Md.phi crf)+  $ Ft.trFeatsOn dag u w v+{-# INLINE onTransition #-}+++---------------------------------------------+-- A bit more complex stuff+---------------------------------------------+++-- | Forward table computation.+forward :: AccF -> Md.Model -> DAG a X -> ProbArray+forward acc crf dag =+  alpha+  where+    alpha = memoProbArray dag alpha'+    alpha' Beg Beg = 1.0+    alpha' End End = acc+      [ alpha End (Mid w)+        -- below, onTransition equals currently to 1; in general, there could be+        -- some related transition features, though.+        * onTransition crf dag Nothing Nothing (Just w)+      | w <- Ft.finalEdgeIxs dag ]+    alpha' u v = acc+      [ alpha v w * psi' u+        * onTransition crf dag (simplify u) (simplify v) (simplify w)+      | w <- complicate Beg <$> Ft.prevEdgeIxs dag (edgeID <$> simplify v) ]+    psi' u = case u of+      Mid x -> psi x+      _ -> 1.0+    psi = memoEdgeIx dag $ onWord crf dag+++-- | Backward table computation.+backward :: AccF -> Md.Model -> DAG a X -> ProbArray+backward acc crf dag =+  beta+  where+    beta = memoProbArray dag beta'+    beta' End End = 1.0+    beta' Beg Beg = acc+      [ beta (Mid u) Beg * psi u+        * onTransition crf dag  (Just u) Nothing Nothing+      | u <- Ft.initialEdgeIxs dag ]+    beta' v w = acc+      [ beta u v * psi' u+        * onTransition crf dag (simplify u) (simplify v) (simplify w)+      | u <- complicate End <$> Ft.nextEdgeIxs dag (edgeID <$> simplify v) ]+    psi' u = case u of+      Mid x -> psi x+      _ -> 1.0+    psi = memoEdgeIx dag $ onWord crf dag+++-- | Normalization factor computed for the sentence using the forward+-- computation.+zx :: Md.Model -> DAG a X -> L.LogFloat+zx crf = zxAlpha . forward L.sum crf++-- | Normalization factor based on the forward table.+zxAlpha :: ProbArray -> L.LogFloat+zxAlpha pa = pa End End+++-- | Normalization factor computed for the sentence using the backward+-- computation.+zx' :: Md.Model -> DAG a X -> L.LogFloat+zx' crf = zxBeta . backward L.sum crf++-- | Normalization factor based on the backward table.+zxBeta :: ProbArray -> L.LogFloat+zxBeta pa = pa Beg Beg+++-- -- | Probability of chosing the given three edges and the corresponding labels.+-- edgeProb3+--   :: Md.Model+--   -- ^ The underlying model+--   -> DAG a X+--   -- ^ The underlying DAG+--   -> ProbArray+--   -- ^ Forward probability table+--   -> ProbArray+--   -- ^ Backward probability table+--   -> Int+--   -- ^ Sentence position+--   -> (CbIx -> L.LogFloat)+--   -- ^ Memoized psi (onWord)+--   -> CbIx+--   -- ^ Corresponding to the current position `i`+--   -> CbIx+--   -- ^ Corresponding to the position `i - 1`+--   -> CbIx+--   -- ^ Corresponding to the position `i - 2`+--   -> L.LogFloat+-- edgeProb3 crf sent alpha beta k psiMem x y z =+--     alpha (k - 1) y z * beta (k + 1) x y * psiMem x+--     * onTransition crf sent k x y z / zxBeta beta+++-- | Probability of chosing the given three edges and the corresponding labels.+edgeProb3+  :: Md.Model+  -- ^ The underlying model+  -> DAG a X+  -- ^ The underlying DAG+  -> (EdgeIx -> L.LogFloat)+  -- ^ Memoized psi (onWord)+  -> ProbArray+  -- ^ Forward probability table+  -> ProbArray+  -- ^ Backward probability table+  -> EdgeIx+  -- ^ Current edge and the corresponding label+  -> Maybe EdgeIx+  -- ^ Previous edge and the corresponding label+  -> Maybe EdgeIx+  -- ^ One before the previous edge and the corresponding label+  -> L.LogFloat+-- edgeProb3 crf dag psi alpha beta x y z =+edgeProb3 crf dag psi alpha beta u0 v0 w0+  = alpha v w+  * beta u v+  * psi u0+  * onTransition crf dag (Just u0) v0 w0+  / zxBeta beta+  where+   u = Mid u0+   v = complicate Beg v0+   w = complicate Beg w0+++-- | Probability of chosing the given pair of edges and the corresponding labels.+edgeProb2+  :: ProbArray+  -- ^ Forward probability table+  -> ProbArray+  -- ^ Backward probability table+  -> EdgeIx+  -- ^ Current edge and the corresponding label+  -> Maybe EdgeIx+  -- ^ Previous edge and the corresponding label+  -> L.LogFloat+edgeProb2 alpha beta u0 v0 =+  alpha u v * beta u v / zxAlpha alpha+  where+    u = Mid u0+    v = complicate Beg v0+++-- | Probability of chosing the given edge and the corresponding label.+edgeProb1+  :: AccF+  -- ^ Accumulating function (should be the same as the one used to+  -- compute forward and backward tables)+  -> DAG a X+  -- ^ The underlying sentence DAG+  -> ProbArray+  -- ^ Forward probability table+  -> ProbArray+  -- ^ Backward probability table+  -> EdgeIx+  -- ^ Edge and the corresponding label+  -> L.LogFloat+edgeProb1 acc dag alpha beta u = acc -- sum+  [ edgeProb2 alpha beta u v+  | v <- Ft.prevEdgeIxs dag (Just $ edgeID u) ]+++-- | Tag potential labels with marginal probabilities.+marginals :: Md.Model -> DAG a X -> DAG a [(CbIx, L.LogFloat)]+marginals crf dag =+  DAG.mapE label dag+  where+    label edgeID _ =+      [ (Ft.lbIx edgeIx, prob1 edgeIx)+      | edgeIx <- Ft.edgeIxs dag edgeID ]+    prob1 = edgeProb1 L.sum dag alpha beta+    alpha = forward L.sum crf dag+    beta = backward L.sum crf dag+++-- | Tag potential labels with marginal probabilities.+marginals' :: Md.Model -> DAG a X -> DAG a [(Cb, L.LogFloat)]+marginals' crf dag = mergeProbs dag (marginals crf dag)+++-- -- | Tag potential labels with alternative probabilities.+-- -- TODO: explain what is that exactly.+-- probs :: Md.Model -> DAG a X -> DAG a [(CbIx, L.LogFloat)]+-- probs crf dag =+--   DAG.mapE label dag+--   where+--     label edgeID _ =+--       [ (Ft.lbIx edgeIx, prob1 edgeIx)+--       | edgeIx <- Ft.edgeIxs dag edgeID ]+--     prob1 = edgeProb1 maximum dag alpha beta+--     alpha = forward maximum crf dag+--     beta = backward maximum crf dag+++-- | Type of resulting probabilities.+data ProbType+  = Marginals+  -- ^ Marginal probabilities+  | MaxProbs+  -- ^ TODO+++-- | Tag potential labels with alternative probabilities.+-- TODO: explain what is that exactly.+probs :: ProbType -> Md.Model -> DAG a X -> DAG a [(CbIx, L.LogFloat)]+probs probTyp crf dag =+  DAG.mapE label dag+  where+    label edgeID _ =+      [ (Ft.lbIx edgeIx, prob1 edgeIx)+      | edgeIx <- Ft.edgeIxs dag edgeID ]+    prob1 = edgeProb1 acc dag alpha beta+    alpha = forward acc crf dag+    beta = backward acc crf dag+    acc = case probTyp of+      Marginals -> L.sum+      MaxProbs  -> maximum+++-- | Tag potential labels with alternative probabilities.+-- TODO: explain what is that exactly.+probs' :: ProbType -> Md.Model -> DAG a X -> DAG a [(Cb, L.LogFloat)]+probs' typ crf dag = mergeProbs dag (probs typ crf dag)+++-- | Utility function useful for `margilans'` and `probs'`.+mergeProbs :: DAG a X -> DAG a [(CbIx, L.LogFloat)] -> DAG a [(Cb, L.LogFloat)]+mergeProbs dag+  = fmap lbAt+  . DAG.zipE dag+  where+    lbAt (x, ys) =+      [ (C.lbAt x cbIx, pr)+      | (cbIx, pr) <- ys ]+++-- | Get (at most) k best tags for each word and return them in+-- descending order.  TODO: Tagging with respect to marginal+-- distributions might not be the best idea.  Think of some+-- more elegant method.+tagK :: Int -> Md.Model -> DAG a X -> DAG a [(CbIx, L.LogFloat)]+tagK k crf dag = fmap+    ( take k+    . reverse+    . List.sortBy (compare `on` snd)+    ) (marginals crf dag)+++-- | Find the most probable label sequence (with probabilities of individual+-- lables determined with respect to marginal distributions) satisfying the+-- constraints imposed over label values.+tag :: Md.Model -> DAG a X -> DAG a CbIx+tag crf = fmap (fst . head) . tagK 1 crf+++-- | Similar to `tag` but directly returns complex labels and not just their+-- `CbIx` indexes.+tag' :: Md.Model -> DAG a X -> DAG a Cb+tag' crf dag+  = fmap (uncurry C.lbAt)+  $ DAG.zipE dag (tag crf dag)+++expectedFeaturesOn+  :: Md.Model+  -- ^ CRF model+  -> DAG a X+  -- ^ The underlying sentence DAG+  -> ProbArray+  -- ^ Forward computation table+  -> ProbArray+  -- ^ Backward computation table+  -> EdgeID+  -- ^ ID of an edge of the underlying DAG+  -> [(C.Feat, L.LogFloat)]+expectedFeaturesOn crf dag alpha beta edgeID =+  fs1 ++ fs3+  where+    psi = memoEdgeIx dag $ onWord crf dag+    prob1 = edgeProb1 L.sum dag alpha beta+    prob3 = edgeProb3 crf dag psi alpha beta++    fs1 =+      [ (ft, prob)+      | edgeIx <- Ft.edgeIxs dag edgeID+      , let prob = prob1 edgeIx+      , ft <- Ft.obFeatsOn dag edgeIx ]++    fs3 =+      [ (ft, prob)+      | u <- Just <$> Ft.edgeIxs dag edgeID+      , v <- Ft.prevEdgeIxs dag (Ft.edgeID <$> u)+      , w <- Ft.prevEdgeIxs dag (Ft.edgeID <$> v)+      , let prob = prob3 (fromJust u) v w+      , ft <- Ft.trFeatsOn dag u v w ]+++-- | A list of features defined within the context of the sentence accompanied+-- by expected probabilities determined on the basis of the model.+--+-- One feature can occur multiple times in the output list.+expectedFeaturesIn+  :: Md.Model+  -> DAG a X+  -> [(C.Feat, L.LogFloat)]+expectedFeaturesIn crf dag = zxF `Par.par` zxB `Par.pseq` zxF `Par.pseq`+    concat [expectedOn edgeID | edgeID <- DAG.dagEdges dag]+  where+    expectedOn = expectedFeaturesOn crf dag alpha beta+    alpha = forward L.sum crf dag+    beta = backward L.sum crf dag+    zxF = zxAlpha alpha+    zxB = zxBeta beta+++goodAndBad :: Md.Model -> DAG a (X, Y) -> (Int, Int)+goodAndBad crf dag =++    F.foldl' gather (0, 0) $ DAG.zipE labels labels'++  where++    gather (good, bad) results =+      if consistent results+      then (good + 1, bad)+      else (good, bad + 1)++    consistent results = case results of+      (Just xs, Just ys) -> (not . S.null) (S.intersection xs ys)+      (Nothing, Nothing) -> True+      _ -> False++    labels' = fmap best $ probs' MaxProbs crf (fmap fst dag)+    labels  = fmap (best . C.unY)    (fmap snd dag)++    best zs+      | null zs   = Nothing+      | otherwise =+          let maxProb = maximum (map snd zs)+          in  if maxProb < eps+              then Nothing+              else Just+                   . S.fromList . map fst+                   . filter ((>= maxProb - eps) . snd)+                   $ zs+    eps = 1.0e-9++++goodAndBad' :: Md.Model -> [DAG a (X, Y)] -> (Int, Int)+goodAndBad' crf dataset =+    let add (g, b) (g', b') = (g + g', b + b')+    in  F.foldl' add (0, 0) [goodAndBad crf x | x <- dataset]+++-- | Compute the accuracy of the model with respect to the labeled dataset.+accuracy :: Md.Model -> [DAG a (X, Y)] -> Double+accuracy crf dataset =+    let k = numCapabilities+    	parts = partition k dataset+        xs = Par.parMap Par.rseq (goodAndBad' crf) parts+        (good, bad) = F.foldl' add (0, 0) xs+        add (g, b) (g', b') = (g + g', b + b')+    in  fromIntegral good / fromIntegral (good + bad)

@@ -0,0 +1,246 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Rank2Types #-}+++module Data.CRF.Chain2.Tiers.DAG.Probs+( probability+, likelihood+, parLikelihood+) where+++import           GHC.Conc (numCapabilities)++import           Control.Applicative ((<$>))+import qualified Control.Arrow as Arr+import qualified Control.Parallel as Par+import qualified Control.Parallel.Strategies as Par++import qualified Data.Number.LogFloat as L+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Array as A+import qualified Data.Set as S+import           Data.Maybe (fromJust, maybeToList)+import qualified Data.MemoCombinators as Memo+import qualified Data.List as List+import           Data.Function (on)+import qualified Data.Foldable as F++import           Data.DAG (EdgeID, DAG)+import qualified Data.DAG as DAG++import qualified Data.CRF.Chain2.Tiers.Core as C+import           Data.CRF.Chain2.Tiers.Core (X, Y, Ob, Cb, CbIx)+import qualified Data.CRF.Chain2.Tiers.Model as Md+import           Data.CRF.Chain2.Tiers.Util (partition)+import           Data.CRF.Chain2.Tiers.DAG.Feature (EdgeIx(..))+import qualified Data.CRF.Chain2.Tiers.DAG.Feature as Ft++import           Data.CRF.Chain2.Tiers.DAG.Inference+                 (AccF, Pos(..), simplify, complicate, ProbArray)+import qualified Data.CRF.Chain2.Tiers.DAG.Inference as I++import Debug.Trace (trace)+++--------------------------------------------+-- Indexing+---------------------------------------------+++-- | List of observations on the given edge of the sentence.+obList :: DAG a (X, Y) -> EdgeID -> [Ob]+obList dag i = C.unX . fst $ DAG.edgeLabel i dag+{-# INLINE obList #-}+++-- | Vector of labels and the corresponding probabilities on the given edge of+-- the sentence.+lbVec :: DAG a (X, Y) -> EdgeID -> V.Vector (Cb, Double)+lbVec dag edgeID =+  case DAG.edgeLabel edgeID dag of+    (_, y) -> C._unY y+{-# INLINE lbVec #-}+++-- | Number of potential labels on the given edge of the sentence.+lbNum :: DAG a (X, Y) -> EdgeID -> Int+lbNum dag = V.length . lbVec dag+{-# INLINE lbNum #-}+++-- | Label on the given edge and on the given position.+lbOn :: DAG a (X, Y) -> EdgeID -> CbIx -> Maybe (Cb, L.LogFloat)+lbOn dag i = fmap (Arr.second L.logToLogFloat) . (lbVec dag i V.!?)+{-# INLINE lbOn #-}+++-- | List of label indices at the given edge.+lbIxs :: DAG a (X, Y) -> EdgeID -> [CbIx]+lbIxs dag i = [0 .. lbNum dag i - 1]+{-# INLINE lbIxs #-}+++-- | The list of EdgeIx's corresponding to the given edge.+edgeIxs :: DAG a (X, Y) -> EdgeID -> [EdgeIx]+edgeIxs dag i =+  [ EdgeIx {edgeID=i, lbIx=u}+  | u <- lbIxs dag i ]+++--------------------------------------------+-- Indexing advanced+---------------------------------------------+++-- | The list of EdgeIx's corresponding to the previous edges. If the argument+-- edgeID is `Nothing` or if the list of previous edges is empty, the result+-- will be a singleton list containing `Nothing` (which represents a special+-- out-of-bounds EdgeIx).+prevEdgeIxs :: DAG a (X, Y) -> Maybe EdgeID -> [Maybe EdgeIx]+prevEdgeIxs _ Nothing = [Nothing]+prevEdgeIxs dag (Just i)+  | null js = [Nothing]+  | otherwise = Just <$>+    [ EdgeIx {edgeID=j, lbIx=u}+    | j <- js, u <- lbIxs dag j ]+  where js = DAG.prevEdges i dag+++-- | Obtain the list of final EdgeIxs.+finalEdgeIxs :: DAG a (X, Y) -> [EdgeIx]+finalEdgeIxs dag = concat+  [ edgeIxs dag i+  | i <- DAG.dagEdges dag+  , DAG.isFinalEdge i dag ]+++---------------------------------------------+-- Feature alternatives+---------------------------------------------+++-- | Observation features on a given position and with respect+-- to a given label (determined by index).+obFeatsOn :: DAG a (X, Y) -> EdgeIx -> [C.Feat]+obFeatsOn dag EdgeIx{..} = concat+  [ C.obFeats o e+  | (e, _prob) <- maybeToList $ lbOn dag edgeID lbIx+  , o <- obList dag edgeID ]+{-# INLINE obFeatsOn #-}+++-- | Probability of the given EdgeIx. WARNING: returns 0 if the Ix is not in the+-- DAG (and we rely on this behavior)!+probOn :: DAG a (X, Y) -> EdgeIx -> L.LogFloat+probOn dag EdgeIx{..} =+  maybe 0 id $ snd <$> lbOn dag edgeID lbIx+{-# INLINE probOn #-}+++-- | Transition features on a given position and with respect to given labels+-- (determined by indexes).+--+-- TODO: almost the same as `Feature.trFeatsOn`.+trFeatsOn+  :: DAG a (X, Y)+  -> Maybe EdgeIx -- ^ Current EdgeIx+  -> Maybe EdgeIx -- ^ Previous EdgeIx+  -> Maybe EdgeIx -- ^ One before the previous EdgeIx+  -> [C.Feat]+trFeatsOn dag u' v' w' = doit+  (lbOn' =<< u')+  (lbOn' =<< v')+  (lbOn' =<< w')+  where+    lbOn' EdgeIx{..} = fst <$> lbOn dag edgeID lbIx+    doit (Just u) (Just v) (Just w) = C.trFeats3 u v w+    doit (Just u) (Just v) _        = C.trFeats2 u v+    doit (Just u) _ _               = C.trFeats1 u+    doit _ _ _                      = []+{-# INLINE trFeatsOn #-}+++----------------------------------------------------+-- Potential+----------------------------------------------------+++-- | Observation potential on a given position and a given label (identified by+-- index), multiplied by the label's probability.+onWord :: Md.Model -> DAG a (X, Y) -> EdgeIx -> L.LogFloat+onWord crf dag ix+  = (probOn dag ix *)+  . L.product+  . map (Md.phi crf)+  . obFeatsOn dag+  $ ix+{-# INLINE onWord #-}+++-- | Transition potential on a given position and a+-- given labels (identified by indexes).+onTransition+  :: Md.Model+  -> DAG a (X, Y)+  -> Maybe EdgeIx+  -> Maybe EdgeIx+  -> Maybe EdgeIx+  -> L.LogFloat+onTransition crf dag u w v+  = L.product+  . map (Md.phi crf)+  $ trFeatsOn dag u w v+{-# INLINE onTransition #-}+++---------------------------------------------+-- A bit more complex stuff+---------------------------------------------+++-- | Forward table computation.+forward :: AccF -> Md.Model -> DAG a (X, Y) -> ProbArray+forward acc crf dag =+  alpha+  where+    alpha = I.memoProbArray dag alpha'+    alpha' Beg Beg = 1.0+    alpha' End End = acc+      [ alpha End (Mid w)+        -- below, onTransition equals currently to 1; in general, there could be+        -- some related transition features, though.+        * onTransition crf dag Nothing Nothing (Just w)+      | w <- finalEdgeIxs dag ]+    alpha' u v = acc+      [ alpha v w * psi' u+        * onTransition crf dag (simplify u) (simplify v) (simplify w)+      | w <- complicate Beg <$> prevEdgeIxs dag (edgeID <$> simplify v) ]+    psi' u = case u of+      Mid x -> psi x+      _ -> 1.0+    psi = I.memoEdgeIx dag $ onWord crf dag+++-- | Probability of the given DAG in the given model.+probability :: Md.Model -> DAG a (X, Y) -> L.LogFloat+probability crf dag =+  zxAlpha (forward L.sum crf dag) / normFactor+  where+    zxAlpha pa = pa End End+    normFactor = I.zx crf (fmap fst dag)+++-- | Log-likelihood of the given dataset (no parallelization).+likelihood :: Md.Model -> [DAG a (X, Y)] -> L.LogFloat+likelihood crf = L.product . map (probability crf)+++-- | Log-likelihood of the given dataset (parallelized version).+parLikelihood :: Md.Model -> [DAG a (X, Y)] -> L.LogFloat+parLikelihood crf dataset =+  let k = numCapabilities+      parts = partition k dataset+      probs = Par.parMap Par.rseq (likelihood crf) parts+  in  L.product probs

@@ -1,5 +1,6 @@ module Data.CRF.Chain2.Tiers.Dataset.Codec ( Codec+, empty , CodecM , obMax , lbMax@@ -27,6 +28,7 @@ ) where  +import Prelude hiding (Word) import Control.Applicative ((<$>), (<*>), pure) import Control.Comonad.Store (store) import Data.Maybe (catMaybes, fromJust)

@@ -10,6 +10,7 @@ , SentL ) where +import Prelude hiding (Word) import qualified Data.Set as S import qualified Data.Map as M @@ -37,17 +38,29 @@ newtype Prob a = Prob { unProb :: M.Map a Double }     deriving (Show, Eq, Ord) +-- -- | Construct the probability distribution.+-- mkProb :: Ord a => [(a, Double)] -> Prob a+-- mkProb =+--     Prob . normalize . M.fromListWith (+) . filter ((>0).snd)+--   where+--     normalize dist+--         | M.null dist =+--             error "mkProb: no elements with positive probability"+--         | otherwise   =+--             let z = sum (M.elems dist)+--             in  fmap (/z) dist+ -- | Construct the probability distribution.+--+-- Normalization is not performed because, when working with DAGs, the+-- probability of a specific DAG edge can be lower than 1 (in particular, it can+-- be 0).+--+-- Elements with probability 0 cab be filtered out since information that a+-- given label is a potential interpretation of the given word/edge is preserved+-- at the level of the `Word` mkProb :: Ord a => [(a, Double)] -> Prob a-mkProb =-    Prob . normalize . M.fromListWith (+) . filter ((>0).snd)-  where-    normalize dist -        | M.null dist =-            error "mkProb: no elements with positive probability"-        | otherwise   =-            let z = sum (M.elems dist)-            in  fmap (/z) dist+mkProb = Prob . M.fromListWith (+) . filter ((>0).snd)  -- | A WordL is a labeled word, i.e. a word with probability distribution -- defined over labels.  We assume that every label from the distribution

@@ -1,230 +1,49 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-- -- | Internal core data types.   module Data.CRF.Chain2.Tiers.Dataset.Internal (--- * Basic types-  Ob (..)-, mkOb, unOb-, Lb (..)-, mkLb, unLb-, FeatIx (..)-, mkFeatIx, unFeatIx-, CbIx---- * Complex label-, Cb (..)-, mkCb-, unCb+  module Data.CRF.Chain2.Tiers.Core  -- * Input element (word)-, X (_unX, _unR) , Xs-, mkX-, unX-, unR  -- * Output element (choice)-, Y (_unY) , Ys-, mkY-, unY  -- * Indexing-, lbAt , lbOn , lbNum , lbIxs ) where  -import           Data.Binary (Binary, put, get)-import           Data.Ix (Ix)-import           Control.Applicative ((<$>), (<*>))-import           Control.Arrow (second)-import           Data.Int (Int16, Int32)-import qualified Data.Array.Unboxed as A+-- import           Data.Binary (Binary, put, get)+-- import           Data.Ix (Ix)+-- import           Control.Applicative ((<$>), (<*>))+-- import           Control.Arrow (second)+-- import           Data.Int (Int16, Int32)+-- import qualified Data.Array.Unboxed as A import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as U-import           Data.Vector.Unboxed.Deriving-import qualified Data.Vector.Generic.Base as G-import qualified Data.Vector.Generic.Mutable as G-import qualified Data.Number.LogFloat as L--- import qualified Data.Primitive.ByteArray as BA--import           Data.CRF.Chain2.Tiers.Array (Bounds)--------------------------------------------------------------------- Basic types---------------------------------------------------------------------- | An observation.-newtype Ob = Ob { _unOb :: Int32 }-    deriving ( Show, Eq, Ord, Binary, A.IArray A.UArray )---           GeneralizedNewtypeDeriving doesn't work for this in 7.8.2:---           , G.Vector U.Vector, G.MVector U.MVector, U.Unbox )-derivingUnbox "Ob" [t| Ob -> Int32 |] [| _unOb |] [| Ob |]---- | Smart observation constructor.-mkOb :: Int -> Ob-mkOb = Ob . fromIntegral-{-# INLINE mkOb #-}----- | Deconstract observation.-unOb :: Ob -> Int-unOb = fromIntegral . _unOb-{-# INLINE unOb #-}----- | An atomic label.-newtype Lb = Lb { _unLb :: Int16 }-    deriving ( Show, Eq, Ord, Binary, A.IArray A.UArray-             , Num, Ix, Bounds)-derivingUnbox "Lb" [t| Lb -> Int16 |] [| _unLb |] [| Lb |]----- | Smart label constructor.-mkLb :: Int -> Lb-mkLb = Lb . fromIntegral-{-# INLINE mkLb #-}----- | Deconstract label.-unLb :: Lb -> Int-unLb = fromIntegral . _unLb-{-# INLINE unLb #-}----- | An index of the label.-type CbIx = Int----- | A feature index.  To every model feature a unique index is assigned.-newtype FeatIx = FeatIx { _unFeatIx :: Int32 }-    deriving ( Show, Eq, Ord, Binary, A.IArray A.UArray )-derivingUnbox "FeatIx" [t| FeatIx -> Int32 |] [| _unFeatIx |] [| FeatIx |]---- | Smart feature index constructor.-mkFeatIx :: Int -> FeatIx-mkFeatIx = FeatIx . fromIntegral-{-# INLINE mkFeatIx #-}----- | Deconstract feature index.-unFeatIx :: FeatIx -> Int-unFeatIx = fromIntegral . _unFeatIx-{-# INLINE unFeatIx #-}---------------------------------------------------------------------- Complex label---------------------------------------------------------------------- TODO: Do we gain anything by representing the--- complex label with a byte array?  Complex labels--- should not be directly stored in a model, so if--- there is something to gain here, its not obvious.+-- import qualified Data.Vector.Unboxed as U+-- import           Data.Vector.Unboxed.Deriving+-- import qualified Data.Vector.Generic.Base as G+-- import qualified Data.Vector.Generic.Mutable as G+-- import qualified Data.Number.LogFloat as L+-- -- import qualified Data.Primitive.ByteArray as BA ----- Perhaps a list representation would be sufficient?----- -- | A complex label is an array of atomic labels.--- newtype Cb = Cb { unCb :: BA.ByteArray }----- | A complex label is a vector of atomic labels.-newtype Cb = Cb { _unCb :: U.Vector Lb }-    deriving (Show, Eq, Ord, Binary)----- | Smart complex label constructor.-mkCb :: [Lb] -> Cb-mkCb = Cb . U.fromList----- | Deconstract complex label.-unCb :: Cb -> [Lb]-unCb = U.toList . _unCb---------------------------------------------------------------------- Internal dataset representation---------------------------------------------------------------------- | A word is represented by a list of its observations--- and a list of its potential label interpretations.-data X = X {-    -- | A set of observations.-      _unX :: U.Vector Ob-    -- | A vector of potential labels.-    , _unR :: V.Vector Cb }-    deriving (Show, Eq, Ord)+-- import           Data.CRF.Chain2.Tiers.Array (Bounds)  -instance Binary X where-    put X{..} = put _unX >> put _unR-    get = X <$> get <*> get+import           Data.CRF.Chain2.Tiers.Core   -- | Sentence of words. type Xs = V.Vector X  --- | Smart `X` constructor.-mkX :: [Ob] -> [Cb] -> X-mkX x r = X (U.fromList x) (V.fromList r)-{-# INLINE mkX #-}----- | List of observations.-unX :: X -> [Ob]-unX = U.toList . _unX-{-# INLINE unX #-}----- | List of potential labels.-unR :: X -> [Cb]-unR = V.toList . _unR-{-# INLINE unR #-}----- | Vector of chosen labels together with--- corresponding probabilities in log domain.-newtype Y = Y { _unY :: V.Vector (Cb, Double) }-    deriving (Show, Eq, Ord, Binary)----- | Y constructor.-mkY :: [(Cb, Double)] -> Y-mkY = Y . V.fromList . map (second log)-{-# INLINE mkY #-}----- | Y deconstructor symetric to mkY.-unY :: Y -> [(Cb, L.LogFloat)]-unY = map (second L.logToLogFloat) . V.toList . _unY-{-# INLINE unY #-}-- -- | Sentence of Y (label choices). type Ys = V.Vector Y----- | Potential label at the given position.-lbAt :: X -> CbIx -> Cb-lbAt x = (_unR x V.!)-{-# INLINE lbAt #-}   lbVec :: Xs -> Int -> V.Vector Cb

@@ -3,11 +3,11 @@ -- * Feature   Feat (..) --- * Feature generation-, obFeats-, trFeats1-, trFeats2-, trFeats3+-- -- * Feature generation+-- , obFeats+-- , trFeats1+-- , trFeats2+-- , trFeats3  -- * Feature extraction , presentFeats@@ -24,88 +24,11 @@  import           Control.Applicative ((<*>), (<$>)) import           Data.Maybe (maybeToList)-import           Data.List (zip4)-import           Data.Binary (Binary, put, get, putWord8, getWord8)+import           Data.Binary (Binary, put, get) import qualified Data.Vector as V import qualified Data.Number.LogFloat as L -import Data.CRF.Chain2.Tiers.Dataset.Internal---------------------------------------------------------- Feature---------------------------------------------------------- | Feature; every feature is associated to a layer with `ln` identifier.-data Feat-    -- | Second-order transition feature.-    = TFeat3-        { x1    :: {-# UNPACK #-} !Lb-        , x2    :: {-# UNPACK #-} !Lb-        , x3    :: {-# UNPACK #-} !Lb-        , ln    :: {-# UNPACK #-} !Int }-    -- | First-order transition feature.-    | TFeat2-        { x1    :: {-# UNPACK #-} !Lb-        , x2    :: {-# UNPACK #-} !Lb-        , ln    :: {-# UNPACK #-} !Int }-    -- | Zero-order transition feature.-    | TFeat1-        { x1    :: {-# UNPACK #-} !Lb-        , ln    :: {-# UNPACK #-} !Int }-    -- | Observation feature.-    | OFeat-        { ob    :: {-# UNPACK #-} !Ob-        , x1    :: {-# UNPACK #-} !Lb-        , ln    :: {-# UNPACK #-} !Int }-    deriving (Show, Eq, Ord)---instance Binary Feat where-    put (OFeat o x k)       = putWord8 0 >> put o >> put x >> put k-    put (TFeat3 x y z k)    = putWord8 1 >> put x >> put y >> put z >> put k-    put (TFeat2 x y k)      = putWord8 2 >> put x >> put y >> put k-    put (TFeat1 x k)        = putWord8 3 >> put x >> put k-    get = getWord8 >>= \i -> case i of-        0   -> OFeat  <$> get <*> get <*> get-        1   -> TFeat3 <$> get <*> get <*> get <*> get-        2   -> TFeat2 <$> get <*> get <*> get-        3   -> TFeat1 <$> get <*> get-        _   -> error "get feature: unknown code"---------------------------------------------------------- Features generation---------------------------------------------------------- | Generate observation features.-obFeats :: Ob -> Cb -> [Feat]-obFeats ob' xs =-    [ OFeat ob' x k-    | (x, k) <- zip (unCb xs) [0..] ]----- | Generate zero-order transition features.-trFeats1 :: Cb -> [Feat]-trFeats1 xs =-    [ TFeat1 x k-    | (x, k) <- zip (unCb xs) [0..] ]----- | Generate first-order transition features.-trFeats2 :: Cb -> Cb -> [Feat]-trFeats2 xs1 xs2 =-    [ TFeat2 x1' x2' k-    | (x1', x2', k) <- zip3 (unCb xs1) (unCb xs2) [0..] ]----- | Generate second-order transition features.-trFeats3 :: Cb -> Cb -> Cb -> [Feat]-trFeats3 xs1 xs2 xs3 =-    [ TFeat3 x1' x2' x3' k-    | (x1', x2', x3', k) <- zip4 (unCb xs1) (unCb xs2) (unCb xs3) [0..] ]+import           Data.CRF.Chain2.Tiers.Dataset.Internal   ----------------------------------------------------@@ -160,13 +83,13 @@   -- | Observation features on a given position and with respect--- to a given label (determined by idenex).+-- to a given label (determined by index). obFeatsOn :: Xs -> Int -> CbIx -> [Feat] obFeatsOn xs i u = concat     [ obFeats ob' e     | e   <- lbs     , ob' <- unX (xs V.! i) ]-  where +  where     lbs     = maybeToList (lbOn xs i u) {-# INLINE obFeatsOn #-} 

@@ -34,6 +34,33 @@  type ProbArray = CbIx -> CbIx -> CbIx -> L.LogFloat ++----------------------------------------------------+-- Potential+----------------------------------------------------+++-- | Observation potential on a given position and a+-- given label (identified by index).+onWord :: Model -> Xs -> Int -> CbIx -> L.LogFloat+onWord crf xs i u =+    product . map (phi crf) $ obFeatsOn xs i u+{-# INLINE onWord #-}+++-- | Transition potential on a given position and a+-- given labels (identified by indexes).+onTransition :: Model -> Xs -> Int -> CbIx -> CbIx -> CbIx -> L.LogFloat+onTransition crf xs i u w v =+    product . map (phi crf) $ trFeatsOn xs i u w v+{-# INLINE onTransition #-}+++----------------------------------------------------+-- More complex stuff+----------------------------------------------------++ computePsi :: Model -> Xs -> Int -> CbIx -> L.LogFloat computePsi crf xs i = (A.!) $ A.array (0, lbNum xs i - 1)     [ (k, onWord crf xs i k)@@ -125,6 +152,7 @@ --         beta = backward maximum crf sent --         normalize xs = --             let d = - sum xs+--             -- UPDATE 13/11/2017: maybe it doesn't work because of that? --             in map (*d) xs --         m1 k x = maximum --             [ alpha k x y * beta (k + 1) x y@@ -164,7 +192,7 @@ accuracy :: Model -> [(Xs, Ys)] -> Double accuracy crf dataset =     let k = numCapabilities-    	parts = partition k dataset+        parts = partition k dataset         xs = parMap rseq (goodAndBad' crf) parts         (good, bad) = foldl add (0, 0) xs         add (g, b) (g', b') = (g + g', b + b')@@ -201,11 +229,11 @@     where psi = computePsi crf sent k           pr1 = prob1 crf alpha beta sent k           pr3 = prob3 crf alpha beta sent k psi-          fs1 = [ (ft, pr) +          fs1 = [ (ft, pr)                 | a <- lbIxs sent k                 , let pr = pr1 a                 , ft <- obFs a ]-    	  fs3 = [ (ft, pr) +          fs3 = [ (ft, pr)                 | a <- lbIxs sent k                 , b <- lbIxs sent $ k - 1                 , c <- lbIxs sent $ k - 2

@@ -17,8 +17,6 @@ -- * Potential , phi , index-, onWord-, onTransition ) where  @@ -312,19 +310,3 @@ index :: Model -> Feat -> Maybe FeatIx index Model{..} ft = featIndex ft featMap {-# INLINE index #-}----- | Observation potential on a given position and a--- given label (identified by index).-onWord :: Model -> Xs -> Int -> CbIx -> L.LogFloat-onWord crf xs i u =-    product . map (phi crf) $ obFeatsOn xs i u-{-# INLINE onWord #-}----- | Transition potential on a given position and a--- given labels (identified by indexes).-onTransition :: Model -> Xs -> Int -> CbIx -> CbIx -> CbIx -> L.LogFloat-onTransition crf xs i u w v =-    product . map (phi crf) $ trFeatsOn xs i u w v-{-# INLINE onTransition #-}