rhine-bayes 0.8.1.1 → 0.9

raw patch · 6 files changed

+119/−52 lines, 6 filesdep ~dunaidep ~rhinesetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: dunai, rhine

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• Setup.hs +1/−0
• app/Main.hs +34/−20
• rhine-bayes.cabal +7/−6
• src/Data/MonadicStreamFunction/Bayes.hs +9/−9
• src/FRP/Rhine/Bayes.hs +64/−17

@@ -1,5 +1,9 @@ # Revision history for rhine-gloss +## 0.9++* Add simple Poisson, Gamma and Bernoulli processes+ ## 0.8.1.1  * First version. Version numbers follow rhine.

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -13,9 +13,10 @@   * A more scalable, modular, interactive architecture, where all these three systems run on separate clocks,     and the user can interactively change the temperature of the heat bath -}+module Main where  -- base-import Control.Monad (void)+import Control.Monad (replicateM, void) import Data.Maybe (fromMaybe) import Data.Monoid (Product (Product, getProduct)) import GHC.Float (double2Float, float2Double)@@ -78,10 +79,6 @@  -- ** Observation --- | Internal utility because `gloss` operates on floats-double2FloatTuple :: (Double, Double) -> (Float, Float)-double2FloatTuple = double2Float *** double2Float- -- | An integral where the integrated value dies of exponentially decayIntegral :: (VectorSpace v (Diff td), Monad m, Floating (Diff td)) => Diff td -> BehaviourF m td v v decayIntegral timeConstant = (timeConstant *^) <$> average timeConstant@@ -112,11 +109,17 @@ initialTemperature :: Temperature initialTemperature = 7 --- | We infer the temperature by randomly moving around with a Brownian motion (Wiener process).+-- | We assume the user changes the temperature randomly every 3 seconds. temperatureProcess :: (MonadDistribution m, Diff td ~ Double) => BehaviourF m td () Temperature-temperatureProcess = proc () -> do-  temperatureFactor <- wienerLogDomain 20 -< ()-  returnA -< runLogDomain temperatureFactor * initialTemperature+temperatureProcess =+  -- Draw events from a Poisson process with a rate of one event per 3 seconds+  poissonHomogeneous 3+    -- For every event, draw a number from a normal distribution+    >>> arrMCl (flip replicateM $ normal 0 0.2)+    -- Sum the numbers and log-transform then into the positive reals+    >>> arr (exp . sum)+    -- Multiply original temperature with the random temperature changes+    >>> accumulateWith (*) initialTemperature  -- | Auxiliary conversion function belonging to the log-domain library, see https://github.com/ekmett/log-domain/issues/38 runLogDomain :: Log Double -> Double@@ -158,6 +161,10 @@  -- * Visualization +-- | Internal utility because `gloss` operates on floats+double2FloatTuple :: (Double, Double) -> (Float, Float)+double2FloatTuple = double2Float *** double2Float+ {- | The monad in which our program will run.    'SamplerIO' is for the probabilistic effects from @monad-bayes@,    while 'GlossConcT' adds interactive effects from @gloss@.@@ -166,7 +173,7 @@  -- | Draw the results of the simulation and inference visualisation :: Diff td ~ Double => BehaviourF App td Result ()-visualisation = proc Result{temperature, measured, latent, particles} -> do+visualisation = proc Result {temperature, measured, latent, particles} -> do   constMCl clearIO -< ()   time <- sinceInitS -< ()   arrMCl paintIO@@ -305,26 +312,27 @@ -- | The user can change the temperature by pressing the up and down arrow keys. userTemperature :: ClSF (GlossConcT IO) (GlossClockUTC GlossEventClockIO) () Temperature userTemperature = tagS >>> arr (selector >>> fmap Product) >>> mappendS >>> arr (fmap getProduct >>> fromMaybe 1 >>> (* initialTemperature))- where-  selector (EventKey (SpecialKey KeyUp) Down _ _) = Just 1.2-  selector (EventKey (SpecialKey KeyDown) Down _ _) = Just (1 / 1.2)-  selector _ = Nothing+  where+    selector (EventKey (SpecialKey KeyUp) Down _ _) = Just 1.2+    selector (EventKey (SpecialKey KeyDown) Down _ _) = Just (1 / 1.2)+    selector _ = Nothing  {- | This part performs the inference (and passes along temperature, sensor and position simulations).    It runs as fast as possible, so this will potentially drain the CPU. -} inference :: Rhine (GlossConcT IO) (LiftClock IO GlossConcT Busy) (Temperature, (Sensor, Pos)) Result inference = hoistClSF sampleIOGloss inferenceBehaviour @@ liftClock Busy- where-  inferenceBehaviour :: (MonadDistribution m, Diff td ~ Double, MonadIO m) => BehaviourF m td (Temperature, (Sensor, Pos)) Result-  inferenceBehaviour = proc (temperature, (measured, latent)) -> do-    particles <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured-    returnA -< Result{temperature, measured, latent, particles}+  where+    inferenceBehaviour :: (MonadDistribution m, Diff td ~ Double, MonadIO m) => BehaviourF m td (Temperature, (Sensor, Pos)) Result+    inferenceBehaviour = proc (temperature, (measured, latent)) -> do+      particles <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured+      returnA -< Result {temperature, measured, latent, particles}  -- | Visualize the current 'Result' at a rate controlled by the @gloss@ backend, usually 30 FPS. visualisationRhine :: Rhine (GlossConcT IO) (GlossClockUTC GlossSimClockIO) Result () visualisationRhine = hoistClSF sampleIOGloss visualisation @@ glossClockUTC GlossSimClockIO +{- FOURMOLU_DISABLE -} -- | Compose all four asynchronous components to a single 'Rhine'. mainRhineMultiRate =   userTemperature@@ -333,8 +341,9 @@         modelRhine         >-- keepLast (initialTemperature, (zeroVector, zeroVector)) -@- glossConcurrently -->           inference-            >-- keepLast Result{temperature = initialTemperature, measured = zeroVector, latent = zeroVector, particles = []} -@- glossConcurrently -->+            >-- keepLast Result {temperature = initialTemperature, measured = zeroVector, latent = zeroVector, particles = []} -@- glossConcurrently -->               visualisationRhine+{- FOURMOLU_ENABLE -}  mainMultiRate :: IO () mainMultiRate =@@ -346,6 +355,11 @@  instance MonadDistribution m => MonadDistribution (GlossConcT m) where   random = lift random++instance MonadFactor m => MonadFactor (GlossConcT m) where+  score = lift . score++instance MonadMeasure m => MonadMeasure (GlossConcT m)  sampleIOGloss :: App a -> GlossConcT IO a sampleIOGloss = hoist sampleIO

