diff --git a/crf-chain1-constrained.cabal b/crf-chain1-constrained.cabal --- a/crf-chain1-constrained.cabal +++ b/crf-chain1-constrained.cabal @@ -1,5 +1,5 @@ name: crf-chain1-constrained -version: 0.3.2 +version: 0.4.0 synopsis: First-order, constrained, linear-chain conditional random fields description: The library provides efficient implementation of the first-order, @@ -8,11 +8,11 @@ . It is strongly related to the simpler - library where constraints are not taken into account and all - features which are not included in the CRF model are considered to have - probability of 0. Here, on the other hand, such features do not influence - the overall probability of the (sentence, labels) pair - they are - assigned the default potential of 0. + library where constraints are not taken into account and all features + which are not included in the CRF model are considered to have + probability of 0. Here, on the other hand, such features do not + influence the overall probability of the (sentence, labels) pair + - they are assigned the default potential of 0. . Efficient algorithm for determining marginal probabilities of individual labels is provided. @@ -37,21 +37,24 @@ build-depends: base >= 4 && < 5 - , containers - , vector - , array - , random - , parallel + , containers >= 0.4 && < 0.6 + , vector >= 0.10 && < 0.13 + , array >= 0.4 && < 0.6 + , random >= 1.0 && < 1.2 + , parallel >= 3.2 && < 3.3 , logfloat >= 0.12.1 && < 0.14 , monad-codec >= 0.2 && < 0.3 - , binary - , vector-binary - , data-lens - , sgd >= 0.3.2 && < 0.4 + , binary >= 0.5 && < 0.9 + , vector-binary >= 0.1 && < 0.2 + , data-lens >= 2.10 && < 2.12 + , sgd >= 0.4.0 && < 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.Chain1.Constrained + , Data.CRF.Chain1.Constrained.Core , Data.CRF.Chain1.Constrained.Dataset.Internal , Data.CRF.Chain1.Constrained.Dataset.External , Data.CRF.Chain1.Constrained.Dataset.Codec @@ -61,6 +64,17 @@ , Data.CRF.Chain1.Constrained.Model , Data.CRF.Chain1.Constrained.Inference , Data.CRF.Chain1.Constrained.Train + + , Data.CRF.Chain1.Constrained.DAG + -- , Data.CRF.Chain1.Constrained.DAG.Dataset.Internal + , Data.CRF.Chain1.Constrained.DAG.Dataset.External + , Data.CRF.Chain1.Constrained.DAG.Dataset.Codec + , Data.CRF.Chain1.Constrained.DAG.Feature + , Data.CRF.Chain1.Constrained.DAG.Feature.Present + , Data.CRF.Chain1.Constrained.DAG.Feature.Hidden + , Data.CRF.Chain1.Constrained.DAG.Inference + , Data.CRF.Chain1.Constrained.DAG.Probs + , Data.CRF.Chain1.Constrained.DAG.Train other-modules: Data.CRF.Chain1.Constrained.DP diff --git a/src/Data/CRF/Chain1/Constrained.hs b/src/Data/CRF/Chain1/Constrained.hs --- a/src/Data/CRF/Chain1/Constrained.hs +++ b/src/Data/CRF/Chain1/Constrained.hs @@ -25,6 +25,7 @@ , module Data.CRF.Chain1.Constrained.Feature.Hidden ) where +import Prelude hiding (Word) import Data.CRF.Chain1.Constrained.Dataset.External import Data.CRF.Chain1.Constrained.Dataset.Codec import Data.CRF.Chain1.Constrained.Feature.Present diff --git a/src/Data/CRF/Chain1/Constrained/Core.hs b/src/Data/CRF/Chain1/Constrained/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Constrained/Core.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + + +module Data.CRF.Chain1.Constrained.Core +( +-- * Basic Types + Ob (..) +, Lb (..) + +, X (..) +, mkX +, unX +, unR + +, Y (..) +, mkY +, unY + +, AVec (..) +, fromList +, fromSet + +-- * Features +, Feature (..) +, isSFeat +, isTFeat +, isOFeat +) where + + +import Control.Applicative ((<*>), (<$>)) +-- import Data.Vector.Generic.Base +-- import Data.Vector.Generic.Mutable +import Data.Vector.Binary () +import Data.Binary (Binary, Get, get, put, putWord8, getWord8) +import Data.Ix (Ix) +import qualified Data.Set as S +-- import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import Data.Vector.Unboxed.Deriving +-- import qualified Data.Number.LogFloat as L + + +---------------------------------------------- +-- Basic Types +---------------------------------------------- + + +-- | 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 |] + +-- | An ascending vector of unique elements. +newtype AVec a = AVec { unAVec :: U.Vector a } + deriving (Show, Read, Eq, Ord, Binary) + +-- | Smart AVec constructor which ensures that the +-- underlying vector satisfies the AVec properties. +fromList :: (Ord a, U.Unbox a) => [a] -> AVec a +fromList = fromSet . S.fromList +{-# INLINE fromList #-} + +-- | Smart AVec constructor which ensures that the +-- underlying vector satisfies the AVec properties. +fromSet :: (Ord a, U.Unbox a) => S.Set a -> AVec a +fromSet = AVec . U.fromList . S.toAscList +{-# INLINE fromSet #-} + +-- | A word represented by a list of its observations +-- and a list of its potential label interpretations. +data X + -- | The word with default set of potential interpretations. + = X { _unX :: AVec Ob } + -- | The word with restricted set of potential labels. + | R { _unX :: AVec Ob + , _unR :: AVec Lb } + deriving (Show, Read, Eq, Ord) + +instance Binary X where + put X{..} = putWord8 0 >> put _unX + put R{..} = putWord8 1 >> put _unX >> put _unR + get = getWord8 >>= \i -> case i of + 0 -> X <$> get + _ -> R <$> get <*> get + +-- | X constructor. +mkX :: [Ob] -> [Lb] -> X +mkX x [] = X (fromList x) +mkX x r = R (fromList x) (fromList r) +{-# INLINE mkX #-} + +-- | List of observations. +unX :: X -> [Ob] +unX = U.toList . unAVec . _unX +{-# INLINE unX #-} + +-- | List of potential labels. +unR :: AVec Lb -> X -> [Lb] +unR r0 X{..} = U.toList . unAVec $ r0 +unR _ R{..} = U.toList . unAVec $ _unR +{-# INLINE unR #-} + + +-- | Probability distribution over labels. We assume, that when y is +-- a member of chosen labels list it is also a member of the list +-- potential labels for corresponding 'X' word. +-- TODO: Perhaps we should substitute 'Lb's with label indices +-- corresponding to labels from the vector of potential labels? +-- FIXME: The type definition is incorrect (see 'fromList' definition), +-- it should be something like AVec2. +newtype Y = Y { _unY :: AVec (Lb, Double) } + deriving (Show, Read, Eq, Ord, Binary) + +-- | Y constructor. +mkY :: [(Lb, Double)] -> Y +mkY = Y . fromList +{-# INLINE mkY #-} + +-- | Y deconstructor symetric to mkY. +unY :: Y -> [(Lb, Double)] +unY = U.toList . unAVec . _unY +{-# INLINE unY #-} + + +---------------------------------------------- +-- Features +---------------------------------------------- + + +-- | 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 #-} diff --git a/src/Data/CRF/Chain1/Constrained/DAG.hs b/src/Data/CRF/Chain1/Constrained/DAG.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Constrained/DAG.hs @@ -0,0 +1,117 @@ + +{-# LANGUAGE RecordWildCards #-} + +-- | The module provides first-order, linear-chain conditional random fields +-- (CRFs) with position-wide constraints over label values. + +module Data.CRF.Chain1.Constrained.DAG +( +-- * Data types + Word (..) +, unknown +, Sent +, Prob (unProb) +, mkProb +, WordL (word, choice) +, mkWordL +, SentL + +-- ** Tagging +, tag +, marginals +-- , tagK + +-- * Modules +, module Data.CRF.Chain1.Constrained.DAG.Train +, module Data.CRF.Chain1.Constrained.DAG.Feature.Present +, module Data.CRF.Chain1.Constrained.DAG.Feature.Hidden +) where + +import Prelude hiding (Word) +import qualified Data.Vector as V +import qualified Data.Number.LogFloat as L + +-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG +import qualified Data.DAG as DAG +import Data.DAG (DAG) + +-- import Data.CRF.Chain1.Constrained.Dataset.External +import Data.CRF.Chain1.Constrained.DAG.Dataset.External +-- import Data.CRF.Chain1.Constrained.DAG.Dataset.External (WordL(..)) +import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Codec as C +import Data.CRF.Chain1.Constrained.Dataset.Codec (decodeLabel, unJust) +import Data.CRF.Chain1.Constrained.DAG.Feature.Present +import Data.CRF.Chain1.Constrained.DAG.Feature.Hidden +import Data.CRF.Chain1.Constrained.DAG.Train +import qualified Data.CRF.Chain1.Constrained.DAG.Inference as I +import qualified Data.CRF.Chain1.Constrained.Dataset.Internal as Int + + +-- | 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 -> DAG () b +tag CRF{..} sent + = onWords + . fmap (decodeLabel codec) + . I.tag model + . C.encodeSent codec + $ sent + where + -- handle unknown labels; otherwise, the type of `tag`s result + -- would be `DAG () (Maybe b)` + onWords labeled = + fmap f labeledSent + where + f = uncurry (unJust codec) + labeledSent = DAG.zipE sent labeled + + +-- | Tag with marginal probabilities. For known words (i.e., with `lbs` +-- non-empty), their known potential interpretations are assigned some +-- probabilities (other interpretations are not considered. For unknown +-- words (i.e., with empty `lbs`), all interpretations are considered +-- (up to the way the set of all interpretations is constructed). +-- In particular, if no interpretation with probability > 0 is found +-- for an unknown word, its set of chosen labels will remain empty. +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 + . C.encodeSent codec + $ sent + where + decodeChosen (word, chosen) = + mkWordL word prob + where + prob = mkProb + [ (decode word x, L.fromLogFloat p) + | (x, p) <- chosen ] + decode word = unJust codec word . decodeLabel codec + + +-- -- | Determine the most probable label sets of the given size (at maximum) +-- -- for each position in the input sentence. +-- tagK :: (Ord a, Ord b) => Int -> CRF a b -> Sent a b -> [[b]] +-- tagK k CRF{..} sent +-- = onWords . map decodeChoice +-- . DAG.toListProv +-- . I.tagK k model +-- . dagSent +-- . encodeSent codec +-- $ sent +-- where +-- decodeChoice = decodeLabels codec . map fst +-- onWords xss = +-- [ take k $ unJusts codec word xs +-- | (word, xs) <- zip sent xss ] +-- +-- +-- ------------------------------------------------------ +-- -- Dataset conversion (Provisional) +-- ------------------------------------------------------ +-- +-- +-- -- | Convert the sequential representation to DAG-based one. +-- dagSent :: Int.Xs -> DAG.DAG () Int.X +-- dagSent = DAG.fromList . V.toList diff --git a/src/Data/CRF/Chain1/Constrained/DAG/Dataset/Codec.hs b/src/Data/CRF/Chain1/Constrained/DAG/Dataset/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Constrained/DAG/Dataset/Codec.hs @@ -0,0 +1,109 @@ +module Data.CRF.Chain1.Constrained.DAG.Dataset.Codec +( + module Data.CRF.Chain1.Constrained.Dataset.Codec + +, Xs +, XYs + +, encodeSent'Cu +, encodeSent'Cn +, encodeSent + +, encodeSentL'Cu +, encodeSentL'Cn +, encodeSentL + +, encodeData +, encodeDataL + +, mkCodec +) where + + +import Prelude hiding (Word) +-- import qualified Data.Foldable as F +import qualified Data.Traversable as T + +import Data.DAG (DAG) +-- import Data.CRF.Chain1.Constrained.DAG.Dataset.Internal +import qualified Data.CRF.Chain1.Constrained.Dataset.Internal as I +import Data.CRF.Chain1.Constrained.DAG.Dataset.External +import qualified Data.CRF.Chain1.Constrained.Dataset.Codec as C +import Data.CRF.Chain1.Constrained.Dataset.Codec hiding + (encodeSent'Cu, encodeSent'Cn, encodeSent, encodeSentL'Cu, encodeSentL'Cn, + encodeSentL, encodeData, encodeDataL, mkCodec) +import Control.Monad.Codec (evalCodec, execCodec) + + +-- | 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) => [SentL a b] -> Codec a b +mkCodec = execCodec empty . mapM_ encodeSentL'Cu diff --git a/src/Data/CRF/Chain1/Constrained/DAG/Dataset/External.hs b/src/Data/CRF/Chain1/Constrained/DAG/Dataset/External.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Constrained/DAG/Dataset/External.hs @@ -0,0 +1,24 @@ +module Data.CRF.Chain1.Constrained.DAG.Dataset.External +( Sent +, SentL +, module Data.CRF.Chain1.Constrained.Dataset.External +) where + + +import Prelude hiding (Word) +-- import qualified Data.Set as S +-- import qualified Data.Map as M + +import qualified Data.DAG as DAG +import Data.DAG (DAG) +-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG +-- import Data.CRF.Chain1.Constrained.DAG.Dataset.Internal (DAG) +import Data.CRF.Chain1.Constrained.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) diff --git a/src/Data/CRF/Chain1/Constrained/DAG/Feature.hs b/src/Data/CRF/Chain1/Constrained/DAG/Feature.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Constrained/DAG/Feature.hs @@ -0,0 +1,63 @@ +module Data.CRF.Chain1.Constrained.DAG.Feature +( featuresIn +, features +) where + + +import qualified Data.Number.LogFloat as L + +-- import Data.CRF.Chain1.Constrained.DAG.Dataset.Internal (EdgeID, DAG) +-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG +import Data.DAG (EdgeID, DAG) +import qualified Data.DAG as DAG + +import Data.CRF.Chain1.Constrained.Core (X, Y, Feature) +import qualified Data.CRF.Chain1.Constrained.Core as C + + +-- | Transition features with assigned probabilities for given position. +trFeats :: EdgeID -> DAG a (X, Y) -> [(Feature, L.LogFloat)] +trFeats edgeID dag = + doit + where + edgeLabel = DAG.edgeLabel edgeID dag + prevEdges = DAG.prevEdges edgeID dag + doit + | null prevEdges = + [ (C.SFeature x, L.logFloat px) + | (x, px) <- C.unY (snd edgeLabel) ] + | otherwise = + [ (C.TFeature x y, L.logFloat px * L.logFloat py) + | (x, px) <- C.unY (snd edgeLabel) + , prevEdgeID <- prevEdges + , let prevEdgeLabel = DAG.edgeLabel prevEdgeID dag + , (y, py) <- C.unY (snd prevEdgeLabel) ] + + +-- | Observation features with assigned probabilities for a given position. +obFeats :: EdgeID -> DAG a (X, Y) -> [(Feature, L.LogFloat)] +obFeats edgeID dag = + [ (C.OFeature o x, L.logFloat px) + | let edgeLabel = DAG.edgeLabel edgeID dag + , (x, px) <- C.unY (snd edgeLabel) + , o <- C.unX (fst edgeLabel) ] + + +-- | Return the list of features with the corresponding probabilities +-- corresponding to the given DAG edge. +features :: EdgeID -> DAG a (X, Y) -> [(Feature, L.LogFloat)] +features edgeID dag = trFeats edgeID dag ++ obFeats edgeID dag + + +-- | Return the list of features, together with the corresponding probabilities +-- (specified in the dataset), in the labeled DAG. +-- +-- WARNING: this function is unsuitable to compute the potential of a given (X, +-- Y) pair w.r.t. to a CRF model for at least two reasons: +-- * The parameters (second elements of the output list) are not from the model. +-- * More importantly, the function does not take into account the potential labels +-- of the OOV words. +featuresIn :: DAG a (X, Y) -> [(Feature, L.LogFloat)] +featuresIn dag = concat + [ features edgeID dag + | edgeID <- DAG.dagEdges dag ] diff --git a/src/Data/CRF/Chain1/Constrained/DAG/Feature/Hidden.hs b/src/Data/CRF/Chain1/Constrained/DAG/Feature/Hidden.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Constrained/DAG/Feature/Hidden.hs @@ -0,0 +1,72 @@ +-- | The module provides feature selection functions which extract +-- hidden features, i.e. all features which can be constructed +-- on the basis of observations and potential labels (constraints) +-- corresponding to individual words. +-- +-- You can mix functions defined here with the selection functions +-- from the "Data.CRF.Chain1.Constrained.Feature.Present" module. + +module Data.CRF.Chain1.Constrained.DAG.Feature.Hidden +( hiddenFeats +, hiddenOFeats +, hiddenTFeats +, hiddenSFeats +) where + +import Data.DAG (DAG) +import qualified Data.DAG as DAG + +import Data.CRF.Chain1.Constrained.Core (AVec, X, Y, Lb, Feature) +import qualified Data.CRF.Chain1.Constrained.Core as C + +-- import Data.CRF.Chain1.Constrained.Dataset.Internal +-- import Data.CRF.Chain1.Constrained.Feature + +-- | Hidden 'OFeature's which can be constructed based on the dataset. +-- The default set of potential interpretations is used for all unknown words. +hiddenOFeats :: AVec Lb -> [DAG a X] -> [Feature] +hiddenOFeats r0 ds = + concatMap oFeats ds + where + oFeats dag = concatMap (oFeatsOn dag) (DAG.dagEdges dag) + oFeatsOn dag edgeID = + [ C.OFeature o x + | let label = DAG.edgeLabel edgeID dag + , o <- C.unX label + , x <- C.unR r0 label ] + + +-- | Hidden 'TFeature's which can be constructed based on the dataset. +-- The default set of potential interpretations is used for all unknown words. +hiddenTFeats :: AVec Lb -> [DAG a X] -> [Feature] +hiddenTFeats r0 ds = + concatMap tFeats ds + where + tFeats dag = + [ C.TFeature x y + | i <- DAG.dagEdges dag + , x <- C.unR r0 $ DAG.edgeLabel i dag + , j <- DAG.prevEdges i dag + , y <- C.unR r0 $ DAG.edgeLabel j dag ] + + +-- | Hidden 'SFeature's which can be constructed based on the dataset. +-- The default set of potential interpretations is used for all unknown words. +hiddenSFeats :: AVec Lb -> [DAG a X] -> [Feature] +hiddenSFeats r0 ds = + concatMap sFeats ds + where + sFeats dag = + [ C.SFeature x + | i <- DAG.dagEdges dag + , x <- C.unR r0 $ DAG.edgeLabel i dag ] + + +-- | Hidden 'Feature's of all types which can be constructed +-- on the basis of the dataset. The default set of potential +-- interpretations is used for all unknown words. +hiddenFeats :: AVec Lb -> [DAG a X] -> [Feature] +hiddenFeats r0 ds + = hiddenOFeats r0 ds + ++ hiddenTFeats r0 ds + ++ hiddenSFeats r0 ds diff --git a/src/Data/CRF/Chain1/Constrained/DAG/Feature/Present.hs b/src/Data/CRF/Chain1/Constrained/DAG/Feature/Present.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Constrained/DAG/Feature/Present.hs @@ -0,0 +1,71 @@ +-- | The module provides feature selection functions which extract +-- features present in the dataset, i.e. features which directly occure +-- the dataset. + + +module Data.CRF.Chain1.Constrained.DAG.Feature.Present +( presentFeats +, presentOFeats +, presentTFeats +, presentSFeats +) where + + +import Data.DAG (DAG) +import qualified Data.DAG as DAG +-- import Data.CRF.Chain1.Constrained.DAG.Dataset.Internal (DAG) +-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG + +import Data.CRF.Chain1.Constrained.Core (X, Y, Lb, Feature) +import qualified Data.CRF.Chain1.Constrained.Core as C + + +-- | 'OFeature's which occur in the dataset. +presentOFeats :: [DAG a (X, Y)] -> [Feature] +presentOFeats = + concatMap sentOFeats + where + sentOFeats dag = + [ C.OFeature o x + | edgeID <- DAG.dagEdges dag + , let edgeLabel = DAG.edgeLabel edgeID dag + , o <- C.unX (fst edgeLabel) + , x <- lbs (snd edgeLabel) ] + + +-- | 'TFeature's which occur in the dataset. +presentTFeats :: [DAG a Y] -> [Feature] +presentTFeats = + concatMap sentTFeats + where + sentTFeats dag = + [ C.TFeature x y + | edgeID <- DAG.dagEdges dag + , x <- lbs (DAG.edgeLabel edgeID dag) + , prevEdgeID <- DAG.prevEdges edgeID dag + , y <- lbs (DAG.edgeLabel prevEdgeID dag) ] + + +-- | 'SFeature's which occur in the given dataset. +presentSFeats :: [DAG a Y] -> [Feature] +presentSFeats = + concatMap sentSFeats + where + sentSFeats dag = + [ C.SFeature x + | edgeID <- DAG.dagEdges dag + , DAG.isInitialEdge edgeID dag + , x <- lbs (DAG.edgeLabel edgeID dag) ] + + +-- | 'Feature's of all kinds which occur in the given dataset. +presentFeats :: [DAG a (X, Y)] -> [Feature] +presentFeats ds + = presentOFeats ds + ++ presentTFeats (map (fmap snd) ds) + ++ presentSFeats (map (fmap snd) ds) + + +-- | Retrieve the domain of the given probability distribution. +lbs :: Y -> [Lb] +lbs = map fst . C.unY diff --git a/src/Data/CRF/Chain1/Constrained/DAG/Inference.hs b/src/Data/CRF/Chain1/Constrained/DAG/Inference.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Constrained/DAG/Inference.hs @@ -0,0 +1,532 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} + + +-- | Inference with CRFs. + + +module Data.CRF.Chain1.Constrained.DAG.Inference +( tag +, tagK +, marginals +, accuracy +, expectedFeaturesIn +, zx +, zx' + +-- , probability +-- , likelihood + +-- * Internals +, computePsi +) where + + +import Control.Applicative ((<$>)) +import Data.Maybe (catMaybes) +import Data.List (maximumBy, sort, sortBy) +import Data.Function (on) +import qualified Data.Set as S +import qualified Data.Array as A +-- import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import qualified Data.Foldable as F + +import Control.Parallel.Strategies (rseq, parMap) +import Control.Parallel (par, pseq) +import GHC.Conc (numCapabilities) +import qualified Data.Number.LogFloat as L + +-- import Data.CRF.Chain1.Constrained.DAG.Dataset.Internal (EdgeID, DAG) +-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG +import Data.DAG (EdgeID, DAG) +import qualified Data.DAG as DAG + +import qualified Data.CRF.Chain1.Constrained.DP as DP +import Data.CRF.Chain1.Constrained.Util (partition) +import qualified Data.CRF.Chain1.Constrained.Model as Md + +import Data.CRF.Chain1.Constrained.Core (X, Y, Lb, AVec) +import qualified Data.CRF.Chain1.Constrained.Core as C +import qualified Data.CRF.Chain1.Constrained.Intersect as I + +import Data.CRF.Chain1.Constrained.DAG.Feature (featuresIn) + +import Debug.Trace (trace) + + +--------------------------------------------- +-- Util Types +--------------------------------------------- + + +-- | TODO. +type LbIx = Int + + +-- | The probability array assigns some probability to each label (represented +-- by its index) which can be assigned to a given edge (represented by its +-- `EdgeID`). +type ProbArray = EdgeID -> LbIx -> L.LogFloat + + +--------------------------------------------- +-- Summing +--------------------------------------------- + + +-- -- | Numerically safer summing. +-- safeSum :: (Ord a, Num a) => [a] -> a +-- -- safeSum = sum . sort +-- safeSum = sum +-- {-#INLINE safeSum #-} + + +-- | Numerically safer summing. +safeSum :: [L.LogFloat] -> L.LogFloat +safeSum [] = 0 +safeSum xs = L.sum xs +{-#INLINE safeSum #-} + + +--------------------------------------------- +-- Some basic functions. +--------------------------------------------- + + +-- | Vector of potential labels on the given edge of the sentence. +lbVec :: Md.Model -> DAG a X -> EdgeID -> AVec Lb +lbVec crf dag edgeID = case DAG.edgeLabel edgeID dag of + C.X _ -> (Md.r0 crf) + C.R _ r -> r +{-# INLINE lbVec #-} + + +-- | Number of potential labels on the given edge of the sentence. +lbNum :: Md.Model -> DAG a X -> EdgeID -> Int +lbNum crf dag = (U.length . C.unAVec) . lbVec crf dag +{-# INLINE lbNum #-} + + +-- | Potential label on the given vector position. +lbOn :: Md.Model -> X -> LbIx -> Lb +lbOn crf (C.X _) = (C.unAVec (Md.r0 crf) U.!) +lbOn _ (C.R _ r) = (C.unAVec r U.!) +{-# INLINE lbOn #-} + + +-- | Potential labels on the given sentence edge (as in `lbVec`), accompanied +-- with the corresponding indexes. I.e., each label `Lb` is accompanied with a +-- number, from [0..], corresponding to its index in the vector of labels +-- obtained with `lbVec`. +lbIxs :: Md.Model -> DAG a X -> EdgeID -> [(LbIx, Lb)] +lbIxs crf dag = zip [0..] . U.toList . C.unAVec . lbVec crf dag +{-# INLINE lbIxs #-} + + +--------------------------------------------- +-- A bit more complex stuff. +--------------------------------------------- + + +-- | Compute the table of potential products associated with observation +-- features for the given sentence edge. +computePsi :: Md.Model -> DAG a X -> EdgeID -> LbIx -> L.LogFloat +computePsi crf dag i = (A.!) $ A.accumArray (*) 1 bounds + [ (k, Md.valueL crf ix) + | ob <- C.unX (DAG.edgeLabel i dag) + , (k, ix) <- I.intersect (Md.obIxs crf ob) (lbVec crf dag i) ] + where + bounds = (0, lbNum crf dag i - 1) + + +-- | Equivalent to `computePsi`, but memoizes additionally on `EdgeID`s. +computePsi' + :: Md.Model -> DAG a X + -> EdgeID -> LbIx + -> L.LogFloat +computePsi' crf dag = + (array A.!) + where + bounds = (DAG.minEdge dag, DAG.maxEdge dag) + array = A.array bounds + [ (i, computePsi crf dag i) + | i <- A.range bounds ] + + +-- | Forward table computation. +forward :: Md.Model -> DAG a X -> ProbArray +forward crf dag = alpha where + alpha = DP.flexible2 bounds boundsOn + (\t i -> withMem (computePsi crf dag i) t i) + bounds = (DAG.minEdge dag, DAG.maxEdge dag + 1) + boundsOn i + | i == snd bounds = (0, 0) + | otherwise = (0, lbNum crf dag i - 1) + -- set of initial edges + initialSet = S.fromList + [ i + | i <- DAG.dagEdges dag + , DAG.isInitialEdge i dag ] + withMem psi alpha i + | i == snd bounds = const u' + | i `S.member` initialSet = \j -> + let x = lbOn crf (DAG.edgeLabel i dag) j + in psi j * Md.sgValue crf x + | otherwise = \j -> + let x = lbOn crf (DAG.edgeLabel i dag) j + in psi j * ((u - v x) + w x) + where + u = safeSum + [ alpha iMinus1 k + | iMinus1 <- DAG.prevEdges i dag + , (k, _) <- lbIxs crf dag iMinus1 ] + v x = safeSum + [ alpha iMinus1 k + | iMinus1 <- DAG.prevEdges i dag + , (k, _) <- I.intersect (Md.prevIxs crf x) (lbVec crf dag iMinus1) ] + w x = safeSum + [ alpha iMinus1 k * Md.valueL crf ix + | iMinus1 <- DAG.prevEdges i dag + , (k, ix) <- I.intersect (Md.prevIxs crf x) (lbVec crf dag iMinus1) ] + -- Note that if `i == snd bounds` then `i` does not refer to any existing + -- edge, hence the need to introduce `u'` which does almost the same thing + -- as `u`. + u' = safeSum + [ alpha iMinus1 k + | iMinus1 <- DAG.dagEdges dag + , DAG.isFinalEdge iMinus1 dag + , (k, _) <- lbIxs crf dag iMinus1 ] + + +-- | Backward table computation. +backward :: Md.Model -> DAG a X -> ProbArray +backward crf dag = beta where + beta = DP.flexible2 bounds boundsOn withMem + bounds = (DAG.minEdge dag - 1, DAG.maxEdge dag) + boundsOn i + | i == fst bounds = (0, 0) + | otherwise = (0, lbNum crf dag i - 1) + psi = computePsi' crf dag + -- set of final edges + finalSet = S.fromList + [ i + | i <- DAG.dagEdges dag + , DAG.isFinalEdge i dag ] + withMem beta i + | i `S.member` finalSet = const 1 + | i == fst bounds = const $ safeSum + [ beta iPlus1 k * psi iPlus1 k + * Md.sgValue crf (lbOn crf (DAG.edgeLabel iPlus1 dag) k) + | iPlus1 <- DAG.dagEdges dag + , DAG.isInitialEdge iPlus1 dag + , (k, _) <- lbIxs crf dag iPlus1 ] + | otherwise = \j -> + let y = lbOn crf (DAG.edgeLabel i dag) j + in (u - v y) + w y + where + -- Note that here `i` is an identifier of the current DAG edge. + -- Instead of simply adding `1` to `i` (i.e., `i + 1`), + -- we need to find the identifiers of the succeeding edges. + u = safeSum + [ beta iPlus1 k * psi iPlus1 k + | iPlus1 <- DAG.nextEdges i dag + , (k, _ ) <- lbIxs crf dag iPlus1 ] + -- `y` is the label on position `i`, we are looking for + -- matching labels on the position `i+1`. + v y = safeSum + [ beta iPlus1 k * psi iPlus1 k + | iPlus1 <- DAG.nextEdges i dag + , (k, _ ) <- I.intersect (Md.nextIxs crf y) (lbVec crf dag iPlus1) ] + -- `y` is the label on position `i`, we are looking for + -- matching labels on the position `i+1`. + w y = safeSum + [ beta iPlus1 k * psi iPlus1 k * Md.valueL crf ix + | iPlus1 <- DAG.nextEdges i dag + , (k, ix) <- I.intersect (Md.nextIxs crf y) (lbVec crf dag iPlus1) ] + + +-- | Normalization factor computed for the 'Xs' sentence using the +-- forward computation. +zx' :: Md.Model -> DAG a X -> L.LogFloat +zx' crf dag = zxAlpha dag (forward crf dag) + +zxAlpha :: DAG a b -> ProbArray -> L.LogFloat +zxAlpha dag alpha = alpha (DAG.maxEdge dag + 1) 0 + + +-- | Normalization factor computed for the 'Xs' sentence using the +-- backward computation. +zx :: Md.Model -> DAG a X -> L.LogFloat +zx crf dag = zxBeta dag (backward crf dag) + +zxBeta :: DAG a b -> ProbArray -> L.LogFloat +zxBeta dag beta = beta (DAG.minEdge dag - 1) 0 + + +-- prob1 :: ProbArray -> ProbArray -> Int -> LbIx -> L.LogFloat +-- prob1 alpha beta k x = +-- alpha k x * beta (k + 1) x / zxBeta beta +-- {-# INLINE prob1 #-} + +-- | Probability of chosing the given edge and the corresponding label. +edgeProb1 + :: DAG a b + -- ^ The underlying sentence DAG + -> ProbArray + -- ^ Forward probability table + -> ProbArray + -- ^ Backward probability table + -> EdgeID + -- ^ ID of the edge in the underlying DAG + -> LbIx + -- ^ Index of the label of the edge represented by the `EdgeID` + -> L.LogFloat +edgeProb1 dag alpha beta k x + -- alpha k x * beta k x / zxBeta dag beta + | any isInf [up1, up2, down] = + error $ "edgeProb1: infinite -- " ++ show [up1, up2, down, down'] -- ++ "; " ++ show (k, x) + | otherwise = up1 * up2 / down + where + isInf x = isInfinite (L.logFromLogFloat x :: Double) + up1 = alpha k x + up2 = beta k x + down = zxBeta dag beta + down' = zxAlpha dag alpha +{-# INLINE edgeProb1 #-} + + +-- | Probability of chosing the given pair of edges and the corresponding labels. +edgeProb2 + :: Md.Model + -- ^ CRF model + -> DAG a b + -- ^ The underlying sentence DAG + -> ProbArray + -- ^ Forward computation table + -> ProbArray + -- ^ Backward computation table + -> (EdgeID -> LbIx -> L.LogFloat) + -- ^ Psi computation + -> (EdgeID, LbIx) + -- ^ First edge and the corresponding label index + -> (EdgeID, LbIx) + -- ^ Succeeding edge and the corresponding label index + -> Md.FeatIx + -- ^ TODO (NO IDEA!); Hypo: index of the transition feature corresponding + -- to the transition between the first and the succeeding edge + -> L.LogFloat +edgeProb2 crf dag alpha beta psi (kEdgeID, xLbIx) (lEdgeID, yLbIx) ix + -- = alpha kEdgeID xLbIx * beta lEdgeID yLbIx + -- -- * psi lEdgeID yLbIx * Md.valueL crf ix / zxBeta dag beta + | any isInf [up1, up2, up3, up4, down] = + error $ "edgeProb2: infinite -- " ++ show [up1, up2, up3, up4, down, down'] + | otherwise = up1 * up2 * up3 * up4 / down + where + isInf x = isInfinite (L.logFromLogFloat x :: Double) + up1 = alpha kEdgeID xLbIx + up2 = beta lEdgeID yLbIx + up3 = psi lEdgeID yLbIx + up4 = Md.valueL crf ix + down = zxBeta dag beta + down' = zxAlpha dag alpha +{-# INLINE edgeProb2 #-} + + +-- prob2 :: Model -> ProbArray -> ProbArray -> Int -> (LbIx -> L.LogFloat) +-- -> LbIx -> LbIx -> FeatIx -> L.LogFloat +-- prob2 crf alpha beta k psi x y ix +-- = alpha (k - 1) y * beta (k + 1) x +-- * psi x * valueL crf ix / zxBeta beta +-- {-# INLINE prob2 #-} + + +-- | Tag potential labels with marginal distributions. +-- marginals :: Md.Model -> DAG a X -> [[(Lb, L.LogFloat)]] +marginals :: Md.Model -> DAG a X -> DAG a [(Lb, L.LogFloat)] +marginals crf dag + | not (zx1 `almostEq` zx2) = trace warning margs + | otherwise = margs + where + margs = DAG.mapE label dag + warning = + "[marginals] normalization factors differ significantly: " + ++ show (L.logFromLogFloat zx1, L.logFromLogFloat zx2) + label edgeID _ = + [ (lab, prob1 edgeID labID) + | (labID, lab) <- lbIxs crf dag edgeID ] + prob1 = edgeProb1 dag alpha beta + alpha = forward crf dag + beta = backward crf dag + zx1 = zxAlpha dag alpha + zx2 = zxBeta dag beta + + +-- | 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 [(Lb, L.LogFloat)] +tagK k crf dag = fmap + ( take k + . reverse + . 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 Lb +tag crf = fmap (fst . head) . (tagK 1 crf) + + +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 + -> [(Md.FeatIx, L.LogFloat)] +expectedFeaturesOn crf dag alpha beta iEdgeID = + tFeats ++ oFeats + where + prob1 = edgeProb1 dag alpha beta iEdgeID + oFeats = [ (ix, prob1 k) + | ob <- C.unX (DAG.edgeLabel iEdgeID dag) + , (k, ix) <- I.intersect (Md.obIxs crf ob) (lbVec crf dag iEdgeID) ] + + -- TODO: Move `psi` to `expectedFeatureIn` + psi = computePsi' crf dag -- iEdgeID + prob2 = edgeProb2 crf dag alpha beta psi + tFeats + | DAG.isInitialEdge iEdgeID dag = catMaybes + [ (, prob1 k) <$> Md.featToIx crf (C.SFeature x) + | (k, x) <- lbIxs crf dag iEdgeID ] + | otherwise = + [ (ix, prob2 (iMinus1, l) (iEdgeID, k) ix) + | (k, x) <- lbIxs crf dag iEdgeID + , iMinus1 <- DAG.prevEdges iEdgeID dag + , (l, ix) <- I.intersect (Md.prevIxs crf x) (lbVec crf dag iMinus1) ] + + +-- | 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 + :: Md.Model + -> DAG a X + -> [(Md.FeatIx, L.LogFloat)] +expectedFeaturesIn crf dag = zxF `par` zxB `pseq` zxF `pseq` + -- concat [expectedOn k | k <- [0 .. V.length xs - 1] ] + concat [expectedOn edgeID | edgeID <- DAG.dagEdges dag] + where + expectedOn = expectedFeaturesOn crf dag alpha beta + alpha = forward crf dag + beta = backward crf dag + zxF = zxAlpha dag alpha + zxB = zxBeta dag beta + + +-- goodAndBad :: Md.Model -> DAG a X -> DAG b Y -> (Int, Int) +goodAndBad :: Md.Model -> DAG a (X, Y) -> (Int, Int) +goodAndBad crf dag = + F.foldl' gather (0, 0) $ DAG.zipE labels labels' + where + xs = fmap fst dag + ys = fmap snd dag + labels = fmap (best . C.unY) ys + best zs + | null zs = Nothing + | otherwise = Just . fst $ maximumBy (compare `on` snd) zs + labels' = fmap Just $ tag crf xs + gather (good, bad) (x, y) + | x == y = (good + 1, bad) + | otherwise = (good, bad + 1) + + +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 = parMap 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) + + +--------------------------------------------- +-- Probability and likelihood +--------------------------------------------- + + +-- -- | Log-likelihood of the given dataset. +-- likelihood :: Md.Model -> [DAG a (X, Y)] -> L.LogFloat +-- -- likelihood crf = L.product . map (probability crf) +-- -- likelihood crf = probability crf . head +-- likelihood crf = maximum . map (probability crf) +-- +-- +-- -- | The conditional probability of the dag in log-domain. +-- probability :: Md.Model -> DAG a (X, Y) -> L.LogFloat +-- probability crf dag = normFactor +-- -- | potential > normFactor = +-- -- error $ "[probability] potential greater than normFactor: " +-- -- ++ show (potential, normFactor) +-- -- | otherwise = potential / normFactor +-- where +-- potential = L.product +-- [ Md.valueL crf (Md.featToJustIx crf feat) +-- | (feat, _val) <- featuresIn dag ] +-- normFactor = zx crf (fmap fst dag) + + +-- -- | Features w.r.t. a given edge. +-- features +-- :: Md.Model +-- -> EdgeID -- ^ ID of an edge of the DAG +-- -> DAG a (X, Y) +-- -> [Md.FeatIx] +-- features crf edgeID dag = +-- where +-- oFeats = [ (ix, prob1 k) +-- | ob <- C.unX (DAG.edgeLabel iEdgeID dag) +-- , (k, ix) <- I.intersect (Md.obIxs crf ob) (lbVec crf dag iEdgeID) ] + + +--------------------------------------------- +-- Utils +--------------------------------------------- + + +almostEq :: L.LogFloat -> L.LogFloat -> Bool +almostEq x0 y0 + | isZero x && isZero y = True + | otherwise = 1.0 - eps < z && z < 1.0 + eps + where + x = L.logFromLogFloat x0 + y = L.logFromLogFloat y0 + z = x / y + + +isZero :: (Fractional t, Ord t) => t -> Bool +isZero x = abs x < eps + + +-- | A very small number. +eps :: Fractional t => t +eps = 0.000001 diff --git a/src/Data/CRF/Chain1/Constrained/DAG/Probs.hs b/src/Data/CRF/Chain1/Constrained/DAG/Probs.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Constrained/DAG/Probs.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} + + +-- | For probability-related computations. + + +module Data.CRF.Chain1.Constrained.DAG.Probs +( probability +, likelihood +, parLikelihood +) where + + +import Control.Applicative ((<$>)) +import Data.Maybe (catMaybes) +import Data.List (maximumBy, sort, sortBy) +import Data.Function (on) +import qualified Data.Set as S +import qualified Data.Array as A +-- import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import qualified Data.Foldable as F + +import Control.Parallel.Strategies (rseq, parMap) +import Control.Parallel (par, pseq) +import GHC.Conc (numCapabilities) +import qualified Data.Number.LogFloat as L + +-- import Data.CRF.Chain1.Constrained.DAG.Dataset.Internal (EdgeID, DAG) +-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG +import Data.DAG (EdgeID, DAG) +import qualified Data.DAG as DAG + +import qualified Data.CRF.Chain1.Constrained.DP as DP +import Data.CRF.Chain1.Constrained.Util (partition) +import qualified Data.CRF.Chain1.Constrained.Model as Md + +import Data.CRF.Chain1.Constrained.Core (X, Y, Lb, AVec) +import qualified Data.CRF.Chain1.Constrained.Core as C +import qualified Data.CRF.Chain1.Constrained.Intersect as I + +import Data.CRF.Chain1.Constrained.DAG.Feature (featuresIn) +import qualified Data.CRF.Chain1.Constrained.DAG.Inference as Inf + + +--------------------------------------------- +-- Util Types +--------------------------------------------- + + +-- | Label index. +type LbIx = Int + + +-- | The probability array assigns some probability to each label (represented +-- by its index) which can be assigned to a given edge (represented by its +-- `EdgeID`). +type ProbArray = EdgeID -> LbIx -> L.LogFloat + + +-------------------------------------------- +-- Basic stuff +--------------------------------------------- + + +-- | Vector of labels and the corresponding probabilities on the given edge of +-- the sentence. +lbVec :: Md.Model -> DAG a (X, Y) -> EdgeID -> AVec (Lb, Double) +lbVec crf 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 :: Md.Model -> DAG a (X, Y) -> EdgeID -> Int +lbNum crf dag = U.length . C.unAVec . lbVec crf dag +{-# INLINE lbNum #-} + + +-- | Label on the given edge and on the given position. +lbOn :: Md.Model -> DAG a (X, Y) -> EdgeID -> LbIx -> (Lb, Double) +lbOn crf dag = (U.!) . C.unAVec . lbVec crf dag +{-# INLINE lbOn #-} + + +-- | Labels on the given sentence edge (as in `lbVec`), accompanied with the +-- corresponding indexes. I.e., each label `Lb` (and its probability) is +-- accompanied with a number, from [0..], corresponding to its index in the +-- vector of labels obtained with `lbVec`. +lbIxs :: Md.Model -> DAG a (X, Y) -> EdgeID -> [(LbIx, (Lb, Double))] +lbIxs crf dag = zip [0..] . U.toList . C.unAVec . lbVec crf dag +{-# INLINE lbIxs #-} + + +--------------------------------------------- +-- A bit more complex stuff +--------------------------------------------- + + +-- | Compute the table of potential products associated with +-- * the observation features for the given sentence edge, +-- * the probabilities assigned to different labels. +computePsi :: Md.Model -> DAG a (X, Y) -> EdgeID -> LbIx -> L.LogFloat +computePsi crf dag edgeID + = (A.!) + . A.accumArray (*) 1 bounds + $ proTab ++ obsTab + where + bounds = (0, lbNum crf dag edgeID - 1) + obsTab = + [ (lbIx, Md.valueL crf featIx) + | ob <- (C.unX . fst) (DAG.edgeLabel edgeID dag) + , (lbIx, featIx) <- + I.intersect (Md.obIxs crf ob) (xify $ lbVec crf dag edgeID) ] + proTab = + [ (lbIx, L.logFloat prob) + | (lbIx, (_lb, prob)) <- lbIxs crf dag edgeID ] + + +-- | An alternative forward computation which takes the probabilities assigned +-- to different lables into account (at the level of the `psi` function). +forward :: Md.Model -> DAG a (X, Y) -> ProbArray +forward crf dag = alpha where + alpha = DP.flexible2 bounds boundsOn + (\t i -> withMem (computePsi crf dag i) t i) + bounds = (DAG.minEdge dag, DAG.maxEdge dag + 1) + boundsOn i + | i == snd bounds = (0, 0) + | otherwise = (0, lbNum crf dag i - 1) + -- set of initial edges + initialSet = S.fromList + [ i + | i <- DAG.dagEdges dag + , DAG.isInitialEdge i dag ] + withMem psi alpha i + | i == snd bounds = const u' -- <= TO CHECK + | i `S.member` initialSet = \j -> + let (x, _) = lbOn crf dag i j + in psi j * Md.sgValue crf x + | otherwise = \j -> + let (x, _) = lbOn crf dag i j + in psi j * ((u - v x) + w x) + where + u = safeSum + [ alpha iMinus1 k + | iMinus1 <- DAG.prevEdges i dag + , (k, _) <- lbIxs crf dag iMinus1 ] + v x = safeSum + [ alpha iMinus1 k + | iMinus1 <- DAG.prevEdges i dag + , (k, _) <- + I.intersect (Md.prevIxs crf x) (xify $ lbVec crf dag iMinus1) ] + w x = safeSum + [ alpha iMinus1 k * Md.valueL crf ix + | iMinus1 <- DAG.prevEdges i dag + , (k, ix) <- I.intersect (Md.prevIxs crf x) (xify $ lbVec crf dag iMinus1) ] + -- Note that if `i == snd bounds` then `i` does not refer to any existing + -- edge, hence the need to introduce `u'` which does almost the same thing + -- as `u`. + u' = safeSum + [ alpha iMinus1 k + | iMinus1 <- DAG.dagEdges dag + , DAG.isFinalEdge iMinus1 dag + , (k, _) <- lbIxs crf dag iMinus1 ] + + +-- | Probability of the given DAG in the given model. +probability :: Md.Model -> DAG a (X, Y) -> L.LogFloat +probability crf dag = + zxAlpha (forward crf dag) / normFactor + where + zxAlpha alpha = alpha (DAG.maxEdge dag + 1) 0 + normFactor = Inf.zx crf (fmap fst dag) + + +-- | 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 = parMap rseq (likelihood crf) parts + in L.product probs + + +-- | Log-likelihood of the given dataset (no parallelization). +likelihood :: Md.Model -> [DAG a (X, Y)] -> L.LogFloat +likelihood crf = L.product . map (probability crf) + + +--------------------------------------------- +-- Utils +--------------------------------------------- + + +-- | X-ify the given ascending vector. +xify :: (U.Unbox x, U.Unbox y) => C.AVec (x, y) -> C.AVec x +xify = C.AVec . U.map fst . C.unAVec +{-# INLINE xify #-} + + +-- | Numerically safer summing. +safeSum :: [L.LogFloat] -> L.LogFloat +safeSum [] = 0 +safeSum xs = L.sum xs +{-#INLINE safeSum #-} diff --git a/src/Data/CRF/Chain1/Constrained/DAG/Train.hs b/src/Data/CRF/Chain1/Constrained/DAG/Train.hs new file mode 100644 --- /dev/null +++ b/src/Data/CRF/Chain1/Constrained/DAG/Train.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} + + +-- | Provisional training module which works on sequential external data +-- but transforms it to DAG internal data form. + + +module Data.CRF.Chain1.Constrained.DAG.Train +( +-- * Model + CRF (..) + +-- * Training +, train + +-- * R0 construction +, oovChosen +, anyChosen +, anyInterps + +-- * Utils +, dagProb +) where + + +import Control.Applicative ((<$>), (<*>)) +import qualified Control.Arrow as Arr +import Control.Monad (when) +import System.IO (hSetBuffering, stdout, BufferMode (..)) +import Data.Binary (Binary, put, get) +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import qualified Data.Foldable as F +import qualified Numeric.SGD.Momentum as SGD +import qualified Data.Number.LogFloat as LogFloat +import qualified Numeric.SGD.LogSigned as L +import qualified Data.MemoCombinators as Memo + +-- import Data.CRF.Chain1.Constrained.DAG.Dataset.Internal (DAG) +-- import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Internal as DAG +import Data.DAG (DAG) +import qualified Data.DAG as DAG + +import Data.CRF.Chain1.Constrained.Core (X, Y, Lb, AVec, Feature) +import qualified Data.CRF.Chain1.Constrained.Core as C +import qualified Data.CRF.Chain1.Constrained.Model as Md +import qualified Data.CRF.Chain1.Constrained.Dataset.Internal as Int + +import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.Codec as Cd +import qualified Data.CRF.Chain1.Constrained.DAG.Dataset.External as E + +-- import Data.CRF.Chain1.Constrained.Model +-- (Model (..), mkModel, FeatIx (..), featToJustInt) +-- import Data.CRF.Chain1.Constrained.Dataset.External +-- (SentL, WordL (..), lbs, unknown, unProb) + +import Data.CRF.Chain1.Constrained.DAG.Feature (featuresIn) +import qualified Data.CRF.Chain1.Constrained.DAG.Inference as I -- (accuracy, expectedFeaturesIn) +import qualified Data.CRF.Chain1.Constrained.DAG.Probs as P -- (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 :: Cd.Codec a b, + -- | The actual model, which is a map from 'Feature's to potentials. + model :: Md.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.Constrained.Feature.Present" and +-- "Data.CRF.Chain1.Constrained.Feature.Hidden" +-- modules for this purpose. +-- +-- You also have to supply R0 construction method (e.g. `oovChosen`) +-- which determines the contents of the default set of labels. +train + :: (Ord a, Ord b) + => SGD.SgdArgs -- ^ Args for SGD + -> Bool -- ^ Store dataset on a disk + -> ([E.SentL a b] -> S.Set b) -- ^ R0 construction + -> (AVec Lb -> [DAG () (X, Y)] -> [Feature]) -- ^ Feature selection + -> IO [E.SentL a b] -- ^ Training data 'IO' action + -> IO [E.SentL a b] -- ^ Evaluation data + -> IO (CRF a b) -- ^ Resulting model +train sgdArgs onDisk mkR0 featSel trainIO evalIO = do + hSetBuffering stdout NoBuffering + + -- Create codec and encode the training dataset + codec <- Cd.mkCodec <$> trainIO + trainData_ <- Cd.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 + + -- Encode the evaluation dataset + evalData_ <- Cd.encodeDataL codec <$> evalIO + SGD.withData onDisk evalData_ $ \evalData -> do + + -- A default set of labels + r0 <- Cd.encodeLabels codec . S.toList . mkR0 <$> trainIO + + -- A set of features + feats <- featSel r0 <$> SGD.loadData trainData + + -- Train the model + let model = (Md.mkModel (Cd.obMax codec) (Cd.lbMax codec) feats) { Md.r0 = r0 } + para <- SGD.sgd sgdArgs + (notify sgdArgs model trainData evalData) + (gradOn model) trainData (Md.values model) + return $ CRF codec (model { Md.values = para }) + + +gradOn :: Md.Model -> SGD.Para -> DAG a (X, Y) -> SGD.Grad +gradOn model para dag = SGD.fromLogList $ + [ (Md.featToJustInt curr feat, L.fromPos val) + | (feat, val) <- featuresIn dag ] ++ + [ (ix, L.fromNeg val) + | (Md.FeatIx ix, val) <- I.expectedFeaturesIn curr (fmap fst dag) ] + where + curr = model { Md.values = para } + + +notify + :: SGD.SgdArgs -> Md.Model + -> SGD.Dataset (DAG a (X, Y)) -- ^ Training dataset + -> SGD.Dataset (DAG a (X, Y)) -- ^ Evaluation 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 {Md.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 + 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 snd $ C.unY y + fromNode nodeID = + case DAG.outgoingEdges nodeID dag of + [] -> 1 + xs -> sum (map fromEdge xs) + + +-- | Filter out the sentences with `dagProb` < 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 + + +------------------------------------------------------ +-- Expectation maximization +------------------------------------------------------ + + +-- TODO: + + +-- ------------------------------------------------------ +-- -- Dataset conversion (provisional?) +-- ------------------------------------------------------ +-- +-- +-- -- | Convert the sequential representation to DAG-based one. +-- dagSent :: (Int.Xs, Int.Ys) -> DAG () (X, Y) +-- dagSent (xs, ys) = DAG.fromList (zip (V.toList xs) (V.toList ys)) +-- +-- +-- -- | Convert the sequential representation to DAG-based one. +-- dagData :: [(Int.Xs, Int.Ys)] -> [DAG () (X, Y)] +-- dagData = map dagSent + + +------------------------------------------------------ +-- R0 construction +------------------------------------------------------ + + +-- | Collect labels assigned to OOV words. +oovChosen :: Ord b => [E.SentL a b] -> S.Set b +oovChosen = + collect onWord + where + onWord x + | E.unknown (E.word x) = M.keys . E.unProb . E.choice $ x + | otherwise = [] + + +-- | Collect labels assigned to words in a dataset. +anyChosen :: Ord b => [E.SentL a b] -> S.Set b +anyChosen = collect $ M.keys . E.unProb . E.choice + + +-- | Collect interpretations (also labels assigned) of words in a dataset. +anyInterps :: Ord b => [E.SentL a b] -> S.Set b +anyInterps = S.union + <$> collect (S.toList . E.lbs . E.word) + <*> anyChosen + + +-- | Collect labels given function which selects labels from a word. +collect :: Ord b => (E.WordL a b -> [b]) -> [E.SentL a b] -> S.Set b +collect onWord = S.fromList . concatMap (F.concatMap onWord) diff --git a/src/Data/CRF/Chain1/Constrained/DP.hs b/src/Data/CRF/Chain1/Constrained/DP.hs --- a/src/Data/CRF/Chain1/Constrained/DP.hs +++ b/src/Data/CRF/Chain1/Constrained/DP.hs @@ -1,7 +1,7 @@ module Data.CRF.Chain1.Constrained.DP ( table , flexible2 -, flexible3 +-- , flexible3 ) where import qualified Data.Array as A @@ -11,7 +11,7 @@ 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' !)) + $ map (f (table' !)) $ range bounds down1 :: A.Ix i => (i, i) -> (i -> e) -> i -> e @@ -27,17 +27,28 @@ [ 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 +-- | 2-dimensional computation using dynamic programming. +flexible2 + :: (A.Ix i, A.Ix j) + => (j, j) + -- ^ Bounds of the 1st dimension + -> (j -> (i, i)) + -- ^ Bounds of the 2st dimension, depending on the position + -- in the 1st dimension + -> ((j -> i -> e) -> j -> i -> e) + -- ^ How to compute the value of the table on (j, i) already having the + -- table partially constructed for lower (j', i') indices. + -> (j -> i -> e) + -- ^ The resulting memoized, 2-dimensional table 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 ] +-- 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/Constrained/Dataset/Codec.hs b/src/Data/CRF/Chain1/Constrained/Dataset/Codec.hs --- a/src/Data/CRF/Chain1/Constrained/Dataset/Codec.hs +++ b/src/Data/CRF/Chain1/Constrained/Dataset/Codec.hs @@ -3,6 +3,7 @@ module Data.CRF.Chain1.Constrained.Dataset.Codec ( Codec +, empty , CodecM , obMax , lbMax @@ -30,6 +31,7 @@ , unJusts ) where +import Prelude hiding (Word) import Control.Applicative ((<$>), (<*>), pure) import Data.Maybe (catMaybes, fromJust) import Data.Lens.Common (fstLens, sndLens) diff --git a/src/Data/CRF/Chain1/Constrained/Dataset/External.hs b/src/Data/CRF/Chain1/Constrained/Dataset/External.hs --- a/src/Data/CRF/Chain1/Constrained/Dataset/External.hs +++ b/src/Data/CRF/Chain1/Constrained/Dataset/External.hs @@ -9,6 +9,7 @@ , SentL ) where +import Prelude hiding (Word) import qualified Data.Set as S import qualified Data.Map as M @@ -37,17 +38,31 @@ 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 @@ -59,10 +74,19 @@ , choice :: Prob b } --- | Ensure, that every label from the distribution domain is a member --- of the set of potential labels corresponding to the word. -mkWordL :: Word a b -> Prob b -> WordL a b -mkWordL = WordL +-- | Ensure, that every label from the distribution domain is a member of the +-- set of potential labels corresponding to the word. +mkWordL :: (Ord b) => Word a b -> Prob b -> WordL a b +mkWordL wd cs +-- | S.null chosen && S.null (lbs wd) = +-- error "mkWordL: no labels assigned to the word" +-- <- the above condition can actualy happen it the model does not +-- find any probable label for a given word. + | S.null (lbs wd) = WordL wd cs + | chosen `S.isSubsetOf` lbs wd = WordL wd cs + | otherwise = error "mkWordL: chosen labels outside of `lbs`" + where + chosen = M.keysSet (unProb cs) -- | A sentence of labeled words. diff --git a/src/Data/CRF/Chain1/Constrained/Dataset/Internal.hs b/src/Data/CRF/Chain1/Constrained/Dataset/Internal.hs --- a/src/Data/CRF/Chain1/Constrained/Dataset/Internal.hs +++ b/src/Data/CRF/Chain1/Constrained/Dataset/Internal.hs @@ -1,124 +1,88 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} +-- {-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- {-# LANGUAGE RecordWildCards #-} +-- {-# LANGUAGE TemplateHaskell #-} +-- {-# LANGUAGE MultiParamTypeClasses #-} +-- {-# LANGUAGE TypeFamilies #-} module Data.CRF.Chain1.Constrained.Dataset.Internal -( Ob (..) -, Lb (..) - -, X (..) -, mkX -, unX -, unR -, Xs - -, Y (..) -, mkY -, unY +( Xs , Ys - -, AVec (unAVec) -, fromList -, fromSet +, module Data.CRF.Chain1.Constrained.Core ) where -import Control.Applicative ((<$>), (<*>)) -import Data.Vector.Generic.Base -import Data.Vector.Generic.Mutable -import Data.Binary (Binary, get, put, putWord8, getWord8) -import Data.Vector.Binary () -import Data.Ix (Ix) -import qualified Data.Set as S +-- import Control.Applicative ((<$>), (<*>)) +-- import Data.Vector.Generic.Base +-- import Data.Vector.Generic.Mutable +-- import Data.Binary (Binary, get, put, putWord8, getWord8) +-- import Data.Vector.Binary () +-- import Data.Ix (Ix) +-- import qualified Data.Set as S import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as U -import Data.Vector.Unboxed.Deriving +-- 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 |] +import Data.CRF.Chain1.Constrained.Core --- | A label. -newtype Lb = Lb { unLb :: Int } - deriving ( Show, Read, Eq, Ord, Binary, Num, Ix ) -derivingUnbox "Lb" [t| Lb -> Int |] [| unLb |] [| Lb |] --- | Ascending vector of unique interger elements. -newtype AVec a = AVec { unAVec :: U.Vector a } - deriving (Show, Read, Eq, Ord, Binary) - --- | Smart AVec constructor which ensures that the --- underlying vector satisfies the AVec properties. -fromList :: (Ord a, U.Unbox a) => [a] -> AVec a -fromList = fromSet . S.fromList -{-# INLINE fromList #-} - --- | Smart AVec constructor which ensures that the --- underlying vector satisfies the AVec properties. -fromSet :: (Ord a, U.Unbox a) => S.Set a -> AVec a -fromSet = AVec . U.fromList . S.toList -{-# INLINE fromSet #-} - --- | A word represented by a list of its observations --- and a list of its potential label interpretations. -data X - -- | The word with default set of potential interpretations. - = X { _unX :: AVec Ob } - -- | The word with custom set of potential labels. - | R { _unX :: AVec Ob - , _unR :: AVec Lb } - deriving (Show, Read, Eq, Ord) - -instance Binary X where - put X{..} = putWord8 0 >> put _unX - put R{..} = putWord8 1 >> put _unX >> put _unR - get = getWord8 >>= \i -> case i of - 0 -> X <$> get - _ -> R <$> get <*> get - --- | X constructor. -mkX :: [Ob] -> [Lb] -> X -mkX x [] = X (fromList x) -mkX x r = R (fromList x) (fromList r) -{-# INLINE mkX #-} - --- | List of observations. -unX :: X -> [Ob] -unX = U.toList . unAVec . _unX -{-# INLINE unX #-} - --- | List of potential labels. -unR :: AVec Lb -> X -> [Lb] -unR r0 X{..} = U.toList . unAVec $ r0 -unR _ R{..} = U.toList . unAVec $ _unR -{-# INLINE unR #-} - -- | Sentence of words. type Xs = V.Vector X --- | Probability distribution over labels. We assume, that when y is --- a member of chosen labels list it is also a member of the list --- potential labels for corresponding 'X' word. --- TODO: Perhaps we should substitute 'Lb's with label indices --- corresponding to labels from the vector of potential labels? --- FIXME: The type definition is incorrect (see 'fromList' definition), --- it should be something like AVec2. -newtype Y = Y { _unY :: AVec (Lb, Double) } - deriving (Show, Read, Eq, Ord, Binary) - --- | Y constructor. -mkY :: [(Lb, Double)] -> Y -mkY = Y . fromList -{-# INLINE mkY #-} - --- | Y deconstructor symetric to mkY. -unY :: Y -> [(Lb, Double)] -unY = U.toList . unAVec . _unY -{-# INLINE unY #-} - -- | Sentence of Y (label choices). type Ys = V.Vector Y + + +------------------------------------------------------------------ +-- DAG representation +------------------------------------------------------------------ +-- +-- Naming proposals: +-- * lattice +-- * word-lattice <- może za bardzo kojarzy się z czymś innym? +-- ale z drugiej strony, chyba kojarz się +-- właśnie z tym co trzeba, ew. sugeruje trochę +-- inną funkcjonalność (jaką?) niż ja zamierzam +-- udostępnić. +-- * word-dag +-- * edge-dag +-- +-- First of all, nodes represent division places of the input text +-- (i.e., they point to places *between* two adjacent characters). +-- +-- Therefore, segments (or tokens) are represented by graph edges. +-- An edge consists of: +-- * An analysis of the corresponding segment, +-- * Nodes (or their identifiers) between which the edge spans. +-- +-- Query operations available on DAGs: +-- * Return nodes with respect to the topological order (in both +-- directions?) +-- * List all edges (in/out)going from the particular node. +-- +-- It should be possible to make something like a context-sensitive +-- fmap, which will make it possible to: +-- * Translate individual edge values to feature vectors, +-- WARNING: there are several strategies of how observations for the, +-- previous edge (for example) are determined, since there may be +-- several candidates for a previous edge! +-- * Translate edge values to forward/backward probabilities. +-- +-- Misc operations: +-- * Join DAG with a particular path of words (morphological analysis +-- will result with a DAG, while disambiguated sentence is just +-- a sequence of morphosyntactic tags refering to a particular path +-- in the DAG), or more general: +-- * Join DAG with a DAG. +-- +-- Other considerations: +-- * Do we want to represent spaces on the level of word lattices? +-- Not necessarily. On the other hand, it should be possible +-- to store a word-with-spaces in an edge -- why not? -- and +-- restore the original sentence from the lattice. Wouldn't +-- that be nice? +-- Since node represents a position between two segments, it can +-- be also explicitly stated if there is a space between these two +-- segments, and what kind of space is that. Yep, it makes sense! +-- * Potential morphosyntactic analyses of a sentence can be represented +-- as a DAG. The same goes for chosen interpretations -- they can also +-- be represented as a DAG with potentials (probabilities?) assigned +-- to each label on every edge. diff --git a/src/Data/CRF/Chain1/Constrained/Feature.hs b/src/Data/CRF/Chain1/Constrained/Feature.hs --- a/src/Data/CRF/Chain1/Constrained/Feature.hs +++ b/src/Data/CRF/Chain1/Constrained/Feature.hs @@ -6,59 +6,14 @@ , featuresIn ) where -import Data.Binary (Binary, Get, put, get) -import Control.Applicative ((<*>), (<$>)) + +-- import Data.Binary (Binary, Get, put, get) +-- import Control.Applicative ((<*>), (<$>)) import qualified Data.Vector as V import qualified Data.Number.LogFloat as L import Data.CRF.Chain1.Constrained.Dataset.Internal --- | A Feature is either an observation feature OFeature o x, which --- models relation between observation o and label x assigned to --- the same word, or a transition feature TFeature x y (SFeature x --- for the first position in the sentence), which models relation --- between two subsequent labels, x (on i-th position) and y --- (on (i-1)-th positoin). -data Feature - = SFeature - {-# UNPACK #-} !Lb - | TFeature - {-# UNPACK #-} !Lb - {-# UNPACK #-} !Lb - | OFeature - {-# UNPACK #-} !Ob - {-# UNPACK #-} !Lb - deriving (Show, Eq, Ord) - -instance Binary Feature where - put (SFeature x) = put (0 :: Int) >> put x - put (TFeature x y) = put (1 :: Int) >> put (x, y) - put (OFeature o x) = put (2 :: Int) >> put (o, x) - get = do - k <- get :: Get Int - case k of - 0 -> SFeature <$> get - 1 -> TFeature <$> get <*> get - 2 -> OFeature <$> get <*> get - _ -> error "Binary Feature: unknown identifier" - --- | Is it a 'SFeature'? -isSFeat :: Feature -> Bool -isSFeat (SFeature _) = True -isSFeat _ = False -{-# INLINE isSFeat #-} - --- | Is it an 'OFeature'? -isOFeat :: Feature -> Bool -isOFeat (OFeature _ _) = True -isOFeat _ = False -{-# INLINE isOFeat #-} - --- | Is it a 'TFeature'? -isTFeat :: Feature -> Bool -isTFeat (TFeature _ _) = True -isTFeat _ = False -{-# INLINE isTFeat #-} -- | Transition features with assigned probabilities for given position. trFeats :: Ys -> Int -> [(Feature, L.LogFloat)] diff --git a/src/Data/CRF/Chain1/Constrained/Inference.hs b/src/Data/CRF/Chain1/Constrained/Inference.hs --- a/src/Data/CRF/Chain1/Constrained/Inference.hs +++ b/src/Data/CRF/Chain1/Constrained/Inference.hs @@ -60,7 +60,7 @@ lbIxs crf xs = zip [0..] . U.toList . unAVec . lbVec crf xs {-# INLINE lbIxs #-} --- | Compute the table of potential products associated with +-- | Compute the table of potential products associated with -- observation features for the given sentence position. computePsi :: Model -> Xs -> Int -> LbIx -> L.LogFloat computePsi crf xs i = (A.!) $ A.accumArray (*) 1 bounds @@ -202,7 +202,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') @@ -218,7 +218,7 @@ pr1 = prob1 alpha beta i pr2 = prob2 crf alpha beta i psi - oFeats = [ (ix, pr1 k) + oFeats = [ (ix, pr1 k) | o <- unX (xs V.! i) , (k, ix) <- intersect (obIxs crf o) (lbVec crf xs i) ] @@ -233,7 +233,7 @@ -- | 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. +-- determined on the basis of the model. -- -- One feature can occur multiple times in the output list. expectedFeaturesIn :: Model -> Xs -> [(FeatIx, L.LogFloat)] diff --git a/src/Data/CRF/Chain1/Constrained/Intersect.hs b/src/Data/CRF/Chain1/Constrained/Intersect.hs --- a/src/Data/CRF/Chain1/Constrained/Intersect.hs +++ b/src/Data/CRF/Chain1/Constrained/Intersect.hs @@ -1,15 +1,18 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} + module Data.CRF.Chain1.Constrained.Intersect ( intersect ) where + import qualified Data.Vector.Unboxed as U import Data.CRF.Chain1.Constrained.Dataset.Internal (Lb, AVec, unAVec) import Data.CRF.Chain1.Constrained.Model (FeatIx) + -- | Assumption: both input list are given in an ascending order. intersect :: AVec (Lb, FeatIx) -- ^ Vector of (label, features index) pairs @@ -26,6 +29,7 @@ n = U.length ys m = U.length xs + merge :: U.Vector (Lb, FeatIx) -> U.Vector Lb -> [(Int, FeatIx)] merge xs ys = doIt 0 0 where @@ -40,3 +44,41 @@ where (x, ix) = xs `U.unsafeIndex` i y = ys `U.unsafeIndex` j + + +--------------------------------------------- +-- Alternative version +--------------------------------------------- + + +-- -- | Assumption: both input list are given in an ascending order. +-- intersect' +-- :: AVec (Lb, FeatIx) -- ^ Vector of (label, features index) pairs +-- -> AVec (Lb, Prob) -- ^ Vector of labels +-- -- | Intersection of arguments: vector indices from the second list +-- -- and feature indices from the first list. +-- -> [(Int, FeatIx)] +-- intersect' xs' ys' +-- | n == 0 || m == 0 = [] +-- | otherwise = merge xs ys +-- where +-- xs = unAVec xs' +-- ys = unAVec ys' +-- n = U.length ys +-- m = U.length xs +-- +-- +-- merge :: U.Vector (Lb, FeatIx) -> U.Vector Lb -> [(Int, FeatIx)] +-- merge xs ys = doIt 0 0 +-- where +-- m = U.length xs +-- n = U.length ys +-- doIt i j +-- | i >= m || j >= n = [] +-- | otherwise = case compare x y of +-- EQ -> (j, ix) : doIt (i+1) (j+1) +-- LT -> doIt (i+1) j +-- GT -> doIt i (j+1) +-- where +-- (x, ix) = xs `U.unsafeIndex` i +-- y = ys `U.unsafeIndex` j diff --git a/src/Data/CRF/Chain1/Constrained/Model.hs b/src/Data/CRF/Chain1/Constrained/Model.hs --- a/src/Data/CRF/Chain1/Constrained/Model.hs +++ b/src/Data/CRF/Chain1/Constrained/Model.hs @@ -73,7 +73,7 @@ -- 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. + -- observation, constitute an observation feature of the model. , obIxsV :: V.Vector (AVec LbIx) -- | Set of ,,previous'' labels for the value of the ,,current'' label. -- Both labels constitute a transition feature present in the the model.