rhine-bayes 1.6 → 1.7
raw patch · 3 files changed
+56/−63 lines, 3 filesdep ~log-domaindep ~mmorphdep ~monad-bayesPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: log-domain, mmorph, monad-bayes, rhine, rhine-gloss, transformers
API changes (from Hackage documentation)
Files
- app/Main.hs +34/−24
- rhine-bayes.cabal +17/−35
- src/FRP/Rhine/Bayes.hs +5/−4
app/Main.hs view
@@ -47,7 +47,17 @@ import FRP.Rhine.Bayes type Temperature = Double-type Pos = (Double, Double)+newtype Pos1d = Pos1d {getPos1 :: Double}+ deriving stock (Show)+ deriving newtype (Eq, Floating, Fractional, Num)++instance VectorSpace Pos1d (Seconds Double) where+ zeroVector = Pos1d 0+ Seconds s *^ Pos1d x = Pos1d $ s * x+ (^+^) = (+)+ dot (Pos1d x) (Pos1d y) = Seconds $ x * y++type Pos = (Pos1d, Pos1d) type Sensor = Pos -- * Model@@ -56,14 +66,14 @@ -- | Harmonic oscillator with white noise prior1d ::- (Diff td ~ Double) =>+ (Diff td ~ Seconds Double) => -- | Starting position- Double ->+ Pos1d -> -- | Starting velocity- Double ->- StochasticProcessF td Temperature Double+ Pos1d ->+ StochasticProcessF td Temperature Pos1d prior1d initialPosition initialVelocity = feedback 0 $ proc (temperature, position') -> do- impulse <- whiteNoiseVarying -< temperature+ impulse <- arr Pos1d <<< whiteNoiseVarying -< temperature let acceleration = (-3) * position' + impulse -- Integral over roughly the last 10 seconds, dying off exponentially, as to model a small friction term velocity <- arr (+ initialVelocity) <<< decayIntegral 10 -< acceleration@@ -71,7 +81,7 @@ returnA -< (position, position) -- | 2D harmonic oscillator with noise-prior :: (MonadDistribution m, Diff td ~ Double) => BehaviourF m td Temperature Pos+prior :: (MonadDistribution m, Diff td ~ Seconds Double) => BehaviourF m td Temperature Pos prior = prior1d 10 0 &&& prior1d 0 10 -- ** Observation@@ -86,10 +96,10 @@ -- | A generative model of the sensor noise noise :: StochasticProcess td Pos-noise = whiteNoise sensorNoiseTemperature &&& whiteNoise sensorNoiseTemperature+noise = (Pos1d <$> whiteNoise sensorNoiseTemperature) &&& (Pos1d <$> whiteNoise sensorNoiseTemperature) -- | A generative model of the sensor position, given the noise-generativeModel :: (Diff td ~ Double) => StochasticProcessF td Pos Sensor+generativeModel :: (Diff td ~ Seconds Double) => StochasticProcessF td Pos Sensor generativeModel = proc latent -> do noiseNow <- noise -< () returnA -< latent ^+^ noiseNow@@ -98,7 +108,7 @@ as to be used in the inference later. -} sensorLikelihood :: Pos -> Sensor -> Log Double-sensorLikelihood (posX, posY) (sensorX, sensorY) = normalPdf posX sensorNoiseTemperature sensorX * normalPdf posY sensorNoiseTemperature sensorY+sensorLikelihood (posX, posY) (sensorX, sensorY) = normalPdf (getPos1 posX) sensorNoiseTemperature (getPos1 sensorX) * normalPdf (getPos1 posY) sensorNoiseTemperature (getPos1 sensorY) -- ** User behaviour @@ -107,7 +117,7 @@ initialTemperature = 7 -- | We assume the user changes the temperature randomly every 3 seconds.-temperatureProcess :: (MonadDistribution m, Diff td ~ Double) => BehaviourF m td () Temperature+temperatureProcess :: (MonadDistribution m, Diff td ~ Seconds Double) => BehaviourF m td () Temperature temperatureProcess = -- Draw events from a Poisson process with a rate of one event per 3 seconds poissonHomogeneous 3@@ -127,7 +137,7 @@ {- | Generate a random position and sensor value, given a temperature. Used for simulating a situation upon which we will perform inference. -}-genModelWithoutTemperature :: (MonadDistribution m, Diff td ~ Double) => BehaviourF m td Temperature (Sensor, Pos)+genModelWithoutTemperature :: (MonadDistribution m, Diff td ~ Seconds Double) => BehaviourF m td Temperature (Sensor, Pos) genModelWithoutTemperature = proc temperature -> do latent <- prior -< temperature sensor <- generativeModel -< latent@@ -136,7 +146,7 @@ {- | Given sensor data, sample a latent position and a temperature, and weight them according to the likelihood of the observed sensor position. Used to infer position and temperature. -}-posteriorTemperatureProcess :: (MonadMeasure m, Diff td ~ Double) => BehaviourF m td Sensor (Temperature, Pos)+posteriorTemperatureProcess :: (MonadMeasure m, Diff td ~ Seconds Double) => BehaviourF m td Sensor (Temperature, Pos) posteriorTemperatureProcess = proc sensor -> do temperature <- temperatureProcess -< () latent <- prior -< temperature@@ -170,8 +180,8 @@ -- * Visualization -- | Internal utility because `gloss` operates on floats-double2FloatTuple :: (Double, Double) -> (Float, Float)-double2FloatTuple = double2Float *** double2Float+pos2FloatTuple :: Pos -> (Float, Float)+pos2FloatTuple = (double2Float . getPos1) *** (double2Float . getPos1) {- | The monad in which our program will run. 'SamplerIO' is for the probabilistic effects from @monad-bayes@,@@ -180,7 +190,7 @@ type App = GlossConcT SamplerIO -- | Draw the results of the simulation and inference-visualisation :: (Diff td ~ Double) => BehaviourF App td Result ()+visualisation :: (Diff td ~ Seconds Double) => BehaviourF App td Result () visualisation = proc Result {temperature, measured, latent, particlesPosition, particlesTemperature} -> do constMCl clearIO -< () time <- sinceInitS -< ()@@ -194,7 +204,7 @@ [0 ..] [ printf "Temperature: %.2f" temperature , printf "Particles: %i" $ length particlesPosition- , printf "Time: %.1f" time+ , printf "Time: %.1f" $ getSeconds time ] return $ translate 0 ((-150) * n) $ text message , color red $ rectangleUpperSolid thermometerWidth $ double2Float temperature * thermometerScale@@ -222,7 +232,7 @@ drawBall :: BehaviourF App td (Pos, Double, Color) () drawBall = proc (position, width, theColor) -> do- arrMCl paintIO -< scale 20 20 $ uncurry translate (double2FloatTuple position) $ color theColor $ circleSolid $ double2Float width+ arrMCl paintIO -< scale 20 20 $ uncurry translate (pos2FloatTuple position) $ color theColor $ circleSolid $ double2Float width drawParticle :: BehaviourF App td (Pos, Log Double) () drawParticle = proc (position, probability) -> do@@ -275,7 +285,7 @@ {- | On startup, sample values from the temperature prior. Then keep sampling from the position prior and condition by the likelihood of the measured sensor position. -}-posteriorTemperatureCollapse :: (MonadMeasure m, Diff td ~ Double) => BehaviourF m td Sensor (Temperature, Pos)+posteriorTemperatureCollapse :: (MonadMeasure m, Diff td ~ Seconds Double) => BehaviourF m td Sensor (Temperature, Pos) posteriorTemperatureCollapse = proc sensor -> do temperature <- performOnFirstSample (arr_ <$> temperaturePrior) -< () latent <- prior -< temperature@@ -285,7 +295,7 @@ {- | Given an actual temperature, simulate a latent position and measured sensor position, and based on the sensor data infer the latent position and the temperature. -}-filteredCollapse :: (Diff td ~ Double) => BehaviourF App td Temperature Result+filteredCollapse :: (Diff td ~ Seconds Double) => BehaviourF App td Temperature Result filteredCollapse = proc temperature -> do (measured, latent) <- genModelWithoutTemperature -< temperature particlesAndTemperature <- runPopulationCl nParticles resampleSystematic posteriorTemperatureCollapse -< measured@@ -300,7 +310,7 @@ } -- | Run simulation, inference, and visualization synchronously-mainClSFCollapse :: (Diff td ~ Double) => BehaviourF App td () ()+mainClSFCollapse :: (Diff td ~ Seconds Double) => BehaviourF App td () () mainClSFCollapse = proc () -> do output <- filteredCollapse -< initialTemperature visualisation -< output@@ -316,7 +326,7 @@ {- | Given an actual temperature, simulate a latent position and measured sensor position, and based on the sensor data infer the latent position and the temperature. -}-filtered :: (Diff td ~ Double) => BehaviourF App td Temperature Result+filtered :: (Diff td ~ Seconds Double) => BehaviourF App td Temperature Result filtered = proc temperature -> do (measured, latent) <- genModelWithoutTemperature -< temperature positionsAndTemperatures <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured@@ -331,7 +341,7 @@ } -- | Run simulation, inference, and visualization synchronously-mainClSF :: (Diff td ~ Double) => BehaviourF App td () ()+mainClSF :: (Diff td ~ Seconds Double) => BehaviourF App td () () mainClSF = proc () -> do output <- filtered -< initialTemperature visualisation -< output@@ -364,7 +374,7 @@ inference :: Rhine App (GlossConcTClock SamplerIO (Millisecond 100)) (Temperature, (Sensor, Pos)) Result inference = inferenceBehaviour @@ glossConcTClock waitClock -inferenceBehaviour :: (MonadDistribution m, Diff td ~ Double, MonadIO m) => BehaviourF m td (Temperature, (Sensor, Pos)) Result+inferenceBehaviour :: (MonadDistribution m, Diff td ~ Seconds Double, MonadIO m) => BehaviourF m td (Temperature, (Sensor, Pos)) Result inferenceBehaviour = proc (temperature, (measured, latent)) -> do positionsAndTemperatures <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured returnA
rhine-bayes.cabal view
@@ -1,12 +1,13 @@+cabal-version: 2.2 name: rhine-bayes-version: 1.6+version: 1.7 synopsis: monad-bayes backend for Rhine description: This package provides a backend to the @monad-bayes@ library, enabling you to write stochastic processes as signal functions, and performing online machine learning on them. -license: BSD3+license: BSD-3-Clause license-file: LICENSE author: Manuel Bärenz maintainer: programming@manuelbaerenz.de@@ -17,8 +18,6 @@ ChangeLog.md README.md -cabal-version: 2.0- source-repository head type: git location: git@github.com:turion/rhine.git@@ -28,28 +27,26 @@ location: git@github.com:turion/rhine.git tag: v1.6 -library- exposed-modules: FRP.Rhine.Bayes- other-modules: Data.Automaton.Bayes+common opts build-depends: automaton, base >=4.16 && <4.22, log-domain >=0.12, mmorph ^>=1.2, monad-bayes ^>=1.3.0.5,- rhine ^>=1.6,- transformers >=0.5+ rhine ^>=1.7,+ transformers >=0.5, - hs-source-dirs: src- default-language: Haskell2010 default-extensions: Arrows DataKinds DeriveFunctor+ DerivingStrategies FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses+ NamedFieldPuns RankNTypes ScopedTypeVariables TupleSections@@ -60,42 +57,27 @@ if flag(dev) ghc-options: -Werror+ default-language: Haskell2010 +library+ import: opts+ exposed-modules: FRP.Rhine.Bayes+ other-modules: Data.Automaton.Bayes+ hs-source-dirs: src+ executable rhine-bayes-gloss+ import: opts main-is: Main.hs hs-source-dirs: app build-depends:- automaton,- base >=4.16 && <4.22,- log-domain,- mmorph,- monad-bayes,- rhine, rhine-bayes,- rhine-gloss ^>=1.6,+ rhine-gloss ^>=1.7, time,- transformers - default-language: Haskell2010- default-extensions:- Arrows- DataKinds- FlexibleContexts- NamedFieldPuns- RankNTypes- TupleSections- TypeApplications- TypeFamilies- TypeOperators- ghc-options:- -W -threaded -rtsopts -with-rtsopts=-N-- if flag(dev)- ghc-options: -Werror flag dev description: Enable warnings as errors. Active on ci.
src/FRP/Rhine/Bayes.hs view
@@ -29,10 +29,11 @@ Int -> -- | Resampler (see 'Control.Monad.Bayes.PopulationT' for some standard choices) (forall x m. (MonadDistribution m) => PopulationT m x -> PopulationT 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.+ {- | 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 (PopulationT m) cl a b -> ClSF m cl a [(b, Log Double)] runPopulationCl nParticles resampler = AutomatonReader.readerS . AutomatonBayes.runPopulationS nParticles resampler . AutomatonReader.runReaderS