{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Mcmc.Mcmc
-- Description :  Framework for running Markov chain Monte Carlo samplers
-- Copyright   :  (c) Dominik Schrempf, 2020
-- 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.RWS.CPS
import Control.Monad.Trans.Reader
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Maybe
import Data.Time.Clock
import Mcmc.Algorithm
import Mcmc.Environment
import Mcmc.Monitor.Time
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 IO a

msgPrepare :: BL.ByteString -> BL.ByteString -> BL.ByteString
msgPrepare :: ByteString -> ByteString -> ByteString
msgPrepare ByteString
pref ByteString
msg = ByteString -> [ByteString] -> ByteString
BL.intercalate ByteString
"\n" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> ByteString
BL.append ByteString
pref) ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BL.lines ByteString
msg

-- Write to standard output and log file.
mcmcOutB :: BL.ByteString -> BL.ByteString -> MCMC ()
mcmcOutB :: ByteString -> ByteString -> MCMC ()
mcmcOutB ByteString
pref ByteString
msg = do
  Handle
h <- Handle -> Maybe Handle -> Handle
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Handle
forall a. HasCallStack => [Char] -> a
error [Char]
"mcmcOut: Log handle is missing.") (Maybe Handle -> Handle)
-> ReaderT Environment IO (Maybe Handle)
-> ReaderT Environment IO Handle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Environment -> Maybe Handle)
-> ReaderT Environment IO (Maybe Handle)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment -> Maybe Handle
logHandle
  IO () -> MCMC ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MCMC ()) -> IO () -> MCMC ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
BL.putStrLn ByteString
msg' IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
h ByteString
msg'
  where
    msg' :: ByteString
msg' = ByteString -> ByteString -> ByteString
msgPrepare ByteString
pref ByteString
msg

-- -- Perform warning action.
-- mcmcWarnA :: MCMC a () -> MCMC a ()
-- mcmcWarnA a = reader (verbosity . settings) >>= \v -> when (v >= Warn) a

-- -- Print warning message.
-- mcmcWarnB :: BL.ByteString -> MCMC a ()
-- mcmcWarnB = mcmcWarnA . mcmcOutB . msgPrepare 'W'

-- -- Print warning message.
-- mcmcWarnS :: String -> MCMC a ()
-- mcmcWarnS = mcmcWarnB . BL.pack

-- Perform info action.
mcmcInfoA :: MCMC () -> MCMC ()
mcmcInfoA :: MCMC () -> MCMC ()
mcmcInfoA MCMC ()
a = (Environment -> Verbosity) -> ReaderT Environment IO Verbosity
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader (Settings -> Verbosity
sVerbosity (Settings -> Verbosity)
-> (Environment -> Settings) -> Environment -> Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment -> Settings
settings) ReaderT Environment IO Verbosity
-> (Verbosity -> MCMC ()) -> MCMC ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Verbosity
v -> Bool -> MCMC () -> MCMC ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Info) MCMC ()
a

-- Print info message.
mcmcInfoB :: BL.ByteString -> MCMC ()
mcmcInfoB :: ByteString -> MCMC ()
mcmcInfoB = MCMC () -> MCMC ()
mcmcInfoA (MCMC () -> MCMC ())
-> (ByteString -> MCMC ()) -> ByteString -> MCMC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> MCMC ()
mcmcOutB ByteString
"I: "

-- Print info message.
mcmcInfoS :: String -> MCMC ()
mcmcInfoS :: [Char] -> MCMC ()
mcmcInfoS = ByteString -> MCMC ()
mcmcInfoB (ByteString -> MCMC ())
-> ([Char] -> ByteString) -> [Char] -> MCMC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
BL.pack

-- Perform debug action.
mcmcDebugA :: MCMC () -> MCMC ()
mcmcDebugA :: MCMC () -> MCMC ()
mcmcDebugA MCMC ()
a = (Environment -> Verbosity) -> ReaderT Environment IO Verbosity
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader (Settings -> Verbosity
sVerbosity (Settings -> Verbosity)
-> (Environment -> Settings) -> Environment -> Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment -> Settings
settings) ReaderT Environment IO Verbosity
-> (Verbosity -> MCMC ()) -> MCMC ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Verbosity
v -> Bool -> MCMC () -> MCMC ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Debug) MCMC ()
a

