declarative

commit 64980319e28090170cfc37a735e100e7590d0c69
parent 6ba12a5b1d704f5dcb578bbe7ef1324264bcea33
Author: Jared Tobin <jared@jtobin.ca>
Date:   Mon,  7 Nov 2016 22:06:51 +1300

Add annealing operator.

Diffstat:
M
declarative.cabal
 | 
5
+++--
M
lib/Numeric/MCMC.hs
 | 
2
++
A
lib/Numeric/MCMC/Anneal.hs
 | 
36
++++++++++++++++++++++++++++++++++++

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
+