@@ -1,5 +1,5 @@ name:                rhine-bayes-version:             0.8.1.1+version:             0.9 synopsis:            monad-bayes backend for Rhine description:   This package provides a backend to the `monad-bayes` library,@@ -14,7 +14,7 @@ build-type:          Simple extra-source-files:  ChangeLog.md extra-doc-files:     README.md-cabal-version:       1.18+cabal-version:       2.0  source-repository head   type:     git@@ -23,7 +23,7 @@ source-repository this   type:     git   location: git@github.com:turion/rhine.git-  tag:      v0.8.1.1+  tag:      v0.9  library   exposed-modules:@@ -32,8 +32,8 @@     Data.MonadicStreamFunction.Bayes   build-depends:       base         >= 4.11 && < 4.18                      , transformers >= 0.5-                     , rhine        == 0.8.1.1-                     , dunai        >= 0.8+                     , rhine        == 0.9+                     , dunai        ^>= 0.9                      , log-domain   >= 0.12                      , monad-bayes  >= 1.1.0   hs-source-dirs:      src@@ -50,6 +50,7 @@     ScopedTypeVariables     TupleSections     TypeFamilies+    TypeOperators    ghc-options:         -W   if flag(dev)@@ -58,7 +59,6 @@ executable rhine-bayes-gloss   main-is:             Main.hs   hs-source-dirs:      app-  ghc-options:         -threaded   build-depends:       base         >= 4.11 && < 4.18                      , rhine                      , rhine-bayes@@ -78,6 +78,7 @@     TupleSections     TypeApplications     TypeFamilies+    TypeOperators    ghc-options:         -W -threaded -rtsopts -with-rtsopts=-N   if flag(dev)

@@ -38,15 +38,15 @@   Population m (MSF (Population m) a b) ->   MSF m a [(b, Log Double)] runPopulationsS resampler = go- where-  go msfs = MSF $ \a -> do-    -- TODO This is quite different than the dunai version now. Maybe it's right nevertheless.-    -- FIXME This normalizes, which introduces bias, whatever that means-    bAndMSFs <- runPopulation $ normalize $ resampler $ flip unMSF a =<< msfs-    return $-      second (go . fromWeightedList . return) $-        unzip $-          (swap . fmap fst &&& swap . fmap snd) . swap <$> bAndMSFs+  where+    go msfs = MSF $ \a -> do+      -- TODO This is quite different than the dunai version now. Maybe it's right nevertheless.+      -- FIXME This normalizes, which introduces bias, whatever that means+      bAndMSFs <- runPopulation $ normalize $ resampler $ flip unMSF a =<< msfs+      return $+        second (go . fromWeightedList . return) $+          unzip $+            (swap . fmap fst &&& swap . fmap snd) . swap <$> bAndMSFs  -- FIXME see PR re-adding this to monad-bayes normalize :: Monad m => Population m a -> Population m a

