hmm-hmatrix 0.1.0.1 → 0.1.1
raw patch · 5 files changed
+233/−139 lines, 5 filesdep +QuickCheckdep +hmm-hmatrixdep ~base
Dependencies added: QuickCheck, hmm-hmatrix
Dependency ranges changed: base
Files
- hmm-hmatrix.cabal +16/−3
- src/Math/HiddenMarkovModel/Example/TrafficLight.hs +12/−135
- src/Math/HiddenMarkovModel/Example/TrafficLightPrivate.hs +136/−0
- src/Math/HiddenMarkovModel/Test.hs +59/−1
- test/Main.hs +10/−0
hmm-hmatrix.cabal view
@@ -1,5 +1,5 @@ Name: hmm-hmatrix-Version: 0.1.0.1+Version: 0.1.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.0.1+ Tag: 0.1.1 Type: darcs Location: http://hub.darcs.net/thielema/hmm-hmatrix @@ -58,14 +58,16 @@ Math.HiddenMarkovModel.Example.TrafficLight Math.HiddenMarkovModel.Example.SineWave Math.HiddenMarkovModel.Example.Circle+ Math.HiddenMarkovModel.Test Other-Modules:+ Math.HiddenMarkovModel.Example.TrafficLightPrivate Math.HiddenMarkovModel.Normalized Math.HiddenMarkovModel.Private Math.HiddenMarkovModel.Utility Math.HiddenMarkovModel.CSV- Math.HiddenMarkovModel.Test Build-Depends: hmatrix >=0.16 && <0.17,+ QuickCheck >=2.5 && <3, explicit-exception >=0.1.7 && <0.2, lazy-csv >=0.5 && <0.6, random >=1.0 && <1.2,@@ -78,5 +80,16 @@ deepseq >=1.3 && <1.5, base >=4.5 && <5 Hs-Source-Dirs: src+ Default-Language: Haskell2010+ GHC-Options: -Wall++Test-Suite hmm-test+ Type: exitcode-stdio-1.0+ Build-Depends:+ hmm-hmatrix,+ QuickCheck,+ base+ Main-Is: Main.hs+ Hs-Source-Dirs: test Default-Language: Haskell2010 GHC-Options: -Wall
src/Math/HiddenMarkovModel/Example/TrafficLight.hs view
@@ -34,139 +34,16 @@ -} module Math.HiddenMarkovModel.Example.TrafficLight {-# WARNING "do not import that module, it is only intended for demonstration" #-}- where--import qualified Math.HiddenMarkovModel as HMM-import qualified Math.HiddenMarkovModel.Distribution as Distr--import qualified Data.Packed.Matrix as Matrix-import qualified Data.Packed.Vector as Vector--import Text.Read.HT (maybeRead)--import Control.Monad (liftM2)--import qualified Data.Map as Map-import qualified Data.NonEmpty as NonEmpty-import qualified Data.List.HT as ListHT-import Data.NonEmpty ((!:))----data Color = Red | Yellow | Green- deriving (Eq, Ord, Enum, Show, Read)--{- |-Using 'show' and 'read' is not always a good choice-since they must format and parse Haskell expressions-which is not of much use to the outside world.--}-instance Distr.CSVSymbol Color where- cellFromSymbol = show- symbolFromCell = maybeRead---hmm :: HMM.Discrete Double Color-hmm =- HMM.Cons {- HMM.initial = Vector.fromList [1/3, 1/6, 1/3, 1/6],- HMM.transition =- Matrix.fromLists $- [0.8, 0.0, 0.0, 0.2] :- [0.2, 0.8, 0.0, 0.0] :- [0.0, 0.2, 0.8, 0.0] :- [0.0, 0.0, 0.2, 0.8] :- [],- HMM.distribution =- Distr.Discrete $ Map.fromList $- (Red, Vector.fromList [1,0,0,0]) :- (Yellow, Vector.fromList [0,1,0,1]) :- (Green, Vector.fromList [0,0,1,0]) :- []- }--hmmDisturbed :: HMM.Discrete Double Color-hmmDisturbed =- HMM.Cons {- HMM.initial = Vector.fromList [1/4, 1/4, 1/4, 1/4],- HMM.transition =- Matrix.fromLists $- [0.3, 0.2, 0.2, 0.3] :- [0.3, 0.3, 0.2, 0.2] :- [0.2, 0.3, 0.3, 0.2] :- [0.2, 0.2, 0.3, 0.3] :- [],- HMM.distribution =- Distr.Discrete $ Map.fromList $- (Red, Vector.fromList [0.6, 0.2, 0.2, 0.2]) :- (Yellow, Vector.fromList [0.2, 0.6, 0.2, 0.6]) :- (Green, Vector.fromList [0.2, 0.2, 0.6, 0.2]) :- []- }---red, yellowRG, green, yellowGR :: (HMM.State, Color)-red = (HMM.state 0, Red)-yellowRG = (HMM.state 1, Yellow)-green = (HMM.state 2, Green)-yellowGR = (HMM.state 3, Yellow)--labeledSequences :: NonEmpty.T [] (NonEmpty.T [] (HMM.State, Color))-labeledSequences =- (red !: red : red : red :- yellowRG : yellowRG :- green : green : green : green : green :- yellowGR :- red : red : red :- []) !:- (green !: green : green :- yellowGR :- red : red : red : red :- yellowRG :- green : green : green : green : green :- yellowGR : yellowGR :- []) :- []--{- |-Construct a Hidden Markov model by watching a set-of manually created sequences of emissions and according states.--}-hmmTrainedSupervised :: HMM.Discrete Double Color-hmmTrainedSupervised =- HMM.trainMany (HMM.trainSupervised 4) labeledSequences---stateSequences :: NonEmpty.T [] (NonEmpty.T [] Color)-stateSequences = fmap (fmap snd) labeledSequences--{- |-Construct a Hidden Markov model starting from a known model-and a set of sequences that contain only the emissions, but no states.--}-hmmTrainedUnsupervised :: HMM.Discrete Double Color-hmmTrainedUnsupervised =- HMM.trainMany (HMM.trainUnsupervised hmm) stateSequences--{- |-Repeat unsupervised training until convergence.--}-hmmIterativelyTrained :: HMM.Discrete Double Color-hmmIterativelyTrained =- snd $ head $ dropWhile fst $- ListHT.mapAdjacent (\hmm0 hmm1 -> (HMM.deviation hmm0 hmm1 > 1e-5, hmm1)) $- iterate- (flip HMM.trainMany stateSequences . HMM.trainUnsupervised)- hmmDisturbed---verifyRevelation ::- HMM.Discrete Double Color -> NonEmpty.T [] (HMM.State, Color) -> Bool-verifyRevelation model xs =- fmap fst xs == HMM.reveal model (fmap snd xs)+ (+ Color(..),+ hmm,+ hmmDisturbed,+ red, yellowRG, green, yellowGR,+ labeledSequences,+ hmmTrainedSupervised,+ stateSequences,+ hmmTrainedUnsupervised,+ hmmIterativelyTrained,+ ) where -verifyRevelations :: [Bool]-verifyRevelations =- liftM2 verifyRevelation- [hmm, hmmDisturbed, hmmTrainedSupervised, hmmTrainedUnsupervised]- (NonEmpty.flatten labeledSequences)+import Math.HiddenMarkovModel.Example.TrafficLightPrivate
+ src/Math/HiddenMarkovModel/Example/TrafficLightPrivate.hs view
@@ -0,0 +1,136 @@+module Math.HiddenMarkovModel.Example.TrafficLightPrivate where++import qualified Math.HiddenMarkovModel as HMM+import qualified Math.HiddenMarkovModel.Distribution as Distr++import qualified Data.Packed.Matrix as Matrix+import qualified Data.Packed.Vector as Vector++import Text.Read.HT (maybeRead)++import Control.Monad (liftM2)++import qualified Data.Map as Map+import qualified Data.NonEmpty as NonEmpty+import qualified Data.List.HT as ListHT+import Data.NonEmpty ((!:))++++data Color = Red | Yellow | Green+ deriving (Eq, Ord, Enum, Show, Read)++{- |+Using 'show' and 'read' is not always a good choice+since they must format and parse Haskell expressions+which is not of much use to the outside world.+-}+instance Distr.CSVSymbol Color where+ cellFromSymbol = show+ symbolFromCell = maybeRead+++hmm :: HMM.Discrete Double Color+hmm =+ HMM.Cons {+ HMM.initial = Vector.fromList [1/3, 1/6, 1/3, 1/6],+ HMM.transition =+ Matrix.fromLists $+ [0.8, 0.0, 0.0, 0.2] :+ [0.2, 0.8, 0.0, 0.0] :+ [0.0, 0.2, 0.8, 0.0] :+ [0.0, 0.0, 0.2, 0.8] :+ [],+ HMM.distribution =+ Distr.Discrete $ Map.fromList $+ (Red, Vector.fromList [1,0,0,0]) :+ (Yellow, Vector.fromList [0,1,0,1]) :+ (Green, Vector.fromList [0,0,1,0]) :+ []+ }++hmmDisturbed :: HMM.Discrete Double Color+hmmDisturbed =+ HMM.Cons {+ HMM.initial = Vector.fromList [1/4, 1/4, 1/4, 1/4],+ HMM.transition =+ Matrix.fromLists $+ [0.3, 0.2, 0.2, 0.3] :+ [0.3, 0.3, 0.2, 0.2] :+ [0.2, 0.3, 0.3, 0.2] :+ [0.2, 0.2, 0.3, 0.3] :+ [],+ HMM.distribution =+ Distr.Discrete $ Map.fromList $+ (Red, Vector.fromList [0.6, 0.2, 0.2, 0.2]) :+ (Yellow, Vector.fromList [0.2, 0.6, 0.2, 0.6]) :+ (Green, Vector.fromList [0.2, 0.2, 0.6, 0.2]) :+ []+ }+++red, yellowRG, green, yellowGR :: (HMM.State, Color)+red = (HMM.state 0, Red)+yellowRG = (HMM.state 1, Yellow)+green = (HMM.state 2, Green)+yellowGR = (HMM.state 3, Yellow)++labeledSequences :: NonEmpty.T [] (NonEmpty.T [] (HMM.State, Color))+labeledSequences =+ (red !: red : red : red :+ yellowRG : yellowRG :+ green : green : green : green : green :+ yellowGR :+ red : red : red :+ []) !:+ (green !: green : green :+ yellowGR :+ red : red : red : red :+ yellowRG :+ green : green : green : green : green :+ yellowGR : yellowGR :+ []) :+ []++{- |+Construct a Hidden Markov model by watching a set+of manually created sequences of emissions and according states.+-}+hmmTrainedSupervised :: HMM.Discrete Double Color+hmmTrainedSupervised =+ HMM.trainMany (HMM.trainSupervised 4) labeledSequences+++stateSequences :: NonEmpty.T [] (NonEmpty.T [] Color)+stateSequences = fmap (fmap snd) labeledSequences++{- |+Construct a Hidden Markov model starting from a known model+and a set of sequences that contain only the emissions, but no states.+-}+hmmTrainedUnsupervised :: HMM.Discrete Double Color+hmmTrainedUnsupervised =+ HMM.trainMany (HMM.trainUnsupervised hmm) stateSequences++{- |+Repeat unsupervised training until convergence.+-}+hmmIterativelyTrained :: HMM.Discrete Double Color+hmmIterativelyTrained =+ snd $ head $ dropWhile fst $+ ListHT.mapAdjacent (\hmm0 hmm1 -> (HMM.deviation hmm0 hmm1 > 1e-5, hmm1)) $+ iterate+ (flip HMM.trainMany stateSequences . HMM.trainUnsupervised)+ hmmDisturbed+++verifyRevelation ::+ HMM.Discrete Double Color -> NonEmpty.T [] (HMM.State, Color) -> Bool+verifyRevelation model xs =+ fmap fst xs == HMM.reveal model (fmap snd xs)++verifyRevelations :: [Bool]+verifyRevelations =+ liftM2 verifyRevelation+ [hmm, hmmDisturbed, hmmTrainedSupervised, hmmTrainedUnsupervised]+ (NonEmpty.flatten labeledSequences)
src/Math/HiddenMarkovModel/Test.hs view
@@ -1,5 +1,11 @@-module Math.HiddenMarkovModel.Test where+{- |+Do not import this module, it is only intended for testing!+-}+module Math.HiddenMarkovModel.Test (tests) where +import qualified Math.HiddenMarkovModel.Example.TrafficLightPrivate+ as TrafficLight+ import qualified Math.HiddenMarkovModel as HMM import qualified Math.HiddenMarkovModel.Normalized as Normalized import qualified Math.HiddenMarkovModel.Private as Priv@@ -11,6 +17,7 @@ import Data.Packed.Matrix (Matrix) import Data.Packed.Vector (Vector) +import qualified Test.QuickCheck as QC import qualified System.Random as Rnd import qualified Data.NonEmpty.Class as NonEmptyC@@ -21,7 +28,9 @@ import qualified Data.Map as Map import Data.NonEmpty ((!:)) +import Text.Printf (printf) + hmm :: HMM.Discrete Double Char hmm = HMM.Cons {@@ -159,3 +168,52 @@ nonEmptyScanr :: Int -> [Int] -> Bool nonEmptyScanr x xs = Normalized.nonEmptyScanr (-) x xs == NonEmpty.scanr (-) x xs+++allPair :: (a -> Bool, b -> Bool) -> (a,b) -> Bool+allPair (f,g) (a,b) = f a && g b++allTriple :: (a -> Bool, b -> Bool, c -> Bool) -> (a,b,c) -> Bool+allTriple (f,g,h) (a,b,c) = f a && g b && h c++almostZero :: Double -> Bool+almostZero x = x < 1e-10++almostOne :: Double -> Bool+almostOne x = almostZero $ abs (x-1)++almostEqual :: Double -> Double -> Bool+almostEqual x y = almostZero $ abs (x-y)++tests :: [(String, QC.Property)]+tests =+ ("sequLikelihood",+ QC.property $+ case sequLikelihood of+ (forwardBackward, expLog, sumProb, alphaBetas) ->+ allPair (almostEqual sumProb, almostEqual sumProb) forwardBackward+ &&+ almostEqual sumProb expLog+ &&+ length (NonEmpty.tail sequ) == length (NonEmpty.tail alphaBetas)+ &&+ Fold.all (almostEqual sumProb) alphaBetas) :+ ("sequLikelihoodNormalized",+ QC.property $+ length (NonEmpty.tail sequ) ==+ length (NonEmpty.tail sequLikelihoodNormalized)+ &&+ Fold.all almostOne sequLikelihoodNormalized) :+ ("zetasDiff",+ QC.property $ allTriple (id, almostZero, almostZero) zetasDiff) :+ ("xisDiff", QC.property $ allPair (id, almostZero) xisDiff) :+ ("reveal", QC.property reveal) :+ ("trainUnsupervisedDiff",+ QC.property $+ allTriple (almostZero, almostZero, allPair (id, almostZero)) $+ trainUnsupervisedDiff) :+ ("nonEmptyScanr", QC.property nonEmptyScanr) :+ (zipWith+ (\k b -> (printf "TrafficLight.verifyRevelation.%d" k, QC.property b))+ [(0::Int) ..] TrafficLight.verifyRevelations) +++ []
+ test/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import Math.HiddenMarkovModel.Test (tests)++import qualified Test.QuickCheck as QC+++main :: IO ()+main =+ mapM_ (\(name,prop) -> putStr (name ++ ": ") >> QC.quickCheck prop) tests