{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Mcmc.Mcmc
-- Description :  Framework for running Markov chain Monte Carlo samplers
-- Copyright   :  2021 Dominik Schrempf
-- 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.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Mcmc.Algorithm
import Mcmc.Cycle
import Mcmc.Environment
import Mcmc.Logger
import Mcmc.Proposal (TuningType (LastTuningStep, NormalTuningStep))
import Mcmc.Settings
import System.IO
import Prelude hiding (cycle)

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

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

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

mcmcExceptionHandler :: Algorithm a => Environment Settings -> a -> AsyncException -> IO b
mcmcExceptionHandler :: forall a b.
Algorithm a =>
Environment Settings -> a -> AsyncException -> IO b
mcmcExceptionHandler Environment Settings
e a
a AsyncException
err = do
  a
_ <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Environment Settings) IO a
action Environment Settings
e
  String -> IO ()
putStrLn String
"Graceful termination successful."
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Rethrowing error: " forall a. Semigroup a => a -> a -> a
<> forall e. Exception e => e -> String
displayException AsyncException
err forall a. Semigroup a => a -> a -> a
<> String
"."
  forall e a. Exception e => e -> IO a
throwIO AsyncException
err
  where
    action :: ReaderT (Environment Settings) IO a
action = do
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logWarnS String
"INTERRUPT!"
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logWarnS String
"Trying to terminate gracefully and to save chain for continuation."
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logWarnS String
"Press CTRL-C (again) to terminate now."
      forall a. Algorithm a => a -> MCMC a
mcmcClose a
a

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

mcmcIterate :: Algorithm a => IterationMode -> Int -> a -> MCMC a
mcmcIterate :: forall a. Algorithm a => IterationMode -> Int -> a -> MCMC a
mcmcIterate IterationMode
m Int
n a
a
  | Int
n forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. HasCallStack => String -> a
error String
"mcmcIterate: Number of iterations is negative."
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  | Bool
otherwise = do
      Environment Settings
e <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      let p :: ParallelizationMode
p = Settings -> ParallelizationMode
sParallelizationMode forall a b. (a -> b) -> a -> b
$ forall s. Environment s -> s
settings Environment Settings
e
      -- NOTE: Handle interrupts during iterations, before writing monitors,
      -- using the old algorithm state @a@.
      let handlerOld :: AsyncException -> IO b
handlerOld = forall a b.
Algorithm a =>
Environment Settings -> a -> AsyncException -> IO b
mcmcExceptionHandler Environment Settings
e a
a
          actionIterate :: IO a
actionIterate = forall a.
Algorithm a =>
IterationMode -> ParallelizationMode -> a -> IO a
aIterate IterationMode
m ParallelizationMode
p a
a
      a
a' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO a
actionIterate forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` forall {b}. AsyncException -> IO b
handlerOld
      -- NOTE: Mask asynchronous exceptions while writing monitor files. Handle
      -- interrupts after writing monitors; use the new state @a'@.
      --
      -- The problem that arises using this method is: What if executing the
      -- monitors actually throws an error (and not the user or the operating
      -- system that want to stop the chain). In this case, the chain is left in
      -- an undefined state because the monitor files are partly written; the
      -- new state is saved by the handler. However, I do not think I can
      -- recover from partly written monitor files.
      let handlerNew :: AsyncException -> IO b
handlerNew = forall a b.
Algorithm a =>
Environment Settings -> a -> AsyncException -> IO b
mcmcExceptionHandler Environment Settings
e a
a'
          actionWrite :: IO ()
actionWrite = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. Algorithm a => a -> MCMC ()
mcmcExecuteMonitors a
a') Environment Settings
e
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (forall a. IO a -> IO a
uninterruptibleMask_ IO ()
actionWrite) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` forall {b}. AsyncException -> IO b
handlerNew
      forall a. Algorithm a => IterationMode -> Int -> a -> MCMC a
mcmcIterate IterationMode
m (Int
n forall a. Num a => a -> a -> a
- Int
1) a
a'

mcmcNewRun :: Algorithm a => a -> MCMC a
mcmcNewRun :: forall a. Algorithm a => a -> MCMC a
mcmcNewRun a
a = do
  Settings
s <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader forall s. Environment s -> s
settings
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"Starting new MCMC sampler."
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"Initial state."
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB forall a b. (a -> b) -> a -> b
$ forall a. Algorithm a => a -> ByteString
aStdMonitorHeader a
a
  forall a. Algorithm a => a -> MCMC ()
mcmcExecuteMonitors a
a
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Algorithm a => a -> Bool
aIsInvalidState a
a) (forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logWarnB ByteString
"The initial state is invalid!")
  a
a' <- forall a. Algorithm a => a -> MCMC a
mcmcBurnIn a
a
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Cleaning chain after burn in."
  let tl :: TraceLength
tl = Settings -> TraceLength
sTraceLength Settings
s
  a
a'' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Algorithm a => TraceLength -> a -> IO a
aCleanAfterBurnIn TraceLength
tl a
a'
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Saving chain after burn in."
  forall a. Algorithm a => a -> MCMC ()
mcmcSave a
a''
  let i :: Int
