{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Mcmc.Monitor
-- Description :  Monitor a Markov chain
-- Copyright   :  (c) Dominik Schrempf, 2020
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Thu May 21 14:35:11 2020.
module Mcmc.Monitor
  ( -- * Create monitors
    Monitor (..),
    MonitorStdOut,
    monitorStdOut,
    MonitorFile,
    monitorFile,
    MonitorBatch,
    monitorBatch,

    -- * Use monitors
    mOpen,
    mAppend,
    mExec,
    mClose,
  )
where

import Control.Monad
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Int
import Data.Time.Clock
import Mcmc.Internal.ByteString
import Mcmc.Item
import Mcmc.Monitor.Log
import Mcmc.Monitor.Parameter
import Mcmc.Monitor.ParameterBatch
import Mcmc.Monitor.Time
import Mcmc.Trace
import Mcmc.Verbosity
import Numeric.Log
import System.Directory
import System.IO
import Prelude hiding (sum)

-- | A 'Monitor' describes which part of the Markov chain should be logged and
-- where. Further, they allow output of summary statistics per iteration in a
-- flexible way.
data Monitor a = Monitor
  { -- | Monitor writing to standard output.
    Monitor a -> MonitorStdOut a
mStdOut :: MonitorStdOut a,
    -- | Monitors writing to files.
    Monitor a -> [MonitorFile a]
mFiles :: [MonitorFile a],
    -- | Monitors calculating batch means and
    -- writing to files.
    Monitor a -> [MonitorBatch a]
mBatches :: [MonitorBatch a]
  }

-- | Monitor to standard output; constructed with 'monitorStdOut'.
data MonitorStdOut a = MonitorStdOut
  { MonitorStdOut a -> [MonitorParameter a]
msParams :: [MonitorParameter a],
    MonitorStdOut a -> Int
msPeriod :: Int
  }

-- | Monitor to standard output.
monitorStdOut ::
  -- | Instructions about which parameters to log.
  [MonitorParameter a] ->
  -- | Logging period.
  Int ->
  MonitorStdOut a
monitorStdOut :: [MonitorParameter a] -> Int -> MonitorStdOut a
monitorStdOut [MonitorParameter a]
ps Int
p
  | Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = [Char] -> MonitorStdOut a
forall a. HasCallStack => [Char] -> a
error [Char]
"monitorStdOut: Monitor period has to be 1 or larger."
  | Bool
otherwise = [MonitorParameter a] -> Int -> MonitorStdOut a
forall a. [MonitorParameter a] -> Int -> MonitorStdOut a
MonitorStdOut [MonitorParameter a]
ps Int
p

msIWidth :: Int
msIWidth :: Int
msIWidth = Int
12

msWidth :: Int
msWidth :: Int
msWidth = Int
22

msRenderRow :: [BL.ByteString] -> BL.ByteString
msRenderRow :: [ByteString] -> ByteString
msRenderRow [ByteString]
xs = Int -> ByteString -> ByteString
alignRight Int
msIWidth ([ByteString] -> ByteString
forall a. [a] -> a
head [ByteString]
xs) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> ByteString
BL.concat [ByteString]
vals
  where
    vals :: [ByteString]
vals = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ByteString -> ByteString
alignRight Int
msWidth) ([ByteString] -> [ByteString]
forall a. [a] -> [a]
tail [ByteString]
xs)

msHeader :: MonitorStdOut a -> BL.ByteString
msHeader :: MonitorStdOut a -> ByteString
msHeader MonitorStdOut a
m = ByteString -> [ByteString] -> ByteString
BL.intercalate ByteString
"\n" [ByteString
row, ByteString
sep]
  where
    row :: ByteString
row =
      [ByteString] -> ByteString
msRenderRow ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
        [ByteString
"Iteration", ByteString
"Log-Prior", ByteString
"Log-Likelihood", ByteString
"Log-Posterior"]
          [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString]
nms
          [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
"Runtime", ByteString
"ETA"]
    sep :: ByteString
sep = ByteString
"   " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int64 -> Char -> ByteString
BL.replicate (ByteString -> Int64
BL.length ByteString
row Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
3) Char
'-'
    nms :: [ByteString]
