module Data.CRF.Chain2.Tiers.Model
(
Model (..)
, mkModel
, fromSet
, fromMap
, toMap
, phi
, index
, onWord
, onTransition
) where
import Control.Applicative ((<$>), (<*>))
import Control.Monad (guard)
import Data.Binary (Binary, get, put)
import Data.Int (Int32)
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 Data.Vector.Binary ()
import qualified Data.Number.LogFloat as L
import Data.CRF.Chain2.Tiers.Dataset.Internal
import Data.CRF.Chain2.Tiers.Feature
import qualified Data.CRF.Chain2.Tiers.Array as A
dummy :: FeatIx
dummy = FeatIx (1)
type T1Map = A.Array Lb FeatIx
type T2Map = A.Array (Lb, Lb) FeatIx
type T3Map = A.Array (Lb, Lb, Lb) FeatIx
mkT3Map :: [(Feat, FeatIx)] -> T3Map
mkT3Map xs =
let ys = [((x, y, z), ix) | (TFeat3 x y z _, ix) <- xs]
in A.mkArray dummy ys
mkT2Map :: [(Feat, FeatIx)] -> T2Map
mkT2Map xs =
let ys = [((x, y), ix) | (TFeat2 x y _, ix) <- xs]
in A.mkArray dummy ys
mkT1Map :: [(Feat, FeatIx)] -> T1Map
mkT1Map xs =
let ys = [(x, ix) | (TFeat1 x _, ix) <- xs]
in A.mkArray dummy ys
unT3Map :: Int -> T3Map -> [(Feat, FeatIx)]
unT3Map k t3 =
[ (TFeat3 x y z k, ix)
| ((x, y, z), ix) <- A.unArray t3
, ix /= dummy ]
unT2Map :: Int -> T2Map -> [(Feat, FeatIx)]
unT2Map k t2 =
[ (TFeat2 x y k, ix)
| ((x, y), ix) <- A.unArray t2
, ix /= dummy ]
unT1Map :: Int -> T1Map -> [(Feat, FeatIx)]
unT1Map k t1 =
[ (TFeat1 x k, ix)
| (x, ix) <- A.unArray t1
, ix /= dummy ]
data OMap = OMap {
oBeg :: U.Vector Int32
, oLb :: U.Vector Lb
, oIx :: U.Vector FeatIx }
instance Binary OMap where
put OMap{..} = put oBeg >> put oLb >> put oIx
get = OMap <$> get <*> get <*> get
mkOMap :: [(Feat, FeatIx)] -> OMap
mkOMap xs = OMap
{ oBeg = U.fromList $ scanl (+) 0
[ fromIntegral (M.size lbMap)
| ob <- map mkOb [0 .. maxOb]
, let lbMap = maybe M.empty id $ M.lookup ob ftMap ]
, oLb = U.fromList . concat $
[ M.keys lbMap
| lbMap <- M.elems ftMap ]
, oIx = U.fromList . concat $
[ M.elems lbMap
| lbMap <- M.elems ftMap ] }
where
ftMap = fmap M.fromList $ M.fromListWith (++)
[ (ob, [(x, ix)])
| (OFeat ob x _, ix) <- xs ]
maxOb = unOb . fst $ M.findMax ftMap
unOMap :: Int -> OMap -> [(Feat, FeatIx)]
unOMap k OMap{..} =
[ (OFeat o x k, i)
| (o, (p, q)) <- zip
(map mkOb [0..])
(pairs . map fromIntegral $ U.toList oBeg)
, (x, i) <- zip
(U.toList $ U.slice p (q p) oLb)
(U.toList $ U.slice p (q p) oIx) ]
where
pairs xs = zip xs (tail xs)
data LayerMap = LayerMap
{ t1Map :: !T1Map
, t2Map :: !T2Map
, t3Map :: !T3Map
, obMap :: !OMap }
instance Binary LayerMap where
put LayerMap{..} = put t1Map >> put t2Map >> put t3Map >> put obMap
get = LayerMap <$> get <*> get <*> get <*> get
unLayerMap :: Int -> LayerMap -> [(Feat, FeatIx)]
unLayerMap k LayerMap{..} = concat
[ unT1Map k t1Map
, unT2Map k t2Map
, unT3Map k t3Map
, unOMap k obMap ]
type FeatMap = V.Vector LayerMap
featIndex :: Feat -> FeatMap -> Maybe FeatIx
featIndex (TFeat3 x y z k) v = do
m <- t3Map <$> (v V.!? k)
ix <- m A.!? (x, y, z)
guard (ix /= dummy)
return ix
featIndex (TFeat2 x y k) v = do
m <- t2Map <$> (v V.!? k)
ix <- m A.!? (x, y)
guard (ix /= dummy)
return ix
featIndex (TFeat1 x k) v = do
m <- t1Map <$> (v V.!? k)
ix <- m A.!? x
guard (ix /= dummy)
return ix
featIndex (OFeat ob x k) v = do
OMap{..} <- obMap <$> (v V.!? k)
p <- fromIntegral <$> oBeg U.!? (unOb ob)
q <- fromIntegral <$> oBeg U.!? (unOb ob + 1)
i <- U.findIndex (==x) (U.slice p (q p) oLb)
ix <- oIx U.!? (p + i)
return ix
mkFeatMap :: [(Feat, FeatIx)] -> FeatMap
mkFeatMap xs = V.fromList
[ mkLayerMap $ filter (inLayer k . fst) xs
| k <- [0 .. maxLayerNum] ]
where
mkLayerMap = LayerMap
<$> mkT1Map
<*> mkT2Map
<*> mkT3Map
<*> mkOMap
maxLayerNum = maximum $ map (ln.fst) xs
inLayer k x | ln x == k = True
| otherwise = False
unFeatMap :: FeatMap -> [(Feat, FeatIx)]
unFeatMap fm = concat
[ unLayerMap i layer
| (i, layer) <- zip [0..] (V.toList fm) ]
data Model = Model
{ values :: U.Vector Double
, featMap :: FeatMap }
instance Binary Model where
put Model{..} = put values >> put featMap
get = Model <$> get <*> get
fromSet :: S.Set Feat -> Model
fromSet ftSet = Model
{ values = U.replicate (S.size ftSet) 0.0
, featMap =
let featIxs = map FeatIx [0..]
featLst = S.toList ftSet
in mkFeatMap (zip featLst featIxs) }
mkModel :: FeatSel -> [(Xs, Ys)] -> Model
mkModel ftSel = fromSet . S.fromList . concatMap (uncurry ftSel)
fromMap :: M.Map Feat L.LogFloat -> Model
fromMap ftMap = Model
{ values = U.fromList . map L.logFromLogFloat $ M.elems ftMap
, featMap =
let featIxs = map FeatIx [0..]
featLst = M.keys ftMap
in mkFeatMap (zip featLst featIxs) }
toMap :: Model -> M.Map Feat L.LogFloat
toMap Model{..} = M.fromList
[ (ft, L.logToLogFloat (values U.! unFeatIx ix))
| (ft, ix) <- unFeatMap featMap ]
phi :: Model -> Feat -> L.LogFloat
phi Model{..} ft = case featIndex ft featMap of
Just ix -> L.logToLogFloat (values U.! unFeatIx ix)
Nothing -> L.logToLogFloat (0 :: Float)
index :: Model -> Feat -> Maybe FeatIx
index Model{..} ft = featIndex ft featMap
onWord :: Model -> Xs -> Int -> CbIx -> L.LogFloat
onWord crf xs i u =
product . map (phi crf) $ obFeatsOn xs i u
onTransition :: Model -> Xs -> Int -> CbIx -> CbIx -> CbIx -> L.LogFloat
onTransition crf xs i u w v =
product . map (phi crf) $ trFeatsOn xs i u w v