-- Print debug message.
mcmcDebugB :: BL.ByteString -> MCMC ()
mcmcDebugB :: ByteString -> MCMC ()
mcmcDebugB = MCMC () -> MCMC ()
mcmcDebugA (MCMC () -> MCMC ())
-> (ByteString -> MCMC ()) -> ByteString -> MCMC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> MCMC ()
mcmcOutB ByteString
"D: "

-- Print debug message.
mcmcDebugS :: String -> MCMC ()
mcmcDebugS :: [Char] -> MCMC ()
mcmcDebugS = ByteString -> MCMC ()
mcmcDebugB (ByteString -> MCMC ())
-> ([Char] -> ByteString) -> [Char] -> MCMC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
BL.pack

mcmcReportTime :: MCMC ()
mcmcReportTime :: MCMC ()
mcmcReportTime = do
  ByteString -> MCMC ()
mcmcDebugB ByteString
"Report time."
  UTCTime
ti <- (Environment -> UTCTime) -> ReaderT Environment IO UTCTime
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment -> UTCTime
startingTime
  [Char] -> MCMC ()
mcmcInfoS ([Char] -> MCMC ()) -> [Char] -> MCMC ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Starting time of MCMC sampler: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> UTCTime -> [Char]
forall t. FormatTime t => t -> [Char]
renderTime UTCTime
ti

mcmcExecute :: Algorithm a => a -> MCMC a
mcmcExecute :: a -> MCMC a
mcmcExecute a
a = do
  ByteString -> MCMC ()
mcmcDebugB ByteString
"Executing MCMC run."
  Settings
s <- (Environment -> Settings) -> ReaderT Environment IO Settings
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment -> Settings
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 -> MCMC ()
mcmcDebugB ByteString
"Executed MCMC run."
  a -> MCMC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a'

-- Reset acceptance counts.
mcmcResetAcceptance :: Algorithm a => a -> MCMC a
mcmcResetAcceptance :: a -> MCMC a
mcmcResetAcceptance a
a = do
  ByteString -> MCMC ()
mcmcDebugB 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

-- Execute the monitors of the chain.
mcmcExecuteMonitors :: Algorithm a => a -> MCMC ()
mcmcExecuteMonitors :: a -> MCMC ()
mcmcExecuteMonitors a
a = do
  Environment
e <- ReaderT Environment IO Environment
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let s :: Settings
s = Environment -> Settings
settings Environment
e
      vb :: Verbosity
vb = Settings -> Verbosity
sVerbosity Settings
s
      t0 :: UTCTime
t0 = Environment -> UTCTime
startingTime Environment
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 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 -> MCMC ()) -> MCMC ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ByteString
mStdLog (ByteString -> ByteString -> MCMC ()
mcmcOutB 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) -> Environment -> ParallelizationMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment -> Settings
settings (Environment -> ParallelizationMode)
-> ReaderT Environment IO Environment
-> ReaderT Environment IO ParallelizationMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Environment IO Environment
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 -> MCMC ()
forall a. Algorithm a => a -> MCMC ()
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) -> ReaderT Environment IO Settings
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment -> Settings
settings
  ByteString -> MCMC ()
mcmcInfoB ByteString
"Start new MCMC sampler."
  ByteString -> MCMC ()
mcmcInfoB ByteString
"Initial state."
  ByteString -> MCMC ()
mcmcInfoB (ByteString -> MCMC ()) -> ByteString -> MCMC ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aStdMonitorHeader a
a
  a -> MCMC ()
forall a. Algorithm a => a -> MCMC ()
mcmcExecuteMonitors a
a
  ByteString -> MCMC ()
mcmcInfoB (ByteString -> MCMC ()) -> ByteString -> MCMC ()
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
  a
a'' <- a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcResetAcceptance 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] -> MCMC ()
mcmcInfoS ([Char] -> MCMC ()) -> [Char] -> MCMC ()
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 -> MCMC ()
mcmcInfoB (ByteString -> MCMC ()) -> ByteString -> MCMC ()
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) -> ReaderT Environment IO Settings
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment -> Settings
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 -> MCMC ()
mcmcInfoB ByteString
"Continuation of MCMC sampler."
  let iCurrent :: Int
iCurrent = a -> Int
forall a. Algorithm a => a -> Int
aIteration a
a
  [Char] -> MCMC ()
