{-# LANGUAGE OverloadedStrings #-}
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)
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
" ")
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
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 =
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
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
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''
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
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'
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."
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'
mcmcRun :: Algorithm a => a -> MCMC a
mcmcRun :: forall a. Algorithm a => a -> MCMC a
mcmcRun a
a = do
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
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
a
a'' <- forall a. Algorithm a => a -> MCMC a
mcmcExecute 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''
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''
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
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}