i = Iterations -> Int
fromIterations forall a b. (a -> b) -> a -> b
$ Settings -> Iterations
sIterations Settings
s
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Running chain for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
" iterations."
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB forall a b. (a -> b) -> a -> b
$ forall a. Algorithm a => a -> ByteString
aStdMonitorHeader a
a''
  forall a. Algorithm a => IterationMode -> Int -> a -> MCMC a
mcmcIterate IterationMode
AllProposals Int
i a
a''

mcmcContinueRun :: Algorithm a => a -> MCMC a
mcmcContinueRun :: forall a. Algorithm a => a -> MCMC a
mcmcContinueRun a
a = do
  Settings
s <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader forall s. Environment s -> s
settings
  let iBurnIn :: Int
iBurnIn = BurnInSettings -> Int
burnInIterations (Settings -> BurnInSettings
sBurnIn Settings
s)
      iNormal :: Int
iNormal = Iterations -> Int
fromIterations (Settings -> Iterations
sIterations Settings
s)
      iTotal :: Int
iTotal = Int
iBurnIn forall a. Num a => a -> a -> a
+ Int
iNormal
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB ByteString
"Continuation of MCMC sampler."
  let iCurrent :: Int
iCurrent = forall a. Algorithm a => a -> Int
aIteration a
a
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Burn in iterations: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
iBurnIn forall a. [a] -> [a] -> [a]
++ String
"."
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Normal iterations: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
iNormal forall a. [a] -> [a] -> [a]
++ String
"."
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Total iterations: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
iTotal forall a. [a] -> [a] -> [a]
++ String
"."
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Current iteration: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
iCurrent forall a. [a] -> [a] -> [a]
++ String
"."
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
iCurrent forall a. Ord a => a -> a -> Bool
< Int
iBurnIn) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"mcmcContinueRun: Can not continue burn in."
  let di :: Int
di = Int
iTotal forall a. Num a => a -> a -> a
- Int
iCurrent
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB forall a b. (a -> b) -> a -> b
$ forall a. Algorithm a => IterationMode -> a -> ByteString
aSummarizeCycle IterationMode
AllProposals a
a
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Running chain for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
di forall a. [a] -> [a] -> [a]
++ String
" iterations."
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB forall a b. (a -> b) -> a -> b
$ forall a. Algorithm a => a -> ByteString
aStdMonitorHeader a
a
  forall a. Algorithm a => IterationMode -> Int -> a -> MCMC a
mcmcIterate IterationMode
AllProposals Int
di a
a

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

-- Auto tune the proposals.
mcmcAutotune :: Algorithm a => TuningType -> Int -> a -> MCMC a
mcmcAutotune :: forall a. Algorithm a => TuningType -> Int -> a -> MCMC a
mcmcAutotune TuningType
NormalTuningStep Int
n a
a = do
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"Intermediate auto tune."
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Algorithm a => TuningType -> Int -> a -> IO a
aAutoTune TuningType
NormalTuningStep Int
n a
a
mcmcAutotune TuningType
LastTuningStep Int
n a
a = do
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"Last auto tune."
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Algorithm a => TuningType -> Int -> a -> IO a
aAutoTune TuningType
LastTuningStep Int
n a
a

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

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

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

-- Report and finish up.
mcmcClose :: Algorithm a => a -> MCMC a
mcmcClose :: forall a. Algorithm a => a -> MCMC a
mcmcClose a
a = do
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS String
"Closing monitors."
  a
a' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Algorithm a => a -> IO a
aCloseMonitors a
a
  forall a. Algorithm a => a -> MCMC ()
mcmcSave a
a'
  forall e.
(HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) =>
Logger e ()
logInfoEndTime
  Environment Settings
e <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS String
"Closing environment."
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall s. Environment s -> IO ()
closeEnvironment Environment Settings
e
  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 :: forall a. Algorithm a => a -> MCMC a
mcmcRun a
a = do
  -- Header.
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
Logger e ()
logInfoHeader
  forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader forall s. Environment s -> s
settings forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> ByteString
settingsPrettyPrint

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

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

  -- Close.
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logInfoB forall a b. (a -> b) -> a -> b
$ forall a. Algorithm a => IterationMode -> a -> ByteString
aSummarizeCycle IterationMode
AllProposals a
a''
  forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ forall a. Algorithm a => a -> String
aName a
a'' forall a. [a] -> [a] -> [a]
++ String
" algorithm finished."
  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 :: forall a. Algorithm a => Settings -> a -> IO a
mcmc Settings
s a
a = do
  Settings -> Int -> IO ()
settingsCheck Settings
s forall a b. (a -> b) -> a -> b
$ forall a. Algorithm a => a -> Int
aIteration a
a
  Environment Settings
e <- forall s.
(HasAnalysisName s, HasExecutionMode s, HasLogMode s,
 HasVerbosity s) =>
s -> IO (Environment s)
initializeEnvironment Settings
s
  forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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 :: forall a. Algorithm a => Iterations -> Settings -> a -> IO a
mcmcContinue Iterations
dn Settings
s = forall a. Algorithm a => Settings -> a -> IO a
mcmc Settings
s'
  where
    n' :: Iterations
n' = Int -> Iterations
Iterations forall a b. (a -> b) -> a -> b
$ Iterations -> Int
fromIterations (Settings -> Iterations
sIterations Settings
s) 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}