{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Data.CRF.Chain1.Constrained.Model
( FeatIx (..)
, Model (..)
, mkModel
, valueL
, featToIx
, featToJustIx
, featToJustInt
, sgValue
, sgIxs
, obIxs
, nextIxs
, prevIxs
) where
import Control.Applicative ((<$>), (<*>))
import Data.Maybe (fromJust)
import Data.List (groupBy, sort)
import Data.Function (on)
import Data.Binary
import qualified Data.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.Constrained.Feature
import Data.CRF.Chain1.Constrained.Dataset.Internal hiding (fromList)
import qualified Data.CRF.Chain1.Constrained.Dataset.Internal as A
newtype FeatIx = FeatIx { unFeatIx :: Int }
deriving ( Show, Eq, Ord, Binary )
derivingUnbox "FeatIx" [t| FeatIx -> Int |] [| unFeatIx |] [| FeatIx |]
type LbIx = (Lb, FeatIx)
dummyFeatIx :: FeatIx
dummyFeatIx = FeatIx (-1)
{-# INLINE dummyFeatIx #-}
isDummy :: FeatIx -> Bool
isDummy (FeatIx ix) = ix < 0
{-# INLINE isDummy #-}
notDummy :: FeatIx -> Bool
notDummy = not . isDummy
{-# INLINE notDummy #-}
data Model = Model {
values :: U.Vector Double
, ixMap :: M.Map Feature FeatIx
, r0 :: AVec Lb
, sgIxsV :: U.Vector FeatIx
, obIxsV :: V.Vector (AVec LbIx)
, prevIxsV :: V.Vector (AVec LbIx)
, nextIxsV :: V.Vector (AVec LbIx) }
instance Binary Model where
put crf = do
put $ values crf
put $ ixMap crf
put $ r0 crf
put $ sgIxsV crf
put $ obIxsV crf
put $ prevIxsV crf
put $ nextIxsV crf
get = Model <$> get <*> get <*> get <*> get <*> get <*> get <*> get
fromList :: Ob -> Lb -> [(Feature, Double)] -> Model
fromList obMax' lbMax' fs =
let _ixMap = M.fromList $ zip
(map fst fs)
(map FeatIx [0..])
sFeats = [feat | (feat, _val) <- fs, isSFeat feat]
tFeats = [feat | (feat, _val) <- fs, isTFeat feat]
oFeats = [feat | (feat, _val) <- fs, isOFeat feat]
obMax = unOb obMax'
lbMax = unLb lbMax'
_r0 = A.fromList (map Lb [0 .. lbMax])
_sgIxsV = sgVects lbMax
[ (unLb x, featToJustIx crf feat)
| feat@(SFeature x) <- sFeats ]
_prevIxsV = adjVects lbMax
[ (unLb x, (y, featToJustIx crf feat))
| feat@(TFeature x y) <- tFeats ]
_nextIxsV = adjVects lbMax
[ (unLb y, (x, featToJustIx crf feat))
| feat@(TFeature x y) <- tFeats ]
_obIxsV = adjVects obMax
[ (unOb o, (x, featToJustIx crf feat))
| feat@(OFeature o x) <- oFeats ]
adjVects n xs =
V.replicate (n + 1) (A.fromList []) V.// update
where
update = map mkVect $ groupBy ((==) `on` fst) $ sort xs
mkVect (y:ys) = (fst y, A.fromList $ map snd (y:ys))
mkVect [] = error "mkVect: null list"
sgVects n xs = U.replicate (n + 1) dummyFeatIx U.// xs
_values = U.replicate (length fs) 0.0
U.// [ (featToJustInt crf feat, val)
| (feat, val) <- fs ]
crf = Model _values _ixMap _r0 _sgIxsV _obIxsV _prevIxsV _nextIxsV
in crf
mkModel :: Ob -> Lb -> [Feature] -> Model
mkModel obMax lbMax fs =
let fSet = Set.fromList fs
fs' = Set.toList fSet
vs = replicate (Set.size fSet) 0.0
in fromList obMax lbMax (zip fs' vs)
valueL :: Model -> FeatIx -> L.LogFloat
valueL crf (FeatIx i) = L.logToLogFloat (values crf U.! i)
{-# INLINE valueL #-}
featToIx :: Model -> Feature -> Maybe FeatIx
featToIx crf feat = M.lookup feat (ixMap crf)
{-# INLINE featToIx #-}
featToJustIx :: Model -> Feature -> FeatIx
featToJustIx _crf = fromJust . featToIx _crf
{-# INLINE featToJustIx #-}
featToJustInt :: Model -> Feature -> Int
featToJustInt _crf = unFeatIx . featToJustIx _crf
{-# INLINE featToJustInt #-}
sgValue :: Model -> Lb -> L.LogFloat
sgValue crf (Lb x) =
case unFeatIx (sgIxsV crf U.! x) of
-1 -> L.logToLogFloat (0 :: Double)
ix -> L.logToLogFloat (values crf U.! ix)
sgIxs :: Model -> [LbIx]
sgIxs crf
= filter (notDummy . snd)
. zip (map Lb [0..])
. U.toList $ sgIxsV crf
{-# INLINE sgIxs #-}
obIxs :: Model -> Ob -> AVec LbIx
obIxs crf x = obIxsV crf V.! unOb x
{-# INLINE obIxs #-}
nextIxs :: Model -> Lb -> AVec LbIx
nextIxs crf x = nextIxsV crf V.! unLb x
{-# INLINE nextIxs #-}
prevIxs :: Model -> Lb -> AVec LbIx
prevIxs crf x = prevIxsV crf V.! unLb x
{-# INLINE prevIxs #-}