commit 64980319e28090170cfc37a735e100e7590d0c69
parent 6ba12a5b1d704f5dcb578bbe7ef1324264bcea33
Author: Jared Tobin <jared@jtobin.ca>
Date: Mon, 7 Nov 2016 22:06:51 +1300
Add annealing operator.
Diffstat:
3 files changed, 41 insertions(+), 2 deletions(-)
diff --git a/declarative.cabal b/declarative.cabal
@@ -1,5 +1,5 @@
name: declarative
-version: 0.2.3
+version: 0.3.3
synopsis: DIY Markov Chains.
homepage: http://github.com/jtobin/declarative
license: MIT
@@ -58,7 +58,8 @@ library
default-language: Haskell2010
hs-source-dirs: lib
exposed-modules:
- Numeric.MCMC
+ Numeric.MCMC
+ , Numeric.MCMC.Anneal
build-depends:
base >= 4 && < 6
, mcmc-types >= 1.0.1
diff --git a/lib/Numeric/MCMC.hs b/lib/Numeric/MCMC.hs
@@ -67,6 +67,7 @@ module Numeric.MCMC (
, sampleAllT
, bernoulliT
, frequency
+ , anneal
, mcmc
-- * Re-exported
@@ -89,6 +90,7 @@ module Numeric.MCMC (
import Control.Monad.Primitive (PrimMonad, PrimState, RealWorld)
import Control.Monad.Trans.State.Strict (execStateT)
import Data.Sampling.Types
+import Numeric.MCMC.Anneal
import Numeric.MCMC.Metropolis hiding (mcmc)
import Numeric.MCMC.Hamiltonian hiding (mcmc)
import Numeric.MCMC.Slice hiding (mcmc)
diff --git a/lib/Numeric/MCMC/Anneal.hs b/lib/Numeric/MCMC/Anneal.hs
@@ -0,0 +1,36 @@
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Numeric.MCMC.Anneal (
+ anneal
+ ) where
+
+import Control.Monad.Trans.State.Strict (get, modify)
+import Data.Sampling.Types (Transition, Chain(..), Target(..))
+
+anneal
+ :: (Monad m, Functor f)
+ => Double
+ -> Transition m (Chain (f Double) b)
+ -> Transition m (Chain (f Double) b)
+anneal invTemp baseTransition
+ | invTemp < 0 = error "anneal: invalid temperture"
+ | otherwise = do
+ Chain {..} <- get
+ let annealedTarget = annealer invTemp chainTarget
+ modify $ useTarget annealedTarget
+ baseTransition
+ modify $ useTarget chainTarget
+
+annealer :: Functor f => Double -> Target (f Double) -> Target (f Double)
+annealer invTemp target = Target annealedL annealedG where
+ annealedL xs = invTemp * lTarget target xs
+ annealedG =
+ case glTarget target of
+ Nothing -> Nothing
+ Just g -> Just (fmap (* invTemp) . g)
+
+useTarget :: Target a -> Chain a b -> Chain a b
+useTarget newTarget Chain {..} =
+ Chain newTarget (lTarget newTarget chainPosition) chainPosition chainTunables
+