diff --git a/hmm-hmatrix.cabal b/hmm-hmatrix.cabal --- a/hmm-hmatrix.cabal +++ b/hmm-hmatrix.cabal @@ -1,5 +1,5 @@ Name: hmm-hmatrix -Version: 0.1 +Version: 0.1.0.1 Synopsis: Hidden Markov Models using HMatrix primitives Description: Hidden Markov Models implemented using HMatrix data types and operations. @@ -41,7 +41,7 @@ Changes.md Source-Repository this - Tag: 0.1 + Tag: 0.1.0.1 Type: darcs Location: http://hub.darcs.net/thielema/hmm-hmatrix @@ -72,7 +72,7 @@ transformers >= 0.2 && <0.6, non-empty >=0.2.1 && <0.4, semigroups >=0.17 && <0.19, - containers >=0.4.2 && <0.6, + containers >=0.4.2 && <0.7, array >=0.4 && <0.6, utility-ht >=0.0.12 && <0.1, deepseq >=1.3 && <1.5, diff --git a/src/Math/HiddenMarkovModel.hs b/src/Math/HiddenMarkovModel.hs --- a/src/Math/HiddenMarkovModel.hs +++ b/src/Math/HiddenMarkovModel.hs @@ -96,8 +96,8 @@ (NC.atIndex (initial hmm)) generate :: - (Rnd.RandomGen g, Ord prob, Rnd.Random prob, - Distr.Generate distr, Distr.Probability distr ~ prob, Distr.Emission distr ~ emission) => + (Rnd.RandomGen g, Ord prob, Rnd.Random prob, Distr.Generate distr, + Distr.Probability distr ~ prob, Distr.Emission distr ~ emission) => T distr prob -> g -> [emission] generate hmm = MS.evalState $ diff --git a/src/Math/HiddenMarkovModel/CSV.hs b/src/Math/HiddenMarkovModel/CSV.hs --- a/src/Math/HiddenMarkovModel/CSV.hs +++ b/src/Math/HiddenMarkovModel/CSV.hs @@ -20,14 +20,10 @@ import qualified Data.List.HT as ListHT -cellsFromVector :: - (Show a, Algo.Field a) => - Vector a -> [String] +cellsFromVector :: (Show a, Algo.Field a) => Vector a -> [String] cellsFromVector = map show . Vector.toList -cellsFromMatrix :: - (Show a, Matrix.Element a) => - Matrix.Matrix a -> [[String]] +cellsFromMatrix :: (Show a, Matrix.Element a) => Matrix a -> [[String]] cellsFromMatrix = map (map show) . Matrix.toLists padTable :: a -> [[a]] -> [[a]] @@ -145,8 +141,7 @@ assert (all ((n==) . Vector.dim) rows) "inconsistent matrix dimensions" return $ Matrix.fromRows rows -parseStringList :: - CSV.CSVRow -> CSVParser [String] +parseStringList :: CSV.CSVRow -> CSVParser [String] parseStringList = MT.lift . mapM cellContent . Rev.dropWhile (null . CSV.csvFieldContent) diff --git a/src/Math/HiddenMarkovModel/Distribution.hs b/src/Math/HiddenMarkovModel/Distribution.hs --- a/src/Math/HiddenMarkovModel/Distribution.hs +++ b/src/Math/HiddenMarkovModel/Distribution.hs @@ -163,8 +163,7 @@ transposeVectorList = Matrix.toRows . Matrix.fromColumns mapLookup :: (Ord k) => String -> Map.Map k a -> k -> a -mapLookup msg dict x = - Map.findWithDefault (error msg) x dict +mapLookup msg dict x = Map.findWithDefault (error msg) x dict newtype Gaussian a = Gaussian (Array State (Vector a, Matrix a, a)) @@ -234,10 +233,10 @@ weight0 + weight1) in GaussianTrained $ Map.unionWith comb distr0 distr1 {- - Sum_i (xi-mi) * (xi-mi)^T - = Sum_i xi*xi^T + Sum_i mi*mi^T - Sum_i xi*mi^T - Sum_i mi*xi^T - = Sum_i xi*xi^T - Sum_i mi*mi^T - = Sum_i xi*xi^T - n * mi*mi^T + Sum_i (xi-m) * (xi-m)^T + = Sum_i xi*xi^T + Sum_i m*m^T - Sum_i xi*m^T - Sum_i m*xi^T + = Sum_i xi*xi^T - Sum_i m*m^T + = Sum_i xi*xi^T - n * m*m^T -} normalize (GaussianTrained distr) = let params (centerSum, covarianceSum, weight) = @@ -252,8 +251,7 @@ gaussian :: (Algo.Field prob) => [(Vector prob, Matrix prob)] -> Gaussian prob -gaussian = - consGaussian . map gaussianParameters +gaussian = consGaussian . map gaussianParameters gaussianParameters :: (Algo.Field prob) => @@ -262,8 +260,7 @@ gaussianFromCholesky center $ Algo.chol covariance consGaussian :: [(Vector a, Matrix a, a)] -> Gaussian a -consGaussian xs = - Gaussian $ listArray (State 0, State $ length xs - 1) xs +consGaussian xs = Gaussian $ listArray (State 0, State $ length xs - 1) xs gaussianFromCholesky :: (Algo.Field prob) => @@ -316,9 +313,10 @@ in MT.lift $ ME.fromMaybe (printf "unknown symbol %s" str) $ symbolFromCell str) (do v <- HMMCSV.parseVectorFields cs - HMMCSV.assert (n == Vector.dim v) + let m = Vector.dim v + HMMCSV.assert (n == m) (printf "number of states (%d) and size of probability vector (%d) mismatch" - n (Vector.dim v)) + n m) return v) diff --git a/src/Math/HiddenMarkovModel/Normalized.hs b/src/Math/HiddenMarkovModel/Normalized.hs --- a/src/Math/HiddenMarkovModel/Normalized.hs +++ b/src/Math/HiddenMarkovModel/Normalized.hs @@ -10,7 +10,8 @@ import qualified Math.HiddenMarkovModel.Distribution as Distr import Math.HiddenMarkovModel.Private - (T(..), Trained(..), emission, matrixMaxMul, sumTransitions) + (T(..), Trained(..), emission, + biscaleTransition, matrixMaxMul, sumTransitions) import Math.HiddenMarkovModel.Distribution (State(State)) import Math.HiddenMarkovModel.Utility (normalizeFactor, normalizeProb) @@ -94,10 +95,7 @@ let (cs,alphas) = Functor.unzip calphas in NonEmptyC.zipWith4 (\x alpha0 c1 beta1 -> - NC.scale (recip c1) $ - NC.mul - (NC.outer (NC.mul (emission hmm x) beta1) alpha0) - (transition hmm)) + NC.scale (recip c1) $ biscaleTransition hmm x alpha0 beta1) (NonEmpty.tail xs) (NonEmpty.init alphas) (NonEmpty.tail cs) diff --git a/src/Math/HiddenMarkovModel/Private.hs b/src/Math/HiddenMarkovModel/Private.hs --- a/src/Math/HiddenMarkovModel/Private.hs +++ b/src/Math/HiddenMarkovModel/Private.hs @@ -128,6 +128,14 @@ +biscaleTransition :: + (Distr.EmissionProb distr, Distr.Probability distr ~ prob) => + T distr prob -> Distr.Emission distr -> + Vector prob -> Vector prob -> Matrix prob +biscaleTransition hmm x alpha0 beta1 = + NC.mul (transition hmm) $ + NC.outer (NC.mul (emission hmm x) beta1) alpha0 + xiFromAlphaBeta :: (Distr.EmissionProb distr, Distr.Probability distr ~ prob, Distr.Emission distr ~ emission) => @@ -140,9 +148,7 @@ zipWith3 (\x alpha0 beta1 -> NC.scale recipLikelihood $ - NC.mul - (NC.outer (NC.mul (emission hmm x) beta1) alpha0) - (transition hmm)) + biscaleTransition hmm x alpha0 beta1) (NonEmpty.tail xs) (NonEmpty.init alphas) (NonEmpty.tail betas) diff --git a/src/Math/HiddenMarkovModel/Utility.hs b/src/Math/HiddenMarkovModel/Utility.hs --- a/src/Math/HiddenMarkovModel/Utility.hs +++ b/src/Math/HiddenMarkovModel/Utility.hs @@ -9,12 +9,10 @@ import qualified Control.Monad.Trans.State as MS -normalizeProb :: - (NC.Container Vector a) => Vector a -> Vector a +normalizeProb :: (NC.Container Vector a) => Vector a -> Vector a normalizeProb = snd . normalizeFactor -normalizeFactor :: - (NC.Container Vector a) => Vector a -> (a, Vector a) +normalizeFactor :: (NC.Container Vector a) => Vector a -> (a, Vector a) normalizeFactor xs = let c = NC.sumElements xs in (c, NC.scale (recip c) xs)