mcmcInfoS ([Char] -> MCMC ()) -> [Char] -> MCMC ()
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] -> MCMC ()
mcmcInfoS ([Char] -> MCMC ()) -> [Char] -> MCMC ()
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 -> MCMC ()
mcmcInfoB (ByteString -> MCMC ()) -> ByteString -> MCMC ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aSummarizeCycle a
a
  [Char] -> MCMC ()
mcmcInfoS ([Char] -> MCMC ()) -> [Char] -> MCMC ()
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 -> MCMC ()
mcmcInfoB (ByteString -> MCMC ()) -> ByteString -> MCMC ()
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) -> ReaderT Environment IO Settings
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment -> Settings
settings
  case Settings -> BurnInSpecification
sBurnIn Settings
s of
    BurnInSpecification
NoBurnIn -> do
      [Char] -> MCMC ()
mcmcInfoS [Char]
"No burn in."
      a -> MCMC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    BurnInWithoutAutoTuning Int
n -> do
      [Char] -> MCMC ()
mcmcInfoS ([Char] -> MCMC ()) -> [Char] -> MCMC ()
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] -> MCMC ()
mcmcInfoS [Char]
"Auto tuning is disabled."
      ByteString -> MCMC ()
mcmcInfoB (ByteString -> MCMC ()) -> ByteString -> MCMC ()
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 -> MCMC ()
mcmcInfoB (ByteString -> MCMC ()) -> ByteString -> MCMC ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aSummarizeCycle a
a'
      ByteString -> MCMC ()
mcmcInfoB 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] -> MCMC ()
mcmcInfoS ([Char] -> MCMC ()) -> [Char] -> MCMC ()
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] -> MCMC ()
mcmcInfoS ([Char] -> MCMC ()) -> [Char] -> MCMC ()
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 -> MCMC ()
mcmcInfoB (ByteString -> MCMC ()) -> ByteString -> MCMC ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aStdMonitorHeader a
a
      a
a' <- Int -> Int -> a -> MCMC a
forall a. Algorithm a => Int -> Int -> a -> MCMC a
mcmcBurnInWithAutoTuning Int
n Int
t a
a
      ByteString -> MCMC ()
mcmcInfoB 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 -> MCMC ()
mcmcDebugB 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 -> Int -> a -> MCMC a
mcmcBurnInWithAutoTuning :: Int -> Int -> a -> MCMC a
mcmcBurnInWithAutoTuning Int
b Int
t a
a
  | Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
t = do
    a
a' <- a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcResetAcceptance a
a
    a
a'' <- Int -> a -> MCMC a
forall a. Algorithm a => Int -> a -> MCMC a
mcmcIterate Int
t a
a'
    ByteString -> MCMC ()
mcmcDebugB (ByteString -> MCMC ()) -> ByteString -> MCMC ()
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
mcmcAutotune a
a''
    ByteString -> MCMC ()
mcmcDebugB (ByteString -> MCMC ()) -> ByteString -> MCMC ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aStdMonitorHeader a
a''
    Int -> Int -> a -> MCMC a
