{-# 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 Data.Functor
import Mcmc.Acceptance (ResetAcceptance (ResetEverything, ResetExpectedRatesOnly))
import Mcmc.Algorithm
import Mcmc.Cycle
import Mcmc.Environment
import Mcmc.Logger
import Mcmc.Proposal
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 => ResetAcceptance -> a -> a
aResetAcceptance ResetAcceptance
ResetEverything 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
"   ")

-- When intermediate tuning is activated, specific proposals get tuned every
-- iterations.
data IntermediateTuningSpec
  = IntermediateTuningFastProposalsOnlyOn
  | IntermediateTuningAllProposalsOn
  | IntermediateTuningOff
  deriving (IntermediateTuningSpec -> IntermediateTuningSpec -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IntermediateTuningSpec -> IntermediateTuningSpec -> Bool
$c/= :: IntermediateTuningSpec -> IntermediateTuningSpec -> Bool
== :: IntermediateTuningSpec -> IntermediateTuningSpec -> Bool
$c== :: IntermediateTuningSpec -> IntermediateTuningSpec -> Bool
Eq)

mcmcIterate :: Algorithm a => IntermediateTuningSpec -> IterationMode -> Int -> a -> MCMC a
mcmcIterate :: forall a.
Algorithm a =>
IntermediateTuningSpec -> IterationMode -> Int -> a -> MCMC a
mcmcIterate IntermediateTuningSpec
t 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
          maybeIntermediateAutoTune :: a -> IO a
maybeIntermediateAutoTune a
x =
            -- Do not perform intermediate tuning at the last step, because a
            -- normal tuning will be performed.
            case IntermediateTuningSpec
t of
              IntermediateTuningSpec
IntermediateTuningFastProposalsOnlyOn
                | Int
n forall a. Ord a => a -> a -> Bool
> Int
1 ->
                    forall a. Algorithm a => TuningType -> Int -> a -> IO a
aAutoTune TuningType
IntermediateTuningFastProposalsOnly Int
1 a
x
                      forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. Algorithm a => ResetAcceptance -> a -> a
aResetAcceptance ResetAcceptance
ResetExpectedRatesOnly
              IntermediateTuningSpec
IntermediateTuningAllProposalsOn
                | Int
n forall a. Ord a => a -> a -> Bool
> Int
1 ->
                    forall a. Algorithm a => TuningType -> Int -> a -> IO a
aAutoTune TuningType
IntermediateTuningAllProposals Int
1 a
x
                      forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. Algorithm a => ResetAcceptance -> a -> a
aResetAcceptance ResetAcceptance
ResetExpectedRatesOnly
              IntermediateTuningSpec
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
          actionIterate :: IO a
actionIterate = forall a.
Algorithm a =>
IterationMode -> ParallelizationMode -> a -> IO a
aIterate IterationMode
m ParallelizationMode
p a
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a}. Algorithm a => a -> IO a
maybeIntermediateAutoTune
      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 =>
IntermediateTuningSpec -> IterationMode -> Int -> a -> MCMC a
mcmcIterate IntermediateTuningSpec
t 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 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 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 =>
IntermediateTuningSpec -> IterationMode -> Int -> a -> MCMC a
mcmcIterate IntermediateTuningSpec
IntermediateTuningOff 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 =>
IntermediateTuningSpec -> IterationMode -> Int -> a -> MCMC a
mcmcIterate IntermediateTuningSpec
IntermediateTuningOff 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 =>
IntermediateTuningSpec -> IterationMode -> Int -> a -> MCMC a
mcmcIterate IntermediateTuningSpec
IntermediateTuningOff 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
t Int
n a
a = do
  case TuningType
t of
    TuningType
NormalTuningFastProposalsOnly -> forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"Normal auto tune; fast proposals only."
    TuningType
IntermediateTuningFastProposalsOnly -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    TuningType
LastTuningFastProposalsOnly -> forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"Last auto tune; fast proposals only."
    TuningType
NormalTuningAllProposals -> forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"Normal auto tune; all proposals."
    TuningType
IntermediateTuningAllProposals -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    TuningType
LastTuningAllProposals -> forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
ByteString -> Logger e ()
logDebugB ByteString
"Last auto tune; all proposals."
  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
t 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.
  let (IntermediateTuningSpec
tti, TuningType
ttl) = case IterationMode
m of
        IterationMode
FastProposals -> (IntermediateTuningSpec
IntermediateTuningFastProposalsOnlyOn, TuningType
LastTuningFastProposalsOnly)
        IterationMode
AllProposals -> (IntermediateTuningSpec
IntermediateTuningAllProposalsOn, TuningType
LastTuningAllProposals)
  a
a' <- forall a.
Algorithm a =>
IntermediateTuningSpec -> IterationMode -> Int -> a -> MCMC a
mcmcIterate IntermediateTuningSpec
tti IterationMode
m Int
x a
a
  a
a'' <- forall a. Algorithm a => TuningType -> Int -> a -> MCMC a
mcmcAutotune TuningType
ttl 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
  let (IntermediateTuningSpec
tti, TuningType
ttn) = case IterationMode
m of
        IterationMode
FastProposals -> (IntermediateTuningSpec
IntermediateTuningFastProposalsOnlyOn, TuningType
NormalTuningFastProposalsOnly)
        IterationMode
AllProposals -> (IntermediateTuningSpec
IntermediateTuningAllProposalsOn, TuningType
NormalTuningAllProposals)
  a
a' <- forall a.
Algorithm a =>
IntermediateTuningSpec -> IterationMode -> Int -> a -> MCMC a
mcmcIterate IntermediateTuningSpec
tti IterationMode
m Int
x a
a
  a
a'' <- forall a. Algorithm a => TuningType -> Int -> a -> MCMC a
mcmcAutotune TuningType
ttn 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}