{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Mcmc.Mcmc
-- Description :  Framework for running Markov chain Monte Carlo samplers
-- Copyright   :  (c) Dominik Schrempf, 2021
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Fri May 29 10:19:45 2020.
--
-- This module provides the general framework for running MCMC samplers. By
-- design choice this module is agnostic about the details of the used
-- 'Algorithm'.
module Mcmc.Mcmc
  ( mcmc,
    mcmcContinue,
  )
where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Mcmc.Algorithm
import Mcmc.Environment
import Mcmc.Logger
import Mcmc.Settings
import System.IO
import Text.Show.Pretty
import Prelude hiding (cycle)

-- The MCMC algorithm has read access to an environment and uses an algorithm
-- transforming the state @a@.
type MCMC a = ReaderT (Environment Settings) IO a

mcmcExecute :: Algorithm a => a -> MCMC a
mcmcExecute :: a -> MCMC a
mcmcExecute a
a = do
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"Executing MCMC run."
  Settings
s <- (Environment Settings -> Settings)
-> ReaderT (Environment Settings) IO Settings
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment Settings -> Settings
forall s. Environment s -> s
settings
  a
a' <- case Settings -> ExecutionMode
sExecutionMode Settings
s of
    ExecutionMode
Fail -> a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcNewRun a
a
    ExecutionMode
Overwrite -> a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcNewRun a
a
    ExecutionMode
Continue -> a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcContinueRun a
a
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"Executed MCMC run."
  a -> MCMC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a'

mcmcResetAcceptance :: Algorithm a => a -> MCMC a
mcmcResetAcceptance :: a -> MCMC a
mcmcResetAcceptance a
a = do
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"Reset acceptance rates."
  a -> MCMC a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> MCMC a) -> a -> MCMC a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Algorithm a => a -> a
aResetAcceptance a
a

mcmcExecuteMonitors :: Algorithm a => a -> MCMC ()
mcmcExecuteMonitors :: a -> Logger (Environment Settings) ()
mcmcExecuteMonitors a
a = do
  Environment Settings
e <- ReaderT (Environment Settings) IO (Environment Settings)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let s :: Settings
s = Environment Settings -> Settings
forall s. Environment s -> s
settings Environment Settings
e
      vb :: Verbosity
vb = Settings -> Verbosity
sVerbosity Settings
s
      t0 :: UTCTime
t0 = Environment Settings -> UTCTime
forall s. Environment s -> UTCTime
startingTime Environment Settings
e
      iTotal :: Int
iTotal = BurnInSpecification -> Int
burnInIterations (Settings -> BurnInSpecification
sBurnIn Settings
s) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Iterations -> Int
fromIterations (Settings -> Iterations
sIterations Settings
s)
  Maybe ByteString
mStdLog <- IO (Maybe ByteString)
-> ReaderT (Environment Settings) IO (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Verbosity -> UTCTime -> Int -> a -> IO (Maybe ByteString)
forall a.
Algorithm a =>
Verbosity -> UTCTime -> Int -> a -> IO (Maybe ByteString)
aExecuteMonitors Verbosity
vb UTCTime
t0 Int
iTotal a
a)
  Maybe ByteString
-> (ByteString -> Logger (Environment Settings) ())
-> Logger (Environment Settings) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ByteString
mStdLog (ByteString -> ByteString -> Logger (Environment Settings) ()
forall e.
(HasLogHandles e, HasLock e) =>
ByteString -> ByteString -> Logger e ()
logOutB ByteString
"   ")

mcmcIterate :: Algorithm a => Int -> a -> MCMC a
mcmcIterate :: Int -> a -> MCMC a
mcmcIterate Int
n a
a
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = [Char] -> MCMC a
forall a. HasCallStack => [Char] -> a
error [Char]
"mcmcIterate: Number of iterations is negative."
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = a -> MCMC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  | Bool
otherwise = do
    ParallelizationMode
