{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Mcmc.Algorithm.MHG
( MHG (..),
mhg,
mhgSave,
mhgLoad,
mhgLoadUnsafe,
MHGRatio,
mhgAccept,
)
where
import Codec.Compression.GZip
import Control.Monad
import Control.Monad.IO.Class
import Control.Parallel.Strategies
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Time
import qualified Data.Vector as VB
import Mcmc.Acceptance
import Mcmc.Algorithm
import Mcmc.Chain.Chain
import Mcmc.Chain.Link
import Mcmc.Chain.Save
import Mcmc.Chain.Trace
import Mcmc.Cycle
import Mcmc.Likelihood
import Mcmc.Monitor
import Mcmc.Posterior
import Mcmc.Prior hiding (uniform)
import Mcmc.Proposal
import Mcmc.Settings
import Numeric.Log
import System.Random.MWC
import Text.Printf
import Prelude hiding (cycle)
newtype MHG a = MHG {MHG a -> Chain a
fromMHG :: Chain a}
instance ToJSON a => Algorithm (MHG a) where
aName :: MHG a -> String
aName = String -> MHG a -> String
forall a b. a -> b -> a
const String
"Metropolis-Hastings-Green (MHG)"
aIteration :: MHG a -> Int
aIteration = Chain a -> Int
forall a. Chain a -> Int
iteration (Chain a -> Int) -> (MHG a -> Chain a) -> MHG a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MHG a -> Chain a
forall a. MHG a -> Chain a
fromMHG
aIsInValidState :: MHG a -> Bool
aIsInValidState = MHG a -> Bool
forall a. MHG a -> Bool
mhgIsInValidState
aIterate :: IterationMode -> ParallelizationMode -> MHG a -> IO (MHG a)
aIterate = IterationMode -> ParallelizationMode -> MHG a -> IO (MHG a)
forall a.
IterationMode -> ParallelizationMode -> MHG a -> IO (MHG a)
mhgIterate
aAutoTune :: Int -> MHG a -> IO (MHG a)
aAutoTune = Int -> MHG a -> IO (MHG a)
forall a. Int -> MHG a -> IO (MHG a)
mhgAutoTune
aResetAcceptance :: MHG a -> MHG a
aResetAcceptance = MHG a -> MHG a
forall a. MHG a -> MHG a
mhgResetAcceptance
aSummarizeCycle :: IterationMode -> MHG a -> ByteString
aSummarizeCycle = IterationMode -> MHG a -> ByteString
forall a. IterationMode -> MHG a -> ByteString
mhgSummarizeCycle
aOpenMonitors :: AnalysisName -> ExecutionMode -> MHG a -> IO (MHG a)
aOpenMonitors = AnalysisName -> ExecutionMode -> MHG a -> IO (MHG a)
forall a. AnalysisName -> ExecutionMode -> MHG a -> IO (MHG a)
mhgOpenMonitors
aExecuteMonitors :: Verbosity -> UTCTime -> Int -> MHG a -> IO (Maybe ByteString)
aExecuteMonitors = Verbosity -> UTCTime -> Int -> MHG a -> IO (Maybe ByteString)
forall a.
Verbosity -> UTCTime -> Int -> MHG a -> IO (Maybe ByteString)
mhgExecuteMonitors
aStdMonitorHeader :: MHG a -> ByteString
aStdMonitorHeader = MHG a -> ByteString
forall a. MHG a -> ByteString
mhgStdMonitorHeader
aCloseMonitors :: MHG a -> IO (MHG a)
aCloseMonitors = MHG a -> IO (MHG a)
forall a. MHG a -> IO (MHG a)
mhgCloseMonitors
aSave :: AnalysisName -> MHG a -> IO ()
aSave = AnalysisName -> MHG a -> IO ()
forall a. ToJSON a => AnalysisName -> MHG a -> IO ()
mhgSave
mhg ::
Settings ->
PriorFunction a ->
LikelihoodFunction a ->
Cycle a ->
Monitor a ->
InitialState a ->
GenIO ->
IO (MHG a)
mhg :: Settings
-> PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> a
-> GenIO
-> IO (MHG a)
mhg Settings
s PriorFunction a
pr PriorFunction a
lh Cycle a
cc Monitor a
mn a
i0 GenIO
g = do
Trace a
tr <- Int -> Link a -> IO (Trace a)
forall a. Int -> Link a -> IO (Trace a)
replicateT Int
traceLength Link a
l0
MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG (Chain a -> MHG a) -> Chain a -> MHG a
forall a b. (a -> b) -> a -> b
$ Maybe Int
-> Link a
-> Int
-> Trace a
-> Acceptance (Proposal a)
-> GenIO
-> Int
-> PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> Chain a
forall a.
Maybe Int
-> Link a
-> Int
-> Trace a
-> Acceptance (Proposal a)
-> GenIO
-> Int
-> PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> Chain a
Chain Maybe Int
forall a. Maybe a
Nothing Link a
l0 Int
0 Trace a
tr Acceptance (Proposal a)
ac GenIO
g Int
0 PriorFunction a
pr PriorFunction a
lh Cycle a
cc Monitor a
mn
where
l0 :: Link a
l0 = a -> Prior -> Prior -> Link a
forall a. a -> Prior -> Prior -> Link a
Link a
i0 (PriorFunction a
pr a
i0) (PriorFunction a
lh a
i0)
ac :: Acceptance (Proposal a)
ac = [Proposal a] -> Acceptance (Proposal a)
forall k. Ord k => [k] -> Acceptance k
emptyA ([Proposal a] -> Acceptance (Proposal a))
-> [Proposal a] -> Acceptance (Proposal a)
forall a b. (a -> b) -> a -> b
$ Cycle a -> [Proposal a]
forall a. Cycle a -> [Proposal a]
ccProposals Cycle a
cc
batchMonitorSizes :: [Int]
batchMonitorSizes = (MonitorBatch a -> Int) -> [MonitorBatch a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map MonitorBatch a -> Int
forall a. MonitorBatch a -> Int
getMonitorBatchSize ([MonitorBatch a] -> [Int]) -> [MonitorBatch a] -> [Int]
forall a b. (a -> b) -> a -> b
$ Monitor a -> [MonitorBatch a]
forall a. Monitor a -> [MonitorBatch a]
mBatches Monitor a
mn
minimumTraceLength :: Int
minimumTraceLength = case Settings -> TraceLength
sTraceLength Settings
s of
TraceLength
TraceAuto -> Int
1
TraceMinimum Int
n -> Int
n
bi :: Int
bi = case Settings -> BurnInSettings
sBurnIn Settings
s of
BurnInWithAutoTuning Int
_ Int
n -> Int
n
BurnInWithCustomAutoTuning [Int]
ns [Int]
ms -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ns) ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ms)
BurnInSettings
_ -> Int
0
traceLength :: Int
traceLength = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
minimumTraceLength Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int
bi Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
batchMonitorSizes
mhgFn :: AnalysisName -> FilePath
mhgFn :: AnalysisName -> String
mhgFn (AnalysisName String
nm) = String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".mcmc.mhg"
mhgSave ::
ToJSON a =>
AnalysisName ->
MHG a ->
IO ()
mhgSave :: AnalysisName -> MHG a -> IO ()
mhgSave AnalysisName
nm (MHG Chain a
c) = do
SavedChain a
savedChain <- Chain a -> IO (SavedChain a)
forall a. Chain a -> IO (SavedChain a)
toSavedChain Chain a
c
String -> ByteString -> IO ()
BL.writeFile (AnalysisName -> String
mhgFn AnalysisName
nm) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
compress (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ SavedChain a -> ByteString
forall a. ToJSON a => a -> ByteString
encode SavedChain a
savedChain
mhgLoad ::
FromJSON a =>
PriorFunction a ->
LikelihoodFunction a ->
Cycle a ->
Monitor a ->
AnalysisName ->
IO (MHG a)
mhgLoad :: PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> AnalysisName
-> IO (MHG a)
mhgLoad = (PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> SavedChain a
-> IO (Chain a))
-> PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> AnalysisName
-> IO (MHG a)
forall a.
FromJSON a =>
(PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> SavedChain a
-> IO (Chain a))
-> PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> AnalysisName
-> IO (MHG a)
mhgLoadWith PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> SavedChain a
-> IO (Chain a)
forall a.
PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> SavedChain a
-> IO (Chain a)
fromSavedChain
mhgLoadUnsafe ::
FromJSON a =>
PriorFunction a ->
LikelihoodFunction a ->
Cycle a ->
Monitor a ->
AnalysisName ->
IO (MHG a)
mhgLoadUnsafe :: PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> AnalysisName
-> IO (MHG a)
mhgLoadUnsafe = (PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> SavedChain a
-> IO (Chain a))
-> PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> AnalysisName
-> IO (MHG a)
forall a.
FromJSON a =>
(PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> SavedChain a
-> IO (Chain a))
-> PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> AnalysisName
-> IO (MHG a)
mhgLoadWith PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> SavedChain a
-> IO (Chain a)
forall a.
PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> SavedChain a
-> IO (Chain a)
fromSavedChainUnsafe
mhgLoadWith ::
FromJSON a =>
(PriorFunction a -> LikelihoodFunction a -> Cycle a -> Monitor a -> SavedChain a -> IO (Chain a)) ->
PriorFunction a ->
LikelihoodFunction a ->
Cycle a ->
Monitor a ->
AnalysisName ->
IO (MHG a)
mhgLoadWith :: (PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> SavedChain a
-> IO (Chain a))
-> PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> AnalysisName
-> IO (MHG a)
mhgLoadWith PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> SavedChain a
-> IO (Chain a)
f PriorFunction a
pr PriorFunction a
lh Cycle a
cc Monitor a
mn AnalysisName
nm = do
Either String (SavedChain a)
savedChain <- ByteString -> Either String (SavedChain a)
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String (SavedChain a))
-> (ByteString -> ByteString)
-> ByteString
-> Either String (SavedChain a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
decompress (ByteString -> Either String (SavedChain a))
-> IO ByteString -> IO (Either String (SavedChain a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BL.readFile (AnalysisName -> String
mhgFn AnalysisName
nm)
Chain a
chain <- (String -> IO (Chain a))
-> (SavedChain a -> IO (Chain a))
-> Either String (SavedChain a)
-> IO (Chain a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO (Chain a)
forall a. HasCallStack => String -> a
error (PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> SavedChain a
-> IO (Chain a)
f PriorFunction a
pr PriorFunction a
lh Cycle a
cc Monitor a
mn) Either String (SavedChain a)
savedChain
MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG Chain a
chain
type MHGRatio = Log Double
mhgRatio :: Posterior -> Posterior -> KernelRatio -> Jacobian -> MHGRatio
mhgRatio :: Prior -> Prior -> Prior -> Prior -> Prior
mhgRatio Prior
fX Prior
fY Prior
q Prior
j = Prior
fY Prior -> Prior -> Prior
forall a. Fractional a => a -> a -> a
/ Prior
fX Prior -> Prior -> Prior
forall a. Num a => a -> a -> a
* Prior
q Prior -> Prior -> Prior
forall a. Num a => a -> a -> a
* Prior
j
{-# INLINE mhgRatio #-}
mhgAccept :: MHGRatio -> GenIO -> IO Bool
mhgAccept :: Prior -> GenIO -> IO Bool
mhgAccept Prior
r GenIO
g
| Prior -> Double
forall a. Log a -> a
ln Prior
r Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0.0 = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
| Bool
otherwise = do
Double
b <- GenIO -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
uniform GenIO
g
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Double
b Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double -> Double
forall a. Floating a => a -> a
exp (Prior -> Double
forall a. Log a -> a
ln Prior
r)
mhgPropose :: MHG a -> Proposal a -> IO (MHG a)
mhgPropose :: MHG a -> Proposal a -> IO (MHG a)
mhgPropose (MHG Chain a
c) Proposal a
p = do
(!a
y, !Prior
q, !Prior
j) <- IO (a, Prior, Prior) -> IO (a, Prior, Prior)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, Prior, Prior) -> IO (a, Prior, Prior))
-> IO (a, Prior, Prior) -> IO (a, Prior, Prior)
forall a b. (a -> b) -> a -> b
$ a -> Gen RealWorld -> IO (a, Prior, Prior)
s a
x Gen RealWorld
g
let (Prior
pY, Prior
lY) = (PriorFunction a
pF a
y, PriorFunction a
lF a
y) (Prior, Prior) -> Strategy (Prior, Prior) -> (Prior, Prior)
forall a. a -> Strategy a -> a
`using` Strategy Prior -> Strategy Prior -> Strategy (Prior, Prior)
forall a b. Strategy a -> Strategy b -> Strategy (a, b)
parTuple2 Strategy Prior
forall a. NFData a => Strategy a
rdeepseq Strategy Prior
forall a. NFData a => Strategy a
rdeepseq
let !r :: Prior
r = Prior -> Prior -> Prior -> Prior -> Prior
mhgRatio (Prior
pX Prior -> Prior -> Prior
forall a. Num a => a -> a -> a
* Prior
lX) (Prior
pY Prior -> Prior -> Prior
forall a. Num a => a -> a -> a
* Prior
lY) Prior
q Prior
j
Bool
accept <- Prior -> GenIO -> IO Bool
mhgAccept Prior
r Gen RealWorld
GenIO
g
if Bool
accept
then do
let !ac' :: Acceptance (Proposal a)
ac' = Proposal a
-> Bool -> Acceptance (Proposal a) -> Acceptance (Proposal a)
forall k. Ord k => k -> Bool -> Acceptance k -> Acceptance k
pushA Proposal a
p Bool
True Acceptance (Proposal a)
ac
MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG (Chain a -> MHG a) -> Chain a -> MHG a
forall a b. (a -> b) -> a -> b
$ Chain a
c {link :: Link a
link = a -> Prior -> Prior -> Link a
forall a. a -> Prior -> Prior -> Link a
Link a
y Prior
pY Prior
lY, acceptance :: Acceptance (Proposal a)
acceptance = Acceptance (Proposal a)
ac'}
else do
let !ac' :: Acceptance (Proposal a)
ac' = Proposal a
-> Bool -> Acceptance (Proposal a) -> Acceptance (Proposal a)
forall k. Ord k => k -> Bool -> Acceptance k -> Acceptance k
pushA Proposal a
p Bool
False Acceptance (Proposal a)
ac
MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG (Chain a -> MHG a) -> Chain a -> MHG a
forall a b. (a -> b) -> a -> b
$ Chain a
c {acceptance :: Acceptance (Proposal a)
acceptance = Proposal a
-> Bool -> Acceptance (Proposal a) -> Acceptance (Proposal a)
forall k. Ord k => k -> Bool -> Acceptance k -> Acceptance k
pushA Proposal a
p Bool
False Acceptance (Proposal a)
ac'}
where
s :: ProposalSimple a
s = Proposal a -> ProposalSimple a
forall a. Proposal a -> ProposalSimple a
prSimple Proposal a
p
(Link a
x Prior
pX Prior
lX) = Chain a -> Link a
forall a. Chain a -> Link a
link Chain a
c
pF :: PriorFunction a
pF = Chain a -> PriorFunction a
forall a. Chain a -> PriorFunction a
priorFunction Chain a
c
lF :: PriorFunction a
lF = Chain a -> PriorFunction a
forall a. Chain a -> PriorFunction a
likelihoodFunction Chain a
c
ac :: Acceptance (Proposal a)
ac = Chain a -> Acceptance (Proposal a)
forall a. Chain a -> Acceptance (Proposal a)
acceptance Chain a
c
g :: GenIO
g = Chain a -> GenIO
forall a. Chain a -> GenIO
generator Chain a
c
mhgPush :: MHG a -> IO (MHG a)
mhgPush :: MHG a -> IO (MHG a)
mhgPush (MHG Chain a
c) = do
Trace a
t' <- Link a -> Trace a -> IO (Trace a)
forall a. Link a -> Trace a -> IO (Trace a)
pushT Link a
i Trace a
t
MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG Chain a
c {trace :: Trace a
trace = Trace a
t', iteration :: Int
iteration = Int -> Int
forall a. Enum a => a -> a
succ Int
n}
where
i :: Link a
i = Chain a -> Link a
forall a. Chain a -> Link a
link Chain a
c
t :: Trace a
t = Chain a -> Trace a
forall a. Chain a -> Trace a
trace Chain a
c
n :: Int
n = Chain a -> Int
forall a. Chain a -> Int
iteration Chain a
c
mhgIsInValidState :: MHG a -> Bool
mhgIsInValidState :: MHG a -> Bool
mhgIsInValidState MHG a
a = Prior -> Bool
forall a. RealFloat a => Log a -> Bool
check Prior
p Bool -> Bool -> Bool
|| Prior -> Bool
forall a. RealFloat a => Log a -> Bool
check Prior
l Bool -> Bool -> Bool
|| Prior -> Bool
forall a. RealFloat a => Log a -> Bool
check (Prior
p Prior -> Prior -> Prior
forall a. Num a => a -> a -> a
* Prior
l)
where
x :: Link a
x = Chain a -> Link a
forall a. Chain a -> Link a
link (Chain a -> Link a) -> Chain a -> Link a
forall a b. (a -> b) -> a -> b
$ MHG a -> Chain a
forall a. MHG a -> Chain a
fromMHG MHG a
a
p :: Prior
p = Link a -> Prior
forall a. Link a -> Prior
prior Link a
x
l :: Prior
l = Link a -> Prior
forall a. Link a -> Prior
likelihood Link a
x
check :: Log a -> Bool
check Log a
v = let v' :: a
v' = Log a -> a
forall a. Log a -> a
ln Log a
v in a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
v' Bool -> Bool -> Bool
|| a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
v' Bool -> Bool -> Bool
|| a
v' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
mhgIterate :: IterationMode -> ParallelizationMode -> MHG a -> IO (MHG a)
mhgIterate :: IterationMode -> ParallelizationMode -> MHG a -> IO (MHG a)
mhgIterate IterationMode
m ParallelizationMode
_ MHG a
a = do
[Proposal a]
ps <- IterationMode -> Cycle a -> GenIO -> IO [Proposal a]
forall a. IterationMode -> Cycle a -> GenIO -> IO [Proposal a]
prepareProposals IterationMode
m Cycle a
cc Gen RealWorld
GenIO
g
MHG a
a' <- (MHG a -> Proposal a -> IO (MHG a))
-> MHG a -> [Proposal a] -> IO (MHG a)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM MHG a -> Proposal a -> IO (MHG a)
forall a. MHG a -> Proposal a -> IO (MHG a)
mhgPropose MHG a
a [Proposal a]
ps
MHG a -> IO (MHG a)
forall a. MHG a -> IO (MHG a)
mhgPush MHG a
a'
where
c :: Chain a
c = MHG a -> Chain a
forall a. MHG a -> Chain a
fromMHG MHG a
a
cc :: Cycle a
cc = Chain a -> Cycle a
forall a. Chain a -> Cycle a
cycle Chain a
c
g :: GenIO
g = Chain a -> GenIO
forall a. Chain a -> GenIO
generator Chain a
c
mhgAutoTune :: Int -> MHG a -> IO (MHG a)
mhgAutoTune :: Int -> MHG a -> IO (MHG a)
mhgAutoTune Int
n (MHG Chain a
c) = do
Vector a
tr <- (Link a -> a) -> Vector (Link a) -> Vector a
forall a b. (a -> b) -> Vector a -> Vector b
VB.map Link a -> a
forall a. Link a -> a
state (Vector (Link a) -> Vector a)
-> IO (Vector (Link a)) -> IO (Vector a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Trace a -> IO (Vector (Link a))
forall a. Int -> Trace a -> IO (Vector (Link a))
takeT Int
n (Chain a -> Trace a
forall a. Chain a -> Trace a
trace Chain a
c)
MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG (Chain a -> MHG a) -> Chain a -> MHG a
forall a b. (a -> b) -> a -> b
$ Chain a
c {cycle :: Cycle a
cycle = Acceptance (Proposal a) -> Vector a -> Cycle a -> Cycle a
forall a. Acceptance (Proposal a) -> Vector a -> Cycle a -> Cycle a
autoTuneCycle Acceptance (Proposal a)
ac Vector a
tr Cycle a
cc}
where
ac :: Acceptance (Proposal a)
ac = Chain a -> Acceptance (Proposal a)
forall a. Chain a -> Acceptance (Proposal a)
acceptance Chain a
c
cc :: Cycle a
cc = Chain a -> Cycle a
forall a. Chain a -> Cycle a
cycle Chain a
c
mhgResetAcceptance :: MHG a -> MHG a
mhgResetAcceptance :: MHG a -> MHG a
mhgResetAcceptance (MHG Chain a
c) = Chain a -> MHG a
forall a. Chain a -> MHG a
MHG (Chain a -> MHG a) -> Chain a -> MHG a
forall a b. (a -> b) -> a -> b
$ Chain a
c {acceptance :: Acceptance (Proposal a)
acceptance = Acceptance (Proposal a) -> Acceptance (Proposal a)
forall k. Ord k => Acceptance k -> Acceptance k
resetA Acceptance (Proposal a)
ac}
where
ac :: Acceptance (Proposal a)
ac = Chain a -> Acceptance (Proposal a)
forall a. Chain a -> Acceptance (Proposal a)
acceptance Chain a
c
mhgSummarizeCycle :: IterationMode -> MHG a -> BL.ByteString
mhgSummarizeCycle :: IterationMode -> MHG a -> ByteString
mhgSummarizeCycle IterationMode
m (MHG Chain a
c) = IterationMode -> Acceptance (Proposal a) -> Cycle a -> ByteString
forall a.
IterationMode -> Acceptance (Proposal a) -> Cycle a -> ByteString
summarizeCycle IterationMode
m Acceptance (Proposal a)
ac Cycle a
cc
where
cc :: Cycle a
cc = Chain a -> Cycle a
forall a. Chain a -> Cycle a
cycle Chain a
c
ac :: Acceptance (Proposal a)
ac = Chain a -> Acceptance (Proposal a)
forall a. Chain a -> Acceptance (Proposal a)
acceptance Chain a
c
mhgOpenMonitors :: AnalysisName -> ExecutionMode -> MHG a -> IO (MHG a)
mhgOpenMonitors :: AnalysisName -> ExecutionMode -> MHG a -> IO (MHG a)
mhgOpenMonitors AnalysisName
nm ExecutionMode
em (MHG Chain a
c) = do
Monitor a
m' <- String -> String -> ExecutionMode -> Monitor a -> IO (Monitor a)
forall a.
String -> String -> ExecutionMode -> Monitor a -> IO (Monitor a)
mOpen String
pre String
suf ExecutionMode
em Monitor a
m
MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG Chain a
c {monitor :: Monitor a
monitor = Monitor a
m'}
where
m :: Monitor a
m = Chain a -> Monitor a
forall a. Chain a -> Monitor a
monitor Chain a
c
pre :: String
pre = AnalysisName -> String
fromAnalysisName AnalysisName
nm
suf :: String
suf = String -> (Int -> String) -> Maybe Int -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%02d") (Maybe Int -> String) -> Maybe Int -> String
forall a b. (a -> b) -> a -> b
$ Chain a -> Maybe Int
forall a. Chain a -> Maybe Int
chainId Chain a
c
mhgExecuteMonitors ::
Verbosity ->
UTCTime ->
Int ->
MHG a ->
IO (Maybe BL.ByteString)
mhgExecuteMonitors :: Verbosity -> UTCTime -> Int -> MHG a -> IO (Maybe ByteString)
mhgExecuteMonitors Verbosity
vb UTCTime
t0 Int
iTotal (MHG Chain a
c) = Verbosity
-> Int
-> Int
-> UTCTime
-> Trace a
-> Int
-> Monitor a
-> IO (Maybe ByteString)
forall a.
Verbosity
-> Int
-> Int
-> UTCTime
-> Trace a
-> Int
-> Monitor a
-> IO (Maybe ByteString)
mExec Verbosity
vb Int
i Int
i0 UTCTime
t0 Trace a
tr Int
iTotal Monitor a
m
where
i :: Int
i = Chain a -> Int
forall a. Chain a -> Int
iteration Chain a
c
i0 :: Int
i0 = Chain a -> Int
forall a. Chain a -> Int
start Chain a
c
tr :: Trace a
tr = Chain a -> Trace a
forall a. Chain a -> Trace a
trace Chain a
c
m :: Monitor a
m = Chain a -> Monitor a
forall a. Chain a -> Monitor a
monitor Chain a
c
mhgStdMonitorHeader :: MHG a -> BL.ByteString
(MHG Chain a
c) = MonitorStdOut a -> ByteString
forall a. MonitorStdOut a -> ByteString
msHeader (Monitor a -> MonitorStdOut a
forall a. Monitor a -> MonitorStdOut a
mStdOut (Monitor a -> MonitorStdOut a) -> Monitor a -> MonitorStdOut a
forall a b. (a -> b) -> a -> b
$ Chain a -> Monitor a
forall a. Chain a -> Monitor a
monitor Chain a
c)
mhgCloseMonitors :: MHG a -> IO (MHG a)
mhgCloseMonitors :: MHG a -> IO (MHG a)
mhgCloseMonitors (MHG Chain a
c) = do
Monitor a
m' <- Monitor a -> IO (Monitor a)
forall a. Monitor a -> IO (Monitor a)
mClose Monitor a
m
MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG (Chain a -> MHG a) -> Chain a -> MHG a
forall a b. (a -> b) -> a -> b
$ Chain a
c {monitor :: Monitor a
monitor = Monitor a
m'}
where
m :: Monitor a
m = Chain a -> Monitor a
forall a. Chain a -> Monitor a
monitor Chain a
c