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
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)
isDummy :: FeatIx -> Bool
isDummy (FeatIx ix) = ix < 0
notDummy :: FeatIx -> Bool
notDummy = not . isDummy
data Model = Model {
values :: U.Vector Double
, ixMap :: M.Map Feature FeatIx
, lbNum :: Int
, sgIxsV :: U.Vector FeatIx
, obIxsV :: V.Vector (U.Vector LbIx)
, prevIxsV :: V.Vector (U.Vector LbIx)
, 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
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 ]
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
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)
lbSet :: Model -> [Lb]
lbSet crf = map Lb [0 .. lbNum crf 1]
valueL :: Model -> FeatIx -> L.LogFloat
valueL crf (FeatIx i) = L.logToLogFloat (values crf U.! i)
featToIx :: Model -> Feature -> FeatIx
featToIx crf feat = ixMap crf M.! feat
featToInt :: Model -> Feature -> Int
featToInt crf = unFeatIx . featToIx crf
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)
sgIxs :: Model -> [LbIx]
sgIxs crf
= filter (notDummy . snd)
. zip (map Lb [0..])
. U.toList $ sgIxsV crf
obIxs :: Model -> Ob -> [LbIx]
obIxs crf x = U.toList (obIxsV crf V.! unOb x)
nextIxs :: Model -> Lb -> [LbIx]
nextIxs crf x = U.toList (nextIxsV crf V.! unLb x)
prevIxs :: Model -> Lb -> [LbIx]
prevIxs crf x = U.toList (prevIxsV crf V.! unLb x)
nub :: Ord a => [a] -> [a]
nub = Set.toList . Set.fromList