{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Mcmc.Save
( saveStatus,
loadStatus,
)
where
import Codec.Compression.GZip
import Control.Monad
import Data.Aeson
import Data.Aeson.TH
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.List hiding (cycle)
import qualified Data.Map as M
import Data.Maybe
import Data.Vector.Unboxed (Vector)
import Data.Word
import Mcmc.Item
import Mcmc.Monitor
import Mcmc.Proposal
import Mcmc.Status hiding (save)
import Mcmc.Trace
import Mcmc.Verbosity
import Numeric.Log
import System.Directory
import System.IO.Unsafe (unsafePerformIO)
import System.Random.MWC
import Prelude hiding (cycle)
data Save a
= Save
String
(Item a)
Int
(Trace a)
(Acceptance Int)
(Maybe Int)
(Maybe Int)
Int
Bool
(Maybe Int)
Verbosity
(Vector Word32)
[Maybe Double]
$(deriveJSON defaultOptions ''Save)
toSave :: Status a -> Save a
toSave (Status nm it i tr ac br at is f sv vb g _ _ _ _ c _) =
Save
nm
it
i
tr'
ac'
br
at
is
f
sv
vb
g'
ts
where
tr' = takeT (fromMaybe 0 sv) tr
ac' = transformKeysA (ccProposals c) [0 ..] ac
g' = fromSeed $ unsafePerformIO $ save g
ts = [fmap tParam mt | mt <- map pTuner $ ccProposals c]
saveStatus :: ToJSON a => FilePath -> Status a -> IO ()
saveStatus fn s = BL.writeFile fn $ compress $ encode (toSave s)
fromSave ::
(a -> Log Double) ->
(a -> Log Double) ->
Cycle a ->
Monitor a ->
Save a ->
Status a
fromSave p l c m (Save nm it i tr ac' br at is f sv vb g' ts) =
Status
nm
it
i
tr
ac
br
at
is
f
sv
vb
g
Nothing
Nothing
p
l
c'
m
where
ac = transformKeysA [0 ..] (ccProposals c) ac'
g = unsafePerformIO $ restore $ toSeed g'
c' = tuneCycle (M.mapMaybe id $ M.fromList $ zip (ccProposals c) ts) c
loadStatus ::
FromJSON a =>
(a -> Log Double) ->
(a -> Log Double) ->
Cycle a ->
Monitor a ->
FilePath ->
IO (Status a)
loadStatus p l c m fn = do
res <- eitherDecode . decompress <$> BL.readFile fn
let s = case res of
Left err -> error err
Right sv -> fromSave p l c m sv
let Item x svp svl = item s
when
(p x /= svp)
( error
"loadStatus: Provided prior function does not match the saved prior."
)
when
(l x /= svl)
( error
"loadStatus: Provided likelihood function does not match the saved likelihood."
)
removeFile fn
return s