p <- Settings -> ParallelizationMode
sParallelizationMode (Settings -> ParallelizationMode)
-> (Environment Settings -> Settings)
-> Environment Settings
-> ParallelizationMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment Settings -> Settings
forall s. Environment s -> s
settings (Environment Settings -> ParallelizationMode)
-> ReaderT (Environment Settings) IO (Environment Settings)
-> ReaderT (Environment Settings) IO ParallelizationMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Environment Settings) IO (Environment Settings)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    a
a' <- IO a -> MCMC a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> MCMC a) -> IO a -> MCMC a
forall a b. (a -> b) -> a -> b
$ ParallelizationMode -> a -> IO a
forall a. Algorithm a => ParallelizationMode -> a -> IO a
aIterate ParallelizationMode
p a
a
    a -> Logger (Environment Settings) ()
forall a. Algorithm a => a -> Logger (Environment Settings) ()
mcmcExecuteMonitors a
a'
    Int -> a -> MCMC a
forall a. Algorithm a => Int -> a -> MCMC a
mcmcIterate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) a
a'

mcmcNewRun :: Algorithm a => a -> MCMC a
mcmcNewRun :: a -> MCMC a
mcmcNewRun a
a = do
  Settings
s <- (Environment Settings -> Settings)
-> ReaderT (Environment Settings) IO Settings
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment Settings -> Settings
forall s. Environment s -> s
settings
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"Start new MCMC sampler."
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"Initial state."
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB (ByteString -> Logger (Environment Settings) ())
-> ByteString -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aStdMonitorHeader a
a
  a -> Logger (Environment Settings) ()
forall a. Algorithm a => a -> Logger (Environment Settings) ()
mcmcExecuteMonitors a
a
  Bool
-> Logger (Environment Settings) ()
-> Logger (Environment Settings) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a -> Bool
forall a. Algorithm a => a -> Bool
aIsInValidState a
a) (ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logWarnB ByteString
"The initial state is invalid!")
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB (ByteString -> Logger (Environment Settings) ())
-> ByteString -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aSummarizeCycle a
a
  a
a' <- a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcBurnIn a
a
  let i :: Int
i = Iterations -> Int
fromIterations (Iterations -> Int) -> Iterations -> Int
forall a b. (a -> b) -> a -> b
$ Settings -> Iterations
sIterations Settings
s
  [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment Settings) ())
-> [Char] -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Run chain for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" iterations."
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB (ByteString -> Logger (Environment Settings) ())
-> ByteString -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aStdMonitorHeader a
a'
  Int -> a -> MCMC a
forall a. Algorithm a => Int -> a -> MCMC a
mcmcIterate Int
i a
a'

mcmcContinueRun :: Algorithm a => a -> MCMC a
mcmcContinueRun :: a -> MCMC a
mcmcContinueRun a
a = do
  Settings
s <- (Environment Settings -> Settings)
-> ReaderT (Environment Settings) IO Settings
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment Settings -> Settings
forall s. Environment s -> s
settings
  let iTotal :: Int
iTotal = Iterations -> Int
fromIterations (Settings -> Iterations
sIterations Settings
s) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ BurnInSpecification -> Int
burnInIterations (Settings -> BurnInSpecification
sBurnIn Settings
s)
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"Continuation of MCMC sampler."
  let iCurrent :: Int
iCurrent = a -> Int
forall a. Algorithm a => a -> Int
aIteration a
a
  [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment Settings) ())
-> [Char] -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Current iteration: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
iCurrent [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
  [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment Settings) ())
-> [Char] -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Total iterations: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
iTotal [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
  let di :: Int
di = Int
iTotal Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
iCurrent
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB (ByteString -> Logger (Environment Settings) ())
-> ByteString -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aSummarizeCycle a
a
  [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment Settings) ())
