diff --git a/Data/CRF/Chain1.hs b/Data/CRF/Chain1.hs deleted file mode 100644 --- a/Data/CRF/Chain1.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | The module provides first-order, linear-chain conditional random fields --- (CRFs). --- --- Important feature of the implemented flavour of CRFs is that transition --- features which are not included in the CRF model are considered to have --- probability of 0. --- It is particularly useful when the training material determines the set --- of possible label transitions (e.g. when using the IOB encoding method). --- Furthermore, this design decision makes the implementation much faster --- for sparse datasets. - -module Data.CRF.Chain1 -( --- * Data types - Word -, Sent -, Dist (unDist) -, mkDist -, WordL -, annotate -, SentL - --- * CRF -, CRF (..) --- ** Training -, train --- ** Tagging -, tag - --- * Feature selection -, hiddenFeats -, presentFeats -) where - -import Data.CRF.Chain1.Dataset.External -import Data.CRF.Chain1.Dataset.Codec -import Data.CRF.Chain1.Feature.Present -import Data.CRF.Chain1.Feature.Hidden -import Data.CRF.Chain1.Train -import qualified Data.CRF.Chain1.Inference as I - --- | Determine the most probable label sequence within the context of the --- given sentence using the model provided by the 'CRF'. -tag :: (Ord a, Ord b) => CRF a b -> Sent a -> [b] -tag CRF{..} = decodeLabels codec . I.tag model . encodeSent codec diff --git a/Data/CRF/Chain1/DP.hs b/Data/CRF/Chain1/DP.hs deleted file mode 100644 --- a/Data/CRF/Chain1/DP.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Data.CRF.Chain1.DP -( table -, flexible2 -, flexible3 -) where - -import qualified Data.Array as A -import Data.Array ((!)) -import Data.Ix (range) - -table :: A.Ix i => (i, i) -> ((i -> e) -> i -> e) -> A.Array i e -table bounds f = table' where - table' = A.listArray bounds - $ map (f (table' !)) - $ range bounds - -down1 :: A.Ix i => (i, i) -> (i -> e) -> i -> e -down1 bounds f = (!) down' where - down' = A.listArray bounds - $ map f - $ range bounds - -down2 :: (A.Ix i, A.Ix j) => (j, j) -> (j -> (i, i)) -> (j -> i -> e) - -> j -> i -> e -down2 bounds1 bounds2 f = (!) down' where - down' = A.listArray bounds1 - [ down1 (bounds2 i) (f i) - | i <- range bounds1 ] - -flexible2 :: (A.Ix i, A.Ix j) => (j, j) -> (j -> (i, i)) - -> ((j -> i -> e) -> j -> i -> e) -> j -> i -> e -flexible2 bounds1 bounds2 f = (!) flex where - flex = A.listArray bounds1 - [ down1 (bounds2 i) (f (flex !) i) - | i <- range bounds1 ] - -flexible3 :: (A.Ix j, A.Ix i, A.Ix k) => (k, k) -> (k -> (j, j)) - -> (k -> j -> (i, i)) -> ((k -> j -> i -> e) -> k -> j -> i -> e) - -> k -> j -> i -> e -flexible3 bounds1 bounds2 bounds3 f = (!) flex where - flex = A.listArray bounds1 - [ down2 (bounds2 i) (bounds3 i) (f (flex !) i) - | i <- range bounds1 ] diff --git a/Data/CRF/Chain1/Dataset/Codec.hs b/Data/CRF/Chain1/Dataset/Codec.hs deleted file mode 100644 --- a/Data/CRF/Chain1/Dataset/Codec.hs +++ /dev/null @@ -1,134 +0,0 @@ -module Data.CRF.Chain1.Dataset.Codec -( Codec -, CodecM - -, encodeWord'Cu -, encodeWord'Cn -, encodeSent'Cu -, encodeSent'Cn -, encodeSent - -, encodeWordL'Cu -, encodeWordL'Cn -, encodeSentL'Cu -, encodeSentL'Cn -, encodeSentL - -, decodeLabel -, decodeLabels - -, mkCodec -, encodeData -, encodeDataL -) where - -import Control.Applicative ((<$>), (<*>), pure) -import Data.Maybe (catMaybes) -import Data.Lens.Common (fstLens, sndLens) -import qualified Data.Set as S -import qualified Data.Map as M -import qualified Data.Vector as V -import qualified Control.Monad.Codec as C - -import Data.CRF.Chain1.Dataset.Internal -import Data.CRF.Chain1.Dataset.External - --- | A codec. The first component is used to encode observations --- of type a, the second one is used to encode labels of type b. -type Codec a b = (C.AtomCodec a, C.AtomCodec b) - --- | Type synonym for the codec monad. It is important to notice that by a --- codec we denote here a structure of two 'C.AtomCodec's while in the --- monad-codec package it denotes a monad. -type CodecM a b c = C.Codec (Codec a b) c - --- | Encode the labeled word and update the codec. -encodeWordL'Cu :: (Ord a, Ord b) => WordL a b -> CodecM a b (X, Y) -encodeWordL'Cu word = do - x <- mkX . map Ob <$> - mapM (C.encode' fstLens) (S.toList $ fst word) - y <- mkY <$> sequence - [ (,) <$> (Lb <$> C.encode sndLens lb) <*> pure pr - | (lb, pr) <- (M.toList . unDist) (snd word) ] - return (x, y) - --- | Encodec the labeled word and do *not* update the codec. --- If the label is not in the codec, use the default value. -encodeWordL'Cn :: (Ord a, Ord b) => Int -> WordL a b -> CodecM a b (X, Y) -encodeWordL'Cn i word = do - x <- mkX . map Ob . catMaybes <$> - mapM (C.maybeEncode fstLens) (S.toList $ fst word) - y <- mkY <$> sequence - [ (,) <$> encodeL i lb <*> pure pr - | (lb, pr) <- (M.toList . unDist) (snd word) ] - return (x, y) - where - encodeL j y = Lb . maybe j id <$> C.maybeEncode sndLens y - --- | Encode the word and update the codec. -encodeWord'Cu :: Ord a => Word a -> CodecM a b X -encodeWord'Cu word = - mkX . map Ob <$> mapM (C.encode' fstLens) (S.toList word) - --- | Encode the word and do *not* update the codec. -encodeWord'Cn :: Ord a => Word a -> CodecM a b X -encodeWord'Cn word = - mkX . map Ob . catMaybes <$> mapM (C.maybeEncode fstLens) (S.toList word) - --- | Encode the labeled sentence and update the codec. -encodeSentL'Cu :: (Ord a, Ord b) => SentL a b -> CodecM a b (Xs, Ys) -encodeSentL'Cu sent = do - ps <- mapM encodeWordL'Cu sent - return (V.fromList (map fst ps), V.fromList (map snd ps)) - --- | Encode the labeled sentence and do *not* update the codec. --- Substitute the default label for any label not present in the codec. -encodeSentL'Cn :: (Ord a, Ord b) => b -> SentL a b -> CodecM a b (Xs, Ys) -encodeSentL'Cn def sent = do - i <- C.maybeEncode sndLens def >>= \mi -> case mi of - Just _i -> return _i - Nothing -> error "encodeWordL'Cn: default label not in the codec" - ps <- mapM (encodeWordL'Cn i) sent - return (V.fromList (map fst ps), V.fromList (map snd ps)) - --- | Encode the labeled sentence with the given codec. Substitute the --- default label for any label not present in the codec. -encodeSentL :: (Ord a, Ord b) => b -> Codec a b -> SentL a b -> (Xs, Ys) -encodeSentL def codec = C.evalCodec codec . encodeSentL'Cn def - --- | Encode the sentence and update the codec. -encodeSent'Cu :: Ord a => Sent a -> CodecM a b Xs -encodeSent'Cu = fmap V.fromList . mapM encodeWord'Cu - --- | Encode the sentence and do *not* update the codec. -encodeSent'Cn :: Ord a => Sent a -> CodecM a b Xs -encodeSent'Cn = fmap V.fromList . mapM encodeWord'Cn - --- | Encode the sentence using the given codec. -encodeSent :: Ord a => Codec a b -> Sent a -> Xs -encodeSent codec = C.evalCodec codec . encodeSent'Cn - --- | Create the codec on the basis of the labeled dataset, return the --- resultant codec and the encoded dataset. -mkCodec :: (Ord a, Ord b) => [SentL a b] -> (Codec a b, [(Xs, Ys)]) -mkCodec = - let swap (x, y) = (y, x) - in swap . C.runCodec (C.empty, C.empty) . mapM encodeSentL'Cu - --- | Encode the labeled dataset using the codec. Substitute the default --- label for any label not present in the codec. -encodeDataL :: (Ord a, Ord b) => b -> Codec a b -> [SentL a b] -> [(Xs, Ys)] -encodeDataL def codec = C.evalCodec codec . mapM (encodeSentL'Cn def) - --- | Encode the dataset with the codec. -encodeData :: Ord a => Codec a b -> [Sent a] -> [Xs] -encodeData codec = map (encodeSent codec) - --- | Decode the label. -decodeLabel :: Ord b => Codec a b -> Lb -> b -decodeLabel codec x = C.evalCodec codec $ C.decode sndLens (unLb x) - --- | Decode the sequence of labels. -decodeLabels :: Ord b => Codec a b -> [Lb] -> [b] -decodeLabels codec xs = C.evalCodec codec $ - sequence [C.decode sndLens (unLb x) | x <- xs] diff --git a/Data/CRF/Chain1/Dataset/External.hs b/Data/CRF/Chain1/Dataset/External.hs deleted file mode 100644 --- a/Data/CRF/Chain1/Dataset/External.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Data.CRF.Chain1.Dataset.External -( Word -, Sent -, Dist (unDist) -, mkDist -, WordL -, annotate -, SentL -) where - -import qualified Data.Set as S -import qualified Data.Map as M - --- | A Word is represented by a set of observations. -type Word a = S.Set a - --- | A sentence of words. -type Sent a = [Word a] - --- | A probability distribution defined over elements of type a. --- All elements not included in the map have probability equal --- to 0. -newtype Dist a = Dist { unDist :: M.Map a Double } - --- | Construct the probability distribution. -mkDist :: Ord a => [(a, Double)] -> Dist a -mkDist = - Dist . normalize . M.fromListWith (+) - where - normalize dist = - let z = sum (M.elems dist) - in fmap (/z) dist - --- | A WordL is a labeled word, i.e. a word with probability distribution --- defined over labels. -type WordL a b = (Word a, Dist b) - --- | Annotate the word with the label. -annotate :: Word a -> b -> WordL a b -annotate w x = (w, Dist (M.singleton x 1)) - --- | A sentence of labeled words. -type SentL a b = [WordL a b] diff --git a/Data/CRF/Chain1/Dataset/Internal.hs b/Data/CRF/Chain1/Dataset/Internal.hs deleted file mode 100644 --- a/Data/CRF/Chain1/Dataset/Internal.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - - -module Data.CRF.Chain1.Dataset.Internal -( Ob (..) -, Lb (..) - -, X (..) -, mkX -, unX -, Xs - -, Y (..) -, mkY -, unY -, Ys -) where - - --- import Data.Vector.Generic.Base --- import Data.Vector.Generic.Mutable -import Data.Binary (Binary) -import Data.Ix (Ix) -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as U -import Data.Vector.Unboxed.Deriving - - - --- | An observation. -newtype Ob = Ob { unOb :: Int } - deriving ( Show, Read, Eq, Ord, Binary ) --- GeneralizedNewtypeDeriving doesn't work for this in 7.8.2: --- , Vector U.Vector, MVector U.MVector, U.Unbox ) -derivingUnbox "Ob" [t| Ob -> Int |] [| unOb |] [| Ob |] - - --- | A label. -newtype Lb = Lb { unLb :: Int } - deriving ( Show, Read, Eq, Ord, Binary, Num, Ix ) -derivingUnbox "Lb" [t| Lb -> Int |] [| unLb |] [| Lb |] - - --- | Simple word represented by a list of its observations. -newtype X = X { _unX :: U.Vector Ob } - deriving (Show, Read, Eq, Ord) - --- | X constructor. -mkX :: [Ob] -> X -mkX = X . U.fromList -{-# INLINE mkX #-} - --- | X deconstructor symetric to mkX. -unX :: X -> [Ob] -unX = U.toList . _unX -{-# INLINE unX #-} - --- | Sentence of words. -type Xs = V.Vector X - --- | Probability distribution over labels. -newtype Y = Y { _unY :: U.Vector (Lb, Double) } - deriving (Show, Read, Eq, Ord) - --- | Y constructor. -mkY :: [(Lb, Double)] -> Y -mkY = Y . U.fromList -{-# INLINE mkY #-} - --- | Y deconstructor symetric to mkY. -unY :: Y -> [(Lb, Double)] -unY = U.toList . _unY -{-# INLINE unY #-} - --- | Sentence of Y (label choices). -type Ys = V.Vector Y diff --git a/Data/CRF/Chain1/Feature.hs b/Data/CRF/Chain1/Feature.hs deleted file mode 100644 --- a/Data/CRF/Chain1/Feature.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Data.CRF.Chain1.Feature -( Feature (..) -, isSFeat -, isTFeat -, isOFeat -, featuresIn -) where - -import Data.Binary (Binary, Get, put, get) -import Control.Applicative ((<*>), (<$>)) -import qualified Data.Vector as V -import qualified Data.Number.LogFloat as L - -import Data.CRF.Chain1.Dataset.Internal - --- | A Feature is either an observation feature OFeature o x, which --- models relation between observation o and label x assigned to --- the same word, or a transition feature TFeature x y (SFeature x --- for the first position in the sentence), which models relation --- between two subsequent labels, x (on i-th position) and y --- (on (i-1)-th positoin). -data Feature - = SFeature - {-# UNPACK #-} !Lb - | TFeature - {-# UNPACK #-} !Lb - {-# UNPACK #-} !Lb - | OFeature - {-# UNPACK #-} !Ob - {-# UNPACK #-} !Lb - deriving (Show, Eq, Ord) - -instance Binary Feature where - put (SFeature x) = put (0 :: Int) >> put x - put (TFeature x y) = put (1 :: Int) >> put (x, y) - put (OFeature o x) = put (2 :: Int) >> put (o, x) - get = do - k <- get :: Get Int - case k of - 0 -> SFeature <$> get - 1 -> TFeature <$> get <*> get - 2 -> OFeature <$> get <*> get - _ -> error "Binary Feature: unknown identifier" - --- | Is it a 'SFeature'? -isSFeat :: Feature -> Bool -isSFeat (SFeature _) = True -isSFeat _ = False -{-# INLINE isSFeat #-} - --- | Is it an 'OFeature'? -isOFeat :: Feature -> Bool -isOFeat (OFeature _ _) = True -isOFeat _ = False -{-# INLINE isOFeat #-} - --- | Is it a 'TFeature'? -isTFeat :: Feature -> Bool -isTFeat (TFeature _ _) = True -isTFeat _ = False -{-# INLINE isTFeat #-} - --- | Transition features with assigned probabilities for given position. -trFeats :: Ys -> Int -> [(Feature, L.LogFloat)] -trFeats ys 0 = - [ (SFeature x, L.logFloat px) - | (x, px) <- unY (ys V.! 0) ] -trFeats ys k = - [ (TFeature x y, L.logFloat px * L.logFloat py) - | (x, px) <- unY (ys V.! k) - , (y, py) <- unY (ys V.! (k-1)) ] - --- | Observation features with assigned probabilities for a given position. -obFeats :: Xs -> Ys -> Int -> [(Feature, L.LogFloat)] -obFeats xs ys k = - [ (OFeature o x, L.logFloat px) - | (x, px) <- unY (ys V.! k) - , o <- unX (xs V.! k) ] - --- | All features with assigned probabilities for given position. -features :: Xs -> Ys -> Int -> [(Feature, L.LogFloat)] -features xs ys k = trFeats ys k ++ obFeats xs ys k - --- | All features with assigned probabilities in given labeled sentence. -featuresIn :: Xs -> Ys -> [(Feature, L.LogFloat)] -featuresIn xs ys = concatMap (features xs ys) [0 .. V.length xs - 1] diff --git a/Data/CRF/Chain1/Feature/Hidden.hs b/Data/CRF/Chain1/Feature/Hidden.hs deleted file mode 100644 --- a/Data/CRF/Chain1/Feature/Hidden.hs +++ /dev/null @@ -1,66 +0,0 @@ --- | The module provides feature selection functions which extract --- hidden features, i.e. all features which can be constructed --- (by means of cartesian product) on the basis of the set of --- observations and the set of labels. --- For example, the list of hidden observation features can --- be defined as 'OFeature' '<$>' os '<*>' xs, where os is a --- list of all observations and xs is a list of all labels. --- --- You can mix functions defined here with the selection functions --- from the "Data.CRF.Chain1.Feature.Present" module. - -module Data.CRF.Chain1.Feature.Hidden -( hiddenFeats -, hiddenOFeats -, hiddenTFeats -, hiddenSFeats -) where - -import qualified Data.Set as S -import qualified Data.Vector as V - -import Data.CRF.Chain1.Dataset.Internal -import Data.CRF.Chain1.Feature - --- | Hidden 'OFeature's which can be constructed based on the dataset. -hiddenOFeats :: [(Xs, Ys)] -> [Feature] -hiddenOFeats ds = - [ OFeature o x - | o <- collectObs ds - , x <- collectLbs ds ] - --- | Hidden 'TFeature's which can be constructed based on the dataset. -hiddenTFeats :: [(Xs, Ys)] -> [Feature] -hiddenTFeats ds = - let xs = collectLbs ds - in [TFeature x y | x <- xs, y <- xs] - --- | Hidden 'SFeature's which can be constructed based on the dataset. -hiddenSFeats :: [(Xs, Ys)] -> [Feature] -hiddenSFeats = map SFeature . collectLbs - --- | Hidden 'Feature's of all types which can be constructed --- based on the dataset. -hiddenFeats :: [(Xs, Ys)] -> [Feature] -hiddenFeats ds - = hiddenOFeats ds - ++ hiddenTFeats ds - ++ hiddenSFeats ds - -collectObs :: [(Xs, Ys)] -> [Ob] -collectObs = nub . concatMap (sentObs . fst) - -collectLbs :: [(Xs, Ys)] -> [Lb] -collectLbs = nub . concatMap (sentLbs . snd) - -sentObs :: Xs -> [Ob] -sentObs = concatMap unX . V.toList - -sentLbs :: Ys -> [Lb] -sentLbs = concatMap lbsAll . V.toList - -lbsAll :: Y -> [Lb] -lbsAll = map fst . unY - -nub :: Ord a => [a] -> [a] -nub = S.toList . S.fromList diff --git a/Data/CRF/Chain1/Feature/Present.hs b/Data/CRF/Chain1/Feature/Present.hs deleted file mode 100644 --- a/Data/CRF/Chain1/Feature/Present.hs +++ /dev/null @@ -1,56 +0,0 @@ --- | The module provides feature selection functions which extract --- features present in the dataset, i.e. features which directly occure --- the dataset. --- --- You can mix functions defined here with the selection functions --- from the "Data.CRF.Chain1.Feature.Hidden" module. - -module Data.CRF.Chain1.Feature.Present -( presentFeats -, presentOFeats -, presentTFeats -, presentSFeats -) where - -import qualified Data.Vector as V - -import Data.CRF.Chain1.Dataset.Internal -import Data.CRF.Chain1.Feature - --- | 'OFeature's which occur in the dataset. -presentOFeats :: [(Xs, Ys)] -> [Feature] -presentOFeats ds = - concatMap sentOFeats ds - where - sentOFeats (xs, ys) = concatMap oFeatsOn (zip (V.toList xs) (V.toList ys)) - oFeatsOn (x, choice) = - [ OFeature o y - | o <- unX x - , y <- lbs choice ] - --- | 'TFeature's which occur in the dataset. -presentTFeats :: [(a, Ys)] -> [Feature] -presentTFeats ds = - concatMap (sentTFeats.snd) ds - where - sentTFeats ys = concatMap (tFeatsOn ys) [1 .. V.length ys - 1] - tFeatsOn ys k = - [ TFeature x y - | x <- lbs (ys V.! k) - , y <- lbs (ys V.! (k-1)) ] - --- | 'SFeature's which occur in the dataset. -presentSFeats :: [(a, Ys)] -> [Feature] -presentSFeats ds = - let sentSFeats s = [SFeature x | x <- lbs (s V.! 0)] - in concatMap (sentSFeats.snd) ds - --- | 'Feature's of all kinds which occur in the dataset. -presentFeats :: [(Xs, Ys)] -> [Feature] -presentFeats ds - = presentOFeats ds - ++ presentTFeats ds - ++ presentSFeats ds - -lbs :: Y -> [Lb] -lbs = map fst . unY diff --git a/Data/CRF/Chain1/Inference.hs b/Data/CRF/Chain1/Inference.hs deleted file mode 100644 --- a/Data/CRF/Chain1/Inference.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - --- Inference with CRFs. - -module Data.CRF.Chain1.Inference -( tag -, marginals -, accuracy -, expectedFeaturesIn -, zx -, zx' -) where - -import Control.Applicative ((<$>), (<*>), pure) -import Data.Maybe (catMaybes) -import Data.List (maximumBy) -import Data.Function (on) -import qualified Data.Array as A -import qualified Data.Vector as V - -import Control.Parallel.Strategies (rseq, parMap) -import Control.Parallel (par, pseq) -import GHC.Conc (numCapabilities) -import qualified Data.Number.LogFloat as L - -import qualified Data.CRF.Chain1.DP as DP -import Data.CRF.Chain1.Util (partition) -import Data.CRF.Chain1.Dataset.Internal -import Data.CRF.Chain1.Model - -type ProbArray = Int -> Lb -> L.LogFloat -type AccF = [L.LogFloat] -> L.LogFloat - --- | Compute the table of potential products associated with --- observation features for the given sentence position. -computePsi :: Model -> Xs -> Int -> Lb -> L.LogFloat -computePsi crf xs i = (A.!) $ A.accumArray (*) 1 bounds - [ (x, valueL crf ix) - | ob <- unX (xs V.! i) - , (x, ix) <- obIxs crf ob ] - where - bounds = (Lb 0, Lb $ lbNum crf - 1) - --- | Forward table computation. -forward :: AccF -> Model -> Xs -> ProbArray -forward acc crf sent = DP.flexible2 - (0, V.length sent) wordBounds - (\t k -> withMem (computePsi crf sent k) t k) - where - wordBounds k - | k == V.length sent = (Lb 0, Lb 0) - | otherwise = (Lb 0, Lb $ lbNum crf - 1) - -- | Forward table equation, where k is current position, x is a label - -- on current position and psi is a psi table computed for current - -- position. - -- FIXME: null sentence? - withMem psi alpha k x - | k == 0 = psi x * sgValue crf x - | k == V.length sent = acc - [ alpha (k - 1) y - | y <- lbSet crf ] - | otherwise = acc - [ alpha (k - 1) y * psi x * valueL crf ix - | (y, ix) <- prevIxs crf x ] - --- | Backward table computation. -backward :: AccF -> Model -> Xs -> ProbArray -backward acc crf sent = DP.flexible2 - (0, V.length sent) wordBounds - (\t k -> withMem (computePsi crf sent k) t k) - where - wordBounds k - | k == 0 = (Lb 0, Lb 0) - | otherwise = (Lb 0, Lb $ lbNum crf - 1) - -- | Backward table equation, where k is current position, y is a label - -- on previous, k-1, position and psi is a psi table computed for current - -- position. - withMem psi beta k y - | k == V.length sent = 1 - | k == 0 = acc - [ beta (k + 1) x * psi x * valueL crf ix - | (x, ix) <- sgIxs crf ] - | otherwise = acc - [ beta (k + 1) x * psi x * valueL crf ix - | (x, ix) <- nextIxs crf y ] - -zxBeta :: ProbArray -> L.LogFloat -zxBeta beta = beta 0 0 - -zxAlpha :: Xs -> ProbArray -> L.LogFloat -zxAlpha sent alpha = alpha (V.length sent) 0 - --- | Normalization factor computed for the 'Xs' sentence using the --- backward computation. -zx :: Model -> Xs -> L.LogFloat -zx crf = zxBeta . backward sum crf - --- | Normalization factor computed for the 'Xs' sentence using the --- forward computation. -zx' :: Model -> Xs -> L.LogFloat -zx' crf sent = zxAlpha sent (forward sum crf sent) - --------------------------------------------------------------- -argmax :: Ord b => (a -> Maybe b) -> [a] -> Maybe (a, b) -argmax _ [] = Nothing -argmax f xs - | null ys = Nothing - | otherwise = Just $ foldl1 choice ys - where - ys = catMaybes $ map (\x -> (,) <$> pure x <*> f x) xs - choice (x1, v1) (x2, v2) - | v1 > v2 = (x1, v1) - | otherwise = (x2, v2) - --- | Determine the most probable label sequence given the context of the --- CRF model and the sentence. -tag :: Model -> Xs -> [Lb] -tag crf sent = collectMaxArg (0, 0) [] $ DP.flexible2 - (0, V.length sent) wordBounds - (\t k -> withMem (computePsi crf sent k) t k) - where - n = V.length sent - - wordBounds k - | k == 0 = (Lb 0, Lb 0) - | otherwise = (Lb 0, Lb $ lbNum crf - 1) - - withMem psi mem k y - | k == n = Just (-1, 1) -- -1 is a dummy value - | k == 0 = prune <$> argmax eval (sgIxs crf) - | otherwise = prune <$> argmax eval (nextIxs crf y) - where - eval (x, ix) = do - v <- snd <$> mem (k + 1) x - return $ v * psi x * valueL crf ix - prune ((x, _ix), v) = (x, v) - - collectMaxArg (i, j) acc mem - | i < n = collect (mem i j) - | otherwise = reverse acc - where - collect (Just (h, _)) = collectMaxArg (i + 1, h) (h:acc) mem - collect Nothing = error "tag.collect: Nothing" - --- | Tag probabilities with respect to marginal distributions. -marginals :: Model -> Xs -> [[(Lb, L.LogFloat)]] -marginals crf sent = - let alpha = forward sum crf sent - beta = backward sum crf sent - in [ [ (x, prob1 alpha beta k x) - | x <- lbSet crf ] - | k <- [0 .. V.length sent - 1] ] - --- tagProbs :: Sent s => Model -> s -> [[Double]] --- tagProbs crf sent = --- let alpha = forward maximum crf sent --- beta = backward maximum crf sent --- normalize vs = --- let d = - logSum vs --- in map (+d) vs --- m1 k x = alpha k x + beta (k + 1) x --- in [ map exp $ normalize [m1 i k | k <- interpIxs sent i] --- | i <- [0 .. V.length sent - 1] ] --- --- -- tag probabilities with respect to --- -- marginal distributions --- tagProbs' :: Sent s => Model -> s -> [[Double]] --- tagProbs' crf sent = --- let alpha = forward logSum crf sent --- beta = backward logSum crf sent --- in [ [ exp $ prob1 crf alpha beta sent i k --- | k <- interpIxs sent i ] --- | i <- [0 .. V.length sent - 1] ] - -goodAndBad :: Model -> Xs -> Ys -> (Int, Int) -goodAndBad crf sent labels = - foldl gather (0, 0) (zip labels' labels'') - where - labels' = [ fst . maximumBy (compare `on` snd) $ unY (labels V.! i) - | i <- [0 .. V.length labels - 1] ] - labels'' = tag crf sent - gather (good, bad) (x, y) - | x == y = (good + 1, bad) - | otherwise = (good, bad + 1) - -goodAndBad' :: Model -> [(Xs, Ys)] -> (Int, Int) -goodAndBad' crf dataset = - let add (g, b) (g', b') = (g + g', b + b') - in foldl add (0, 0) [goodAndBad crf x y | (x, y) <- dataset] - --- | Compute the accuracy of the model with respect to the labeled dataset. -accuracy :: Model -> [(Xs, Ys)] -> Double -accuracy crf dataset = - let k = numCapabilities - parts = partition k dataset - xs = parMap rseq (goodAndBad' crf) parts - (good, bad) = foldl add (0, 0) xs - add (g, b) (g', b') = (g + g', b + b') - in fromIntegral good / fromIntegral (good + bad) - --------------------------------------------------------------- - --- prob :: L.Vect t Int => Model -> Sent Int t -> Double --- prob crf sent = --- sum [ phiOn crf sent k --- | k <- [0 .. (length sent) - 1] ] --- - zx' crf sent --- --- -- TODO: Wziac pod uwage "Regularization Variance" ! --- cll :: Model -> [Sentence] -> Double --- cll crf dataset = sum [prob crf sent | sent <- dataset] - --- prob2 :: SentR s => Model -> ProbArray -> ProbArray -> s --- -> Int -> Lb -> Lb -> Double --- prob2 crf alpha beta sent k x y --- = alpha (k - 1) y + beta (k + 1) x --- + phi crf (observationsOn sent k) a b --- - zxBeta beta --- where --- a = interp sent k x --- b = interp sent (k - 1) y - -prob2 :: Model -> ProbArray -> ProbArray -> Int -> (Lb -> L.LogFloat) - -> Lb -> Lb -> FeatIx -> L.LogFloat -prob2 crf alpha beta k psi x y ix - = alpha (k - 1) y * beta (k + 1) x - * psi x * valueL crf ix / zxBeta beta - --- prob1 :: SentR s => Model -> ProbArray -> ProbArray --- -> s -> Int -> Label -> Double --- prob1 crf alpha beta sent k x = logSum --- [ prob2 crf alpha beta sent k x y --- | y <- interpIxs sent (k - 1) ] - -prob1 :: ProbArray -> ProbArray -> Int -> Lb -> L.LogFloat -prob1 alpha beta k x = - alpha k x * beta (k + 1) x / zxBeta beta - -expectedFeaturesOn - :: Model -> ProbArray -> ProbArray -> Xs - -> Int -> [(FeatIx, L.LogFloat)] -expectedFeaturesOn crf alpha beta sent k = - tFeats ++ oFeats - where - psi = computePsi crf sent k - pr1 = prob1 alpha beta k - pr2 = prob2 crf alpha beta k psi - - oFeats = [ (ix, pr1 x) - | o <- unX (sent V.! k) - , (x, ix) <- obIxs crf o ] - - tFeats - | k == 0 = - [ (ix, pr1 x) - | (x, ix) <- sgIxs crf ] - | otherwise = - [ (ix, pr2 x y ix) - | x <- lbSet crf - , (y, ix) <- prevIxs crf x ] - --- | A list of features (represented by feature indices) defined within --- the context of the sentence accompanied by expected probabilities --- determined on the basis of the model. --- --- One feature can occur multiple times in the output list. -expectedFeaturesIn :: Model -> Xs -> [(FeatIx, L.LogFloat)] -expectedFeaturesIn crf sent = zxF `par` zxB `pseq` zxF `pseq` - concat [expectedOn k | k <- [0 .. V.length sent - 1] ] - where - expectedOn = expectedFeaturesOn crf alpha beta sent - alpha = forward sum crf sent - beta = backward sum crf sent - zxF = zxAlpha sent alpha - zxB = zxBeta beta diff --git a/Data/CRF/Chain1/Model.hs b/Data/CRF/Chain1/Model.hs deleted file mode 100644 --- a/Data/CRF/Chain1/Model.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - --- | Internal implementation of the CRF model. - -module Data.CRF.Chain1.Model -( FeatIx (..) -, Model (..) -, mkModel -, lbSet -, valueL -, featToIx -, featToInt -, sgValue -, sgIxs -, obIxs -, nextIxs -, prevIxs -) where - -import Control.Applicative ((<$>), (<*>)) -import Data.List (groupBy, sort) -import Data.Function (on) -import Data.Binary -import Data.Vector.Binary () -import qualified Data.Vector.Generic.Base as G -import qualified Data.Vector.Generic.Mutable as G -import qualified Data.Set as Set -import qualified Data.Map as M -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector as V -import qualified Data.Number.LogFloat as L -import Data.Vector.Unboxed.Deriving - -import Data.CRF.Chain1.Dataset.Internal -import Data.CRF.Chain1.Feature - --- | A feature index. To every model feature a unique index is assigned. -newtype FeatIx = FeatIx { unFeatIx :: Int } - deriving ( Show, Eq, Ord, Binary) - -- , G.Vector U.Vector, G.MVector U.MVector, U.Unbox ) -derivingUnbox "FeatIx" [t| FeatIx -> Int |] [| unFeatIx |] [| FeatIx |] - --- | A label and a feature index determined by that label. -type LbIx = (Lb, FeatIx) - -dummyFeatIx :: FeatIx -dummyFeatIx = FeatIx (-1) - -isDummy :: FeatIx -> Bool -isDummy (FeatIx ix) = ix < 0 - -notDummy :: FeatIx -> Bool -notDummy = not . isDummy - --- | The model is realy a map from features to potentials, but for the sake --- of efficiency the internal representation is more complex. -data Model = Model { - -- | Value (potential) of the model for feature index. - values :: U.Vector Double - -- | A map from features to feature indices - , ixMap :: M.Map Feature FeatIx - -- | Number of labels. The label set is of the {0, 1, .., lbNum - 1} - -- form, which is guaranteed by the codec. - , lbNum :: Int - -- | Singular feature index for the given label. Index is equall to -1 - -- if feature is not present in the model. - , sgIxsV :: U.Vector FeatIx - -- | Set of labels for the given observation which, together with the - -- observation, constitute an observation feature of the model. - , obIxsV :: V.Vector (U.Vector LbIx) - -- | Set of ,,previous'' labels for the value of the ,,current'' label. - -- Both labels constitute a transition feature present in the the model. - , prevIxsV :: V.Vector (U.Vector LbIx) - -- | Set of ,,next'' labels for the value of the ,,current'' label. - -- Both labels constitute a transition feature present in the the model. - , nextIxsV :: V.Vector (U.Vector LbIx) } - -instance Binary Model where - put crf = do - put $ values crf - put $ ixMap crf - put $ lbNum crf - put $ sgIxsV crf - put $ obIxsV crf - put $ prevIxsV crf - put $ nextIxsV crf - get = Model <$> get <*> get <*> get <*> get <*> get <*> get <*> get - --- | Construct CRF model from associations list. There should be --- no repetition of features in the input list. -fromList :: [(Feature, Double)] -> Model -fromList fs = - let featLbs (SFeature x) = [x] - featLbs (OFeature _ x) = [x] - featLbs (TFeature x y) = [x, y] - featObs (OFeature o _) = [o] - featObs _ = [] - - _ixMap = M.fromList $ zip - (map fst fs) - (map FeatIx [0..]) - - _obSet = nub $ concatMap (featObs . fst) fs - _obNum = length _obSet - _lbSet = nub $ concatMap (featLbs . fst) fs - _lbNum = length _lbSet - - sFeats = [feat | (feat, _val) <- fs, isSFeat feat] - tFeats = [feat | (feat, _val) <- fs, isTFeat feat] - oFeats = [feat | (feat, _val) <- fs, isOFeat feat] - - _sgIxsV = sgVects _lbNum - [ (unLb x, featToIx crf feat) - | feat@(SFeature x) <- sFeats ] - - _prevIxsV = adjVects _lbNum - [ (unLb x, (y, featToIx crf feat)) - | feat@(TFeature x y) <- tFeats ] - - _nextIxsV = adjVects _lbNum - [ (unLb y, (x, featToIx crf feat)) - | feat@(TFeature x y) <- tFeats ] - - _obIxsV = adjVects _obNum - [ (unOb o, (x, featToIx crf feat)) - | feat@(OFeature o x) <- oFeats ] - - -- | Adjacency vectors. - adjVects n xs = - V.replicate n (U.fromList []) V.// update - where - update = map mkVect $ groupBy ((==) `on` fst) $ sort xs - mkVect (y:ys) = (fst y, U.fromList $ sort $ map snd (y:ys)) - mkVect [] = error "mkVect: null list" - - sgVects n xs = U.replicate n dummyFeatIx U.// xs - - _values = U.replicate (length fs) 0.0 - U.// [ (featToInt crf feat, val) - | (feat, val) <- fs ] - - checkSet set cont = if set == [0 .. length set - 1] - then cont - else error "Model.fromList: basic assumption not fulfilled" - - crf = Model _values _ixMap _lbNum _sgIxsV _obIxsV _prevIxsV _nextIxsV - in checkSet (map unLb _lbSet) - . checkSet (map unOb _obSet) - $ crf - --- | Construct the model from the list of features. All parameters will be --- set to 0. There may be repetitions in the input list. -mkModel :: [Feature] -> Model -mkModel fs = - let fSet = Set.fromList fs - fs' = Set.toList fSet - vs = replicate (Set.size fSet) 0.0 - in fromList (zip fs' vs) - --- | List of labels [0 .. 'lbNum' - 1]. -lbSet :: Model -> [Lb] -lbSet crf = map Lb [0 .. lbNum crf - 1] - --- | Model potential defined for the given feature interpreted as a --- number in logarithmic domain. -valueL :: Model -> FeatIx -> L.LogFloat -valueL crf (FeatIx i) = L.logToLogFloat (values crf U.! i) -{-# INLINE valueL #-} - --- | Determine the index for the given feature. -featToIx :: Model -> Feature -> FeatIx -featToIx crf feat = ixMap crf M.! feat -{-# INLINE featToIx #-} - --- | Same as 'featToIx' but immediately unwrap the feature index to --- integer value. -featToInt :: Model -> Feature -> Int -featToInt crf = unFeatIx . featToIx crf -{-# INLINE featToInt #-} - --- | Potential value (in log domain) of the singular feature with the --- given label. The value defaults to 0 when the feature is not a --- member of the model. -sgValue :: Model -> Lb -> L.LogFloat -sgValue crf (Lb x) = - case unFeatIx (sgIxsV crf U.! x) of - -1 -> 0 - ix -> L.logToLogFloat (values crf U.! ix) - --- | List of labels which can be located on the first position of --- a sentence together with feature indices determined by them. -sgIxs :: Model -> [LbIx] -sgIxs crf - = filter (notDummy . snd) - . zip (map Lb [0..]) - . U.toList $ sgIxsV crf -{-# INLINE sgIxs #-} - --- | List of labels which constitute a valid feature in combination with --- the given observation accompanied by feature indices determined by --- these labels. -obIxs :: Model -> Ob -> [LbIx] -obIxs crf x = U.toList (obIxsV crf V.! unOb x) -{-# INLINE obIxs #-} - --- | List of ,,next'' labels which constitute a valid feature in combination --- with the ,,current'' label accompanied by feature indices determined by --- ,,next'' labels. -nextIxs :: Model -> Lb -> [LbIx] -nextIxs crf x = U.toList (nextIxsV crf V.! unLb x) -{-# INLINE nextIxs #-} - --- | List of ,,previous'' labels which constitute a valid feature in --- combination with the ,,current'' label accompanied by feature indices --- determined by ,,previous'' labels. -prevIxs :: Model -> Lb -> [LbIx] -prevIxs crf x = U.toList (prevIxsV crf V.! unLb x) -{-# INLINE prevIxs #-} - -nub :: Ord a => [a] -> [a] -nub = Set.toList . Set.fromList diff --git a/Data/CRF/Chain1/Train.hs b/Data/CRF/Chain1/Train.hs deleted file mode 100644 --- a/Data/CRF/Chain1/Train.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternGuards #-} - -module Data.CRF.Chain1.Train -( CRF (..) -, train -) where - -import Control.Applicative ((<$>), (<*>)) -import System.IO (hSetBuffering, stdout, BufferMode (..)) -import Data.Binary (Binary, put, get) -import qualified Data.Vector as V -import qualified Numeric.SGD as SGD -import qualified Numeric.SGD.LogSigned as L - -import Data.CRF.Chain1.Dataset.Internal -import Data.CRF.Chain1.Dataset.External (SentL) -import Data.CRF.Chain1.Dataset.Codec (mkCodec, Codec, encodeDataL) -import Data.CRF.Chain1.Feature (Feature, featuresIn) -import Data.CRF.Chain1.Model (Model (..), mkModel, FeatIx (..), featToInt) -import Data.CRF.Chain1.Inference (accuracy, expectedFeaturesIn) - --- | A conditional random field model with additional codec used for --- data encoding. -data CRF a b = CRF { - -- | The codec is used to transform data into internal representation, - -- where each observation and each label is represented by a unique - -- integer number. - codec :: Codec a b, - -- | The actual model, which is a map from 'Feature's to potentials. - model :: Model } - -instance (Ord a, Ord b, Binary a, Binary b) => Binary (CRF a b) where - put CRF{..} = put codec >> put model - get = CRF <$> get <*> get - --- | Train the CRF using the stochastic gradient descent method. --- The resulting model will contain features extracted with --- the user supplied extraction function. --- You can use the functions provided by the "Data.CRF.Chain1.Feature.Present" --- and "Data.CRF.Chain1.Feature.Hidden" modules for this purpose. --- When the evaluation data 'IO' action is 'Just', the iterative --- training process will notify the user about the current accuracy --- on the evaluation part every full iteration over the training part. -train - :: (Ord a, Ord b) - => SGD.SgdArgs -- ^ Args for SGD - -> IO [SentL a b] -- ^ Training data 'IO' action - -> Maybe (b, IO [SentL a b]) -- ^ Default label and evalation data - -> ([(Xs, Ys)] -> [Feature]) -- ^ Feature selection - -> IO (CRF a b) -- ^ Resulting model -train sgdArgs trainIO evalIO'Maybe extractFeats = do - hSetBuffering stdout NoBuffering - (_codec, trainData) <- mkCodec <$> trainIO - evalDataM <- case evalIO'Maybe of - Just (x, evalIO) -> Just . encodeDataL x _codec <$> evalIO - Nothing -> return Nothing - let crf = mkModel (extractFeats trainData) - para <- SGD.sgdM sgdArgs - (notify sgdArgs crf trainData evalDataM) - (gradOn crf) (V.fromList trainData) (values crf) - return $ CRF _codec (crf { values = para }) - -gradOn :: Model -> SGD.Para -> (Xs, Ys) -> SGD.Grad -gradOn crf para (xs, ys) = SGD.fromLogList $ - [ (featToInt curr feat, L.fromPos val) - | (feat, val) <- featuresIn xs ys ] ++ - [ (ix, L.fromNeg val) - | (FeatIx ix, val) <- expectedFeaturesIn curr xs ] - where - curr = crf { values = para } - -notify - :: SGD.SgdArgs -> Model -> [(Xs, Ys)] -> Maybe [(Xs, Ys)] - -> SGD.Para -> Int -> IO () -notify SGD.SgdArgs{..} crf trainData evalDataM para k - | doneTotal k == doneTotal (k - 1) = putStr "." - | Just dataSet <- evalDataM = do - let x = accuracy (crf { values = para }) dataSet - putStrLn ("\n" ++ "[" ++ show (doneTotal k) ++ "] acc = " ++ show x) - | otherwise = - putStrLn ("\n" ++ "[" ++ show (doneTotal k) ++ "] acc = #") - where - doneTotal :: Int -> Int - doneTotal = floor . done - done :: Int -> Double - done i - = fromIntegral (i * batchSize) - / fromIntegral trainSize - trainSize = length trainData diff --git a/Data/CRF/Chain1/Util.hs b/Data/CRF/Chain1/Util.hs deleted file mode 100644 --- a/Data/CRF/Chain1/Util.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Data.CRF.Chain1.Util -( partition -) where - -import Data.List (transpose) - -partition :: Int -> [a] -> [[a]] -partition n = - transpose . group n - where - group _ [] = [] - group k xs = take k xs : (group k $ drop k xs) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +Efficient, first-order, linear-chain conditional random fields. diff --git a/crf-chain1.cabal b/crf-chain1.cabal --- a/crf-chain1.cabal +++ b/crf-chain1.cabal @@ -1,62 +1,61 @@ -name: crf-chain1 -version: 0.2.2 -synopsis: First-order, linear-chain conditional random fields -description: - The library provides efficient implementation of the first-order, - linear-chain conditional random fields (CRFs). - . - Important feature of the implemented flavour of CRFs is that transition - features which are not included in the CRF model are considered to have - probability of 0. - It is particularly useful when the training material determines the set - of possible label transitions (e.g. when using the IOB encoding method). - Furthermore, this design decision makes the implementation much faster - for sparse datasets. -license: BSD3 -license-file: LICENSE -cabal-version: >= 1.6 -copyright: Copyright (c) 2012 IPI PAN -author: Jakub Waszczuk -maintainer: waszczuk.kuba@gmail.com -stability: experimental -category: Math -homepage: https://github.com/kawu/crf-chain1 -build-type: Simple - -library - build-depends: - base >= 4 && < 5 - , containers - , vector - , array - , random - , parallel - , logfloat - , monad-codec >= 0.2 && < 0.3 - , binary - , vector-binary >= 0.1 && < 0.2 - , data-lens - , sgd >= 0.2.1 && < 0.3 - , vector-th-unbox >= 0.2.1 && < 0.3 - - exposed-modules: - Data.CRF.Chain1 - , Data.CRF.Chain1.Dataset.Internal - , Data.CRF.Chain1.Dataset.External - , Data.CRF.Chain1.Dataset.Codec - , Data.CRF.Chain1.Feature - , Data.CRF.Chain1.Feature.Present - , Data.CRF.Chain1.Feature.Hidden - , Data.CRF.Chain1.Model - , Data.CRF.Chain1.Inference - , Data.CRF.Chain1.Train +cabal-version: 1.12 - other-modules: - Data.CRF.Chain1.DP - Data.CRF.Chain1.Util +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 50e9f0ceac68e2f16698eb87a6a43c29aab1842212ccfc3b88ca65e85f3da3dd - ghc-options: -Wall -O2 +name: crf-chain1 +version: 0.2.3 +synopsis: First-order, linear-chain conditional random fields +description: Please see the README on GitHub at +category: Math +homepage: https://github.com/kawu/crf-chain1#readme +bug-reports: https://github.com/kawu/crf-chain1/issues +author: Jakub Waszczuk +maintainer: waszczuk.kuba@gmail.com +copyright: 2012-2019 IPI PAN, Jakub Waszczuk +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md source-repository head - type: git - location: git://github.com/kawu/crf-chain1.git + type: git + location: https://github.com/kawu/crf-chain1 + +library + exposed-modules: + Data.CRF.Chain1 + Data.CRF.Chain1.Dataset.Codec + Data.CRF.Chain1.Dataset.External + Data.CRF.Chain1.Dataset.Internal + Data.CRF.Chain1.DP + Data.CRF.Chain1.Feature + Data.CRF.Chain1.Feature.Hidden + Data.CRF.Chain1.Feature.Present + Data.CRF.Chain1.Inference + Data.CRF.Chain1.Model + Data.CRF.Chain1.Train + Data.CRF.Chain1.Util + other-modules: + Paths_crf_chain1 + hs-source-dirs: + src + build-depends: + array + , base >=4.7 && <5 + , binary + , containers + , data-lens-light + , logfloat + , monad-codec >=0.2.1 && <0.3 + , parallel + , random + , sgd >=0.2.1 && <0.3 + , vector + , vector-binary-instances + , vector-th-unbox >=0.2.1 && <0.3 + default-language: Haskell2010 diff --git a/src/Data/CRF/Chain1.hs b/src/Data/CRF/Chain1.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | The module provides first-order, linear-chain conditional random fields +-- (CRFs). +-- +-- Important feature of the implemented flavour of CRFs is that transition +-- features which are not included in the CRF model are considered to have +-- probability of 0. +-- It is particularly useful when the training material determines the set +-- of possible label transitions (e.g. when using the IOB encoding method). +-- Furthermore, this design decision makes the implementation much faster +-- for sparse datasets. + +module Data.CRF.Chain1 +( +-- * Data types + Word +, Sent +, Dist (unDist) +, mkDist +, WordL +, annotate +, SentL + +-- * CRF +, CRF (..) +-- ** Training +, train +-- ** Tagging +, tag + +-- * Feature selection +, hiddenFeats +, presentFeats +) where + +import Prelude hiding (Word) + +import Data.CRF.Chain1.Dataset.External +import Data.CRF.Chain1.Dataset.Codec +import Data.CRF.Chain1.Feature.Present +import Data.CRF.Chain1.Feature.Hidden +import Data.CRF.Chain1.Train +import qualified Data.CRF.Chain1.Inference as I + +-- | Determine the most probable label sequence within the context of the +-- given sentence using the model provided by the 'CRF'. +tag :: (Ord a, Ord b) => CRF a b -> Sent a -> [b] +tag CRF{..} = decodeLabels codec . I.tag model . encodeSent codec diff --git a/src/Data/CRF/Chain1/DP.hs b/src/Data/CRF/Chain1/DP.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/DP.hs @@ -0,0 +1,43 @@ +module Data.CRF.Chain1.DP +( table +, flexible2 +, flexible3 +) where + +import qualified Data.Array as A +import Data.Array ((!)) +import Data.Ix (range) + +table :: A.Ix i => (i, i) -> ((i -> e) -> i -> e) -> A.Array i e +table bounds f = table' where + table' = A.listArray bounds + $ map (f (table' !)) + $ range bounds + +down1 :: A.Ix i => (i, i) -> (i -> e) -> i -> e +down1 bounds f = (!) down' where + down' = A.listArray bounds + $ map f + $ range bounds + +down2 :: (A.Ix i, A.Ix j) => (j, j) -> (j -> (i, i)) -> (j -> i -> e) + -> j -> i -> e +down2 bounds1 bounds2 f = (!) down' where + down' = A.listArray bounds1 + [ down1 (bounds2 i) (f i) + | i <- range bounds1 ] + +flexible2 :: (A.Ix i, A.Ix j) => (j, j) -> (j -> (i, i)) + -> ((j -> i -> e) -> j -> i -> e) -> j -> i -> e +flexible2 bounds1 bounds2 f = (!) flex where + flex = A.listArray bounds1 + [ down1 (bounds2 i) (f (flex !) i) + | i <- range bounds1 ] + +flexible3 :: (A.Ix j, A.Ix i, A.Ix k) => (k, k) -> (k -> (j, j)) + -> (k -> j -> (i, i)) -> ((k -> j -> i -> e) -> k -> j -> i -> e) + -> k -> j -> i -> e +flexible3 bounds1 bounds2 bounds3 f = (!) flex where + flex = A.listArray bounds1 + [ down2 (bounds2 i) (bounds3 i) (f (flex !) i) + | i <- range bounds1 ] diff --git a/src/Data/CRF/Chain1/Dataset/Codec.hs b/src/Data/CRF/Chain1/Dataset/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Dataset/Codec.hs @@ -0,0 +1,148 @@ +module Data.CRF.Chain1.Dataset.Codec +( Codec +, CodecM + +, encodeWord'Cu +, encodeWord'Cn +, encodeSent'Cu +, encodeSent'Cn +, encodeSent + +, encodeWordL'Cu +, encodeWordL'Cn +, encodeSentL'Cu +, encodeSentL'Cn +, encodeSentL + +, decodeLabel +, decodeLabels + +, mkCodec +, encodeData +, encodeDataL +) where + +import Prelude hiding (Word) + +import Control.Applicative ((<$>), (<*>), pure) +import Data.Maybe (catMaybes) +-- import Data.Lens.Common (fstLens, sndLens) +import Data.Lens.Light (Lens, lens) +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.Vector as V +import qualified Control.Monad.Codec as C + +import Data.CRF.Chain1.Dataset.Internal +import Data.CRF.Chain1.Dataset.External + +-- | A codec. The first component is used to encode observations +-- of type a, the second one is used to encode labels of type b. +type Codec a b = (C.AtomCodec a, C.AtomCodec b) + +-- | Type synonym for the codec monad. It is important to notice that by a +-- codec we denote here a structure of two 'C.AtomCodec's while in the +-- monad-codec package it denotes a monad. +type CodecM a b c = C.Codec (Codec a b) c + +-- | Encode the labeled word and update the codec. +encodeWordL'Cu :: (Ord a, Ord b) => WordL a b -> CodecM a b (X, Y) +encodeWordL'Cu word = do + x <- mkX . map Ob <$> + mapM (C.encode' fstLens) (S.toList $ fst word) + y <- mkY <$> sequence + [ (,) <$> (Lb <$> C.encode sndLens lb) <*> pure pr + | (lb, pr) <- (M.toList . unDist) (snd word) ] + return (x, y) + +-- | Encodec the labeled word and do *not* update the codec. +-- If the label is not in the codec, use the default value. +encodeWordL'Cn :: (Ord a, Ord b) => Int -> WordL a b -> CodecM a b (X, Y) +encodeWordL'Cn i word = do + x <- mkX . map Ob . catMaybes <$> + mapM (C.maybeEncode fstLens) (S.toList $ fst word) + y <- mkY <$> sequence + [ (,) <$> encodeL i lb <*> pure pr + | (lb, pr) <- (M.toList . unDist) (snd word) ] + return (x, y) + where + encodeL j y = Lb . maybe j id <$> C.maybeEncode sndLens y + +-- | Encode the word and update the codec. +encodeWord'Cu :: Ord a => Word a -> CodecM a b X +encodeWord'Cu word = + mkX . map Ob <$> mapM (C.encode' fstLens) (S.toList word) + +-- | Encode the word and do *not* update the codec. +encodeWord'Cn :: Ord a => Word a -> CodecM a b X +encodeWord'Cn word = + mkX . map Ob . catMaybes <$> mapM (C.maybeEncode fstLens) (S.toList word) + +-- | Encode the labeled sentence and update the codec. +encodeSentL'Cu :: (Ord a, Ord b) => SentL a b -> CodecM a b (Xs, Ys) +encodeSentL'Cu sent = do + ps <- mapM encodeWordL'Cu sent + return (V.fromList (map fst ps), V.fromList (map snd ps)) + +-- | Encode the labeled sentence and do *not* update the codec. +-- Substitute the default label for any label not present in the codec. +encodeSentL'Cn :: (Ord a, Ord b) => b -> SentL a b -> CodecM a b (Xs, Ys) +encodeSentL'Cn def sent = do + i <- C.maybeEncode sndLens def >>= \mi -> case mi of + Just _i -> return _i + Nothing -> error "encodeWordL'Cn: default label not in the codec" + ps <- mapM (encodeWordL'Cn i) sent + return (V.fromList (map fst ps), V.fromList (map snd ps)) + +-- | Encode the labeled sentence with the given codec. Substitute the +-- default label for any label not present in the codec. +encodeSentL :: (Ord a, Ord b) => b -> Codec a b -> SentL a b -> (Xs, Ys) +encodeSentL def codec = C.evalCodec codec . encodeSentL'Cn def + +-- | Encode the sentence and update the codec. +encodeSent'Cu :: Ord a => Sent a -> CodecM a b Xs +encodeSent'Cu = fmap V.fromList . mapM encodeWord'Cu + +-- | Encode the sentence and do *not* update the codec. +encodeSent'Cn :: Ord a => Sent a -> CodecM a b Xs +encodeSent'Cn = fmap V.fromList . mapM encodeWord'Cn + +-- | Encode the sentence using the given codec. +encodeSent :: Ord a => Codec a b -> Sent a -> Xs +encodeSent codec = C.evalCodec codec . encodeSent'Cn + +-- | Create the codec on the basis of the labeled dataset, return the +-- resultant codec and the encoded dataset. +mkCodec :: (Ord a, Ord b) => [SentL a b] -> (Codec a b, [(Xs, Ys)]) +mkCodec = + let swap (x, y) = (y, x) + in swap . C.runCodec (C.empty, C.empty) . mapM encodeSentL'Cu + +-- | Encode the labeled dataset using the codec. Substitute the default +-- label for any label not present in the codec. +encodeDataL :: (Ord a, Ord b) => b -> Codec a b -> [SentL a b] -> [(Xs, Ys)] +encodeDataL def codec = C.evalCodec codec . mapM (encodeSentL'Cn def) + +-- | Encode the dataset with the codec. +encodeData :: Ord a => Codec a b -> [Sent a] -> [Xs] +encodeData codec = map (encodeSent codec) + +-- | Decode the label. +decodeLabel :: Ord b => Codec a b -> Lb -> b +decodeLabel codec x = C.evalCodec codec $ C.decode sndLens (unLb x) + +-- | Decode the sequence of labels. +decodeLabels :: Ord b => Codec a b -> [Lb] -> [b] +decodeLabels codec xs = C.evalCodec codec $ + sequence [C.decode sndLens (unLb x) | x <- xs] + + +-- * Stock lenses + +fstLens :: Lens (a,b) a +-- fstLens = Lens $ \(a,b) -> store (\ a' -> (a', b)) a +fstLens = lens fst (\a' (a, b) -> (a', b)) + +sndLens :: Lens (a,b) b +-- sndLens = Lens $ \(a,b) -> store (\ b' -> (a, b')) b +sndLens = lens snd (\b' (a, b) -> (a, b')) diff --git a/src/Data/CRF/Chain1/Dataset/External.hs b/src/Data/CRF/Chain1/Dataset/External.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Dataset/External.hs @@ -0,0 +1,45 @@ +module Data.CRF.Chain1.Dataset.External +( Word +, Sent +, Dist (unDist) +, mkDist +, WordL +, annotate +, SentL +) where + +import Prelude hiding (Word) + +import qualified Data.Set as S +import qualified Data.Map as M + +-- | A Word is represented by a set of observations. +type Word a = S.Set a + +-- | A sentence of words. +type Sent a = [Word a] + +-- | A probability distribution defined over elements of type a. +-- All elements not included in the map have probability equal +-- to 0. +newtype Dist a = Dist { unDist :: M.Map a Double } + +-- | Construct the probability distribution. +mkDist :: Ord a => [(a, Double)] -> Dist a +mkDist = + Dist . normalize . M.fromListWith (+) + where + normalize dist = + let z = sum (M.elems dist) + in fmap (/z) dist + +-- | A WordL is a labeled word, i.e. a word with probability distribution +-- defined over labels. +type WordL a b = (Word a, Dist b) + +-- | Annotate the word with the label. +annotate :: Word a -> b -> WordL a b +annotate w x = (w, Dist (M.singleton x 1)) + +-- | A sentence of labeled words. +type SentL a b = [WordL a b] diff --git a/src/Data/CRF/Chain1/Dataset/Internal.hs b/src/Data/CRF/Chain1/Dataset/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Dataset/Internal.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + + +module Data.CRF.Chain1.Dataset.Internal +( Ob (..) +, Lb (..) + +, X (..) +, mkX +, unX +, Xs + +, Y (..) +, mkY +, unY +, Ys +) where + + +-- import Data.Vector.Generic.Base +-- import Data.Vector.Generic.Mutable +import Data.Binary (Binary) +import Data.Ix (Ix) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import Data.Vector.Unboxed.Deriving + + + +-- | An observation. +newtype Ob = Ob { unOb :: Int } + deriving ( Show, Read, Eq, Ord, Binary ) +-- GeneralizedNewtypeDeriving doesn't work for this in 7.8.2: +-- , Vector U.Vector, MVector U.MVector, U.Unbox ) +derivingUnbox "Ob" [t| Ob -> Int |] [| unOb |] [| Ob |] + + +-- | A label. +newtype Lb = Lb { unLb :: Int } + deriving ( Show, Read, Eq, Ord, Binary, Num, Ix ) +derivingUnbox "Lb" [t| Lb -> Int |] [| unLb |] [| Lb |] + + +-- | Simple word represented by a list of its observations. +newtype X = X { _unX :: U.Vector Ob } + deriving (Show, Read, Eq, Ord) + +-- | X constructor. +mkX :: [Ob] -> X +mkX = X . U.fromList +{-# INLINE mkX #-} + +-- | X deconstructor symetric to mkX. +unX :: X -> [Ob] +unX = U.toList . _unX +{-# INLINE unX #-} + +-- | Sentence of words. +type Xs = V.Vector X + +-- | Probability distribution over labels. +newtype Y = Y { _unY :: U.Vector (Lb, Double) } + deriving (Show, Read, Eq, Ord) + +-- | Y constructor. +mkY :: [(Lb, Double)] -> Y +mkY = Y . U.fromList +{-# INLINE mkY #-} + +-- | Y deconstructor symetric to mkY. +unY :: Y -> [(Lb, Double)] +unY = U.toList . _unY +{-# INLINE unY #-} + +-- | Sentence of Y (label choices). +type Ys = V.Vector Y diff --git a/src/Data/CRF/Chain1/Feature.hs b/src/Data/CRF/Chain1/Feature.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Feature.hs @@ -0,0 +1,86 @@ +module Data.CRF.Chain1.Feature +( Feature (..) +, isSFeat +, isTFeat +, isOFeat +, featuresIn +) where + +import Data.Binary (Binary, Get, put, get) +import Control.Applicative ((<*>), (<$>)) +import qualified Data.Vector as V +import qualified Data.Number.LogFloat as L + +import Data.CRF.Chain1.Dataset.Internal + +-- | A Feature is either an observation feature OFeature o x, which +-- models relation between observation o and label x assigned to +-- the same word, or a transition feature TFeature x y (SFeature x +-- for the first position in the sentence), which models relation +-- between two subsequent labels, x (on i-th position) and y +-- (on (i-1)-th positoin). +data Feature + = SFeature + {-# UNPACK #-} !Lb + | TFeature + {-# UNPACK #-} !Lb + {-# UNPACK #-} !Lb + | OFeature + {-# UNPACK #-} !Ob + {-# UNPACK #-} !Lb + deriving (Show, Eq, Ord) + +instance Binary Feature where + put (SFeature x) = put (0 :: Int) >> put x + put (TFeature x y) = put (1 :: Int) >> put (x, y) + put (OFeature o x) = put (2 :: Int) >> put (o, x) + get = do + k <- get :: Get Int + case k of + 0 -> SFeature <$> get + 1 -> TFeature <$> get <*> get + 2 -> OFeature <$> get <*> get + _ -> error "Binary Feature: unknown identifier" + +-- | Is it a 'SFeature'? +isSFeat :: Feature -> Bool +isSFeat (SFeature _) = True +isSFeat _ = False +{-# INLINE isSFeat #-} + +-- | Is it an 'OFeature'? +isOFeat :: Feature -> Bool +isOFeat (OFeature _ _) = True +isOFeat _ = False +{-# INLINE isOFeat #-} + +-- | Is it a 'TFeature'? +isTFeat :: Feature -> Bool +isTFeat (TFeature _ _) = True +isTFeat _ = False +{-# INLINE isTFeat #-} + +-- | Transition features with assigned probabilities for given position. +trFeats :: Ys -> Int -> [(Feature, L.LogFloat)] +trFeats ys 0 = + [ (SFeature x, L.logFloat px) + | (x, px) <- unY (ys V.! 0) ] +trFeats ys k = + [ (TFeature x y, L.logFloat px * L.logFloat py) + | (x, px) <- unY (ys V.! k) + , (y, py) <- unY (ys V.! (k-1)) ] + +-- | Observation features with assigned probabilities for a given position. +obFeats :: Xs -> Ys -> Int -> [(Feature, L.LogFloat)] +obFeats xs ys k = + [ (OFeature o x, L.logFloat px) + | (x, px) <- unY (ys V.! k) + , o <- unX (xs V.! k) ] + +-- | All features with assigned probabilities for given position. +features :: Xs -> Ys -> Int -> [(Feature, L.LogFloat)] +features xs ys k = trFeats ys k ++ obFeats xs ys k + +-- | All features with assigned probabilities in given labeled sentence. +featuresIn :: Xs -> Ys -> [(Feature, L.LogFloat)] +featuresIn xs ys = concatMap (features xs ys) [0 .. V.length xs - 1] diff --git a/src/Data/CRF/Chain1/Feature/Hidden.hs b/src/Data/CRF/Chain1/Feature/Hidden.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Feature/Hidden.hs @@ -0,0 +1,66 @@ +-- | The module provides feature selection functions which extract +-- hidden features, i.e. all features which can be constructed +-- (by means of cartesian product) on the basis of the set of +-- observations and the set of labels. +-- For example, the list of hidden observation features can +-- be defined as 'OFeature' '<$>' os '<*>' xs, where os is a +-- list of all observations and xs is a list of all labels. +-- +-- You can mix functions defined here with the selection functions +-- from the "Data.CRF.Chain1.Feature.Present" module. + +module Data.CRF.Chain1.Feature.Hidden +( hiddenFeats +, hiddenOFeats +, hiddenTFeats +, hiddenSFeats +) where + +import qualified Data.Set as S +import qualified Data.Vector as V + +import Data.CRF.Chain1.Dataset.Internal +import Data.CRF.Chain1.Feature + +-- | Hidden 'OFeature's which can be constructed based on the dataset. +hiddenOFeats :: [(Xs, Ys)] -> [Feature] +hiddenOFeats ds = + [ OFeature o x + | o <- collectObs ds + , x <- collectLbs ds ] + +-- | Hidden 'TFeature's which can be constructed based on the dataset. +hiddenTFeats :: [(Xs, Ys)] -> [Feature] +hiddenTFeats ds = + let xs = collectLbs ds + in [TFeature x y | x <- xs, y <- xs] + +-- | Hidden 'SFeature's which can be constructed based on the dataset. +hiddenSFeats :: [(Xs, Ys)] -> [Feature] +hiddenSFeats = map SFeature . collectLbs + +-- | Hidden 'Feature's of all types which can be constructed +-- based on the dataset. +hiddenFeats :: [(Xs, Ys)] -> [Feature] +hiddenFeats ds + = hiddenOFeats ds + ++ hiddenTFeats ds + ++ hiddenSFeats ds + +collectObs :: [(Xs, Ys)] -> [Ob] +collectObs = nub . concatMap (sentObs . fst) + +collectLbs :: [(Xs, Ys)] -> [Lb] +collectLbs = nub . concatMap (sentLbs . snd) + +sentObs :: Xs -> [Ob] +sentObs = concatMap unX . V.toList + +sentLbs :: Ys -> [Lb] +sentLbs = concatMap lbsAll . V.toList + +lbsAll :: Y -> [Lb] +lbsAll = map fst . unY + +nub :: Ord a => [a] -> [a] +nub = S.toList . S.fromList diff --git a/src/Data/CRF/Chain1/Feature/Present.hs b/src/Data/CRF/Chain1/Feature/Present.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Feature/Present.hs @@ -0,0 +1,56 @@ +-- | The module provides feature selection functions which extract +-- features present in the dataset, i.e. features which directly occure +-- the dataset. +-- +-- You can mix functions defined here with the selection functions +-- from the "Data.CRF.Chain1.Feature.Hidden" module. + +module Data.CRF.Chain1.Feature.Present +( presentFeats +, presentOFeats +, presentTFeats +, presentSFeats +) where + +import qualified Data.Vector as V + +import Data.CRF.Chain1.Dataset.Internal +import Data.CRF.Chain1.Feature + +-- | 'OFeature's which occur in the dataset. +presentOFeats :: [(Xs, Ys)] -> [Feature] +presentOFeats ds = + concatMap sentOFeats ds + where + sentOFeats (xs, ys) = concatMap oFeatsOn (zip (V.toList xs) (V.toList ys)) + oFeatsOn (x, choice) = + [ OFeature o y + | o <- unX x + , y <- lbs choice ] + +-- | 'TFeature's which occur in the dataset. +presentTFeats :: [(a, Ys)] -> [Feature] +presentTFeats ds = + concatMap (sentTFeats.snd) ds + where + sentTFeats ys = concatMap (tFeatsOn ys) [1 .. V.length ys - 1] + tFeatsOn ys k = + [ TFeature x y + | x <- lbs (ys V.! k) + , y <- lbs (ys V.! (k-1)) ] + +-- | 'SFeature's which occur in the dataset. +presentSFeats :: [(a, Ys)] -> [Feature] +presentSFeats ds = + let sentSFeats s = [SFeature x | x <- lbs (s V.! 0)] + in concatMap (sentSFeats.snd) ds + +-- | 'Feature's of all kinds which occur in the dataset. +presentFeats :: [(Xs, Ys)] -> [Feature] +presentFeats ds + = presentOFeats ds + ++ presentTFeats ds + ++ presentSFeats ds + +lbs :: Y -> [Lb] +lbs = map fst . unY diff --git a/src/Data/CRF/Chain1/Inference.hs b/src/Data/CRF/Chain1/Inference.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Inference.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- Inference with CRFs. + +module Data.CRF.Chain1.Inference +( tag +, marginals +, accuracy +, expectedFeaturesIn +, zx +, zx' +) where + +import Control.Applicative ((<$>), (<*>), pure) +import Data.Maybe (catMaybes) +import Data.List (maximumBy) +import Data.Function (on) +import qualified Data.Array as A +import qualified Data.Vector as V + +import Control.Parallel.Strategies (rseq, parMap) +import Control.Parallel (par, pseq) +import GHC.Conc (numCapabilities) +import qualified Data.Number.LogFloat as L + +import qualified Data.CRF.Chain1.DP as DP +import Data.CRF.Chain1.Util (partition) +import Data.CRF.Chain1.Dataset.Internal +import Data.CRF.Chain1.Model + +type ProbArray = Int -> Lb -> L.LogFloat +type AccF = [L.LogFloat] -> L.LogFloat + +-- | Compute the table of potential products associated with +-- observation features for the given sentence position. +computePsi :: Model -> Xs -> Int -> Lb -> L.LogFloat +computePsi crf xs i = (A.!) $ A.accumArray (*) 1 bounds + [ (x, valueL crf ix) + | ob <- unX (xs V.! i) + , (x, ix) <- obIxs crf ob ] + where + bounds = (Lb 0, Lb $ lbNum crf - 1) + +-- | Forward table computation. +forward :: AccF -> Model -> Xs -> ProbArray +forward acc crf sent = DP.flexible2 + (0, V.length sent) wordBounds + (\t k -> withMem (computePsi crf sent k) t k) + where + wordBounds k + | k == V.length sent = (Lb 0, Lb 0) + | otherwise = (Lb 0, Lb $ lbNum crf - 1) + -- | Forward table equation, where k is current position, x is a label + -- on current position and psi is a psi table computed for current + -- position. + -- FIXME: null sentence? + withMem psi alpha k x + | k == 0 = psi x * sgValue crf x + | k == V.length sent = acc + [ alpha (k - 1) y + | y <- lbSet crf ] + | otherwise = acc + [ alpha (k - 1) y * psi x * valueL crf ix + | (y, ix) <- prevIxs crf x ] + +-- | Backward table computation. +backward :: AccF -> Model -> Xs -> ProbArray +backward acc crf sent = DP.flexible2 + (0, V.length sent) wordBounds + (\t k -> withMem (computePsi crf sent k) t k) + where + wordBounds k + | k == 0 = (Lb 0, Lb 0) + | otherwise = (Lb 0, Lb $ lbNum crf - 1) + -- | Backward table equation, where k is current position, y is a label + -- on previous, k-1, position and psi is a psi table computed for current + -- position. + withMem psi beta k y + | k == V.length sent = 1 + | k == 0 = acc + [ beta (k + 1) x * psi x * valueL crf ix + | (x, ix) <- sgIxs crf ] + | otherwise = acc + [ beta (k + 1) x * psi x * valueL crf ix + | (x, ix) <- nextIxs crf y ] + +zxBeta :: ProbArray -> L.LogFloat +zxBeta beta = beta 0 0 + +zxAlpha :: Xs -> ProbArray -> L.LogFloat +zxAlpha sent alpha = alpha (V.length sent) 0 + +-- | Normalization factor computed for the 'Xs' sentence using the +-- backward computation. +zx :: Model -> Xs -> L.LogFloat +zx crf = zxBeta . backward sum crf + +-- | Normalization factor computed for the 'Xs' sentence using the +-- forward computation. +zx' :: Model -> Xs -> L.LogFloat +zx' crf sent = zxAlpha sent (forward sum crf sent) + +-------------------------------------------------------------- +argmax :: Ord b => (a -> Maybe b) -> [a] -> Maybe (a, b) +argmax _ [] = Nothing +argmax f xs + | null ys = Nothing + | otherwise = Just $ foldl1 choice ys + where + ys = catMaybes $ map (\x -> (,) <$> pure x <*> f x) xs + choice (x1, v1) (x2, v2) + | v1 > v2 = (x1, v1) + | otherwise = (x2, v2) + +-- | Determine the most probable label sequence given the context of the +-- CRF model and the sentence. +tag :: Model -> Xs -> [Lb] +tag crf sent = collectMaxArg (0, 0) [] $ DP.flexible2 + (0, V.length sent) wordBounds + (\t k -> withMem (computePsi crf sent k) t k) + where + n = V.length sent + + wordBounds k + | k == 0 = (Lb 0, Lb 0) + | otherwise = (Lb 0, Lb $ lbNum crf - 1) + + withMem psi mem k y + | k == n = Just (-1, 1) -- -1 is a dummy value + | k == 0 = prune <$> argmax eval (sgIxs crf) + | otherwise = prune <$> argmax eval (nextIxs crf y) + where + eval (x, ix) = do + v <- snd <$> mem (k + 1) x + return $ v * psi x * valueL crf ix + prune ((x, _ix), v) = (x, v) + + collectMaxArg (i, j) acc mem + | i < n = collect (mem i j) + | otherwise = reverse acc + where + collect (Just (h, _)) = collectMaxArg (i + 1, h) (h:acc) mem + collect Nothing = error "tag.collect: Nothing" + +-- | Tag probabilities with respect to marginal distributions. +marginals :: Model -> Xs -> [[(Lb, L.LogFloat)]] +marginals crf sent = + let alpha = forward sum crf sent + beta = backward sum crf sent + in [ [ (x, prob1 alpha beta k x) + | x <- lbSet crf ] + | k <- [0 .. V.length sent - 1] ] + +-- tagProbs :: Sent s => Model -> s -> [[Double]] +-- tagProbs crf sent = +-- let alpha = forward maximum crf sent +-- beta = backward maximum crf sent +-- normalize vs = +-- let d = - logSum vs +-- in map (+d) vs +-- m1 k x = alpha k x + beta (k + 1) x +-- in [ map exp $ normalize [m1 i k | k <- interpIxs sent i] +-- | i <- [0 .. V.length sent - 1] ] +-- +-- -- tag probabilities with respect to +-- -- marginal distributions +-- tagProbs' :: Sent s => Model -> s -> [[Double]] +-- tagProbs' crf sent = +-- let alpha = forward logSum crf sent +-- beta = backward logSum crf sent +-- in [ [ exp $ prob1 crf alpha beta sent i k +-- | k <- interpIxs sent i ] +-- | i <- [0 .. V.length sent - 1] ] + +goodAndBad :: Model -> Xs -> Ys -> (Int, Int) +goodAndBad crf sent labels = + foldl gather (0, 0) (zip labels' labels'') + where + labels' = [ fst . maximumBy (compare `on` snd) $ unY (labels V.! i) + | i <- [0 .. V.length labels - 1] ] + labels'' = tag crf sent + gather (good, bad) (x, y) + | x == y = (good + 1, bad) + | otherwise = (good, bad + 1) + +goodAndBad' :: Model -> [(Xs, Ys)] -> (Int, Int) +goodAndBad' crf dataset = + let add (g, b) (g', b') = (g + g', b + b') + in foldl add (0, 0) [goodAndBad crf x y | (x, y) <- dataset] + +-- | Compute the accuracy of the model with respect to the labeled dataset. +accuracy :: Model -> [(Xs, Ys)] -> Double +accuracy crf dataset = + let k = numCapabilities + parts = partition k dataset + xs = parMap rseq (goodAndBad' crf) parts + (good, bad) = foldl add (0, 0) xs + add (g, b) (g', b') = (g + g', b + b') + in fromIntegral good / fromIntegral (good + bad) + +-------------------------------------------------------------- + +-- prob :: L.Vect t Int => Model -> Sent Int t -> Double +-- prob crf sent = +-- sum [ phiOn crf sent k +-- | k <- [0 .. (length sent) - 1] ] +-- - zx' crf sent +-- +-- -- TODO: Wziac pod uwage "Regularization Variance" ! +-- cll :: Model -> [Sentence] -> Double +-- cll crf dataset = sum [prob crf sent | sent <- dataset] + +-- prob2 :: SentR s => Model -> ProbArray -> ProbArray -> s +-- -> Int -> Lb -> Lb -> Double +-- prob2 crf alpha beta sent k x y +-- = alpha (k - 1) y + beta (k + 1) x +-- + phi crf (observationsOn sent k) a b +-- - zxBeta beta +-- where +-- a = interp sent k x +-- b = interp sent (k - 1) y + +prob2 :: Model -> ProbArray -> ProbArray -> Int -> (Lb -> L.LogFloat) + -> Lb -> Lb -> FeatIx -> L.LogFloat +prob2 crf alpha beta k psi x y ix + = alpha (k - 1) y * beta (k + 1) x + * psi x * valueL crf ix / zxBeta beta + +-- prob1 :: SentR s => Model -> ProbArray -> ProbArray +-- -> s -> Int -> Label -> Double +-- prob1 crf alpha beta sent k x = logSum +-- [ prob2 crf alpha beta sent k x y +-- | y <- interpIxs sent (k - 1) ] + +prob1 :: ProbArray -> ProbArray -> Int -> Lb -> L.LogFloat +prob1 alpha beta k x = + alpha k x * beta (k + 1) x / zxBeta beta + +expectedFeaturesOn + :: Model -> ProbArray -> ProbArray -> Xs + -> Int -> [(FeatIx, L.LogFloat)] +expectedFeaturesOn crf alpha beta sent k = + tFeats ++ oFeats + where + psi = computePsi crf sent k + pr1 = prob1 alpha beta k + pr2 = prob2 crf alpha beta k psi + + oFeats = [ (ix, pr1 x) + | o <- unX (sent V.! k) + , (x, ix) <- obIxs crf o ] + + tFeats + | k == 0 = + [ (ix, pr1 x) + | (x, ix) <- sgIxs crf ] + | otherwise = + [ (ix, pr2 x y ix) + | x <- lbSet crf + , (y, ix) <- prevIxs crf x ] + +-- | A list of features (represented by feature indices) defined within +-- the context of the sentence accompanied by expected probabilities +-- determined on the basis of the model. +-- +-- One feature can occur multiple times in the output list. +expectedFeaturesIn :: Model -> Xs -> [(FeatIx, L.LogFloat)] +expectedFeaturesIn crf sent = zxF `par` zxB `pseq` zxF `pseq` + concat [expectedOn k | k <- [0 .. V.length sent - 1] ] + where + expectedOn = expectedFeaturesOn crf alpha beta sent + alpha = forward sum crf sent + beta = backward sum crf sent + zxF = zxAlpha sent alpha + zxB = zxBeta beta diff --git a/src/Data/CRF/Chain1/Model.hs b/src/Data/CRF/Chain1/Model.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Model.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Internal implementation of the CRF model. + +module Data.CRF.Chain1.Model +( FeatIx (..) +, Model (..) +, mkModel +, lbSet +, valueL +, featToIx +, featToInt +, sgValue +, sgIxs +, obIxs +, nextIxs +, prevIxs +) where + +import Control.Applicative ((<$>), (<*>)) +import Data.List (groupBy, sort) +import Data.Function (on) +import Data.Binary +import Data.Vector.Binary () +import qualified Data.Vector.Generic.Base as G +import qualified Data.Vector.Generic.Mutable as G +import qualified Data.Set as Set +import qualified Data.Map as M +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector as V +import qualified Data.Number.LogFloat as L +import Data.Vector.Unboxed.Deriving + +import Data.CRF.Chain1.Dataset.Internal +import Data.CRF.Chain1.Feature + +-- | A feature index. To every model feature a unique index is assigned. +newtype FeatIx = FeatIx { unFeatIx :: Int } + deriving ( Show, Eq, Ord, Binary) + -- , G.Vector U.Vector, G.MVector U.MVector, U.Unbox ) +derivingUnbox "FeatIx" [t| FeatIx -> Int |] [| unFeatIx |] [| FeatIx |] + +-- | A label and a feature index determined by that label. +type LbIx = (Lb, FeatIx) + +dummyFeatIx :: FeatIx +dummyFeatIx = FeatIx (-1) + +isDummy :: FeatIx -> Bool +isDummy (FeatIx ix) = ix < 0 + +notDummy :: FeatIx -> Bool +notDummy = not . isDummy + +-- | The model is realy a map from features to potentials, but for the sake +-- of efficiency the internal representation is more complex. +data Model = Model { + -- | Value (potential) of the model for feature index. + values :: U.Vector Double + -- | A map from features to feature indices + , ixMap :: M.Map Feature FeatIx + -- | Number of labels. The label set is of the {0, 1, .., lbNum - 1} + -- form, which is guaranteed by the codec. + , lbNum :: Int + -- | Singular feature index for the given label. Index is equall to -1 + -- if feature is not present in the model. + , sgIxsV :: U.Vector FeatIx + -- | Set of labels for the given observation which, together with the + -- observation, constitute an observation feature of the model. + , obIxsV :: V.Vector (U.Vector LbIx) + -- | Set of ,,previous'' labels for the value of the ,,current'' label. + -- Both labels constitute a transition feature present in the the model. + , prevIxsV :: V.Vector (U.Vector LbIx) + -- | Set of ,,next'' labels for the value of the ,,current'' label. + -- Both labels constitute a transition feature present in the the model. + , nextIxsV :: V.Vector (U.Vector LbIx) } + +instance Binary Model where + put crf = do + put $ values crf + put $ ixMap crf + put $ lbNum crf + put $ sgIxsV crf + put $ obIxsV crf + put $ prevIxsV crf + put $ nextIxsV crf + get = Model <$> get <*> get <*> get <*> get <*> get <*> get <*> get + +-- | Construct CRF model from associations list. There should be +-- no repetition of features in the input list. +fromList :: [(Feature, Double)] -> Model +fromList fs = + let featLbs (SFeature x) = [x] + featLbs (OFeature _ x) = [x] + featLbs (TFeature x y) = [x, y] + featObs (OFeature o _) = [o] + featObs _ = [] + + _ixMap = M.fromList $ zip + (map fst fs) + (map FeatIx [0..]) + + _obSet = nub $ concatMap (featObs . fst) fs + _obNum = length _obSet + _lbSet = nub $ concatMap (featLbs . fst) fs + _lbNum = length _lbSet + + sFeats = [feat | (feat, _val) <- fs, isSFeat feat] + tFeats = [feat | (feat, _val) <- fs, isTFeat feat] + oFeats = [feat | (feat, _val) <- fs, isOFeat feat] + + _sgIxsV = sgVects _lbNum + [ (unLb x, featToIx crf feat) + | feat@(SFeature x) <- sFeats ] + + _prevIxsV = adjVects _lbNum + [ (unLb x, (y, featToIx crf feat)) + | feat@(TFeature x y) <- tFeats ] + + _nextIxsV = adjVects _lbNum + [ (unLb y, (x, featToIx crf feat)) + | feat@(TFeature x y) <- tFeats ] + + _obIxsV = adjVects _obNum + [ (unOb o, (x, featToIx crf feat)) + | feat@(OFeature o x) <- oFeats ] + + -- | Adjacency vectors. + adjVects n xs = + V.replicate n (U.fromList []) V.// update + where + update = map mkVect $ groupBy ((==) `on` fst) $ sort xs + mkVect (y:ys) = (fst y, U.fromList $ sort $ map snd (y:ys)) + mkVect [] = error "mkVect: null list" + + sgVects n xs = U.replicate n dummyFeatIx U.// xs + + _values = U.replicate (length fs) 0.0 + U.// [ (featToInt crf feat, val) + | (feat, val) <- fs ] + + checkSet set cont = if set == [0 .. length set - 1] + then cont + else error "Model.fromList: basic assumption not fulfilled" + + crf = Model _values _ixMap _lbNum _sgIxsV _obIxsV _prevIxsV _nextIxsV + in checkSet (map unLb _lbSet) + . checkSet (map unOb _obSet) + $ crf + +-- | Construct the model from the list of features. All parameters will be +-- set to 0. There may be repetitions in the input list. +mkModel :: [Feature] -> Model +mkModel fs = + let fSet = Set.fromList fs + fs' = Set.toList fSet + vs = replicate (Set.size fSet) 0.0 + in fromList (zip fs' vs) + +-- | List of labels [0 .. 'lbNum' - 1]. +lbSet :: Model -> [Lb] +lbSet crf = map Lb [0 .. lbNum crf - 1] + +-- | Model potential defined for the given feature interpreted as a +-- number in logarithmic domain. +valueL :: Model -> FeatIx -> L.LogFloat +valueL crf (FeatIx i) = L.logToLogFloat (values crf U.! i) +{-# INLINE valueL #-} + +-- | Determine the index for the given feature. +featToIx :: Model -> Feature -> FeatIx +featToIx crf feat = ixMap crf M.! feat +{-# INLINE featToIx #-} + +-- | Same as 'featToIx' but immediately unwrap the feature index to +-- integer value. +featToInt :: Model -> Feature -> Int +featToInt crf = unFeatIx . featToIx crf +{-# INLINE featToInt #-} + +-- | Potential value (in log domain) of the singular feature with the +-- given label. The value defaults to 0 when the feature is not a +-- member of the model. +sgValue :: Model -> Lb -> L.LogFloat +sgValue crf (Lb x) = + case unFeatIx (sgIxsV crf U.! x) of + -1 -> 0 + ix -> L.logToLogFloat (values crf U.! ix) + +-- | List of labels which can be located on the first position of +-- a sentence together with feature indices determined by them. +sgIxs :: Model -> [LbIx] +sgIxs crf + = filter (notDummy . snd) + . zip (map Lb [0..]) + . U.toList $ sgIxsV crf +{-# INLINE sgIxs #-} + +-- | List of labels which constitute a valid feature in combination with +-- the given observation accompanied by feature indices determined by +-- these labels. +obIxs :: Model -> Ob -> [LbIx] +obIxs crf x = U.toList (obIxsV crf V.! unOb x) +{-# INLINE obIxs #-} + +-- | List of ,,next'' labels which constitute a valid feature in combination +-- with the ,,current'' label accompanied by feature indices determined by +-- ,,next'' labels. +nextIxs :: Model -> Lb -> [LbIx] +nextIxs crf x = U.toList (nextIxsV crf V.! unLb x) +{-# INLINE nextIxs #-} + +-- | List of ,,previous'' labels which constitute a valid feature in +-- combination with the ,,current'' label accompanied by feature indices +-- determined by ,,previous'' labels. +prevIxs :: Model -> Lb -> [LbIx] +prevIxs crf x = U.toList (prevIxsV crf V.! unLb x) +{-# INLINE prevIxs #-} + +nub :: Ord a => [a] -> [a] +nub = Set.toList . Set.fromList diff --git a/src/Data/CRF/Chain1/Train.hs b/src/Data/CRF/Chain1/Train.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Train.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} + +module Data.CRF.Chain1.Train +( CRF (..) +, train +) where + +import Control.Applicative ((<$>), (<*>)) +import System.IO (hSetBuffering, stdout, BufferMode (..)) +import Data.Binary (Binary, put, get) +import qualified Data.Vector as V +import qualified Numeric.SGD as SGD +import qualified Numeric.SGD.LogSigned as L + +import Data.CRF.Chain1.Dataset.Internal +import Data.CRF.Chain1.Dataset.External (SentL) +import Data.CRF.Chain1.Dataset.Codec (mkCodec, Codec, encodeDataL) +import Data.CRF.Chain1.Feature (Feature, featuresIn) +import Data.CRF.Chain1.Model (Model (..), mkModel, FeatIx (..), featToInt) +import Data.CRF.Chain1.Inference (accuracy, expectedFeaturesIn) + +-- | A conditional random field model with additional codec used for +-- data encoding. +data CRF a b = CRF { + -- | The codec is used to transform data into internal representation, + -- where each observation and each label is represented by a unique + -- integer number. + codec :: Codec a b, + -- | The actual model, which is a map from 'Feature's to potentials. + model :: Model } + +instance (Ord a, Ord b, Binary a, Binary b) => Binary (CRF a b) where + put CRF{..} = put codec >> put model + get = CRF <$> get <*> get + +-- | Train the CRF using the stochastic gradient descent method. +-- The resulting model will contain features extracted with +-- the user supplied extraction function. +-- You can use the functions provided by the "Data.CRF.Chain1.Feature.Present" +-- and "Data.CRF.Chain1.Feature.Hidden" modules for this purpose. +-- When the evaluation data 'IO' action is 'Just', the iterative +-- training process will notify the user about the current accuracy +-- on the evaluation part every full iteration over the training part. +train + :: (Ord a, Ord b) + => SGD.SgdArgs -- ^ Args for SGD + -> IO [SentL a b] -- ^ Training data 'IO' action + -> Maybe (b, IO [SentL a b]) -- ^ Default label and evalation data + -> ([(Xs, Ys)] -> [Feature]) -- ^ Feature selection + -> IO (CRF a b) -- ^ Resulting model +train sgdArgs trainIO evalIO'Maybe extractFeats = do + hSetBuffering stdout NoBuffering + (_codec, trainData) <- mkCodec <$> trainIO + evalDataM <- case evalIO'Maybe of + Just (x, evalIO) -> Just . encodeDataL x _codec <$> evalIO + Nothing -> return Nothing + let crf = mkModel (extractFeats trainData) + para <- SGD.sgdM sgdArgs + (notify sgdArgs crf trainData evalDataM) + (gradOn crf) (V.fromList trainData) (values crf) + return $ CRF _codec (crf { values = para }) + +gradOn :: Model -> SGD.Para -> (Xs, Ys) -> SGD.Grad +gradOn crf para (xs, ys) = SGD.fromLogList $ + [ (featToInt curr feat, L.fromPos val) + | (feat, val) <- featuresIn xs ys ] ++ + [ (ix, L.fromNeg val) + | (FeatIx ix, val) <- expectedFeaturesIn curr xs ] + where + curr = crf { values = para } + +notify + :: SGD.SgdArgs -> Model -> [(Xs, Ys)] -> Maybe [(Xs, Ys)] + -> SGD.Para -> Int -> IO () +notify SGD.SgdArgs{..} crf trainData evalDataM para k + | doneTotal k == doneTotal (k - 1) = putStr "." + | Just dataSet <- evalDataM = do + let x = accuracy (crf { values = para }) dataSet + putStrLn ("\n" ++ "[" ++ show (doneTotal k) ++ "] acc = " ++ show x) + | otherwise = + putStrLn ("\n" ++ "[" ++ show (doneTotal k) ++ "] acc = #") + where + doneTotal :: Int -> Int + doneTotal = floor . done + done :: Int -> Double + done i + = fromIntegral (i * batchSize) + / fromIntegral trainSize + trainSize = length trainData diff --git a/src/Data/CRF/Chain1/Util.hs b/src/Data/CRF/Chain1/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Util.hs @@ -0,0 +1,12 @@ +module Data.CRF.Chain1.Util +( partition +) where + +import Data.List (transpose) + +partition :: Int -> [a] -> [[a]] +partition n = + transpose . group n + where + group _ [] = [] + group k xs = take k xs : (group k $ drop k xs)