{-# LANGUAGE OverloadedStrings #-}
module Mcmc.Monitor
(
Monitor (..),
MonitorStdOut,
monitorStdOut,
MonitorFile,
monitorFile,
MonitorBatch,
monitorBatch,
mOpen,
mAppend,
mHeader,
mExec,
mClose,
)
where
import Control.Monad
import Data.Int
import qualified Data.Text.Lazy as T
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy.Builder as T
import qualified Data.Text.Lazy.IO as T
import Data.Time.Clock
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)
data Monitor a
= Monitor
{
mStdOut :: MonitorStdOut a,
mFiles :: [MonitorFile a],
mBatches :: [MonitorBatch a]
}
data MonitorStdOut a
= MonitorStdOut
{ msParams :: [MonitorParameter a],
msPeriod :: Int
}
monitorStdOut ::
[MonitorParameter a] ->
Int ->
MonitorStdOut a
monitorStdOut ps p
| p < 1 = error "monitorStdOut: Monitor period has to be 1 or larger."
| otherwise = MonitorStdOut ps p
msIWidth :: Int64
msIWidth = 12
msWidth :: Int64
msWidth = 22
msRenderRow :: [Text] -> Text
msRenderRow xs = T.justifyRight msIWidth ' ' (head xs) <> T.concat vals
where
vals = map (T.justifyRight msWidth ' ') (tail xs)
msHeader :: MonitorStdOut a -> Text
msHeader m = T.intercalate "\n" [row, sep]
where
row =
msRenderRow $
["Iteration", "Log-Prior", "Log-Likelihood", "Log-Posterior"]
++ nms
++ ["Runtime", "ETA"]
sep = " " <> T.replicate (T.length row - 3) "─"
nms = [T.pack $ mpName p | p <- msParams m]
msExec ::
Int ->
Item a ->
Int ->
UTCTime ->
Int ->
MonitorStdOut a ->
IO (Maybe Text)
msExec i (Item x p l) ss st j m
| i `mod` msPeriod m /= 0 = return Nothing
| otherwise = do
ct <- getCurrentTime
let dt = ct `diffUTCTime` st
timePerIter = dt / fromIntegral (i - ss)
eta =
if (i - ss) < 10
then ""
else renderDuration $ timePerIter * fromIntegral (j - i)
return $ Just $ msRenderRow $
[T.pack (show i), renderLog p, renderLog l, renderLog (p * l)]
++ [T.toLazyText $ mpFunc mp x | mp <- msParams m]
++ [renderDuration dt, eta]
data MonitorFile a
= MonitorFile
{ mfName :: String,
mfHandle :: Maybe Handle,
mfParams :: [MonitorParameter a],
mfPeriod :: Int
}
monitorFile ::
String ->
[MonitorParameter a] ->
Int ->
MonitorFile a
monitorFile n ps p
| p < 1 = error "monitorFile: Monitor period has to be 1 or larger."
| otherwise = MonitorFile n Nothing ps p
mfRenderRow :: [Text] -> Text
mfRenderRow = T.intercalate "\t"
open' :: String -> Bool -> IO Handle
open' n frc = do
fe <- doesFileExist n
case (fe, frc) of
(False, _) -> openFile n WriteMode
(True, True) -> openFile n WriteMode
(True, False) -> error $ "open': File \"" <> n <> "\" exists; probably use 'force'?"
mfOpen :: String -> Bool -> MonitorFile a -> IO (MonitorFile a)
mfOpen n frc m = do
let mfn = n <> mfName m <> ".monitor"
h <- open' mfn frc
hSetBuffering h LineBuffering
return $ m {mfHandle = Just h}
mfAppend :: String -> MonitorFile a -> IO (MonitorFile a)
mfAppend n m = do
let fn = n <> mfName m <> ".monitor"
fe <- doesFileExist fn
if fe
then do
h <- openFile fn AppendMode
hSetBuffering h LineBuffering
return $ m {mfHandle = Just h}
else error $ "mfAppend: Monitor file does not exist: " ++ fn ++ "."
mfHeader :: MonitorFile a -> IO ()
mfHeader m = case mfHandle m of
Nothing ->
error $
"mfHeader: No handle available for monitor with name "
<> mfName m
<> "."
Just h ->
T.hPutStrLn h
$ mfRenderRow
$ ["Iteration", "Log-Prior", "Log-Likelihood", "Log-Posterior"]
++ [T.pack $ mpName p | p <- mfParams m]
mfExec ::
Int ->
Item a ->
MonitorFile a ->
IO ()
mfExec i (Item x p l) m
| i `mod` mfPeriod m /= 0 = return ()
| otherwise = case mfHandle m of
Nothing ->
error $
"mfExec: No handle available for monitor with name "
<> mfName m
<> "."
Just h ->
T.hPutStrLn h
$ mfRenderRow
$ T.pack (show i)
: renderLog p
: renderLog l
: renderLog (p * l)
: [T.toLazyText $ mpFunc mp x | mp <- mfParams m]
mfClose :: MonitorFile a -> IO ()
mfClose m = case mfHandle m of
Just h -> hClose h
Nothing -> error $ "mfClose: File was not opened for monitor " <> mfName m <> "."
data MonitorBatch a
= MonitorBatch
{ mbName :: String,
mbHandle :: Maybe Handle,
mbParams :: [MonitorParameterBatch a],
mbSize :: Int
}
monitorBatch ::
String ->
[MonitorParameterBatch a] ->
Int ->
MonitorBatch a
monitorBatch n ps p
| p < 2 = error "monitorBatch: Batch size has to be 2 or larger."
| otherwise = MonitorBatch n Nothing ps p
mbOpen :: String -> Bool -> MonitorBatch a -> IO (MonitorBatch a)
mbOpen n frc m = do
let mfn = n <> mbName m <> ".batch"
h <- open' mfn frc
hSetBuffering h LineBuffering
return $ m {mbHandle = Just h}
mbAppend :: String -> MonitorBatch a -> IO (MonitorBatch a)
mbAppend n m = do
let fn = n <> mbName m <> ".batch"
fe <- doesFileExist fn
if fe
then do
h <- openFile fn AppendMode
hSetBuffering h LineBuffering
return $ m {mbHandle = Just h}
else error $ "mbAppend: Monitor file does not exist: " ++ fn ++ "."
mbHeader :: MonitorBatch a -> IO ()
mbHeader m = case mbHandle m of
Nothing ->
error $
"mbHeader: No handle available for batch monitor with name "
<> mbName m
<> "."
Just h ->
T.hPutStrLn h
$ mfRenderRow
$ ["Iteration", "Mean log-Prior", "Mean log-Likelihood", "Mean log-Posterior"]
++ [T.pack $ mbpName mbp | mbp <- mbParams m]
mean :: [Log Double] -> Log Double
mean xs = sum xs / fromIntegral (length xs)
mbExec ::
Int ->
Trace a ->
MonitorBatch a ->
IO ()
mbExec i t' m
| (i `mod` mbSize m /= 0) || (i == 0) = return ()
| otherwise = case mbHandle m of
Nothing ->
error $
"mbExec: No handle available for batch monitor with name "
<> mbName m
<> "."
Just h ->
T.hPutStrLn h
$ mfRenderRow
$ T.pack (show i)
: renderLog mlps
: renderLog mlls
: renderLog mlos
: [T.toLazyText $ mbpFunc mbp (map state t) | mbp <- mbParams m]
where
t = takeT (mbSize m) t'
lps = map prior t
lls = map likelihood t
los = zipWith (*) lps lls
mlps = mean lps
mlls = mean lls
mlos = mean los
mbClose :: MonitorBatch a -> IO ()
mbClose m = case mbHandle m of
Just h -> hClose h
Nothing -> error $ "mfClose: File was not opened for batch monitor: " <> mbName m <> "."
mOpen :: String -> Bool -> Monitor a -> IO (Monitor a)
mOpen n frc (Monitor s fs bs) = do
fs' <- mapM (mfOpen n frc) fs
mapM_ mfHeader fs'
bs' <- mapM (mbOpen n frc) bs
mapM_ mbHeader bs'
return $ Monitor s fs' bs'
mAppend :: String -> Monitor a -> IO (Monitor a)
mAppend n (Monitor s fs bs) = do
fs' <- mapM (mfAppend n) fs
bs' <- mapM (mbAppend n) bs
return $ Monitor s fs' bs'
mHeader :: Monitor a -> Text
mHeader (Monitor s _ _) = msHeader s
mExec ::
Verbosity ->
Int ->
Int ->
UTCTime ->
Trace a ->
Int ->
Monitor a ->
IO (Maybe Text)
mExec v i ss st xs j (Monitor s fs bs) = do
mapM_ (mfExec i $ headT xs) fs
mapM_ (mbExec i xs) bs
if v == Quiet
then return Nothing
else msExec i (headT xs) ss st j s
mClose :: Monitor a -> IO (Monitor a)
mClose m@(Monitor _ fms bms) = do
mapM_ mfClose fms
mapM_ mbClose bms
let fms' = map (\fm -> fm {mfHandle = Nothing}) fms
let bms' = map (\bm -> bm {mbHandle = Nothing}) bms
return m {mFiles = fms', mBatches = bms'}