{-# 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 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 -> IO ()
msHeader m = T.hPutStr stdout $ T.unlines [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 ()
msExec i (Item x p l) (ss, st) j m
| i `mod` msPeriod m /= 0 =
return ()
| otherwise = do
ct <- getCurrentTime
let dt = ct `diffUTCTime` st
timePerIter = dt / fromIntegral (i - ss)
eta = if i < 10
then ""
else renderDuration $ timePerIter * fromIntegral (j - i)
T.hPutStrLn stdout
$ 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"
mfOpen :: String -> MonitorFile a -> IO (MonitorFile a)
mfOpen n m = do
h <- openFile (n <> mfName m <> ".monitor") WriteMode
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 -> MonitorBatch a -> IO (MonitorBatch a)
mbOpen n m = do
h <- openFile (n <> mbName m <> ".batch") WriteMode
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 -> Monitor a -> IO (Monitor a)
mOpen n (Monitor s fs bs) = do
fs' <- mapM (mfOpen n) fs
mapM_ mfHeader fs'
bs' <- mapM (mbOpen n) 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 -> IO ()
mHeader (Monitor s _ _) = msHeader s
mExec ::
Int ->
(Int, UTCTime) ->
Trace a ->
Int ->
Monitor a ->
IO ()
mExec i t xs j (Monitor s fs bs) = do
msExec i (headT xs) t j s
mapM_ (mfExec i $ headT xs) fs
mapM_ (mbExec i xs) bs
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'}