nms = [[Char] -> ByteString
BL.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ MonitorParameter a -> [Char]
forall a. MonitorParameter a -> [Char]
mpName MonitorParameter a
p | MonitorParameter a
p <- MonitorStdOut a -> [MonitorParameter a]
forall a. MonitorStdOut a -> [MonitorParameter a]
msParams MonitorStdOut a
m]

msDataLine ::
  Int ->
  Item a ->
  Int ->
  UTCTime ->
  Int ->
  MonitorStdOut a ->
  IO BL.ByteString
msDataLine :: Int
-> Item a
-> Int
-> UTCTime
-> Int
-> MonitorStdOut a
-> IO ByteString
msDataLine Int
i (Item a
x Log Double
p Log Double
l) Int
ss UTCTime
st Int
j MonitorStdOut a
m = do
  UTCTime
ct <- IO UTCTime
getCurrentTime
  let dt :: NominalDiffTime
dt = UTCTime
ct UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
st
      -- Careful, don't evaluate this when i == ss.
      timePerIter :: NominalDiffTime
timePerIter = NominalDiffTime
dt NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ss)
      -- -- Always 0; doesn't make much sense.
      -- tpi = if (i - ss) < 10
      --       then ""
      --       else renderDurationS timePerIter
      eta :: ByteString
eta =
        if (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ss) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10
          then ByteString
""
          else NominalDiffTime -> ByteString
renderDuration (NominalDiffTime -> ByteString) -> NominalDiffTime -> ByteString
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
timePerIter NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
  ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
    [ByteString] -> ByteString
