kaushikc.org / hmm
Haskell implementations of Hidden Markov Models & related algorithms from AIMA book
0
fork

Configure Feed

Select the types of activity you want to include in your feed.

refactoring and simplifying input for running forward-backward

Kaushik Chakraborty 7e1f71ea fea62325

+31 -25
+31 -25
src/hmm.hs
··· 36 36 -- | Utility Functions 37 37 38 38 -- | Multiply each number by a constant such that the sum is 1.0 39 - 40 39 normalise :: (Fractional a, Foldable f, Functor f) => f a -> f a 41 40 normalise xs | null xs = xs 42 41 | otherwise = ··· 108 107 sensorDiagonal :: (KnownNat s, KnownNat t, Eq b) => HMM s t a b -> b -> Maybe (SensorDiagonal s a) 109 108 sensorDiagonal hmm e = findIndexOf (sDist.folded) (== e) hmm >>= (\i -> hmm ^? sModel . ix i) 110 109 110 + -- | Filtering message propagated forward 111 + forward :: (KnownNat s) => HMM s t R b -> SensorDiagonal s R -> Message s R -> Message s R 112 + forward hmm ot f = normalise (ot !*! Linear.transpose (hmm ^. tModel) !*! f) 113 + 114 + -- | Smoothing message propagated backward 115 + backward :: (KnownNat s) => HMM s t R b -> SensorDiagonal s R -> Message s R -> Message s R 116 + backward hmm ok1 bk2 = (hmm ^. tModel) !*! ok1 !*! bk2 117 + 118 + 111 119 -- | Fixed Lag Smoothing 112 120 113 121 -- | Persistent State ··· 122 130 -- | State to start with 123 131 persistentInit :: forall s b d. (KnownNat s, Integral d) => Message s R -> Persistent s R b d 124 132 persistentInit p = Persistent { _t = 1, _f_msg = p, _b = identity, _e_td_t = Vec.empty} 125 - 126 - -- | Filtering message propagated forward 127 - forward :: (KnownNat s) => HMM s t R b -> SensorDiagonal s R -> Message s R -> Message s R 128 - forward hmm ot f = normalise (ot !*! Linear.transpose (hmm ^. tModel) !*! f) 129 - 130 - -- | Smoothing message propagated backward 131 - backward :: (KnownNat s) => HMM s t R b -> SensorDiagonal s R -> Message s R -> Message s R 132 - backward hmm ok1 bk2 = (hmm ^. tModel) !*! ok1 !*! bk2 133 - 134 133 135 134 -- | Online Algorithm for smoothing with a fixed time lag of `d` steps 136 135 -- hmm -- HMM model ··· 166 165 -- evs - list of evidences for each time step 167 166 forwardBackward :: forall s t u b . (KnownNat t, KnownNat s, KnownNat u, Eq b) => HMM s u R b -> V t b -> V t (Distribution s R) 168 167 forwardBackward hmm evs = let 169 - -- forward messages 168 + -- reifying the number of evidences 169 + tNat = dim evs 170 + -- forward messages from time t .. 0 170 171 fv :: V (t + 1) (Message s R) 171 172 fv = V $ Vec.fromList $ foldl' (\m@(x:_) e -> forward hmm (sensorDiagonal hmm e ^?! _Just) x : m) [hmm ^. prior] evs 172 - -- reifying the number of evidences 173 - tNat = dim evs 174 173 -- getting rid of the prior message from the end of the list 174 + -- so now forward messages vector is from time t .. 1 175 175 fv_0 :: V t (Message s R) 176 176 fv_0 = V $ Vec.fromList $ fv ^.. taking tNat traversed 177 - -- backward messages 177 + 178 + -- backward messages from time 1 .. t 178 179 bs :: V t (Message s R) 179 180 bs = V $ Vec.fromList $ foldl' (\m@(x:_) e -> backward hmm (sensorDiagonal hmm e ^?! _Just) x : m) [unitColumn] $ reverseV evs 181 + -- reversing the backward messages 182 + -- so now the backward messages vector is from time t .. 1 183 + revBs :: V t (Message s R) 184 + revBs = reverseV bs 180 185 in 181 186 -- smoothing probabilities in reverse order of the list of evidences 182 - liftA2 (\f b' -> extract1 $ normalise $ f !**! b') fv_0 (reverseV bs) 187 + -- i.e. starting from time t .. 1 188 + liftA2 (\f b' -> extract1 $ normalise $ f !**! b') fv_0 revBs 183 189 184 190 -- | execution 185 191 umbrellaHMM :: HMM 2 2 R Bool 186 192 umbrellaHMM = mkHMM1 (V2 (V2 0.7 0.3) (V2 0.3 0.7)) (V2 (V2 0.9 0.2) (V2 0.1 0.8)) 187 193 188 - runFLSAlgo :: [Bool] -> [Maybe (Distribution 2 String)] 189 - runFLSAlgo bs = let hmm = mkHMM1 (V2 (V2 0.7 0.3) (V2 0.3 0.7)) (V2 (V2 0.9 0.2) (V2 0.1 0.8)) 190 - initState = persistentInit (V $ Vec.fromList [V $ Vec.singleton 0.5, V $ Vec.singleton 0.5]) :: Persistent 2 R Bool Integer 191 - algo = fixedLagSmoothing hmm 1 192 - a :: ([Maybe (Distribution 2 R)], Persistent 2 R Bool Integer) 193 - a = foldl' (\(rs, s) x -> runState (runMaybeT $ algo x) s & _1 #%~ ((rs ++) . pure)) ([], initState) bs 194 - in 195 - (a ^. _1) & traverse.traverse.traverse %~ \(x :: R) -> printf "%.3f" x :: String 194 + runFLSAlgo :: [Bool] -> Integer -> [Maybe (Distribution 2 String)] 195 + runFLSAlgo bs d = let hmm = mkHMM1 (V2 (V2 0.7 0.3) (V2 0.3 0.7)) (V2 (V2 0.9 0.2) (V2 0.1 0.8)) 196 + initState = persistentInit (V $ Vec.fromList [V $ Vec.singleton 0.5, V $ Vec.singleton 0.5]) :: Persistent 2 R Bool Integer 197 + algo = fixedLagSmoothing hmm d 198 + a :: ([Maybe (Distribution 2 R)], Persistent 2 R Bool Integer) 199 + a = foldl' (\(rs, s) x -> runState (runMaybeT $ algo x) s & _1 #%~ ((rs ++) . pure)) ([], initState) bs 200 + in 201 + (a ^. _1) & traverse.traverse.traverse %~ \(x :: R) -> printf "%.3f" x :: String 196 202 197 203 198 - runFBAlgo :: (KnownNat t) =>V t Bool -> [Distribution 2 R] 199 - runFBAlgo bs = toList $ forwardBackward umbrellaHMM bs 204 + runFBAlgo :: [Bool] -> [Distribution 2 R] 205 + runFBAlgo bs = reifyVectorNat (Vec.fromList bs) (toList . forwardBackward umbrellaHMM)