-> [Char] -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Run chain for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
di [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" iterations."
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB (ByteString -> Logger (Environment Settings) ())
-> ByteString -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aStdMonitorHeader a
a
  Int -> a -> MCMC a
forall a. Algorithm a => Int -> a -> MCMC a
mcmcIterate Int
di a
a

mcmcBurnIn :: Algorithm a => a -> MCMC a
mcmcBurnIn :: a -> MCMC a
mcmcBurnIn a
a = do
  Settings
s <- (Environment Settings -> Settings)
-> ReaderT (Environment Settings) IO Settings
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment Settings -> Settings
forall s. Environment s -> s
settings
  case Settings -> BurnInSpecification
sBurnIn Settings
s of
    BurnInSpecification
NoBurnIn -> do
      [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"No burn in."
      a -> MCMC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    BurnInWithoutAutoTuning Int
n -> do
      [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment Settings) ())
-> [Char] -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Burn in for " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" iterations."
      [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS [Char]
"Auto tuning is disabled."
      ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB (ByteString -> Logger (Environment Settings) ())
-> ByteString -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aStdMonitorHeader a
a
      a
a' <- Int -> a -> MCMC a
forall a. Algorithm a => Int -> a -> MCMC a
mcmcIterate Int
n a
a
      ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB (ByteString -> Logger (Environment Settings) ())
-> ByteString -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aSummarizeCycle a
a'
      a
a'' <- a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcResetAcceptance a
a'
      ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"Burn in finished."
      a -> MCMC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a''
    BurnInWithAutoTuning Int
n Int
t -> do
      [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment Settings) ())
-> [Char] -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Burn in for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" iterations."
      [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment Settings) ())
-> [Char] -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Auto tuning is enabled with a period of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
      ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB (ByteString -> Logger (Environment Settings) ())
-> ByteString -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aStdMonitorHeader a
a
      let (Int
m, Int
r) = Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
t
          -- Don't add if 0. Because then we auto tune without acceptance counts
          -- and get NaNs.
          xs :: [Int]
xs = Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
m Int
t [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> [Int
r | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0]
      a
a' <- [Int] -> a -> MCMC a
forall a. Algorithm a => [Int] -> a -> MCMC a
mcmcBurnInWithAutoTuning [Int]
xs a
a
      ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"Burn in finished."
      a -> MCMC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a'
    BurnInWithCustomAutoTuning [Int]
xs -> do
      [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment Settings) ())
-> [Char] -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Burn in for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
xs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" iterations."
      [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment Settings) ())
-> [Char] -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Custom auto tuning is enabled with periods " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show [Int]
xs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
      ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB (ByteString -> Logger (Environment Settings) ())
-> ByteString -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aStdMonitorHeader a
a
      a
a' <- [Int] -> a -> MCMC a
forall a. Algorithm a => [Int] -> a -> MCMC a
mcmcBurnInWithAutoTuning [Int]
xs a
a
      ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"Burn in finished."
      a -> MCMC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a'

-- Auto tune the proposals.
mcmcAutotune :: Algorithm a => a -> MCMC a
mcmcAutotune :: a -> MCMC a
mcmcAutotune a
a = do
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"Auto tune."
  a -> MCMC a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> MCMC a) -> a -> MCMC a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Algorithm a => a -> a
aAutoTune a
a

mcmcBurnInWithAutoTuning :: Algorithm a => [Int] -> a -> MCMC a
mcmcBurnInWithAutoTuning :: [Int] -> a -> MCMC a
mcmcBurnInWithAutoTuning [] a
_ = [Char] -> MCMC a
forall a. HasCallStack => [Char] -> a
error [Char]
"mcmcBurnInWithAutoTuning: Empty lisst."
mcmcBurnInWithAutoTuning [Int
x] a
a = do
  -- Last round.
  a
a' <- Int -> a -> MCMC a
forall a. Algorithm a => Int -> a -> MCMC a
mcmcIterate Int
x a
a
  a
a'' <- a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcAutotune a
a'
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB (ByteString -> Logger (Environment Settings) ())
-> ByteString -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aSummarizeCycle a
a''
  [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment Settings) ())