msRenderRow ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
      [[Char] -> ByteString
BL.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i), Log Double -> ByteString
renderLog Log Double
p, Log Double -> ByteString
renderLog Log Double
l, Log Double -> ByteString
renderLog (Log Double
p Log Double -> Log Double -> Log Double
forall a. Num a => a -> a -> a
* Log Double
l)]
        [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ MonitorParameter a -> a -> Builder
forall a. MonitorParameter a -> a -> Builder
mpFunc MonitorParameter a
mp a
x | MonitorParameter a
mp <- MonitorStdOut a -> [MonitorParameter a]
forall a. MonitorStdOut a -> [MonitorParameter a]
msParams MonitorStdOut a
m]
        [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [NominalDiffTime -> ByteString
renderDuration NominalDiffTime
dt, ByteString
eta]

msExec ::
  Int ->
  Item a ->
  Int ->
  UTCTime ->
  Int ->
  MonitorStdOut a ->
  IO (Maybe BL.ByteString)
msExec :: Int
-> Item a
-> Int
-> UTCTime
-> Int
-> MonitorStdOut a
-> IO (Maybe ByteString)
msExec Int
i Item a
it Int
ss UTCTime
st Int
j MonitorStdOut a
m
  | Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` MonitorStdOut a -> Int
forall a. MonitorStdOut a -> Int
msPeriod MonitorStdOut a
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
  | Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (MonitorStdOut a -> Int
forall a. MonitorStdOut a -> Int
msPeriod MonitorStdOut a
m Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = do
    ByteString
l <- Int
-> Item a
-> Int
-> UTCTime
-> Int
-> MonitorStdOut a
-> IO ByteString
forall a.
Int
-> Item a
-> Int
-> UTCTime
-> Int
-> MonitorStdOut a
-> IO ByteString
msDataLine Int
i Item a
it Int
ss UTCTime
st Int
j MonitorStdOut a
m
    Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ MonitorStdOut a -> ByteString
forall a. MonitorStdOut a -> ByteString
msHeader MonitorStdOut a
m ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
l
  | Bool
otherwise = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Item a
-> Int
-> UTCTime
-> Int
-> MonitorStdOut a
-> IO ByteString
forall a.
Int
-> Item a
-> Int
-> UTCTime
-> Int
-> MonitorStdOut a
-> IO ByteString
msDataLine Int
i Item a
it Int
ss UTCTime
st Int
j MonitorStdOut a
m

-- | Monitor to a file; constructed with 'monitorFile'.
data MonitorFile a = MonitorFile
  { MonitorFile a -> [Char]
mfName :: String,
    MonitorFile a -> Maybe Handle
mfHandle :: Maybe Handle,
    MonitorFile a -> [MonitorParameter a]
mfParams :: [MonitorParameter a],
    MonitorFile a -> Int
mfPeriod :: Int
  }

-- | Monitor parameters to a file.
monitorFile ::
  -- | Name; used as part of the file name.
  String ->
  -- | Instructions about which parameters to log.
  [MonitorParameter a] ->
  -- | Logging period.
  Int ->
  MonitorFile a
monitorFile :: [Char] -> [MonitorParameter a] -> Int -> MonitorFile a
monitorFile [Char]
n [MonitorParameter a]
ps Int
p
  | Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = [Char] -> MonitorFile a
forall a. HasCallStack => [Char] -> a
error [Char]
"monitorFile: Monitor period has to be 1 or larger."
  | Bool
otherwise = [Char]
-> Maybe Handle -> [MonitorParameter a] -> Int -> MonitorFile a
forall a.
[Char]
-> Maybe Handle -> [MonitorParameter a] -> Int -> MonitorFile a
MonitorFile [Char]
n Maybe Handle
forall a. Maybe a
Nothing [MonitorParameter a]
ps Int
p

mfRenderRow :: [BL.ByteString] -> BL.ByteString
mfRenderRow :: [ByteString] -> ByteString
mfRenderRow = ByteString -> [ByteString] -> ByteString
BL.intercalate ByteString
"\t"

open' :: String -> Bool -> IO Handle
open' :: [Char] -> Bool -> IO Handle
open' [Char]
n Bool
frc = do
  Bool
fe <- [Char] -> IO Bool
doesFileExist [Char]
n
  case (Bool
fe, Bool
frc) of
    (Bool
False, Bool
_) -> [Char] -> IOMode -> IO Handle
openFile [Char]
n IOMode
WriteMode
    (Bool
True, Bool
True) -> [Char] -> IOMode -> IO Handle
openFile [Char]
n IOMode
WriteMode
    (Bool
True, Bool
False) -> [Char] -> IO Handle
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO Handle) -> [Char] -> IO Handle
forall a b. (a -> b) -> a -> b
$ [Char]
"open': File \"" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\" exists; probably use 'force'?"

mfOpen :: String -> Bool -> MonitorFile a -> IO (MonitorFile a)
mfOpen :: [Char] -> Bool -> MonitorFile a -> IO (MonitorFile a)
mfOpen [Char]
n Bool
frc MonitorFile a
m = do
  let mfn :: [Char]
mfn = [Char]
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> MonitorFile a -> [Char]
forall a. MonitorFile a -> [Char]
mfName MonitorFile a
m [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
".monitor"
  Handle
h <- [Char] -> Bool -> IO Handle
open' [Char]
mfn Bool
frc
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
  MonitorFile a -> IO (MonitorFile a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MonitorFile a -> IO (MonitorFile a))
-> MonitorFile a -> IO (MonitorFile a)
forall a b. (a -> b) -> a -> b
$ MonitorFile a
m {mfHandle :: Maybe Handle
mfHandle = Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h}

mfAppend :: String -> MonitorFile a -> IO (MonitorFile a)
mfAppend :: [Char] -> MonitorFile a -> IO (MonitorFile a)
mfAppend [Char]
n MonitorFile a
m = do
  let fn :: [Char]
fn = [Char]
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> MonitorFile a -> [Char]
forall a. MonitorFile a -> [Char]
mfName MonitorFile a
m [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
".monitor"
  Bool
fe <- [Char] -> IO Bool
doesFileExist [Char]
fn
  if Bool
fe
    then do
      Handle
h <- [Char] -> IOMode -> IO Handle
openFile [Char]
fn IOMode
AppendMode
      Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
      MonitorFile a -> IO (MonitorFile a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MonitorFile a -> IO (MonitorFile a))
-> MonitorFile a -> IO (MonitorFile a)
forall a b. (a -> b) -> a -> b
$ MonitorFile a
m {mfHandle :: Maybe Handle
mfHandle = Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h}
    else [Char] -> IO (MonitorFile a)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (MonitorFile a)) -> [Char] -> IO (MonitorFile a)
forall a b. (a -> b) -> a -> b
$ [Char]
"mfAppend: Monitor file does not exist: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."

mfHeader :: MonitorFile a -> IO ()
mfHeader :: MonitorFile a -> IO ()
mfHeader MonitorFile a
m = case MonitorFile a -> Maybe Handle
forall a. MonitorFile a -> Maybe Handle
mfHandle MonitorFile a
m of
  Maybe Handle
Nothing ->
    [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char]
"mfHeader: No handle available for monitor with name "
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> MonitorFile a -> [Char]
forall a. MonitorFile a -> [Char]
mfName MonitorFile a
m
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"."
  Just Handle
h ->
    Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
      [ByteString] -> ByteString
mfRenderRow ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
        [ByteString
"Iteration", ByteString
"Log-Prior", ByteString
"Log-Likelihood", ByteString
"Log-Posterior"]
          [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [[Char] -> ByteString
BL.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ MonitorParameter a -> [Char]
forall a. MonitorParameter a -> [Char]
mpName MonitorParameter a
p | MonitorParameter a
p <- MonitorFile a -> [MonitorParameter a]
forall a. MonitorFile a -> [MonitorParameter a]
mfParams MonitorFile a
m]

mfExec ::
  Int ->
  Item a ->
  MonitorFile a ->
  IO ()
mfExec :: Int -> Item a -> MonitorFile a -> IO ()
mfExec Int
i (Item a
x Log Double
p Log Double
l) MonitorFile a
m
  | Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` MonitorFile a -> Int
forall a. MonitorFile a -> Int
mfPeriod MonitorFile a
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = case MonitorFile a -> Maybe Handle
forall a. MonitorFile a -> Maybe Handle
mfHandle MonitorFile a
m of
    Maybe Handle
Nothing ->
      [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char]
"mfExec: No handle available for monitor with name "
          [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> MonitorFile a -> [Char]
forall a. MonitorFile a -> [Char]
mfName MonitorFile a
m
          [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"."
    Just Handle
h ->
      Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
        [ByteString] -> ByteString
mfRenderRow ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
          [Char] -> ByteString
BL.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i) ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:
          Log Double -> ByteString
renderLog Log Double
p ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:
          Log Double -> ByteString
renderLog Log Double
l ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:
          Log Double -> ByteString
renderLog (Log Double
p Log Double -> Log Double -> Log Double
forall a. Num a => a -> a -> a
* Log Double
l) ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:
            [Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ MonitorParameter a -> a -> Builder
forall a. MonitorParameter a -> a -> Builder
mpFunc MonitorParameter a
mp a
x | MonitorParameter a
mp <- MonitorFile a -> [MonitorParameter a]
forall a. MonitorFile a -> [MonitorParameter a]
mfParams MonitorFile a
m]

mfClose :: MonitorFile a -> IO ()
mfClose :: MonitorFile a -> IO ()
mfClose MonitorFile a
m = case MonitorFile a -> Maybe Handle
forall a. MonitorFile a -> Maybe Handle
mfHandle MonitorFile a
m of
  Just Handle
h -> Handle -> IO ()
hClose Handle
h
  Maybe Handle
Nothing -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"mfClose: File was not opened for monitor " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> MonitorFile a -> [Char]
forall a. MonitorFile a -> [Char]
mfName MonitorFile a
m [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"."

-- | Monitor to a file, but calculate batch means for the given batch size;
-- constructed with 'monitorBatch'.
--
-- Batch monitors are slow at the moment because the monitored parameter has to
-- be extracted from the state for each iteration.
data MonitorBatch a = MonitorBatch
  { MonitorBatch a -> [Char]
mbName :: String,
    MonitorBatch a -> Maybe Handle
mbHandle :: Maybe Handle,
    MonitorBatch a -> [MonitorParameterBatch a]
mbParams :: [MonitorParameterBatch a],
    MonitorBatch a -> Int
mbSize :: Int
  }

-- | Monitor parameters to a file, see 'MonitorBatch'.
monitorBatch ::
  -- | Name; used as part of the file name.
  String ->
  -- | Instructions about which parameters to log
  -- and how to calculate the batch means.
  [MonitorParameterBatch a] ->
  -- | Batch size.
  Int ->
  MonitorBatch a
monitorBatch :: [Char] -> [MonitorParameterBatch a] -> Int -> MonitorBatch a
monitorBatch [Char]
n [MonitorParameterBatch a]
ps Int
p
  | Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = [Char] -> MonitorBatch a
forall a. HasCallStack => [Char] -> a
error [Char]
"monitorBatch: Batch size has to be 2 or larger."
  | Bool
otherwise = [Char]
-> Maybe Handle
-> [MonitorParameterBatch a]
-> Int
-> MonitorBatch a
forall a.
[Char]
-> Maybe Handle
-> [MonitorParameterBatch a]
-> Int
-> MonitorBatch a
MonitorBatch [Char]
n Maybe Handle
forall a. Maybe a
Nothing [MonitorParameterBatch a]
ps Int
p

mbOpen :: String -> Bool -> MonitorBatch a -> IO (MonitorBatch a)
mbOpen :: [Char] -> Bool -> MonitorBatch a -> IO (MonitorBatch a)
mbOpen [Char]
n Bool
frc MonitorBatch a
m = do
  let mfn :: [Char]
mfn = [Char]
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> MonitorBatch a -> [Char]
forall a. MonitorBatch a -> [Char]
mbName MonitorBatch a
m [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
".batch"
  Handle
h <- [Char] -> Bool -> IO Handle
open' [Char]
mfn Bool
frc
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
  MonitorBatch a -> IO (MonitorBatch a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MonitorBatch a -> IO (MonitorBatch a))
-> MonitorBatch a -> IO (MonitorBatch a)
forall a b. (a -> b) -> a -> b
$ MonitorBatch a
m {mbHandle :: Maybe Handle
mbHandle = Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h}

mbAppend :: String -> MonitorBatch a -> IO (MonitorBatch a)
mbAppend :: [Char] -> MonitorBatch a -> IO (MonitorBatch a)
mbAppend [Char]
n MonitorBatch a
m = do
  let fn :: [Char]
fn = [Char]
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> MonitorBatch a -> [Char]
forall a. MonitorBatch a -> [Char]
mbName MonitorBatch a
m [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
".batch"
  Bool
fe <- [Char] -> IO Bool
doesFileExist [Char]
fn
  if Bool
fe
    then do
      Handle
h <- [Char] -> IOMode -> IO Handle
openFile [Char]
fn IOMode
AppendMode
      Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
      MonitorBatch a -> IO (MonitorBatch a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MonitorBatch a -> IO (MonitorBatch a))
-> MonitorBatch a -> IO (MonitorBatch a)
forall a b. (a -> b) -> a -> b
$ MonitorBatch a
m {mbHandle :: Maybe Handle
mbHandle = Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h}
    else [Char] -> IO (MonitorBatch a)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (MonitorBatch a)) -> [Char] -> IO (MonitorBatch a)
forall a b. (a -> b) -> a -> b
$ [Char]
"mbAppend: Monitor file does not exist: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."

mbHeader :: MonitorBatch a -> IO ()
mbHeader :: MonitorBatch a -> IO ()
mbHeader MonitorBatch a
m = case MonitorBatch a -> Maybe Handle
forall a. MonitorBatch a -> Maybe Handle
mbHandle MonitorBatch a
m of
  Maybe Handle
Nothing ->
    [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char]
"mbHeader: No handle available for batch monitor with name "
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> MonitorBatch a -> [Char]
forall a. MonitorBatch a -> [Char]
mbName MonitorBatch a
m
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"."
  Just Handle
h ->
    Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
      [ByteString] -> ByteString
mfRenderRow ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
        [ByteString
"Iteration", ByteString
"Mean log-Prior", ByteString
"Mean log-Likelihood", ByteString
"Mean log-Posterior"]
          [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [[Char] -> ByteString
BL.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ MonitorParameterBatch a -> [Char]
forall a. MonitorParameterBatch a -> [Char]
mbpName MonitorParameterBatch a
mbp | MonitorParameterBatch a
mbp <- MonitorBatch a -> [MonitorParameterBatch a]
forall a. MonitorBatch a -> [MonitorParameterBatch a]
mbParams MonitorBatch a
m]

mean :: [Log Double] -> Log Double
mean :: [Log Double] -> Log Double
mean [Log Double]
xs = [Log Double] -> Log Double
forall a (f :: * -> *).
(RealFloat a, Foldable f) =>
f (Log a) -> Log a
sum [Log Double]
xs Log Double -> Log Double -> Log Double
forall a. Fractional a => a -> a -> a
/ Int -> Log Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Log Double] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Log Double]
xs)

mbExec ::
  Int ->
  Trace a ->
  MonitorBatch a ->
  IO ()
mbExec :: Int -> Trace a -> MonitorBatch a -> IO ()
mbExec Int
i Trace a
t' MonitorBatch a
m
  | (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` MonitorBatch a -> Int
forall a. MonitorBatch a -> Int
mbSize MonitorBatch a
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) Bool -> Bool -> Bool
|| (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = case MonitorBatch a -> Maybe Handle
forall a. MonitorBatch a -> Maybe Handle
mbHandle MonitorBatch a
m of
    Maybe Handle
Nothing ->
      [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char]
"mbExec: No handle available for batch monitor with name "
          [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> MonitorBatch a -> [Char]
forall a. MonitorBatch a -> [Char]
mbName MonitorBatch a
m
          [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"."
    Just Handle
h ->
      Handle -> ByteString -> IO ()
BL.hPutStrLn Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
        [ByteString] -> ByteString
mfRenderRow ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
          [Char] -> ByteString
BL.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i) ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:
          Log Double -> ByteString
renderLog Log Double
mlps ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:
          Log Double -> ByteString
renderLog Log Double
mlls ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:
          Log Double -> ByteString
renderLog Log Double
mlos ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:
            [Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ MonitorParameterBatch a -> [a] -> Builder
forall a. MonitorParameterBatch a -> [a] -> Builder
mbpFunc MonitorParameterBatch a
mbp ((Item a -> a) -> [Item a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Item a -> a
forall a. Item a -> a
state [Item a]
t) | MonitorParameterBatch a
mbp <- MonitorBatch a -> [MonitorParameterBatch a]
forall a. MonitorBatch a -> [MonitorParameterBatch a]
mbParams MonitorBatch a
m]
  where
    t :: [Item a]
t = Int -> Trace a -> [Item a]
forall a. Int -> Trace a -> [Item a]
takeItems (MonitorBatch a -> Int
forall a. MonitorBatch a -> Int
mbSize MonitorBatch a
m) Trace a
t'
    lps :: [Log Double]
lps = (Item a -> Log Double) -> [Item a] -> [Log Double]
forall a b. (a -> b) -> [a] -> [b]
map Item a -> Log Double
forall a. Item a -> Log Double
prior [Item a]
t
    lls :: [Log Double]
lls = (Item a -> Log Double) -> [Item a] -> [Log Double]
forall a b. (a -> b) -> [a] -> [b]
map Item a -> Log Double
forall a. Item a -> Log Double
likelihood [Item a]
t
    los :: [Log Double]
los = (Log Double -> Log Double -> Log Double)
-> [Log Double] -> [Log Double] -> [Log Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Log Double -> Log Double -> Log Double
forall a. Num a => a -> a -> a
(*) [Log Double]
lps [Log Double]
lls
    mlps :: Log Double
mlps = [Log Double] -> Log Double
mean [Log Double]
lps
    mlls :: Log Double
mlls = [Log Double] -> Log Double
mean [Log Double]
lls
    mlos :: Log Double
mlos = [Log Double] -> Log Double
mean [Log Double]
los

mbClose :: MonitorBatch a -> IO ()
mbClose :: MonitorBatch a -> IO ()
mbClose MonitorBatch a
m = case MonitorBatch a -> Maybe Handle
forall a. MonitorBatch a -> Maybe Handle
mbHandle MonitorBatch a
m of
  Just Handle
h -> Handle -> IO ()
hClose Handle
h
  Maybe Handle
Nothing -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"mfClose: File was not opened for batch monitor: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> MonitorBatch a -> [Char]
forall a. MonitorBatch a -> [Char]
mbName MonitorBatch a
m [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"."

-- | Open the files associated with the 'Monitor'.
mOpen :: String -> Bool -> Monitor a -> IO (Monitor a)
mOpen :: [Char] -> Bool -> Monitor a -> IO (Monitor a)
mOpen [Char]
n Bool
frc (Monitor MonitorStdOut a
s [MonitorFile a]
fs [MonitorBatch a]
bs) = do
  [MonitorFile a]
fs' <- (MonitorFile a -> IO (MonitorFile a))
-> [MonitorFile a] -> IO [MonitorFile a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Char] -> Bool -> MonitorFile a -> IO (MonitorFile a)
forall a. [Char] -> Bool -> MonitorFile a -> IO (MonitorFile a)
mfOpen [Char]
n Bool
frc) [MonitorFile a]
fs
  (MonitorFile a -> IO ()) -> [MonitorFile a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MonitorFile a -> IO ()
forall a. MonitorFile a -> IO ()
mfHeader [MonitorFile a]
fs'
  [MonitorBatch a]
bs' <- (MonitorBatch a -> IO (MonitorBatch a))
-> [MonitorBatch a] -> IO [MonitorBatch a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Char] -> Bool -> MonitorBatch a -> IO (MonitorBatch a)
forall a. [Char] -> Bool -> MonitorBatch a -> IO (MonitorBatch a)
mbOpen [Char]
n Bool
frc) [MonitorBatch a]
bs
  (MonitorBatch a -> IO ()) -> [MonitorBatch a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MonitorBatch a -> IO ()
forall a. MonitorBatch a -> IO ()
mbHeader [MonitorBatch a]
bs'
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
  Monitor a -> IO (Monitor a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Monitor a -> IO (Monitor a)) -> Monitor a -> IO (Monitor a)
forall a b. (a -> b) -> a -> b
$ MonitorStdOut a -> [MonitorFile a] -> [MonitorBatch a] -> Monitor a
forall a.
MonitorStdOut a -> [MonitorFile a] -> [MonitorBatch a] -> Monitor a
Monitor MonitorStdOut a
s [MonitorFile a]
fs' [MonitorBatch a]
bs'

-- | Open the files associated with the 'Monitor' in append mode.
mAppend :: String -> Monitor a -> IO (Monitor a)
mAppend :: [Char] -> Monitor a -> IO (Monitor a)
mAppend [Char]
n (Monitor MonitorStdOut a
s [MonitorFile a]
fs [MonitorBatch a]
bs) = do
  [MonitorFile a]
fs' <- (MonitorFile a -> IO (MonitorFile a))
-> [MonitorFile a] -> IO [MonitorFile a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Char] -> MonitorFile a -> IO (MonitorFile a)
forall a. [Char] -> MonitorFile a -> IO (MonitorFile a)
mfAppend [Char]
n) [MonitorFile a]
fs
  [MonitorBatch a]
bs' <- (MonitorBatch a -> IO (MonitorBatch a))
-> [MonitorBatch a] -> IO [MonitorBatch a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Char] -> MonitorBatch a -> IO (MonitorBatch a)
forall a. [Char] -> MonitorBatch a -> IO (MonitorBatch a)
mbAppend [Char]
n) [MonitorBatch a]
bs
  Monitor a -> IO (Monitor a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Monitor a -> IO (Monitor a)) -> Monitor a -> IO (Monitor a)
forall a b. (a -> b) -> a -> b
$ MonitorStdOut a -> [MonitorFile a] -> [MonitorBatch a] -> Monitor a
forall a.
MonitorStdOut a -> [MonitorFile a] -> [MonitorBatch a] -> Monitor a
Monitor MonitorStdOut a
s [MonitorFile a]
fs' [MonitorBatch a]
bs'

-- | Execute monitors; print status information to files and return text to be
-- printed to standard output and log file.
mExec ::
  -- | Verbosity
  Verbosity ->
  -- | Iteration.
  Int ->
  -- | Starting state.
  Int ->
  -- | Starting time.
  UTCTime ->
  -- | Trace of Markov chain.
  Trace a ->
  -- | Total number of iterations; to calculate ETA.
  Int ->
  -- | The monitor.
  Monitor a ->
  IO (Maybe BL.ByteString)
mExec :: Verbosity
-> Int
-> Int
-> UTCTime
-> Trace a
-> Int
-> Monitor a
-> IO (Maybe ByteString)
mExec Verbosity
v Int
i Int
ss UTCTime
st Trace a
xs Int
j (Monitor MonitorStdOut a
s [MonitorFile a]
fs [MonitorBatch a]
bs) = do
  (MonitorFile a -> IO ()) -> [MonitorFile a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int -> Item a -> MonitorFile a -> IO ()
forall a. Int -> Item a -> MonitorFile a -> IO ()
mfExec Int
i (Item a -> MonitorFile a -> IO ())
-> Item a -> MonitorFile a -> IO ()
forall a b. (a -> b) -> a -> b
$ Trace a -> Item a
forall a. Trace a -> Item a
headT Trace a
xs) [MonitorFile a]
fs
  (MonitorBatch a -> IO ()) -> [MonitorBatch a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int -> Trace a -> MonitorBatch a -> IO ()
forall a. Int -> Trace a -> MonitorBatch a -> IO ()
mbExec Int
i Trace a
xs) [MonitorBatch a]
bs
  if Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Quiet
    then Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
    else Int
-> Item a
-> Int
-> UTCTime
-> Int
-> MonitorStdOut a
-> IO (Maybe ByteString)
forall a.
Int
-> Item a
-> Int
-> UTCTime
-> Int
-> MonitorStdOut a
-> IO (Maybe ByteString)
msExec Int
i (Trace a -> Item a
forall a. Trace a -> Item a
headT Trace a
xs) Int
ss UTCTime
st Int
j MonitorStdOut a
s

-- | Close the files associated with the 'Monitor'.
mClose :: Monitor a -> IO (Monitor a)
mClose :: Monitor a -> IO (Monitor a)
mClose m :: Monitor a
m@(Monitor MonitorStdOut a
_ [MonitorFile a]
fms [MonitorBatch a]
bms) = do
  (MonitorFile a -> IO ()) -> [MonitorFile a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MonitorFile a -> IO ()
forall a. MonitorFile a -> IO ()
mfClose [MonitorFile a]
fms
  (MonitorBatch a -> IO ()) -> [MonitorBatch a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MonitorBatch a -> IO ()
forall a. MonitorBatch a -> IO ()
mbClose [MonitorBatch a]
bms
  let fms' :: [MonitorFile a]
fms' = (MonitorFile a -> MonitorFile a)
-> [MonitorFile a] -> [MonitorFile a]
forall a b. (a -> b) -> [a] -> [b]
map (\MonitorFile a
fm -> MonitorFile a
fm {mfHandle :: Maybe Handle
mfHandle = Maybe Handle
forall a. Maybe a
Nothing}) [MonitorFile a]
fms
  let bms' :: [MonitorBatch a]
bms' = (MonitorBatch a -> MonitorBatch a)
-> [MonitorBatch a] -> [MonitorBatch a]
forall a b. (a -> b) -> [a] -> [b]
map (\MonitorBatch a
bm -> MonitorBatch a
bm {mbHandle :: Maybe Handle
mbHandle = Maybe Handle
forall a. Maybe a
Nothing}) [MonitorBatch a]
bms
  Monitor a -> IO (Monitor a)
forall (m :: * -> *) a. Monad m => a -> m a
return Monitor a
m {mFiles :: [MonitorFile a]
mFiles = [MonitorFile a]
fms', mBatches :: [MonitorBatch a]
mBatches = [MonitorBatch a]
bms'}