measurable

commit 2c683db9f2d791dc8bf3e9bf6107f65844704dc2
parent c797f2a3b2edcb87b1a95a1c6091dc0f09492583
Author: Jared Tobin <jared@jtobin.ca>
Date:   Mon, 21 Oct 2013 16:53:11 +1300

Add mixture model to examples.

Diffstat:
M
src/Examples.hs
 | 
35
+++++++++++++++++++++++++++++++++--

1 file changed, 33 insertions(+), 2 deletions(-)
diff --git a/src/Examples.hs b/src/Examples.hs
@@ -136,11 +136,37 @@ categoricalOnGroupDensity g
 
 -- | Here's a measure defined on the Group data type. 
 categoricalOnGroupMeasure 
-  :: (Applicative m, Monad m, Fractional a)
-  => MeasureT a m Group
+  :: (Applicative m, Monad m, Fractional r)
+  => MeasureT r m Group
 categoricalOnGroupMeasure = 
   fromMassFunction (return . categoricalOnGroupDensity) [A, B, C]
 
+-- | A gaussian mixture model, with mixing probabilities based on observed 
+--   groups.  Again, note that Group is not an instance of Num!   We can compose
+--   measures of various types, so long as our 'end type' is Fractional.
+--
+--   X | S ~ case S of
+--             A -> observed from N(-2, 1)
+--             B -> observed from N( 0, 1)
+--             C -> observed from N( 1, 1)
+--
+--   S     ~ observed from categorical
+--
+gaussianMixtureModel
+  :: (Fractional r, Applicative m, PrimMonad m)
+  => Int
+  -> [Group] 
+  -> Gen (PrimState m)
+  -> MeasureT r m Double
+gaussianMixtureModel n observed g = do
+  s       <- fromObservations observed
+  samples <- case s of
+               A -> lift $ genNormalSamples n (-2) 1 g
+               B -> lift $ genNormalSamples n 0 1 g
+               C -> lift $ genNormalSamples n 1 1 g
+
+  fromObservations samples
+
 main :: IO ()
 main = do
   let nng  = normalNormalGammaMeasure 30 2 6 1 0.5
@@ -168,6 +194,9 @@ main = do
   groupsObservedProbBC <- expectation id
     (containing [B, C] <$> categoricalFromObservationsMeasure)
 
+  mixtureModelMean <- withSystemRandom . asGenIO $ \g -> 
+    expectation id (gaussianMixtureModel 30 groupsObserved g)
+
   print m0
   print m1
 
@@ -179,3 +208,5 @@ main = do
   print groupProbBC
   print groupsObservedProbBC
 
+  print mixtureModelMean
+