@@ -1,5 +1,8 @@ module FRP.Rhine.Bayes where +-- transformers+import Control.Monad.Trans.Reader (ReaderT (..))+ -- log-domain import Numeric.Log hiding (sum) @@ -19,17 +22,19 @@ -- * Inference methods  -- | Run the Sequential Monte Carlo algorithm continuously on a 'ClSF'.-runPopulationCl :: forall m cl a b . Monad m =>+runPopulationCl ::+  forall m cl a b.+  Monad m =>   -- | Number of particles   Int ->   -- | Resampler (see 'Control.Monad.Bayes.Population' for some standard choices)-  (forall x . Population m x -> Population m x)+  (forall x. Population m x -> Population m x) ->   -- | A signal function modelling the stochastic process on which to perform inference.   --   @a@ represents observations upon which the model should condition, using e.g. 'score'.   --   It can also additionally contain hyperparameters.   --   @b@ is the type of estimated current state.-  -> ClSF (Population m) cl a b-  -> ClSF m cl a [(b, Log Double)]+  ClSF (Population m) cl a b ->+  ClSF m cl a [(b, Log Double)] runPopulationCl nParticles resampler = DunaiReader.readerS . DunaiBayes.runPopulationS nParticles resampler . DunaiReader.runReaderS  -- * Short standard library of stochastic processes@@ -47,27 +52,28 @@ levy incrementor = sinceLastS >>> arrMCl incrementor >>> sumS  -- | The Wiener process, also known as Brownian motion.-wiener, brownianMotion ::-  (MonadDistribution m, Diff td ~ Double) =>-  -- | Time scale of variance.-  Diff td ->-  Behaviour m td Double+wiener+  , brownianMotion ::+    (MonadDistribution m, Diff td ~ Double) =>+    -- | Time scale of variance.+    Diff td ->+    Behaviour m td Double wiener timescale = levy $ \diffTime -> normal 0 $ sqrt $ diffTime / timescale- brownianMotion = wiener  -- | The Wiener process, also known as Brownian motion, with varying variance parameter.-wienerVarying, brownianMotionVarying ::-  (MonadDistribution m, Diff td ~ Double) =>-  BehaviourF m td (Diff td) Double+wienerVarying+  , brownianMotionVarying ::+    (MonadDistribution m, Diff td ~ Double) =>+    BehaviourF m td (Diff td) Double wienerVarying = proc timeScale -> do   diffTime <- sinceLastS -< ()   let stdDev = sqrt $ diffTime / timeScale-  increment <- if stdDev > 0-    then arrM $ normal 0 -< stdDev-    else returnA -< 0+  increment <-+    if stdDev > 0+      then arrM $ normal 0 -< stdDev+      else returnA -< 0   sumS -< increment- brownianMotionVarying = wienerVarying  -- | The 'wiener' process transformed to the Log domain, also called the geometric Wiener process.@@ -83,3 +89,44 @@   (MonadDistribution m, Diff td ~ Double) =>   BehaviourF m td (Diff td) (Log Double) wienerVaryingLogDomain = wienerVarying >>> arr Exp++{- | Inhomogeneous Poisson point process, as described in:+  https://en.wikipedia.org/wiki/Poisson_point_process#Inhomogeneous_Poisson_point_process++  * The input is the inverse of the current rate or intensity.+    It corresponds to the average duration between two events.+  * The output is the number of events since the last tick.+-}+poissonInhomogeneous ::+  (MonadDistribution m, Real (Diff td), Fractional (Diff td)) =>+  BehaviourF m td (Diff td) Int+poissonInhomogeneous = arrM $ \rate -> ReaderT $ \diffTime -> poisson $ realToFrac $ sinceLast diffTime / rate++-- | Like 'poissonInhomogeneous', but the rate is constant.+poissonHomogeneous ::+  (MonadDistribution m, Real (Diff td), Fractional (Diff td)) =>+  -- | The (constant) rate of the process+  Diff td ->+  BehaviourF m td () Int+poissonHomogeneous rate = arr (const rate) >>> poissonInhomogeneous++{- | The Gamma process, https://en.wikipedia.org/wiki/Gamma_process.++  The live input corresponds to inverse shape parameter, which is variance over mean.+-}+gammaInhomogeneous ::+  (MonadDistribution m, Real (Diff td), Fractional (Diff td), Floating (Diff td)) =>+  -- | The scale parameter+  Diff td ->+  BehaviourF m td (Diff td) Int+gammaInhomogeneous gamma = proc rate -> do+  t <- sinceInitS -< ()+  accumulateWith (+) 0 <<< poissonInhomogeneous -< gamma / t * exp (-t / rate)++{- | The inhomogeneous Bernoulli process, https://en.wikipedia.org/wiki/Bernoulli_process++  Throws a coin to a given probability at each tick.+  The live input is the probability.+-}+bernoulliInhomogeneous :: MonadDistribution m => BehaviourF m td Double Bool+bernoulliInhomogeneous = arrMCl bernoulli