-> [Char] -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Acceptance rates calculated over the last " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" iterations."
  a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcResetAcceptance a
a''
mcmcBurnInWithAutoTuning (Int
x:[Int]
xs) a
a = do
  a
a' <- Int -> a -> MCMC a
forall a. Algorithm a => Int -> a -> MCMC a
mcmcIterate Int
x a
a
  a
a'' <- a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcAutotune a
a'
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB (ByteString -> Logger (Environment Settings) ())
-> ByteString -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aSummarizeCycle a
a''
  [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logDebugS ([Char] -> Logger (Environment Settings) ())
-> [Char] -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Acceptance rates calculated over the last " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" iterations."
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB (ByteString -> Logger (Environment Settings) ())
-> ByteString -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aStdMonitorHeader a
a''
  a
a''' <- a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcResetAcceptance a
a''
  [Int] -> a -> MCMC a
forall a. Algorithm a => [Int] -> a -> MCMC a
mcmcBurnInWithAutoTuning [Int]
xs a
a'''

mcmcInitialize :: Algorithm a => a -> MCMC a
mcmcInitialize :: a -> MCMC a
mcmcInitialize a
a = do
  [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment Settings) ())
-> [Char] -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> [Char]
forall a. Algorithm a => a -> [Char]
aName a
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" algorithm."
  Settings
s <- Environment Settings -> Settings
forall s. Environment s -> s
settings (Environment Settings -> Settings)
-> ReaderT (Environment Settings) IO (Environment Settings)
-> ReaderT (Environment Settings) IO Settings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Environment Settings) IO (Environment Settings)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"Opening monitors."
  a
a' <- IO a -> MCMC a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> MCMC a) -> IO a -> MCMC a
forall a b. (a -> b) -> a -> b
$ AnalysisName -> ExecutionMode -> a -> IO a
forall a. Algorithm a => AnalysisName -> ExecutionMode -> a -> IO a
aOpenMonitors (Settings -> AnalysisName
sAnalysisName Settings
s) (Settings -> ExecutionMode
sExecutionMode Settings
s) a
a
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"Monitors opened."
  a -> MCMC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a'

-- Save the MCMC run.
mcmcSave :: Algorithm a => a -> MCMC ()
mcmcSave :: a -> Logger (Environment Settings) ()
mcmcSave a
a = do
  Settings
s <- (Environment Settings -> Settings)
-> ReaderT (Environment Settings) IO Settings
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment Settings -> Settings
forall s. Environment s -> s
settings
  case Settings -> SaveMode
sSaveMode Settings
s of
    SaveMode
NoSave -> ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"Do not save the MCMC analysis."
    SaveMode
Save -> do
      ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"Save settings."
      IO () -> Logger (Environment Settings) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment Settings) ())
-> IO () -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ Settings -> IO ()
settingsSave Settings
s
      let nm :: AnalysisName
nm = Settings -> AnalysisName
sAnalysisName Settings
s
      ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"Save compressed MCMC analysis."
      ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"For long traces, or complex objects, this may take a while."
      IO () -> Logger (Environment Settings) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment Settings) ())
-> IO () -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ AnalysisName -> a -> IO ()
forall a. Algorithm a => AnalysisName -> a -> IO ()
aSave AnalysisName
nm a
a
      ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"Markov chain saved."

-- Report and finish up.
mcmcClose :: Algorithm a => a -> MCMC a
mcmcClose :: a -> MCMC a
mcmcClose a
a = do
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"Closing MCMC run."
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB (ByteString -> Logger (Environment Settings) ())
-> ByteString -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aSummarizeCycle a
a
  [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logInfoS ([Char] -> Logger (Environment Settings) ())
-> [Char] -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ a -> [Char]
forall a. Algorithm a => a -> [Char]
aName a
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" algorithm finished."
  a -> Logger (Environment Settings) ()
forall a. Algorithm a => a -> Logger (Environment Settings) ()
mcmcSave a
a
  Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) =>