forall a. Algorithm a => Int -> Int -> a -> MCMC a
mcmcBurnInWithAutoTuning (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
t) Int
t a
a'''
  | Bool
otherwise = do
    a
a' <- a -> MCMC a
forall a. Algorithm a => a -> MCMC a
mcmcResetAcceptance a
a
    a
a'' <- Int -> a -> MCMC a
forall a. Algorithm a => Int -> a -> MCMC a
mcmcIterate Int
b a
a'
    ByteString -> MCMC ()
mcmcInfoB (ByteString -> MCMC ()) -> ByteString -> MCMC ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aSummarizeCycle a
a''
    [Char] -> MCMC ()
mcmcInfoS ([Char] -> MCMC ()) -> [Char] -> MCMC ()
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
b [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" iterations."
    a -> MCMC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a''

mcmcInitialize :: Algorithm a => a -> MCMC a
mcmcInitialize :: a -> MCMC a
mcmcInitialize a
a = do
  [Char] -> MCMC ()
mcmcInfoS ([Char] -> MCMC ()) -> [Char] -> MCMC ()
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 (Environment -> Settings)
-> ReaderT Environment IO Environment
-> ReaderT Environment IO Settings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Environment IO Environment
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  ByteString -> MCMC ()
mcmcDebugB 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 -> MCMC ()
mcmcDebugB 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 -> MCMC ()
mcmcSave a
a = do
  Settings
s <- (Environment -> Settings) -> ReaderT Environment IO Settings
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment -> Settings
settings
  case Settings -> SaveMode
sSaveMode Settings
s of
    SaveMode
NoSave -> ByteString -> MCMC ()
mcmcInfoB ByteString
"Do not save the MCMC analysis."
    SaveMode
Save -> do
      ByteString -> MCMC ()
mcmcInfoB ByteString
"Save settings."
      IO () -> MCMC ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MCMC ()) -> IO () -> MCMC ()
forall a b. (a -> b) -> a -> b
$ Settings -> IO ()
settingsSave Settings
s
      let nm :: AnalysisName
nm = Settings -> AnalysisName
sAnalysisName Settings
s
      ByteString -> MCMC ()
mcmcInfoB ByteString
"Save compressed MCMC analysis."
      ByteString -> MCMC ()
mcmcInfoB ByteString
"For long traces, or complex objects, this may take a while."
      IO () -> MCMC ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MCMC ()) -> IO () -> MCMC ()
forall a b. (a -> b) -> a -> b
$ AnalysisName -> a -> IO ()
forall a. Algorithm a => AnalysisName -> a -> IO ()
aSave AnalysisName
nm a
a
      ByteString -> MCMC ()
mcmcInfoB ByteString
"Markov chain saved."

-- Report and finish up.
mcmcClose :: Algorithm a => a -> MCMC a
mcmcClose :: a -> MCMC a
mcmcClose a
a = do
  ByteString -> MCMC ()
mcmcDebugB ByteString
"Closing MCMC run."
  ByteString -> MCMC ()
mcmcInfoB (ByteString -> MCMC ()) -> ByteString -> MCMC ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Algorithm a => a -> ByteString
aSummarizeCycle a
a
  [Char] -> MCMC ()
mcmcInfoS ([Char] -> MCMC ()) -> [Char] -> MCMC ()
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 -> MCMC ()
forall a. Algorithm a => a -> MCMC ()
mcmcSave a
a
  UTCTime
ti <- (Environment -> UTCTime) -> ReaderT Environment IO UTCTime
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment -> UTCTime
startingTime
  UTCTime
te <- IO UTCTime -> ReaderT Environment IO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let dt :: NominalDiffTime
dt = UTCTime
te UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
ti
  ByteString -> MCMC ()
mcmcInfoB (ByteString -> MCMC ()) -> ByteString -> MCMC ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Wall clock run time: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> ByteString
renderDuration NominalDiffTime
dt ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"."
  [Char] -> MCMC ()
mcmcInfoS ([Char] -> MCMC ()) -> [Char] -> MCMC ()
forall a b. (a -> b) -> a -> b
$ [Char]
"End time: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> UTCTime -> [Char]
forall t. FormatTime t => t -> [Char]
renderTime UTCTime
te
  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
  Maybe Handle
h <- (Environment -> Maybe Handle)
-> ReaderT Environment IO (Maybe Handle)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment -> Maybe Handle
logHandle
  IO () -> MCMC ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MCMC ()) -> IO () -> MCMC ()
forall a b. (a -> b) -> a -> b
$ Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Handle
h Handle -> IO ()
hClose
  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
  ByteString -> MCMC ()
mcmcDebugB ByteString
"The settings are:"
  (Environment -> Settings) -> ReaderT Environment IO Settings
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader Environment -> Settings
settings ReaderT Environment IO Settings -> (Settings -> MCMC ()) -> MCMC ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> MCMC ()
mcmcDebugS ([Char] -> MCMC ()) -> (Settings -> [Char]) -> Settings -> MCMC ()
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
  MCMC ()
mcmcReportTime

  -- 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
e <- Settings -> IO Environment
initializeEnvironment Settings
s
  ReaderT Environment IO a -> Environment -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> ReaderT Environment IO a
forall a. Algorithm a => a -> MCMC a
mcmcRun a
a) Environment
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.
--
-- See:
--
-- - 'Mcmc.Algorithm.Metropolis.mhgLoad'
--
-- - 'Mcmc.Algorithm.MC3.mc3Load'
mcmcContinue :: Algorithm a => Int -> Settings -> a -> IO a
mcmcContinue :: Int -> Settings -> a -> IO a
mcmcContinue Int
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
+ Int
dn
    s' :: Settings
s' = Settings
s {sIterations :: Iterations
sIterations = Iterations
n', sExecutionMode :: ExecutionMode
sExecutionMode = ExecutionMode
Continue}