Logger e ()
logInfoEndTime
  a
a' <- IO a -> MCMC a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> MCMC a) -> IO a -> MCMC a
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. Algorithm a => a -> IO a
aCloseMonitors a
a
  Environment Settings
e <- ReaderT (Environment Settings) IO (Environment Settings)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO () -> Logger (Environment Settings) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Logger (Environment Settings) ())
-> IO () -> Logger (Environment Settings) ()
forall a b. (a -> b) -> a -> b
$ Environment Settings -> IO ()
forall s. Environment s -> IO ()
closeEnvironment Environment Settings
e
  a -> MCMC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a'

-- Initialize the run, execute the run, and close the run.
mcmcRun :: Algorithm a => a -> MCMC a
mcmcRun :: a -> MCMC a
mcmcRun a
a = do
  Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
Logger e ()
logInfoHeader

  -- Debug settings.
  ByteString -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"The MCMC settings are:"
  (Environment Settings -> Settings)
-> ReaderT (Environment Settings) IO Settings
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment Settings -> Settings
forall s. Environment s -> s
settings ReaderT (Environment Settings) IO Settings
-> (Settings -> Logger (Environment Settings) ())
-> Logger (Environment Settings) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
[Char] -> Logger e ()
logDebugS ([Char] -> Logger (Environment Settings) ())
-> (Settings -> [Char])
-> Settings
-> Logger (Environment Settings) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> [Char]
forall a. Show a => a -> [Char]
ppShow

  -- Initialize.
  a
a' <- a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcInitialize a
a
  Logger (Environment Settings) ()
forall e.
(HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) =>
Logger e ()
logInfoStartingTime

  -- Execute.
  a
a'' <- a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcExecute a
a'

  -- Close.
  a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcClose a
a''

-- | Run an MCMC algorithm with given settings.
mcmc :: Algorithm a => Settings -> a -> IO a
mcmc :: Settings -> a -> IO a
mcmc Settings
s a
a = do
  Settings -> Int -> IO ()
settingsCheck Settings
s (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Algorithm a => a -> Int
aIteration a
a
  Environment Settings
e <- Settings -> IO (Environment Settings)
forall s.
(HasAnalysisName s, HasExecutionMode s, HasLogMode s,
 HasVerbosity s) =>
s -> IO (Environment s)
initializeEnvironment Settings
s
  ReaderT (Environment Settings) IO a -> Environment Settings -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT (Environment Settings) IO a
forall a. Algorithm a => a -> MCMC a
mcmcRun a
a) Environment Settings
e

-- | Continue an MCMC algorithm for the given number of iterations.
--
-- Currently, it is only possible to continue MCMC algorithms that have
-- completed successfully. This restriction is necessary, because for parallel
-- chains, it is hardly possible to ensure all chains are synchronized when the
-- process is killed or fails.
--
-- See:
--
-- - 'Mcmc.Algorithm.MHG.mhgLoad'
--
-- - 'Mcmc.Algorithm.MC3.mc3Load'
mcmcContinue :: Algorithm a => Iterations -> Settings -> a -> IO a
mcmcContinue :: Iterations -> Settings -> a -> IO a
mcmcContinue Iterations
dn Settings
s = Settings -> a -> IO a
forall a. Algorithm a => Settings -> a -> IO a
mcmc Settings
s'
  where
    n' :: Iterations
n' = Int -> Iterations
Iterations (Int -> Iterations) -> Int -> Iterations
forall a b. (a -> b) -> a -> b
$ Iterations -> Int
fromIterations (Settings -> Iterations
sIterations Settings
s) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Iterations -> Int
fromIterations Iterations
dn
    s' :: Settings
s' = Settings
s {sIterations :: Iterations
sIterations = Iterations
n', sExecutionMode :: ExecutionMode
sExecutionMode = ExecutionMode
Continue}