diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for experimenter + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,3 @@ +Copyright Manuel Schneckenreither (c) 2020 + +BSD3, see https://opensource.org/licenses/BSD-3-Clause diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,103 @@ +# Experimenter: Scientific experiments made easy + +[![Build Status](https://travis-ci.com/schnecki/experimenter.svg?branch=master)](https://travis-ci.com/schnecki/experimenter) + + +This package can be used to run experiments and repetitions of these that are then evaluated and a +report generated. The user can specify parameters, which span a set of experiment instances that are +automatically run and continuously saved to a PostgreSQL database, s.t. they can be resumed on the +same or other PCs. The design allows to run different experiment instances on different PCs at the +same time. Thus it efficiently distributes work. + +All random generators are repeated for the experiments. Thus, all (evaluation) replications use the +same standard number generator, Even after a crash and restart of the experiment on a different +computer. + +At the end of an experiment a LaTeX report can be generated according to the user specifications. +E.g. one might be interested in the mean and standard deviation of an experiment that rolls a dice. +This can be specified by: + + [ Mean OverExperimentRepetitions (Of "draw") `Named` "Mean Repetitions" + , StdDev OverExperimentRepetitions (Of "draw") `Named` "StdDev Repetitions" + ] + +The part left of the `Named` tag specifies the metric and right of it is the name that will be used +in the report. + +Each experiment can have a preparation phase, e.g. a learning phase for machine learning algorithms, +a warm-up phase, e.g. a queuing system that needs to be filled and get into the steady with the same +properties of the evaluation phase. The later is the one used for generating report of user defined +metrics. For instance, the user can define the dice draw like this: + + let result = StepResult "draw" Nothing (fromIntegral $ 1 + nr `mod` 6) + in ... + +The package provides a simple interface class `ExperimentDef a`, which is all that is needed to run +experiments in. In the simplest form this amounts to a datatype that holds the experiment state and +a function that implements one step of the experiment: + + -- | Data type for state + data Dice = + Dice + StdGen -- ^ Random number generator + deriving (Show, Generic) + + -- | NFData and Serialize instances + ... + + -- | Experiment definition + instance ExperimentDef Dice where + type ExpM Dice = IO + type InputValue Dice = () -- ^ No Input value + type InputState Dice = () -- ^ No Input state is generated when generating the input value + type Serializable Dice = Dice -- ^ Serialisation type is the same. One can use + + -- ^ One step, that is one dice draw. + runStep _ (Dice g) _ _ = + let (nr, g') = next g + result = StepResult "draw" Nothing (fromIntegral $ 1 + nr `mod` 6) + in return ([result], Dice g') + + +Here the state is saved in the type `Dice`, no further input information is used for each step. In +an experiment of a production system this might be the demand of the current period, which should be +the same over all instances of the experiment to ensure every instance has the same properties. The +function `runStep` makes one draw of a `6` sided dice and returns the result as well as the new +state. + +The experiment can then be configured like this: + + setup :: MkExperimentSetting a + setup _ = + ExperimentSetting + { _experimentBaseName = "dice param experiment" -- ^ Gives the experiment a name. + , _experimentInfoParameters = [] -- ^ For storing information which only effects the report. + , _experimentRepetitions = 2 -- ^ How often to repeat the whole experiment (including the preperation phase). + , _preparationSteps = 0 -- ^ How many steps to execute for the preperation phase. + , _evaluationWarmUpSteps = 1000 -- ^ How many steps to execute for the warm-up phase. + , _evaluationSteps = 10000 -- ^ How many steps to execute for the evaluation phase. + , _evaluationReplications = 1 -- ^ How often to execute the evaluation for each experiment repetition. + , _evaluationMaxStepsBetweenSaves = Just 100000 -- ^ Specify after how many steps the data will be saved. `Nothing` adaptively chooses a sensible value. + } + +If these settings are changed the library only deletes data when it is necessary. For instance +increasing the replications or repetitions of the experiment will not delete any data. When however, +the preparation steps are changed, all consequitive data, including warm-up and all evaluations, are +deleted and rerun. + +See [Dice.hs](examples/Dice.hs) for a full implementation, where the sides of the dices are variable +over the experiment. An example report of this experiment can be found in the same folder. + + +# Ideas and TODOs + +- Time of experiment run as step result. +- Nice Reports +- Html Results? +- Statistical measures for reports +- More test for the test suite +- CSV output: average over experiments not implemented + +# Help + +Any help is warmly welcomed. Please feel free to start coding, submit pull requests or contact me :) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/experimenter.cabal b/experimenter.cabal new file mode 100644 --- /dev/null +++ b/experimenter.cabal @@ -0,0 +1,160 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: bf820cc6e79b79354f552cd7494e0734f04c0525b7ed9d9137baf4d34284f88d + +name: experimenter +version: 0.1.0.0 +synopsis: Perform scientific experiments stored in a DB, and generate reports. +description: Please see the README on GitHub at +category: Experiment +homepage: https://github.com/schnecki/experimenter#readme +bug-reports: https://github.com/schnecki/experimenter/issues +author: Manuel Schneckenreither +maintainer: manuel.schneckenreither@uibk.ac.at +copyright: 2020 Manuel Schneckenreither +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/schnecki/experimenter + +flag fast + description: Disables optimizations + manual: True + default: False + +library + exposed-modules: + Experimenter + Experimenter.Availability + Experimenter.Availability.Ops + Experimenter.Availability.Type + Experimenter.ConcurrentIO + Experimenter.DatabaseSetting + Experimenter.DB + Experimenter.Eval + Experimenter.Eval.Csv + Experimenter.Eval.Latex + Experimenter.Eval.Ops + Experimenter.Eval.Reduce + Experimenter.Eval.Table + Experimenter.Eval.Type + Experimenter.Eval.Util + Experimenter.Experiment + Experimenter.Input + Experimenter.MasterSlave + Experimenter.Measure + Experimenter.Models + Experimenter.Parameter + Experimenter.Parameter.Ops + Experimenter.Parameter.Query + Experimenter.Parameter.Type + Experimenter.Result + Experimenter.Result.Query + Experimenter.Result.Type + Experimenter.Run + Experimenter.Setting + Experimenter.State + Experimenter.StepResult + Experimenter.Util + other-modules: + Paths_experimenter + hs-source-dirs: + src + ghc-options: -Wall -Wno-name-shadowing -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fwarn-tabs + build-depends: + HaTeX >=3.22.0.0 + , aeson + , base >=4.7 && <5 + , bytestring + , cereal + , cereal-vector + , conduit + , containers + , deepseq + , directory + , esqueleto + , filepath + , hostname + , lens + , matrix + , monad-logger + , mtl + , mwc-random + , parallel + , persistent >=2.0 + , persistent-postgresql >=2.1.1 + , persistent-template >=2.0 + , process + , resource-pool + , resourcet + , stm + , text + , time + , transformers + , unix + , unliftio-core + , vector + if flag(fast) + ghc-options: --disable-optimization + else + ghc-options: -O2 + default-language: Haskell2010 + +test-suite experimenter-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + TestExperimenter.Serialise.Instances + TestExperimenter.Serialise.SerialiseSpec + Paths_experimenter + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + HaTeX >=3.22.0.0 + , QuickCheck + , aeson + , base >=4.7 && <5 + , bytestring + , cereal + , cereal-vector + , conduit + , containers + , deepseq + , directory + , esqueleto + , experimenter + , filepath + , foundation + , hostname + , hspec + , lens + , matrix + , monad-logger + , mtl + , mwc-random + , parallel + , persistent >=2.0 + , persistent-postgresql >=2.1.1 + , persistent-template >=2.0 + , process + , resource-pool + , resourcet + , stm + , text + , time + , transformers + , unix + , unliftio-core + , vector + default-language: Haskell2010 diff --git a/src/Experimenter.hs b/src/Experimenter.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter.hs @@ -0,0 +1,16 @@ +module Experimenter + ( module E + ) where + +import Experimenter.Availability as E +import Experimenter.Eval as E +import Experimenter.Experiment as E +import Experimenter.Input as E +import Experimenter.Measure as E +import Experimenter.Models as E +import Experimenter.Parameter as E +import Experimenter.Result as E +import Experimenter.Run as E +import Experimenter.Setting as E +import Experimenter.State as E +import Experimenter.StepResult as E diff --git a/src/Experimenter/Availability.hs b/src/Experimenter/Availability.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Availability.hs @@ -0,0 +1,6 @@ +module Experimenter.Availability + ( module A + ) where + +import Experimenter.Availability.Ops as A +import Experimenter.Availability.Type as A diff --git a/src/Experimenter/Availability/Ops.hs b/src/Experimenter/Availability/Ops.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Availability/Ops.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} + +module Experimenter.Availability.Ops where + +import Experimenter.Availability.Type + +import Conduit as C +import Data.Conduit.List as CL + +import Experimenter.DB + +mkAvailable :: (Monad m) => Availability m b -> DB m (Availability m b) +mkAvailable (AvailableOnDemand query) = Available <$> query +mkAvailable (Available x) = return (Available x) + +mkTransientlyAvailable :: (Monad m) => Availability m b -> DB m b +mkTransientlyAvailable (Available x) = return x +mkTransientlyAvailable (AvailableOnDemand query) = query + +mkAvailableList :: (Monad m) => AvailabilityList m b -> DB m (AvailabilityList m b) +mkAvailableList (AvailableList (nr, xs) src) = return $ AvailableList (nr, xs) src +mkAvailableList (AvailableListOnDemand (_, query)) = (\xs -> AvailableList (length xs, xs) query) <$> C.runConduit (query GetAll C..| CL.consume) + +mkTransientlyAvailableList :: (Monad m) => AvailabilityList m b -> DB m [b] +mkTransientlyAvailableList (AvailableList (_,x) _) = return x +mkTransientlyAvailableList (AvailableListOnDemand (_,query)) = C.runConduit $ query GetAll C..| CL.consume + +lengthAvailabilityList :: AvailabilityList m b -> Int +lengthAvailabilityList (AvailableList (nr, _) _) = nr +lengthAvailabilityList (AvailableListOnDemand (nr, _)) = nr + +srcAvailableList :: (Monad m) => AvailabilityList m a -> ConduitT () a (DB m) () +srcAvailableList (AvailableList (_, xs) _) = CL.sourceList xs +srcAvailableList (AvailableListOnDemand (_,src)) = src GetAll + +srcAvailableListWhere :: AvailabilityListWhere -> AvailabilityList m a -> ConduitT () a (DB m) () +srcAvailableListWhere where' (AvailableList _ src) = src where' +srcAvailableListWhere where' (AvailableListOnDemand (_,src)) = src where' + diff --git a/src/Experimenter/Availability/Type.hs b/src/Experimenter/Availability/Type.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Availability/Type.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} + +module Experimenter.Availability.Type where + +import Control.DeepSeq +import Data.Conduit +import Database.Esqueleto as E +import Experimenter.Models + +import Experimenter.DB + +data Availability m b + = Available !b + | AvailableOnDemand !(DB m b) + +instance (Show b) => Show (Availability m b) where + show (Available b) = show b + show (AvailableOnDemand _) = "Available on demand" + +instance (NFData b) => NFData (Availability m b) where + rnf (Available b) = rnf b + rnf (AvailableOnDemand !_) = () + + +type AggregateFunction = E.SqlExpr (E.Value Double) -> E.SqlExpr (E.Value (Maybe Double)) + + +data AvailabilityListWhere + = GetAll + | PrepInputWhere !(E.SqlExpr (Entity PrepInput) -> E.SqlExpr (Entity PrepInputValue) -> E.SqlQuery ()) + | WarmUpInputWhere !(E.SqlExpr (Entity WarmUpInput) -> E.SqlExpr (Entity WarmUpInputValue) -> E.SqlQuery ()) + | RepInputWhere !(E.SqlExpr (Entity RepInput) -> E.SqlExpr (Entity RepInputValue) -> E.SqlQuery ()) + | PrepMeasureWhere !(E.SqlExpr (Entity PrepMeasure) -> E.SqlExpr (Entity PrepResultStep) -> E.SqlQuery ()) + | WarmUpMeasureWhere !(E.SqlExpr (Entity WarmUpMeasure) -> E.SqlExpr (Entity WarmUpResultStep) -> E.SqlQuery ()) + | RepMeasureWhere !(E.SqlExpr (Entity RepMeasure) -> E.SqlExpr (Entity RepResultStep) -> E.SqlQuery ()) + + +instance Show AvailabilityListWhere where + show GetAll{} = "GetAll" + show PrepInputWhere{} = "PrepInputWhere" + show WarmUpInputWhere{} = "WarmUpInputWhere" + show RepInputWhere{} = "RepInputWhere" + show PrepMeasureWhere{} = "PrepMeasureWhere" + show WarmUpMeasureWhere{} = "WarmUpMeasureWhere" + show RepMeasureWhere{} = "RepMeasureWhere" + + +data AvailabilityList m b + = AvailableList !(Int, [b]) (AvailabilityListWhere -> ConduitT () b (DB m) ()) + | AvailableListOnDemand (Int, AvailabilityListWhere -> ConduitT () b (DB m) ()) + + +instance (Show b) => Show (AvailabilityList m b) where + show (AvailableList b _) = show b + show (AvailableListOnDemand _) = "AvailableList on demand" + +instance (NFData b) => NFData (AvailabilityList m b) where + rnf (AvailableList b _) = rnf b + rnf (AvailableListOnDemand (nr,_)) = rnf nr diff --git a/src/Experimenter/ConcurrentIO.hs b/src/Experimenter/ConcurrentIO.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/ConcurrentIO.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Experimenter.ConcurrentIO + ( doFork + , collectForkResult + , mapConurrentIO + ) where + +import Control.Concurrent (forkIO, yield) +import Control.Concurrent.STM +import Control.DeepSeq +import Control.Monad (void) +import Data.IORef +import Data.Maybe (fromJust) + + +mapConurrentIO :: (NFData b) => Int -> (a -> IO b) -> [a] -> IO [b] +mapConurrentIO maxNr f xs = do + nr <- newTMVarIO 0 + mapConurrentIO' nr maxNr f xs + +mapConurrentIO' :: (NFData b) => TMVar Int -> Int -> (a -> IO b) -> [a] -> IO [b] +mapConurrentIO' _ _ _ [] = return [] +mapConurrentIO' tmVar maxNr f (x:xs) = do + nr <- fmap fromJust $ atomically $ tryReadTMVar tmVar + -- putStrLn ("Nr: " ++ show nr) >> hFlush stdout + if nr >= maxNr + then atomically (readTMVar tmVar) >> mapConurrentIO' tmVar maxNr f (x : xs) + else do + increase + !xThread <- doFork $ f x >>= (\v -> decrease >> return v) + xs' <- mapConurrentIO' tmVar maxNr f xs + x' <- collectForkResult xThread + return (x' : xs') + where + increase = modify (+ 1) + decrease = modify (subtract 1) + modify g = + void $ + atomically $ do + nr <- fromJust <$> tryReadTMVar tmVar + swapTMVar tmVar (g nr) + +doFork :: NFData a => IO a -> IO (IORef (ThreadState a)) +doFork f = do + ref <- newIORef NotReady + void $ forkIO (f >>= writeIORef ref . Ready . force) + return ref + +collectForkResult :: IORef (ThreadState a) -> IO a +collectForkResult ref = do + mRes <- readIORef ref + case mRes of + NotReady -> yield >> collectForkResult ref + Ready a -> return a + +data ThreadState a = NotReady | Ready !a diff --git a/src/Experimenter/DB.hs b/src/Experimenter/DB.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/DB.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +module Experimenter.DB where + + +import Conduit as C +import Control.Monad.Logger +import Control.Monad.Trans.Reader (ReaderT) +import Data.Char +import Data.List (foldl') +import qualified Data.Text as T +import qualified Database.Esqueleto as E +import Database.Persist.Postgresql (SqlBackend, withPostgresqlPool) + +import Experimenter.DatabaseSetting + + +type DB m = ReaderT SqlBackend (LoggingT (ResourceT m)) +type SimpleDB = DB IO + +logFun :: (MonadIO m) => LoggingT m a -> m a +logFun = runStdoutLoggingT . filterLogger (\s _ -> s /= "SQL") + +-- logFun :: NoLoggingT m a -> m a +-- logFun = runNoLoggingT + + +runDB :: (MonadUnliftIO m) => DatabaseSetting -> DB m a -> m a +runDB = runDBWithM runResourceT + +runDBSimple :: DatabaseSetting -> SimpleDB a -> IO a +runDBSimple = runDBWithM runResourceT + + +runDBWithM :: (MonadUnliftIO m1) => (m1 a -> m a) -> DatabaseSetting -> ReaderT SqlBackend (LoggingT m1) a -> m a +runDBWithM runM dbSetting action = runM $ logFun $ withPostgresqlPool (connectionString dbSetting) (parallelConnections dbSetting) $ \pool -> E.runSqlPool action pool + + +-- withPostgresqlPool :: (MonadLogger m, MonadUnliftIO m) => ConnectionString -> Int -> (Pool SqlBackend -> m a) -> m a +-- runSqlPool :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> m a + +-- | Create indices for fast lookups in the DB. +indexCreation :: (MonadIO m) => ReaderT SqlBackend (NoLoggingT (ResourceT m)) () +indexCreation = mapM_ ((\x -> E.rawExecute ("CREATE INDEX IF NOT EXISTS " <> mkName x <> " ON " <> x) []) . mkLowerCase) indices + where + mkName txt = foldl' (\acc (from, to) -> T.replace from to acc) (txt <> "index") replacements + replacements = [("(", "_"), (")", "_"), (",", "_"), ("\"", "")] + mkLowerCase x = toLowerCase ( T.takeWhile (/= '(') x) <> T.singleton '(' <> toLowerCase (T.tail $ T.dropWhile (/= '(') x) + toLowerCase = + let go c + | isUpper c = T.pack ['_', toLower c] + | otherwise = T.singleton c + in T.dropWhile (== '_') . T.concatMap go + indices = + [ -- "ExpsInfoParam(exps)" + -- , "ExpsMaster(exps)" + -- , "ExpsSetup(exps)" + -- , "Param(exps)" + -- , "Exp(exps)" + -- , "ExpExecutionLock(exp)" + -- , "ExpProgress(exp)" + -- , "ParamSetting(exp)" + -- , "ExpResult(exp)" + -- , "PrepStartStatePart(resultData)" + -- , "PrepEndStatePart(resultData)" + -- , "PrepInput(prepResultData)" + -- , "PrepInputValue(prepInput)" + -- , "PrepMeasure(prepResultData)" + -- , "PrepResultStep(measure)" + -- , "RepResult(expResult)" + + "RepResultStep(measure)" + , "WarmUpResultStep(measure)" + , "PrepResultStep(measure)" + + , "RepMeasure(repResult)" + , "WarmUpMeasure(repResult)" + , "PrepMeasure(prepResultData)" + + , "RepInputValue(repInput)" + , "WarmUpInputValue(warmUpInput)" + , "PrepInputValue(prepInput)" + + , "RepStartStatePart(resultData)" + , "RepEndStatePart(resultData)" + + + -- , "\"user\"(ident)" -- user is a postgres keyword! + ] diff --git a/src/Experimenter/DatabaseSetting.hs b/src/Experimenter/DatabaseSetting.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/DatabaseSetting.hs @@ -0,0 +1,9 @@ + +module Experimenter.DatabaseSetting where + +import qualified Data.ByteString as BS + +data DatabaseSetting = DatabaseSetting + { connectionString :: !BS.ByteString -- ^. e.g. "host=localhost dbname=experimenter user=postgres password=postgres port=5432" + , parallelConnections :: !Int + } diff --git a/src/Experimenter/Eval.hs b/src/Experimenter/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Eval.hs @@ -0,0 +1,11 @@ + +module Experimenter.Eval + ( module E + ) where + +import Experimenter.Eval.Csv as E +import Experimenter.Eval.Latex as E +import Experimenter.Eval.Ops as E +import Experimenter.Eval.Reduce as E +import Experimenter.Eval.Table as E +import Experimenter.Eval.Type as E diff --git a/src/Experimenter/Eval/Csv.hs b/src/Experimenter/Eval/Csv.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Eval/Csv.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module Experimenter.Eval.Csv + ( writeCsvMeasure + , Smoothing (..) + , MeasureName + ) where + +import Conduit as C +import Control.Lens hiding (Cons, Over) +import Control.Monad.Logger +import Control.Monad.Reader +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import qualified Database.Esqueleto as E +import System.Directory +import System.FilePath.Posix +import System.IO + +import Experimenter.DatabaseSetting +import Experimenter.DB +import Experimenter.Eval.Util +import Experimenter.Experiment (Phase (..)) +import Experimenter.Models +import Experimenter.Result.Type +import Experimenter.Util + + +data Smoothing = NoSmoothing | SmoothingMovAvg !Int + +type MeasureName = T.Text + +writeCsvMeasure :: DatabaseSetting -> Experiments a -> Smoothing -> [MeasureName] -> IO () +writeCsvMeasure dbSetup exps smoothing measures = runDBWithM runResourceT dbSetup $ mapM_ (smoothAndWriteFile exps smoothing) measures + +smoothAndWriteFile :: Experiments a -> Smoothing -> MeasureName -> DB IO () +smoothAndWriteFile exps smoothing measureName = mapM_ (smoothAndWriteFileExp exps smoothing measureName) (exps ^. experiments) + +smoothAndWriteFileExp :: Experiments a -> Smoothing -> MeasureName -> Experiment a -> DB IO () +smoothAndWriteFileExp exps smoothing measureName exp = do + $(logDebug) $ "Processing CSV for experiment number " <> tshow (exp ^. experimentNumber) + mapM_ + (\expRes -> do + $(logDebug) $ "Processing CSV for experiment repetition number " <> tshow (expRes ^. repetitionNumber) + mapM_ + (smoothAndWriteFileResultData exps (namePrefix expNr PreparationPhase (None (expRes ^. repetitionNumber) Nothing)) smoothing measureName . return) + (expRes ^.. preparationResults . traversed) + -- All experiment evaluations runs + mapM_ + (\(replRes :: ReplicationResult a) -> do + mapM_ + (\(repRes :: ResultData a) -> + smoothAndWriteFileResultData + exps + (namePrefix expNr WarmUpPhase (None (expRes ^. repetitionNumber) (Just $ replRes ^. replicationNumber))) + smoothing + measureName + [repRes]) + (replRes ^.. warmUpResults . traversed) + mapM_ + (\(repRes :: ResultData a) -> + smoothAndWriteFileResultData + exps + (namePrefix expNr EvaluationPhase (None (expRes ^. repetitionNumber) (Just $ replRes ^. replicationNumber))) + smoothing + measureName + [repRes]) + (replRes ^.. evalResults . traversed)) + (expRes ^. evaluationResults)) + (exp ^.. experimentResults . traversed) + -- avg over experiments + -- when (length (exp ^. experimentResults) > 1) $ do + -- $(logDebug) $ "Processing aggregated CSV for experiment number " <> tshow (exp ^. experimentNumber) + -- mapM_ + -- (\expRes -> do + -- error "Averages over experiment results are currently not supported. Please feel free to submit a merge request." + -- print expRes + -- ) (exp ^. experimentResults) + where + expNr = exp ^. experimentNumber + + +smoothC :: (Monad m) => Smoothing -> C.ConduitT (Int, Double) (Int, Double) m () +smoothC NoSmoothing = C.filterC (const True) +smoothC (SmoothingMovAvg nr) = process (0, []) + where + process inp@(sm, xs) = do + mx <- await + unless (null xs) $ yield (movAvg inp) + case mx of + Nothing -> return () + Just (x :: (Int, Double)) -> do + let m + | length xs < nr = 0 + | otherwise = snd $ last xs + v = snd x + process (sm + v - m, take nr (x : xs)) + +-- movAvg :: [Measure] -> Measure +-- movAvg [] = error "empty list when makeing movAvg" +-- movAvg xs@(x:_) = set (measureResults.traversed.resultYValue) (Prelude.sum (concatMap (^.. (measureResults.traversed.resultYValue)) xs) / fromIntegral (length xs)) x + +movAvg :: (Double, [(Int, Double)]) -> (Int, Double) +movAvg (_,[]) = error "No input for movAvg. Programming error!" +movAvg (sm, xs) = (fst x, sm / fromIntegral (length xs)) + where x = last xs + +data Keys = ResultDataPrepKeys ![Key PrepResultData] + | ResultDataWarmUpKeys ![Key WarmUpResultData] + | ResultDataRepKeys ![Key RepResultData] + +concatKeys :: Keys -> Keys -> Keys +concatKeys (ResultDataPrepKeys xs) (ResultDataPrepKeys ys) = ResultDataPrepKeys (xs ++ ys) +concatKeys (ResultDataWarmUpKeys xs) (ResultDataWarmUpKeys ys)= ResultDataWarmUpKeys (xs ++ ys) +concatKeys (ResultDataRepKeys xs) (ResultDataRepKeys ys) = ResultDataRepKeys (xs ++ ys) +concatKeys _ _ = error "cannot concat different key types in Csv.hs" + +smoothAndWriteFileResultData :: Experiments a -> T.Text -> Smoothing -> MeasureName -> [ResultData a] -> DB IO () +smoothAndWriteFileResultData _ _ _ _ [] = return () +smoothAndWriteFileResultData exps prefix smoothing measureName resData = do + $(logInfo) $ "Processing measure " <> measureName <> ". Saving data to: " <> T.pack folder + liftIO $ createDirectoryIfMissing True folder + liftIO $ writeFile filePath header >> writeFile filePathPlotSh plotSh + fileH <- liftIO $ openFile filePath AppendMode + start <- liftIO getCurrentTime + let vals = + -- fmap (map (fromMaybe 0 . E.unValue)) $ + -- E.select $ -- E.selectSource $ + E.selectSource $ + case foldl1 concatKeys keys of + ResultDataPrepKeys xs -> + E.from $ \(measure `E.InnerJoin` result) -> do + E.on (measure E.^. PrepMeasureId E.==. result E.^. PrepResultStepMeasure) + case xs of + [x] -> E.where_ (measure E.^. PrepMeasurePrepResultData E.==. E.val x) + _ -> E.where_ (measure E.^. PrepMeasurePrepResultData `E.in_` E.valList xs) + E.where_ (result E.^. PrepResultStepName E.==. E.val measureName) + E.orderBy [E.asc (measure E.^. PrepMeasurePeriod)] + E.groupBy (measure E.^. PrepMeasurePeriod) + return (measure E.^. PrepMeasurePeriod, E.avg_ $ result E.^. PrepResultStepYValue) + ResultDataWarmUpKeys xs -> + E.from $ \(measure `E.InnerJoin` result) -> do + E.on (measure E.^. WarmUpMeasureId E.==. result E.^. WarmUpResultStepMeasure) + case xs of + [x] -> E.where_ (measure E.^. WarmUpMeasureRepResult E.==. E.val x) + _ -> E.where_ (measure E.^. WarmUpMeasureRepResult `E.in_` E.valList xs) + E.where_ (result E.^. WarmUpResultStepName E.==. E.val measureName) + E.orderBy [E.asc (measure E.^. WarmUpMeasurePeriod)] + E.groupBy (measure E.^. WarmUpMeasurePeriod) + return (measure E.^. WarmUpMeasurePeriod, E.avg_ $ result E.^. WarmUpResultStepYValue) + ResultDataRepKeys xs -> + E.from $ \(measure `E.InnerJoin` result) -> do + E.on (measure E.^. RepMeasureId E.==. result E.^. RepResultStepMeasure) + case xs of + [x] -> E.where_ (measure E.^. RepMeasureRepResult E.==. E.val x) + _ -> E.where_ (measure E.^. RepMeasureRepResult `E.in_` E.valList xs) + E.where_ (result E.^. RepResultStepName E.==. E.val measureName) + E.orderBy [E.asc (measure E.^. RepMeasurePeriod)] + E.groupBy (measure E.^. RepMeasurePeriod) + return (measure E.^. RepMeasurePeriod, E.avg_ $ result E.^. RepResultStepYValue) + keys = map (toKeys . view resultDataKey) resData + toKeys (ResultDataRep key) = ResultDataRepKeys [key] + toKeys (ResultDataWarmUp key) = ResultDataWarmUpKeys [key] + toKeys (ResultDataPrep key) = ResultDataPrepKeys [key] + + + -- let toMeasure (E.Value p, E.Value v) = Measure p [StepResult measureName Nothing v] + C.runConduit $ + vals C..| C.mapC fromValueC C..| smoothC smoothing C..| C.mapC toFileCts C..| C.filterC (not . null) C..| C.mapC (T.pack . (++ "\n")) C..| C.encodeUtf8C C..| sinkHandle fileH + + liftIO $ hFlush fileH >> hClose fileH + end <- liftIO getCurrentTime + $(logInfo) $ "Done. Computation Time: " <> tshow (diffUTCTime end start) + where + filePath = folder T.unpack (prefix <> "_" <> measureName <> ".csv") + filePathPlotSh = folder "plot.sh" + folder = expsPath exps "csv" + header = "Period\t" <> T.unpack (prefix <> "_" <> measureName) <> "\n" + toFileCts (p, res) = show p <> "\t" <> show res + fromValueC :: (E.Value Int, E.Value (Maybe Double)) -> (Int, Double) + fromValueC (vPeriod, vMVal) = (E.unValue vPeriod, fromMaybe 0 $ E.unValue vMVal) + + +-- smoothAndWriteFileResultData :: Experiments a -> T.Text -> Smoothing -> MeasureName -> ResultData a -> DB IO () +-- smoothAndWriteFileResultData exps prefix smoothing measureName resData = do +-- $(logInfo) $ "Processing measure " <> measureName <> ". Saving data to: " <> T.pack folder +-- liftIO $ createDirectoryIfMissing True folder +-- liftIO $ writeFile filePath header >> writeFile filePathPlotSh plotSh +-- fileH <- liftIO $ openFile filePath AppendMode +-- start <- liftIO getCurrentTime +-- let src = +-- E.selectSource $ +-- case resData ^. resultDataKey of +-- ResultDataPrep key -> +-- E.from $ \(measure `E.InnerJoin` result) -> do +-- E.on (measure E.^. PrepMeasureId E.==. result E.^. PrepResultStepMeasure) +-- E.where_ (measure E.^. PrepMeasurePrepResultData E.==. E.val key) +-- E.where_ (result E.^. PrepResultStepName E.==. E.val measureName) +-- E.orderBy [E.asc (measure E.^. PrepMeasurePeriod)] +-- return (measure E.^. PrepMeasurePeriod, result E.^. PrepResultStepYValue) +-- ResultDataWarmUp key -> undefined +-- ResultDataRep key -> undefined +-- let toMeasure (E.Value p, E.Value v) = Measure p [StepResult measureName Nothing v] +-- C.runConduit $ +-- src C..| C.mapC toMeasure C..| smoothC smoothing C..| C.mapC toFileCts C..| C.filterC (not . null) C..| C.mapC (T.pack . (++ "\n")) C..| C.encodeUtf8C C..| sinkHandle fileH +-- liftIO $ hFlush fileH >> hClose fileH +-- end <- liftIO getCurrentTime +-- $(logInfo) $ "Done. Computation Time: " <> tshow (diffUTCTime end start) +-- where +-- filePath = folder T.unpack (prefix <> "_" <> measureName <> ".csv") +-- filePathPlotSh = folder "plot.sh" +-- folder = expsPath exps "csv" +-- header = "Period\t" <> T.unpack (prefix <> "_" <> measureName) <> "\n" +-- toFileCts (Measure p []) = [] +-- toFileCts (Measure p [res]) = show p <> "\t" <> show (res ^. resultYValue) +-- toFileCts (Measure p _) = error $ "The measure " <> T.unpack measureName <> " has more than one results in period " <> show p + + +namePrefix :: Int -> Phase -> Avg -> T.Text +namePrefix expNr ph av = "exp" <> tshow expNr <> "_" <> phaseName ph <> "_" <> avgName av <> "_" + +phaseName :: Phase -> T.Text +phaseName PreparationPhase = "prep" +phaseName WarmUpPhase = "warmUp" +phaseName EvaluationPhase = "eval" + +type ReplNr = Int +type RepetNr = Int +data Avg = None !RepetNr !(Maybe ReplNr) | Repl !RepetNr | Repet !ReplNr | RepetRepl + +avgName :: Avg -> T.Text +avgName (None repet (Just repl)) = "repet" <> tshow repet <> "_repl" <> tshow repl +avgName (None repet Nothing) = "repet" <> tshow repet +avgName (Repl repet) = "repet" <> tshow repet <> "_replAvg" +avgName (Repet repl) = "repetAvg_repl" <> tshow repl +avgName RepetRepl = "repetAvg_replAvg" + +plotSh :: String +plotSh = + unlines + [ "FILES=\"\" " + , " " + , "for arg in $@; do " + , " FILES=\"$FILES `find . -type f -name \"*$arg*\"`\" " + , "done " + , " " + , "echo $FILES " + , " " + , "ARRAY=($FILES) " + , "for col in {2,3,4}; do " + , " CMD=\"set key autotitle columnhead; plot \" " + , " for f in $FILES; do " + , " echo $f " + , " CMD=\"$CMD '$f' using 0:$col with lines \" " + , " if [ \"$f\" != \"${ARRAY[-1]}\" ]; then " + , " CMD=\"$CMD, \" " + , " fi " + , " done " + , " CMD=\"$CMD; pause mouse close; \" " + , " echo $CMD " + , " gnuplot -e \"$CMD\" & " + , "done " + ] diff --git a/src/Experimenter/Eval/Latex.hs b/src/Experimenter/Eval/Latex.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Eval/Latex.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Experimenter.Eval.Latex + ( writeLatex + , writeAndCompileLatex + ) where + +import Control.Arrow ((&&&)) +import Control.DeepSeq +import Control.Lens hiding ((&)) +import Control.Monad (forM, unless, void) +import Control.Monad.Logger +import Data.List as L (find, foldl') +import qualified Data.Map.Strict as M +import qualified Data.Serialize as S +import qualified Data.Text as T +import GHC.Generics +import System.Directory +import System.FilePath.Posix +import System.Process +import Text.LaTeX +import Text.LaTeX.Packages.AMSMath +import Text.LaTeX.Packages.Hyperref +import Text.LaTeX.Packages.Inputenc + +import Experimenter.Availability +import Experimenter.DatabaseSetting +import Experimenter.DB +import Experimenter.Eval.Table +import Experimenter.Eval.Type +import Experimenter.Eval.Util +import Experimenter.Models +import Experimenter.Parameter.Type +import Experimenter.Result.Type +import Experimenter.Setting (ExperimentInfoParameter (..)) +import Experimenter.Util + + +writeAndCompileLatex :: DatabaseSetting -> Evals a -> IO () +writeAndCompileLatex dbSetup evals = writeLatex dbSetup evals >> compileLatex evals + +compileLatex :: Evals a -> IO () +compileLatex evals = do + let exps = evals ^. evalsExperiments + dir = expsPath exps + n = getExpsName exps + void $ runProcess "pdflatex" [mainFile exps] (Just dir) Nothing Nothing Nothing Nothing >>= waitForProcess + pwd <- getCurrentDirectory + putStrLn $ "n\nSuccessfully compiled your results! See file://" <> pwd <> "/results/" <> n <> "/" <> mainFilePdf exps + + +writeLatex :: DatabaseSetting -> Evals a -> IO () +writeLatex dbSetup evals = do + let exps = evals ^. evalsExperiments + dir = expsPath exps + file = dir mainFile exps + liftIO $ createDirectoryIfMissing True dir + res <- runDBSimple dbSetup $ execLaTeXT (root evals) + renderFile file res + + +root :: Evals a -> LaTeXT SimpleDB () +root evals = do + thePreamble evals + document $ theBody evals + + +-- Preamble with some basic info. +thePreamble :: (MonadLogger m) => Evals a -> LaTeXT m () +thePreamble evals = do + let n = evals ^. evalsExperiments . experimentsName + documentclass [] article + author "Manuel Schneckenreither" + title $ "Evaluation for ``" <> raw n <> "''" + usepackage [utf8] inputenc + usepackage [] "fullpage" + usepackage [] "array" + usepackage [] amsmath + usepackage [pdftex] hyperref + +-- Body with a section. +theBody :: Evals a -> LaTeXT SimpleDB () +theBody evals = do + maketitle + experimentsInfo (evals ^. evalsExperiments) + experimentsEvals evals + + +experimentsInfo :: (MonadLogger m) => Experiments a -> LaTeXT m () +experimentsInfo exps = do + part "General Information" + printTable $ Table (Row ["Parameter", "Value"]) + [ Row ["Experiment Name: ", CellT (exps ^. experimentsName)] + , Row ["Start time:", CellT (tshow $ exps ^. experimentsStartTime)] + , Row ["End time:", CellT (maybe "" tshow (exps ^. experimentsEndTime))] + , Row ["Number of conducted Experiments: ", CellT (tshow $ length (exps ^. experiments))] + , Row ["Experiment Repetitions (complete restarts):", CellT (tshow $ exps ^. experimentsSetup . expsSetupRepetitions)] + , Row ["Experiment Preparation Steps:", CellT (tshow $ exps ^. experimentsSetup . expsSetupPreparationSteps)] + , Row ["Experiment Evaluation Warm Up Steps:", CellT (tshow $ exps ^. experimentsSetup . expsSetupEvaluationWarmUpSteps)] + , Row ["Experiment Evaluation Steps:", CellT (tshow $ exps ^. experimentsSetup . expsSetupEvaluationSteps)] + , Row ["Experiment Evaluation Replications:", CellT (tshow $ exps ^. experimentsSetup . expsSetupEvaluationReplications)] + ] + + let infoParams = exps ^. experimentsInfoParameters + unless (null infoParams) $ do + part "Experiment Information Parameters" + printTable $ Table (Row ["Parameter", "Value"]) + (map mkInfoParam infoParams) + + where mkInfoParam (ExperimentInfoParameter n v) = Row [CellT n, CellT (tshow v)] + + +experimentsEvals :: Evals a -> LaTeXT SimpleDB () +experimentsEvals evals = do + pagebreak (pure "4") + part "Experiment Evaluations" + !(force -> tablesP) <- lift $! mkResultTablesFor UnitPeriods evals + !(force -> tablesR) <- lift $! mkResultTablesFor UnitReplications evals + !(force -> tablesE) <- lift $! mkResultTablesFor UnitExperimentRepetition evals + !(force -> tablesS) <- lift $! mkResultTablesFor UnitScalar evals + let tables = tablesP <> tablesR <> tablesE <> tablesS + mParams = M.fromList $ map (view evalExperimentNumber &&& paramSettingTable evals) (evals ^. evalsResults) + writeTables mParams (force tables) + + +data EvalTables a = EvalTables + { periodic :: ![(Int, [(StatsDef a, Table)])] + , replications :: ![(Int, [(StatsDef a, Table)])] + , experimentReplications :: ![(Int, [(StatsDef a, Table)])] + , numbers :: ![(Int, [(StatsDef a, Table)])] + } deriving (Show, Generic, NFData) + +instance Semigroup (EvalTables a) where + EvalTables ap ar ae an <> EvalTables bp br be bn = EvalTables (ap <> bp) (ar <> br) (ae <> be) (an <> bn) + +instance Monoid (EvalTables a) where + mempty = EvalTables [] [] [] [] + + +mkResultTablesFor :: Unit -> Evals a -> SimpleDB [EvalTables a] +mkResultTablesFor unit evals = + fmap force $! + forM (evals ^. evalsResults) $ \eval@(ExperimentEval _ avRes _) -> + fmap (force . mconcat) $! + forM avRes $ \av -> do + res <- mkTransientlyAvailable av + return $ + let ~tbl = mkExperimentTable evals (leastUnit res, eval, [res]) + in case leastUnit res of + UnitPeriods -> EvalTables [tbl | unit == UnitPeriods] [] [] [] + UnitReplications -> EvalTables [] [tbl | unit == UnitReplications] [] [] + UnitExperimentRepetition -> EvalTables [] [] [tbl | unit == UnitExperimentRepetition] [] + UnitScalar -> EvalTables [] [] [] [tbl | unit == UnitScalar] + + +writeTables :: M.Map Int (Maybe Table) -> [EvalTables a] -> LaTeXT SimpleDB () +writeTables params !(force -> tables) = do + void $ writeTableFor "Scalar Value" (concatMap numbers tables) + void $ writeTableFor "Repetition" (concatMap experimentReplications tables) + void $ writeTableFor "Replications" (concatMap replications tables) + void $ writeTableFor "Periodic" (concatMap periodic tables) + where + writeTableFor :: LaTeXT SimpleDB () -> [(Int, [(StatsDef a, Table)])] -> LaTeXT SimpleDB [()] + writeTableFor name tbls = do + section (name <> " Evaluations") + forM (M.keys params) $ \k -> do + let tblsFiltered = filter (( == k) . fst) tbls + unless (null tblsFiltered) $ do + subsection $ "Experiment No. " <> raw (tshow k) + maybe "There are no configured parameters!" printTable (M.findWithDefault Nothing k params) + mapM_ (\(_, tbls') -> forM tbls' $ \statsDefTbl -> printTableWithName statsDefTbl) tblsFiltered + + +printTableWithName :: (MonadLogger m) => (StatsDef a, Table) -> LaTeXT m () +printTableWithName (nm, tbl) = do + paragraph (raw $ prettyStatsDef nm) + printTable tbl + + +leastUnit :: EvalResults a -> Unit +leastUnit (EvalValue _ u _ _ _) = u +leastUnit (EvalReducedValue _ u _) = u +leastUnit (EvalVector _ u []) = u +leastUnit (EvalVector _ u vals) = min u (leastUnit (head vals)) + + +unpackUntil :: Unit -> EvalResults a -> [EvalResults a] +unpackUntil unit res | res ^. evalUnit == unit = [res] + | otherwise = case res of + EvalVector{} -> concatMap (unpackUntil unit) (res ^. evalValues) + _ -> error $ "cannot unpack res: " <> show res + +mkNamesUntil :: Unit -> EvalResults a -> [Text] +mkNamesUntil unit res + | res ^. evalUnit == unit = [mempty] + | otherwise = + case res of + EvalVector _ u vals -> + case u of + UnitPeriods -> [mempty] + UnitReplications -> map (\x -> "Rpl " <> tshow x <> ": ") [1 .. length vals] + _ -> + let sub = head $ map (mkNamesUntil unit) vals + in concatMap (\x -> map (\s -> if T.isInfixOf "Rpt" s then s else "Rpt " <> tshow x <> ": " <> s) sub) [1 .. length vals] + _ -> error $ "cannot unpack res: " <> show res + + +mkExperimentTable :: Evals a -> (Unit, ExperimentEval a, [EvalResults a]) -> (Int, [(StatsDef a, Table)]) +mkExperimentTable _ (lowestUnit, eval, res) = + let resUnit = map (\rs -> (mkNames rs, unpackUntil lowestUnit rs)) res + tableRes = map (uncurry (zipWith (mkEvalResult lowestUnit))) resUnit + tbls = map toTables tableRes + mkNames = map (map CellT . return) . mkNamesUntil lowestUnit + evalStatDefs = map (^. evalType) res + in (eval ^. evalExperimentNumber, zip evalStatDefs tbls) + + +data TableResult = TableResult + { header :: !Row + , rows :: ![Row] + } deriving (Show) + +toTables :: [TableResult] -> Table +toTables xs = Table (header $ head xs) (concatMap rows xs) + +mkEvalResult :: Unit -> [Cell] -> EvalResults a -> TableResult +mkEvalResult _ _ (EvalVector _ _ []) = error "Empty evaluation. Check your eval setup." +mkEvalResult leastUnit' name (EvalVector _ _ vals) = + TableResult (Row $ CellT (unitName leastUnit') : map (CellT . tshow) [1 .. length vals]) (map Row (foldl' mkRows [name] rowVals)) + where + subVals = map (mkEvalResult leastUnit' []) vals + rowVals = map rows subVals + mkRows :: [[Cell]] -> [Row] -> [[Cell]] + mkRows accs vs = zipWith (++) accs (map fromRow vs) + fromRow (Row xs) = xs + unitName UnitPeriods = "Period:" + unitName UnitReplications = "Replication:" + unitName UnitExperimentRepetition = "Experiment Repetition:" + -- unitName (UnitBestExperimentRepetitions bestNr) = "Best " <> tshow bestNr <> " Experiment Repetitions:" + unitName UnitScalar = "Value:" +mkEvalResult _ [] (EvalValue _ _ _ x y) = TableResult (Row [getXValue x]) [Row [CellD y]] + where getXValue (Left v) = CellT $ tshow v + getXValue (Right d) = CellD d +mkEvalResult _ (n1:_) (EvalValue _ _ _ x y) = TableResult (Row [CellEmpty, getXValue x]) [Row [n1, CellD y]] + where getXValue (Left v) = CellT $ tshow v + getXValue (Right d) = CellD d +mkEvalResult _ [] (EvalReducedValue statsDef _ y) = TableResult (Row [CellT $ tshow statsDef]) [Row [CellD y]] +mkEvalResult _ (n:_) (EvalReducedValue statsDef _ y) = TableResult (Row [CellEmpty , CellT $ prettyStatsDef statsDef]) [Row [n, CellD y]] + + +paramSettingTable :: Evals a -> ExperimentEval a -> Maybe Table +paramSettingTable evals (ExperimentEval _ _ exp) + | null (exp ^. parameterSetup) = Nothing + | otherwise = Just $ Table (Row ["Parameter", "Value"]) (concatMap mkRow (exp ^. parameterSetup)) + where + dropRow :: Row + dropRow = Row [CellT "Skip Preparation Phase", CellT "True (No preparation phase was executed!)"] + singleInstanceRow :: Text -> Row + singleInstanceRow n = Row [CellT "Run a single instance", CellT $ "True (No further variations needed as specified by parameter " <> n <> "!)"] + mkRow :: ParameterSetting a -> [Row] + mkRow (ParameterSetting n bsV drp design) = + case find ((== n) . parameterName) (evals ^. evalsExperiments . experimentsParameters) of + Nothing -> + Row + [ CellT n + , CellT $ "was not modified as it is not listed in the parameter setting" <> + (if drp + then " [SkipPrepPhase]" + else "") <> + (case design of + FullFactory -> "" + SingleInstance -> "[SingleInstance]") + ] : + [dropRow | drp] ++ + [singleInstanceRow n | drp] + Just (ParameterSetup _ setter _ _ mBounds _ _) -> + case S.runGet S.get bsV of + Left err -> [Row [CellT n, CellT (T.pack err)]] + Right val -> + let _ = setter val (evals ^. evalsExperiments . experimentsInitialState) -- only needed for type inference + in Row + [ CellT n + , CellL $ raw (dereferLatex $ tshow val) <> + (case mBounds of + Nothing -> "" + Just (minVal, maxVal) -> math (text " " `in_` autoParens (text (raw (dereferLatex $ tshow minVal)) <> ", " <> text (raw (dereferLatex $ tshow maxVal))))) <> + (if drp + then " [SkipPrepPhase]" + else mempty) <> + (case design of + FullFactory -> "" + SingleInstance -> "[SingleInstance]") + ] : + [dropRow | drp] ++ + [singleInstanceRow n | drp] diff --git a/src/Experimenter/Eval/Ops.hs b/src/Experimenter/Eval/Ops.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Eval/Ops.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + + +module Experimenter.Eval.Ops + ( genEvals + , genEvalsIO + , genEvalsConcurrent + ) where + +import Conduit as C +import Control.DeepSeq +import Control.Lens hiding (Cons, Over) +import Control.Monad.Reader +import qualified Data.Conduit.List as CL +import Data.List (find) +import Data.Maybe (fromMaybe, isJust) +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import qualified Database.Esqueleto as E +import Prelude hiding (exp) + + +import Experimenter.Availability +import Experimenter.ConcurrentIO +import Experimenter.DatabaseSetting +import Experimenter.DB +import Experimenter.Eval.Reduce +import Experimenter.Eval.Type as E +import Experimenter.Eval.Util +import Experimenter.Experiment +import Experimenter.Measure +import Experimenter.Models +import Experimenter.Result.Query +import Experimenter.Result.Type +import Experimenter.StepResult + + +genEvalsIO :: (ExperimentDef a, IO ~ ExpM a) => DatabaseSetting -> Experiments a -> [StatsDef a] -> IO (Evals a) +genEvalsIO = genEvals id + + +genEvals :: (ExperimentDef a) => (ExpM a (Evals a) -> IO (Evals a)) -> DatabaseSetting -> Experiments a -> [StatsDef a] -> IO (Evals a) +genEvals runExpM dbSetup exps evals = runExpM $ runDBWithM runResourceT dbSetup $ do + res <- mapM (mkEvals evals) (exps ^. experiments) + return $ Evals (exps {_experiments = []}) res + + +genEvalsConcurrent :: (ExperimentDef a) => Int -> (ExpM a (ExperimentEval a) -> IO (ExperimentEval a)) -> DatabaseSetting -> Experiments a -> [StatsDef a] -> IO (Evals a) +genEvalsConcurrent parallelWorkers runExpM dbSetup exps evals = do + res <- mapConurrentIO parallelWorkers (runExpM . runDBWithM runResourceT dbSetup . mkEvals evals) (exps ^. experiments) + return $ Evals (exps {_experiments = []}) res + +mkEvals :: (ExperimentDef a ) => [StatsDef a] -> Experiment a -> DB (ExpM a) (ExperimentEval a) +mkEvals evals e = do + xs <- mkTime "All Experiment Evaluations" $ mapMRnf (fmap Available . genExperiment e) evals + return $ force $ ExperimentEval (e ^. experimentNumber) xs (e {_experimentResults = []}) + + +mapMRnf :: (NFData b, Monad m) => (a -> m b) -> [a] -> m [b] +mapMRnf _ [] = return [] +mapMRnf f (x:xs) = do + !(force -> x') <- f x + (x' :) <$!> mapMRnf f xs +-- mapMRnf :: (NFData b, Monad m) => (a -> m b) -> [a] -> m [b] +-- mapMRnf = mapM + + +genExperiment :: (ExperimentDef a) => Experiment a -> StatsDef a -> DB (ExpM a) (EvalResults a) +genExperiment exp (Named eval name) = addName <$!> genExperiment exp eval + where addName res = res { _evalType = Named (res ^. evalType) name } +genExperiment exp (Name name eval) = addName <$!> genExperiment exp eval + where addName res = res { _evalType = Named (res ^. evalType) name } +genExperiment exp eval = + case eval of + Mean OverExperimentRepetitions (Stats eval') -> reduce (Stats eval') <$!> genExpRes id eval' + Mean OverExperimentRepetitions eval' -> reduce eval' <$!> genExpRes id (Id eval') + Sum OverExperimentRepetitions (Stats eval') -> reduce (Stats eval') <$!> genExpRes id eval' + Sum OverExperimentRepetitions eval' -> reduce eval' <$!> genExpRes id (Id eval') + StdDev OverExperimentRepetitions (Stats eval') -> reduce (Stats eval') <$!> genExpRes id eval' + StdDev OverExperimentRepetitions eval' -> reduce eval' <$!> genExpRes id (Id eval') + -- Mean (OverBestXExperimentRepetitions nr cmp) eval' -> reduce eval' <$> genExpRes (take nr . sortBy (cmp `on` id)) (Id eval') + -- Sum (OverBestXExperimentRepetitions nr cmp) eval' -> reduce eval' <$> genExpRes (take nr . sortBy (cmp `on` id)) (Id eval') + -- StdDev (OverBestXExperimentRepetitions nr cmp) eval' -> reduce eval' <$> genExpRes (take nr . sortBy (cmp `on` id)) (Id eval') + _ -> packGenRes <$!> genExpRes id eval + where + packGenRes = EvalVector eval UnitExperimentRepetition + genExpRes f e = mapMRnf (genExperimentResult exp e) (f $ exp ^. experimentResults) + -- reduce = reduceUnary eval . EvalVector eval UnitExperimentRepetition + reduce eval' = reduceUnary eval . EvalVector (Id eval') UnitExperimentRepetition + + +genExperimentResult :: (ExperimentDef a) => Experiment a -> StatsDef a -> ExperimentResult a -> DB (ExpM a) (EvalResults a) +genExperimentResult _ (Named _ n) _ = error $ "An evaluation may only be named on the outermost function in evaluation " <> T.unpack (E.decodeUtf8 n) +genExperimentResult _ (Name n _) _ = error $ "An evaluation may only be named on the outermost function in evaluation " <> T.unpack (E.decodeUtf8 n) +genExperimentResult exp eval expRes = + case eval of + Mean OverReplications (Stats eval') -> reduce <$!> genRepl eval' + Mean OverReplications eval' -> reduce <$!> genRepl (Id eval') + StdDev OverReplications (Stats eval') -> reduce <$!> genRepl eval' + StdDev OverReplications eval' -> reduce <$!> genRepl (Id eval') + Sum OverReplications (Stats eval') -> reduce <$!> genRepl eval' + Sum OverReplications eval' -> reduce <$!> genRepl (Id eval') + _ -> packGenRes <$!> genRepl eval + where + packGenRes = EvalVector eval UnitReplications + -- genRepl e = mapMRnf (fmap force . genReplication exp e) (expRes ^. evaluationResults) + genRepl e = mapMRnf (genReplication exp e (expRes ^. repetitionNumber)) (expRes ^.. evaluationResults . traversed . filtered (\x -> isJust (x ^. evalResults))) + reduce !inp = EvalVector eval (getUnit inp) $ map (reduceUnary eval) $ transpose UnitReplications inp + getUnit (EvalVector _ unit _:_) = unit + getUnit (EvalValue _ unit _ _ _:_) = unit + getUnit (EvalReducedValue _ unit _:_) = unit + getUnit [] = error "Unexpected empty data in getUnit in genExperimentResult in Eval.Ops" + + +genReplication :: (ExperimentDef a) => Experiment a -> StatsDef a -> Int -> ReplicationResult a -> DB (ExpM a) (EvalResults a) +genReplication exp eval repNr repl = + mkTime ("Experiment " <> show (exp ^. experimentNumber) <> " Repetition " <> show repNr <> " Replication" <> show (repl ^. replicationNumber)) $ + fromMaybe (error "Evaluation data is incomplete!") <$!> sequence (genResultData exp eval <$!> (repl ^. evalResults)) + + +-- stddevSamp :: (E.PersistField a, E.PersistField b) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value (Maybe b)) +-- stddevSamp = unsafeSqlFunction "SUM" +-- where -- | (Internal) A raw SQL function. Once again, the same warning +-- -- from 'unsafeSqlBinOp' applies to this function as well. +-- -- unsafeSqlFunction :: E.UnsafeSqlFunctionArgument a => +-- -- TLB.Builder -> a -> SqlExpr (Value b) +-- unsafeSqlFunction name arg = +-- ERaw Never $ \info -> +-- let (argsTLB, argsVals) = +-- uncommas' $ map (\(E.ERaw _ f) -> f info) $ toArgList arg +-- in (name <> parens argsTLB, argsVals) + +genResultData :: (ExperimentDef a) => Experiment a -> StatsDef a -> ResultData a -> DB (ExpM a) (EvalResults a) +genResultData _ (Named _ n) _ = error $ "An evaluation may only be named on the outermost function in evaluation " <> T.unpack (E.decodeUtf8 n) +genResultData _ (Name n _) _ = error $ "An evaluation may only be named on the outermost function in evaluation " <> T.unpack (E.decodeUtf8 n) +genResultData exp eval resData = + case eval of + Mean OverPeriods (Of name) -> aggregate name E.avg_ + Mean OverPeriods eval' -> reduceUnary eval <$!> genResultData exp (Id eval') resData + -- StdDev OverPeriods (Of name) -> aggregate name E.stdDev_ -- not available in esqueleto :-o + StdDev OverPeriods eval' -> reduceUnary eval <$!> genResultData exp (Id eval') resData + Sum OverPeriods (Of name) -> aggregate name E.sum_ + Sum OverPeriods eval' -> reduceUnary eval <$!> genResultData exp (Id eval') resData + Id eval' -> evalOf exp eval' resData + _ -> genExperiment exp eval + where + aggregate name agg = + fmap (EvalReducedValue eval UnitPeriods) $ + case resData ^. resultDataKey of + ResultDataPrep k -> loadPreparationAggregateWhere k agg (whereName name) + ResultDataWarmUp k -> loadReplicationWarmUpAggregateWhere k agg (whereName name) + ResultDataRep k -> loadReparationAggregateWhere k agg (whereName name) + whereName name = + case resData ^. resultDataKey of + ResultDataPrep{} -> PrepMeasureWhere $ \_ resStep -> E.where_ (resStep E.^. PrepResultStepName E.==. E.val (E.decodeUtf8 name)) + ResultDataWarmUp{} -> WarmUpMeasureWhere $ \_ resStep -> E.where_ (resStep E.^. WarmUpResultStepName E.==. E.val (E.decodeUtf8 name)) + ResultDataRep{} -> RepMeasureWhere $ \_ resStep -> E.where_ (resStep E.^. RepResultStepName E.==. E.val (E.decodeUtf8 name)) + + +-- cacheMVar :: MVar (M.Map (Of a, ResultDataKey) (EvalResults a)) +-- cacheMVar = unsafePerformIO $ newMVar mempty +-- {-# NOINLINE cacheMVar #-} + +-- emptyCache :: IO () +-- emptyCache = liftIO $ modifyMVar_ cacheMVar (const mempty) + +-- addCache :: (Of a, ResultDataKey) -> EvalResults a -> IO () +-- addCache k v = liftIO $ modifyMVar_ cacheMVar (return . M.insert k v) + +-- lookupCache :: (Of a, ResultDataKey) -> IO (Maybe (EvalResults a)) +-- lookupCache k = liftIO $ (M.lookup k =<<) <$> tryReadMVar cacheMVar + + +evalOf :: (ExperimentDef a) => Experiment a -> Of a -> ResultData a -> DB (ExpM a) (EvalResults a) +evalOf exp eval resData = + case eval of + Of name -> do + -- mCache <- liftIO $ lookupCache (eval, resData ^. resultDataKey) + -- case mCache of + -- Nothing -> do + -- res <- runConduit $ srcAvailableListWhere (whereName name) (resData ^. results) .| mapC (fromMeasure $ E.decodeUtf8 name) .| CL.consume + -- let evalVector = EvalVector (Id $ Of name) UnitPeriods res + -- liftIO $ addCache (eval, resData ^. resultDataKey) evalVector + -- return evalVector + -- Just evalVector -> return evalVector + ---- + res <- runConduit $ srcAvailableListWhere (whereName name) (resData ^. results) .| mapC (fromMeasure $ E.decodeUtf8 name) .| CL.consume + let evalVector = EvalVector (Id $ Of name) UnitPeriods res + return evalVector + + Stats def -- alter experiment and restart evaluation + | maybe False (> OverPeriods) (getOver def) -> do + error "OverExperimentRepetitions and OverReplications have to be the two outermost evaluations or not present" + -- let k = resData ^. resultDataKey + -- isK = (== k) + -- check Nothing = Nothing + -- check (Just rD) + -- | isK (rD ^. resultDataKey) = Just rD + -- | otherwise = Nothing + -- fil lns = over lns check + -- let exp' = over (experimentResults . traversed) (over (evaluationResults . traversed) (fil warmUpResults . fil evalResults) . over preparationResults check) exp + -- allResData x = x ^.. evaluationResults . traversed . evalResults . traversed ++ x ^.. evaluationResults . traversed . warmUpResults . traversed ++ x ^.. preparationResults . traversed + -- expFiltered = over experimentResults (filter (not . null . allResData)) exp' + -- liftIO $ putStrLn $ "Filtered: " ++ show (length $ concatMap allResData (expFiltered ^. experimentResults)) + -- genExperiment expFiltered def + Stats def -> genResultData exp def resData + Div eval1 eval2 -> reduceBinaryOf eval <$!> evalOf exp eval1 resData <*> evalOf exp eval2 resData + Add eval1 eval2 -> reduceBinaryOf eval <$!> evalOf exp eval1 resData <*> evalOf exp eval2 resData + Sub eval1 eval2 -> reduceBinaryOf eval <$!> evalOf exp eval1 resData <*> evalOf exp eval2 resData + Mult eval1 eval2 -> reduceBinaryOf eval <$!> evalOf exp eval1 resData <*> evalOf exp eval2 resData + First (Of name) -> do + + -- res <- aggregate (E.orderBy [E.asc (repM E.^. RepMeasurePeriod)]) name + + -- todo: sorting!!! + res <- runConduit $ srcAvailableListWhere (whereName' (E.limit 1) name) (resData ^. results) .| mapC (fromMeasure $ E.decodeUtf8 name) .| headC + return $ EvalVector (Id $ First $ Stats $ Id $ Of name) UnitPeriods [fromMaybe (error $ "empty elements in evalOf First(Of " <> show name <> ")") res] + First eval' -> reduceUnaryOf eval <$!> evalOf exp eval' resData + Last (Of name) -> do + res <- runConduit $ srcAvailableListWhere (whereName name) (resData ^. results) .| mapC (fromMeasure $ E.decodeUtf8 name) .| lastC + return $ EvalVector (Id $ Last $ Stats $ Id $ Of name) UnitPeriods [fromMaybe (error $ "empty elements in evalOf Last(Of " <> show name <> ")") res] + Last eval' -> reduceUnaryOf eval <$!> evalOf exp eval' resData + EveryXthElem _ eval' -> reduceUnaryOf eval <$!> evalOf exp eval' resData + Length (Of name) -> do + res <- runConduit $ srcAvailableListWhere (whereName name) (resData ^. results) .| mapC (fromMeasure $ E.decodeUtf8 name) .| lengthC + return $ EvalReducedValue (Id $ Length $ Stats $ Id $ Of name) UnitScalar res + Length eval' -> reduceUnaryOf eval <$!> evalOf exp eval' resData + where + whereName = whereName' (return ()) + whereName' add name = + case resData ^. resultDataKey of + ResultDataPrep _ -> PrepMeasureWhere $ \_ resStep -> E.where_ (resStep E.^. PrepResultStepName E.==. E.val (E.decodeUtf8 name)) >> add + ResultDataWarmUp _ -> WarmUpMeasureWhere $ \_ resStep -> E.where_ (resStep E.^. WarmUpResultStepName E.==. E.val (E.decodeUtf8 name)) >> add + ResultDataRep _ -> RepMeasureWhere $ \_ resStep -> E.where_ (resStep E.^. RepResultStepName E.==. E.val (E.decodeUtf8 name)) >> add + -- aggregate add name agg = + -- case resData ^. resultDataKey of + -- ResultDataPrep k -> loadPreparationAggregateWhere k agg (whereName' add name) + -- ResultDataWarmUp k -> loadReplicationWarmUpAggregateWhere k agg (whereName' add name) + -- ResultDataRep k -> loadReparationAggregateWhere k agg (whereName' add name) + +fromMeasure :: T.Text -> Measure -> EvalResults a +fromMeasure name (Measure p res) = case find ((==name) . view resultName) res of + Nothing -> error $ "Variable with name " <> T.unpack name <> " could not be found!" + Just (StepResult n mX y) -> EvalValue (Id $ Of $ E.encodeUtf8 n) UnitPeriods (E.encodeUtf8 n) (maybe (Left p) Right mX) y diff --git a/src/Experimenter/Eval/Reduce.hs b/src/Experimenter/Eval/Reduce.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Eval/Reduce.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +module Experimenter.Eval.Reduce + ( reduceUnary + , reduceUnaryOf + , reduceBinaryOf + , transpose + , flatten + ) where + +import Control.DeepSeq +import Control.Lens hiding (Cons, Over, over) +import qualified Data.List as L (transpose) + +import Experimenter.Eval.Type hiding (sum) + +transpose :: Unit -> [EvalResults a] -> [EvalResults a] +transpose resUnit vs@(EvalValue tp _ _ _ _:_) = map (EvalVector tp resUnit) $ L.transpose $ map (: []) vs +transpose resUnit vs@(EvalReducedValue tp _ _:_) = map (EvalVector tp resUnit) $ L.transpose $ map (: []) vs +transpose resUnit vs@(EvalVector tp _ _:_) = map (EvalVector tp resUnit) $ L.transpose $ map (view evalValues) vs +transpose _ [] = [] + +reduceUnary :: StatsDef a -> EvalResults a -> EvalResults a +reduceUnary (Mean over _) !eval = force $! EvalReducedValue (flatten tp) (fromOver over) val + where + res = getEvalValue eval + val = sum res / fromIntegral (length res) + tp = getEvalType Mean eval +reduceUnary (StdDev over _) !eval = force $! EvalReducedValue (flatten tp) (fromOver over) val + where + res = getEvalValue eval + mean' = sum res / fromIntegral (length res) + val = sqrt $ sum (map ((^ (2::Int)) . subtract mean') res) / max 1 (fromIntegral $ length res-1) + tp = getEvalType StdDev eval +reduceUnary (Sum over _) !eval = force $! EvalReducedValue (flatten $ getEvalType Sum eval) (fromOver over) (sum (getEvalValue eval)) +reduceUnary eval _ = error $ "unexpected reduce: " ++ show eval + +flatten :: StatsDef a -> StatsDef a +flatten (Mean over o) = force $! flattenStats $ Mean over (flattenOf o) +flatten (StdDev over o) = force $! flattenStats $ StdDev over (flattenOf o) +flatten (Sum over o) = force $! flattenStats $ Sum over (flattenOf o) +flatten (Id (Stats e)) = force $! flatten e +flatten (Id o) = force $! flattenStats $ Id $ flattenOf o +flatten (Named _ x) = error $ "Unexpected Named in flatten in Reduce.hs: " ++ show x +flatten (Name _ x) = error $ "Unexpected Name in flatten in Reduce.hs: " ++ show x + + +flattenOf :: Of a -> Of a +flattenOf (Stats (Id e)) = e +flattenOf e = e + +flattenStats :: StatsDef a -> StatsDef a +flattenStats (Id (Stats e)) = e +flattenStats e = e + + +reduceUnaryOf :: Of a -> EvalResults a -> EvalResults a +reduceUnaryOf First {} (EvalVector tp unit vals) = + case vals of + (EvalVector {}:_) -> force $! EvalVector (Id $ First $ Stats tp) unit [head vals] + (EvalValue _ _ _ _ v:_) -> force $! EvalReducedValue (Id $ First $ Stats tp) UnitScalar v + (EvalReducedValue _ _ v:_) -> force $! EvalReducedValue (Id $ First $ Stats tp) UnitScalar v + [] -> error "empty elements in reduceUnaryOf First{}" +reduceUnaryOf Last {} (EvalVector tp unit vals) = + case vals of + (EvalVector {}:_) -> force $! EvalVector (Id $ Last $ Stats tp) unit [last vals] + (EvalValue _ _ _ _ _:_) -> force $! EvalReducedValue (Id $ Last $ Stats tp) UnitScalar ((^?! evalY) $ last vals) + (EvalReducedValue _ _ _:_) -> force $! EvalReducedValue (Id $ Last $ Stats tp) UnitScalar ((^?! evalValue) $ last vals) + [] -> error "empty elements in reduceUnaryOf Last{}" +reduceUnaryOf (EveryXthElem nr _) (EvalVector tp unit vals) = + case vals of + (EvalVector {}:_) -> force $! EvalVector (Id $ EveryXthElem nr $ Stats tp) unit (extractEvery nr vals) + (EvalValue _ _ _ _ _:_) -> force $! EvalVector (Id $ EveryXthElem nr $ Stats tp) unit (extractEvery nr vals) + (EvalReducedValue _ _ _:_) -> force $! EvalVector (Id $ EveryXthElem nr $ Stats tp) unit (extractEvery nr vals) + [] -> error "empty elements in reduceUnaryOf EveryXthElem{}" + where + extractEvery m = map snd . filter (\(x, _) -> mod x m == 0) . zip [1 ..] +reduceUnaryOf Length {} (EvalVector tp _ vals) = force $! EvalReducedValue (Id $ Length $ Stats tp) UnitScalar (fromIntegral $ length vals) +reduceUnaryOf eval dt = error $ "unexpected unary reduce: " ++ show eval ++ " on " ++ show dt + +reduceBinaryOf :: Of a -> EvalResults a -> EvalResults a -> EvalResults a +reduceBinaryOf Add{} (EvalValue tp1 u1 _ _ val1) (EvalValue tp2 u2 _ _ val2) = force $! checkUnitTypes "Add" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Add` Stats tp2) u1 (val1 + val2) +reduceBinaryOf Sub{} (EvalValue tp1 u1 _ _ val1) (EvalValue tp2 u2 _ _ val2) = force $! checkUnitTypes "Sub" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Sub` Stats tp2) u1 (val1 - val2) +reduceBinaryOf Mult{} (EvalValue tp1 u1 _ _ val1) (EvalValue tp2 u2 _ _ val2) = force $! checkUnitTypes "Mult" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Mult` Stats tp2) u1 (val1 * val2) +reduceBinaryOf Div{} (EvalValue tp1 u1 _ _ val1) (EvalValue tp2 u2 _ _ val2) = force $! checkUnitTypes "Div" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Div` Stats tp2) u1 (val1 / val2) +reduceBinaryOf Add{} (EvalReducedValue tp1 u1 val1) (EvalReducedValue tp2 u2 val2) = force $! checkUnitTypes "Add" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Add` Stats tp2) u1 (val1 + val2) +reduceBinaryOf Sub{} (EvalReducedValue tp1 u1 val1) (EvalReducedValue tp2 u2 val2) = force $! checkUnitTypes "Sub" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Sub` Stats tp2) u1 (val1 - val2) +reduceBinaryOf Mult{} (EvalReducedValue tp1 u1 val1) (EvalReducedValue tp2 u2 val2) = force $! checkUnitTypes "Mult" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Mult` Stats tp2) u1 (val1 * val2) +reduceBinaryOf Div{} (EvalReducedValue tp1 u1 val1) (EvalReducedValue tp2 u2 val2) = force $! checkUnitTypes "Div" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Div` Stats tp2) u1 (val1 / val2) +reduceBinaryOf Add{} (EvalValue tp1 u1 _ _ val1) (EvalReducedValue tp2 u2 val2) = force $! checkUnitTypes "Add" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Add` Stats tp2) u1 (val1 + val2) +reduceBinaryOf Sub{} (EvalValue tp1 u1 _ _ val1) (EvalReducedValue tp2 u2 val2) = force $! checkUnitTypes "Sub" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Sub` Stats tp2) u1 (val1 - val2) +reduceBinaryOf Mult{} (EvalValue tp1 u1 _ _ val1) (EvalReducedValue tp2 u2 val2) = force $! checkUnitTypes "Mult" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Mult` Stats tp2) u1 (val1 * val2) +reduceBinaryOf Div{} (EvalValue tp1 u1 _ _ val1) (EvalReducedValue tp2 u2 val2) = force $! checkUnitTypes "Div" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Div` Stats tp2) u1 (val1 / val2) +-- reduceBinaryOf Add{} (EvalValue tp1 u1 _ _ val1) (EvalReducedValue tp2 u2 val2) = force $ checkUnitTypes "Add" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Add` Stats tp2) u1 (val1 + val2) +-- reduceBinaryOf Sub{} (EvalValue tp1 u1 _ _ val1) (EvalReducedValue tp2 u2 val2) = force $ checkUnitTypes "Sub" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Sub` Stats tp2) u1 (val1 - val2) +-- reduceBinaryOf Mult{} (EvalValue tp1 u1 _ _ val1) (EvalReducedValue tp2 u2 val2) = force $ checkUnitTypes "Mult" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Mult` Stats tp2) u1 (val1 * val2) +-- reduceBinaryOf Div{} (EvalValue tp1 u1 _ _ val1) (EvalReducedValue tp2 u2 val2) = force $ checkUnitTypes "Div" u1 u2 $ EvalReducedValue (Id $ Stats tp1 `Div` Stats tp2) u1 (val1 / val2) + +-- Todo: reduce with EvalVector? +reduceBinaryOf eval _ _ = error $ "unexpected binary reduce: " ++ show eval + + +checkUnitTypes :: (Eq a, Show a) => String -> a -> a -> p -> p +checkUnitTypes f a b c | a == b = c + | otherwise = error $ f <> " on different units: " <> show a <> ", " <> show b diff --git a/src/Experimenter/Eval/Table.hs b/src/Experimenter/Eval/Table.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Eval/Table.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} +module Experimenter.Eval.Table where + +import Control.DeepSeq +import Control.Monad (forM_) +import Control.Monad.Logger +import Data.List (foldl') +import qualified Data.Text as T +import GHC.Generics + +import Text.LaTeX +import Text.LaTeX.Base.Class +import Text.Printf + +data Table = + Table !Row + ![Row] + deriving (Show, Eq, Generic, NFData) + +newtype Row = + Row [Cell] + deriving (Show, Eq, Generic, NFData) + + +data Cell + = CellT !Text + | CellD !Double + | CellL !LaTeX + | CellEmpty + deriving (Show, Eq, Generic) + +instance NFData Cell where + rnf (CellT !_) = () + rnf (CellD x) = rnf x + rnf (CellL !_) = () + rnf CellEmpty = () + + +instance IsString Cell where + fromString = CellT . T.pack + +dereferLatex :: T.Text -> T.Text +dereferLatex = protectText . T.replace "{" "\\{" . T.replace "}" "\\}" . T.replace "_" "\\_" + + +printTable :: (MonadLogger m) => Table -> LaTeXT m () +printTable tbl@Table{} = forM_ (splitTable tbl) printTable' + where + printTable' (Table headerInput rowsInput) = + center $ + tabular Nothing (replicate colLen LeftColumn) $ hline <> printRow textbf header <> hline <> mconcat (map (printRow id) rows) <> hline + where + printRow :: (LaTeXC l) => (l -> l) -> Row -> l + printRow _ (Row []) = mempty + printRow f (Row (c:cs)) = foldl' (&) (f $ printCell c) (map (f . printCell) cs) <> lnbk + printCell :: (LaTeXC l) => Cell -> l + printCell (CellT txt) = raw (dereferLatex txt) + printCell (CellD nr) = raw $ printDouble nr + printCell (CellL l) = fromLaTeX l + printCell CellEmpty = mempty + colLen = maximum $ map cellCount (headerInput : rowsInput) + cellCount (Row xs) = length xs + extendRow (Row xs) = Row $ xs ++ replicate (colLen - length xs) CellEmpty + header = extendRow headerInput + rows = map extendRow rowsInput + +splitTable :: Table -> [Table] +splitTable tbl@(Table headerInput rowsInput) + | colLen <= maxColLen = [tbl] + | otherwise = takeCols maxColLen tbl : splitTable (dropCols maxColLen tbl) + where + colLen = maximum $ map cellCount (headerInput : rowsInput) + cellCount (Row xs) = length xs + takeCols n (Table (Row hs) rs) = Table (Row $ take n hs) (map (\(Row r) -> Row (take n r)) rs) + dropCols n (Table (Row hs) rs) = Table (Row $ take 1 hs ++ drop n hs) (map (\(Row r) -> Row (take 1 r ++ drop n r)) rs) + +maxColLen :: Int +maxColLen = 11 + +commas :: Int +commas = 3 + +printDouble :: Double -> T.Text +printDouble x = T.pack $ printf ("%." ++ show commas ++ "f") x diff --git a/src/Experimenter/Eval/Type.hs b/src/Experimenter/Eval/Type.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Eval/Type.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Experimenter.Eval.Type where + +import Control.DeepSeq +import Control.Lens hiding (Over) +import Data.ByteString (ByteString) +import Data.Serialize +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import GHC.Generics +import Prelude hiding (sum) + + +import Experimenter.Availability +import Experimenter.Result.Type hiding (Experiments) +import qualified Experimenter.Result.Type as R + +-- | Over datatype to reduce data vectors. +data Over a + = OverPeriods + | OverReplications + | OverExperimentRepetitions + -- implement this by sorting and taking/dropping results + -- | OverBestXExperimentRepetitions Int (ExperimentResult a -> ExperimentResult a -> Ordering) + deriving (Generic, Serialize, NFData) + +instance Eq (Over a) where + OverReplications == OverReplications = True + OverPeriods == OverPeriods = True + OverExperimentRepetitions == OverExperimentRepetitions = True + -- OverBestXExperimentRepetitions _ _ == OverBestXExperimentRepetitions _ _ = True + _ == _ = False + +instance Show (Over a) where + show OverReplications = "Replications" + show OverPeriods = "Periods" + show OverExperimentRepetitions = "Experiments" + -- show (OverBestXExperimentRepetitions nr _) = "(BestXExperimentEvaluations " <> show nr <> ")" + +instance Ord (Over a) where + compare OverExperimentRepetitions OverExperimentRepetitions = EQ + compare OverExperimentRepetitions _ = GT + compare OverReplications OverReplications = EQ + compare OverReplications _ = GT + compare OverPeriods OverPeriods = EQ + compare OverPeriods _ = LT + + -- compare OverExperimentRepetitions OverReplications = GT + -- compare OverExperimentRepetitions OverPeriods = GT + + -- compare OverReplications _ = LT + -- compare OverReplications OverPeriods = GT + -- compare OverPeriods OverPeriods = EQ + -- compare OverPeriods _ = LT + -- compare OverBestXExperimentRepetitions{} OverBestXExperimentRepetitions{} = EQ + -- compare OverBestXExperimentRepetitions{} _ = GT + + +-- | Definition of statisics. Is used to define the desired output. + + +data StatsDef a + = Mean !(Over a) !(Of a) + | StdDev !(Over a) !(Of a) + | Sum !(Over a) !(Of a) + -- | TakeBest Int (StatsDef a) (Of a) + | Id !(Of a) + | Named !(StatsDef a) !ByteString + | Name !ByteString !(StatsDef a) + deriving (Generic, Serialize, Show, Eq, Ord, NFData) + +-- type Name = + +getOver :: StatsDef a -> Maybe (Over a) +getOver (Mean o _) = Just o +getOver (StdDev o _) = Just o +getOver (Sum o _) = Just o +getOver (Id _) = Nothing +getOver (Named _ _) = Nothing +getOver (Name _ _) = Nothing + + +data Of a + = Of !ByteString + | Stats !(StatsDef a) + | Div !(Of a) !(Of a) + | Add !(Of a) !(Of a) + | Sub !(Of a) !(Of a) + | Mult !(Of a) !(Of a) + | Last !(Of a) + | First !(Of a) + | EveryXthElem !Int !(Of a) + | Length !(Of a) + deriving (Generic, Serialize, Show, Eq, Ord, NFData) + +prettyStatsDef :: StatsDef a -> T.Text +prettyStatsDef statsDef = + case statsDef of + Named _ txt -> E.decodeUtf8 txt + Name txt _ -> E.decodeUtf8 txt + Mean over of' -> "Mean " <> prettyOver over <> " " <> prettyOf of' + StdDev over of' -> "StdDev " <> prettyOver over <> " " <> prettyOf of' + Sum over of' -> "Sum " <> prettyOver over <> " " <> prettyOf of' + Id (Of name) -> E.decodeUtf8 name <> "s" + Id of' -> prettyOf of' + +prettyOf :: Of a -> T.Text +prettyOf = dropDoublePars . prettyOf' + where + prettyOf' of' = + case of' of + Of name -> "of " <> E.decodeUtf8 name + Stats statsDef -> "(" <> prettyStatsDef statsDef <> ")" + Div x y -> "( " <> prettyOf' x <> ") / (" <> prettyOf' y <> ")" + Add x y -> "( " <> prettyOf' x <> ") + (" <> prettyOf' y <> ")" + Sub x y -> "( " <> prettyOf' x <> ") - (" <> prettyOf' y <> ")" + Mult x y -> "( " <> prettyOf' x <> ") * (" <> prettyOf' y <> ")" + Last x -> "Last(" <> prettyOf' x <> ")" + First x -> "First(" <> prettyOf' x <> ")" + Length x -> "Length(" <> prettyOf' x <> ")" + EveryXthElem nr x -> "EveryXthElem(" <> T.pack (show nr) <> ", " <> prettyOf' x <> ")" + dropDoublePars = T.replace "((" "(" . T.replace "))" ")" + + +prettyOver :: Over a -> T.Text +prettyOver ov = "over " <> case ov of + OverPeriods -> "periods" + OverReplications -> "replications" + OverExperimentRepetitions -> "experiment repetitions" + -- OverBestXExperimentRepetitions nr _ -> "best " <> T.pack (show nr) <> " experiment repetitions" + + +-- Helper functions for demoting StatsDefs to Ofs. + +sum :: Over a -> Of a -> Of a +sum over of' = Stats (Sum over of') + +stdDev :: Over a -> Of a -> Of a +stdDev over of' = Stats (StdDev over of') + +mean :: Over a -> Of a -> Of a +mean over of' = Stats (Mean over of') + + +-- | Simple examples on how to use the types + +example :: StatsDef a +example = Mean OverReplications (sum OverPeriods (Of "NrEarly") `Div` sum OverPeriods (Of "NrOrders")) + +example2 :: StatsDef a +example2 = Mean OverReplications (Of "NrEarly" `Div` Of "NrOrders") + + +example3 :: StatsDef a +example3 = Mean OverReplications (Of "X") + + +-- | Datatypes for the evaluation result. +data Unit + = UnitPeriods + | UnitReplications + | UnitExperimentRepetition + | UnitScalar + deriving (Generic, Serialize, Read, Eq, Ord, Show, NFData) + -- UnitBestExperimentRepetitions Int + +data EvalResults a + = EvalVector { _evalType :: !(StatsDef a) + , _evalUnit :: !Unit -- ^ Over which the vector runs. + , _evalValues :: ![EvalResults a] + } + | EvalValue { _evalType :: !(StatsDef a) + , _evalUnit :: !Unit -- ^ Is always periods. + , _evalVariableName :: !ByteString + , _evalX :: !(Either Int Double) -- ^ Either period or xValue. + , _evalY :: !Double } + | EvalReducedValue { _evalType :: !(StatsDef a) + , _evalUnit :: !Unit -- ^ Over which was reduced. + , _evalValue :: !Double } + deriving (Generic, Serialize, Show, NFData) +makeLenses ''EvalResults + +data ExperimentEval a = ExperimentEval + { _evalExperimentNumber :: !Int + , _evalExperimentResults :: ![Availability IO (EvalResults a)] + , _evalExperiment :: !(Experiment a) + } deriving (Generic, NFData) +makeLenses ''ExperimentEval + +instance Show (ExperimentEval a) where + show x = show (x ^. evalExperimentResults) + +data Evals a = Evals + { _evalsExperiments :: !(R.Experiments a) + , _evalsResults :: ![ExperimentEval a] + } deriving (Generic, NFData) +makeLenses ''Evals + + +-- Helper Functions + +getEvalValue :: EvalResults a -> [Double] +getEvalValue (EvalVector _ _ xs) = concatMap getEvalValue xs +getEvalValue (EvalValue _ _ _ _ y) = [y] +getEvalValue (EvalReducedValue _ _ y) = [y] + +getEvalType :: (Over a -> Of a -> StatsDef a) -> EvalResults a -> StatsDef a +getEvalType f (EvalVector tp unit _) = f (fromUnit unit) (Stats tp) + where fromUnit UnitPeriods = OverPeriods + fromUnit UnitReplications = OverReplications + fromUnit UnitExperimentRepetition = OverExperimentRepetitions + -- fromUnit (UnitBestExperimentRepetitions nr) = OverBestXExperimentRepetitions nr (error "compare function in BestXExperimentEvaluations may not be used") + fromUnit UnitScalar = OverExperimentRepetitions -- TODO really? +getEvalType _ (EvalValue t _ _ _ _) = t +getEvalType _ (EvalReducedValue t _ _) = t + +fromOver :: Over a -> Unit +fromOver OverPeriods = UnitPeriods +fromOver OverReplications = UnitReplications +fromOver OverExperimentRepetitions = UnitExperimentRepetition +-- fromOver (OverBestXExperimentRepetitions nr _) = UnitBestExperimentRepetitions nr + + +-- | Demotes the unit by 1 degree. Thus this calculates the unit of a vector over which it was reduced. +demoteUnit :: Unit -> Maybe Unit +demoteUnit UnitPeriods = Nothing +demoteUnit UnitReplications = Just UnitPeriods +demoteUnit UnitExperimentRepetition = Just UnitReplications +-- demoteUnit UnitBestExperimentRepetitions{} = Just UnitReplications +demoteUnit UnitScalar = Just UnitExperimentRepetition diff --git a/src/Experimenter/Eval/Util.hs b/src/Experimenter/Eval/Util.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Eval/Util.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +module Experimenter.Eval.Util where + +import Control.DeepSeq +import Control.Lens hiding (Cons, Over, over) +import Control.Monad.IO.Class +import qualified Data.Text as T +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import System.FilePath.Posix + +import Experimenter.Result.Type + + +rootPath :: FilePath +rootPath = "results" + +mainFile :: Experiments a -> FilePath +mainFile exps = "main_" <> getTime exps <> ".tex" + +getTime :: Experiments a -> String +getTime exps = maybe "unfinished_experiment" (T.unpack . T.replace " " "_" . T.pack . show) (exps ^. experimentsEndTime) + +scalarFile :: Experiments a -> FilePath +scalarFile exps = "scalar_" <> getTime exps <> ".tex" + +repetitionFile :: Experiments a -> FilePath +repetitionFile exps = "repetition_" <> getTime exps <> ".tex" + +replicationFile :: Experiments a -> FilePath +replicationFile exps = "replication_" <> getTime exps <> ".tex" + +periodicFile :: Experiments a -> FilePath +periodicFile exps = "periodic_" <> getTime exps <> ".tex" + +mainFilePdf :: Experiments a -> FilePath +mainFilePdf exps = T.unpack (T.dropWhileEnd (/= '.') (T.pack $ mainFile exps)) <> "pdf" + +getExpsName :: Experiments a -> String +getExpsName exps = T.unpack $ T.replace "/" "_" $ T.replace " " "_" $ exps ^. experimentsName + +expsPath :: Experiments a -> FilePath +expsPath exps = rootPath getExpsName exps + +mkTime :: (MonadIO m, NFData t) => String -> m t -> m t +mkTime name a = do + start <- liftIO getCurrentTime + !val <- force <$> a + end <- liftIO getCurrentTime + let name' | null name = name + | otherwise = name ++ [' '] + liftIO $ putStrLn (name' <> "Computation Time: " ++ show (diffUTCTime end start)) + return val diff --git a/src/Experimenter/Experiment.hs b/src/Experimenter/Experiment.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Experiment.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +module Experimenter.Experiment where + + +import Control.DeepSeq +import Control.Monad.IO.Unlift +import Data.Serialize (Serialize) +import Data.Kind +import System.Random.MWC + +import Experimenter.Parameter +import Experimenter.StepResult + + +type Period = Int +type ExperimentNumber = Int +type RepetitionNumber = Int +type ReplicationNumber = Int + +-- | Phase of experiment. Each experiment runs through all phases, where however a phase may have 0 steps. +data Phase + = PreparationPhase -- ^ For preparing the evaluation. For instance to let a machine learning algorithm learn its function, before it is evaluated. + | WarmUpPhase -- ^ The warm up phase is equal to the evaluation phase, but does not count as evaluation. Used to get the system in a steady state. + | EvaluationPhase -- ^ Evaluation phase. + deriving (Eq, Ord, Show, Enum) + +-- | Definition of the Experiment. +class (Monad (ExpM a), MonadUnliftIO (ExpM a), NFData a, NFData (InputState a), NFData (InputValue a), Serialize (InputValue a), Serialize (InputState a), Serialize (Serializable a)) => ExperimentDef a where + + -- | Monad to run experiments in. In most cases you want this to be `IO`. + type ExpM a :: (Type -> Type) + + -- | Type that is used to serialize the current state. + type Serializable a :: Type + + -- Types for input values to the experiment: + + -- | The input to the system for running a step. Set to `()` if unused. + type InputValue a :: Type + + -- | Can be used to save a information from one call to `generateInput` to the next. Set to `()` if unused. + type InputState a :: Type + + + -- | Generate some input values and possibly modify state. This function can be used to change the state. It is called + -- before `runStep` and its output is used to call `runStep`. + generateInput :: GenIO -> a -> InputState a -> Period -> (ExpM a) (InputValue a, InputState a) + default generateInput :: (InputValue a ~ (), InputState a ~ ()) => GenIO -> a -> InputState a -> Period -> (ExpM a) (InputValue a, InputState a) + generateInput _ _ _ _ = return ((), ()) + + -- | Run a step of the environment and return new state and result. + runStep :: Phase -> a -> InputValue a -> Period -> (ExpM a) ([StepResult], a) + + -- | Provides the parameter setting. Parameters are used to design the experiment instances, e.g. the variants that will be run. + parameters :: a -> [ParameterSetup a] + default parameters :: a -> [ParameterSetup a] + parameters _ = [] + + -- | This function defines how to find experiments that can be resumed. Note that the experiments name and experiment + -- info parameters are always comparison factors, that is, experiments with different names or info parameters are + -- unequal. The default is always True. + equalExperiments :: (a, InputState a) -> (a, InputState a) -> Bool + default equalExperiments :: (a, InputState a) -> (a, InputState a) -> Bool + equalExperiments _ _ = True + + + -- | Function to convert to a serializable object. Can be used to convert the state to serialisable representation. + serialisable :: a -> ExpM a (Serializable a) + default serialisable :: (a ~ Serializable a) => a -> ExpM a (Serializable a) + serialisable = return + + -- | Function to convert from a serializable object. Can be used to convert the state from its serialisable representation. + deserialisable :: Serializable a -> ExpM a a + default deserialisable :: (a ~ Serializable a) => Serializable a -> ExpM a a + deserialisable = return + + -- HOOKS + + -- | Function to call on the state before the preparation. This function is only executed if the preparation phase + -- exists (that is >0 preparation steps) and is started from period 0! + beforePreparationHook :: ExperimentNumber -> RepetitionNumber -> GenIO -> a -> ExpM a a + default beforePreparationHook :: ExperimentNumber -> RepetitionNumber -> GenIO -> a -> ExpM a a + beforePreparationHook _ _ _ = return + + -- | Function to call on the state before the warm up phase. This function is only executed if a warm up phase exists + -- (that is >0 warm-up steps) and is initialised, which happens on the first time it is started! + beforeWarmUpHook :: ExperimentNumber -> RepetitionNumber -> ReplicationNumber -> GenIO -> a -> ExpM a a + default beforeWarmUpHook :: ExperimentNumber -> RepetitionNumber -> ReplicationNumber -> GenIO -> a -> ExpM a a + beforeWarmUpHook _ _ _ _ = return + + + -- | Function to call on the state before the evaluation phase. This function is only executed if the evaluation phase + -- exists (that is >0 evaluation steps) and is initialised which happens on the first time it is started! + beforeEvaluationHook :: ExperimentNumber -> RepetitionNumber -> ReplicationNumber -> GenIO -> a -> ExpM a a + default beforeEvaluationHook :: ExperimentNumber -> RepetitionNumber -> ReplicationNumber -> GenIO -> a -> ExpM a a + beforeEvaluationHook _ _ _ _ = return + + + -- | Function to call after the preparation phase, e.g. it can be used to move files. This function is only executed if + -- the preparation phase is updated. The first parameter is the input state and is only used for type checking. + afterPreparationHook :: a -> ExperimentNumber -> RepetitionNumber -> IO () + default afterPreparationHook :: a -> ExperimentNumber -> RepetitionNumber -> IO () + afterPreparationHook _ _ _ = return () + + + -- | Function to call after the warmUp phase, e.g. it can be used to move files. This function is only executed if + -- the warmUp phase is updated. The first parameter is the input state and is only used for type checking. + afterWarmUpHook :: a -> ExperimentNumber -> RepetitionNumber -> ReplicationNumber -> IO () + default afterWarmUpHook :: a -> ExperimentNumber -> RepetitionNumber -> ReplicationNumber -> IO () + afterWarmUpHook _ _ _ _ = return () + + + -- | Function to call after the evaluation phase, e.g. it can be used to move files. This function is only executed if + -- the evaluation phase is updated. The first parameter is the input state before the evaluation and is only used for type checking. + afterEvaluationHook :: a -> ExperimentNumber -> RepetitionNumber -> ReplicationNumber -> IO () + default afterEvaluationHook :: a -> ExperimentNumber -> RepetitionNumber -> ReplicationNumber -> IO () + afterEvaluationHook _ _ _ _ = return () diff --git a/src/Experimenter/Input.hs b/src/Experimenter/Input.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Input.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + + +module Experimenter.Input where + +import Control.DeepSeq +import Control.Lens + +import Experimenter.Experiment + +data Input a = Input + { _inputValuePeriod :: !Int + , _inputValue :: !(InputValue a) + } + + +instance NFData (InputValue a) => NFData (Input a) where + rnf (Input p v) = rnf p `seq` rnf v + + +makeLenses ''Input diff --git a/src/Experimenter/MasterSlave.hs b/src/Experimenter/MasterSlave.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/MasterSlave.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Experimenter.MasterSlave + ( WorkerStatus (..) + , createKeepAliveFork + , waitForSlaves + , keepAliveTimeout + ) where + +import Control.Lens +import Control.Monad.IO.Class +import Control.Monad.Logger (NoLoggingT, logInfo, runNoLoggingT) +import Data.IORef + +import Control.Concurrent (forkIO, threadDelay) +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import qualified Data.Text as T +import Data.Time (UTCTime, diffUTCTime, getCurrentTime) +import Database.Persist.Postgresql +import Network.HostName +import System.Posix.Process + + +import Experimenter.DatabaseSetting +import Experimenter.DB +import Experimenter.Models +import Experimenter.Result +import Experimenter.Util + + +keepAliveTimeout :: Num t => t +keepAliveTimeout = 10 + + +data WorkerStatus = Working | Finished + deriving (Eq, Show) + +createKeepAliveFork :: DatabaseSetting -> (UTCTime -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()) -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) () -> IO (IORef WorkerStatus) +createKeepAliveFork dbSetup updateFunction deletionFunction = do + ref <- liftIO $ newIORef Working + void $ liftIO $ forkIO (runNoLoggingT $ withPostgresqlPool (connectionString dbSetup) 1 $ liftSqlPersistMPool $ keepAlive ref) + return ref + where + keepAlive ref = do + res <- liftIO $ readIORef ref + if res == Working + then do + time <- liftIO getCurrentTime + updateFunction time + transactionSave + liftIO $ threadDelay (1000000 * keepAliveTimeout) + keepAlive ref + else deletionFunction + +waitForSlaves :: (MonadIO m) => Experiments a -> DB m Bool +waitForSlaves exps = do + pid <- liftIO getProcessID + hostName <- T.pack <$> liftIO getHostName + let notSelf (ExpExecutionLock _ h p _) = not (h == hostName && p == fromIntegral pid) + expIds <- selectKeysList [ExpExps ==. expsId] [] + waitForSlaves' notSelf expIds + where + expsId = exps ^. experimentsKey + waitForSlaves' notSelf expIds = do + locks <- filter notSelf . fmap entityVal <$> selectList [ExpExecutionLockExp <-. expIds] [] + if null locks + then do + deleteWhere [ExpProgressExp <-. expIds] + return True + else do + time <- liftIO getCurrentTime + let workingSlaves = filter (\l -> diffUTCTime time (l ^. expExecutionLockLastAliveSign) <= 2 * keepAliveTimeout) locks + if null workingSlaves + then return False -- a slive must have died as it didn't delete the lock + else do + $(logInfo) "Waiting for slaves. List of slaves currently working: " + mapM_ printInfoSlave locks + liftIO $ threadDelay (1000000 * keepAliveTimeout) + waitForSlaves' notSelf expIds + printInfoSlave (ExpExecutionLock _ host pid _) = $(logInfo) $ "Slave from host " <> tshow host <> " with process ID " <> tshow pid diff --git a/src/Experimenter/Measure.hs b/src/Experimenter/Measure.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Measure.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +module Experimenter.Measure where + +import Control.DeepSeq +import Control.Lens +import GHC.Generics + +import Experimenter.StepResult + +data Measure = Measure + { _measurePeriod :: !Int + , _measureResults :: ![StepResult] + } deriving (Generic) +makeLenses ''Measure + +instance NFData Measure where + rnf (Measure !p !r) = rnf p `seq` rnf1 r diff --git a/src/Experimenter/Models.hs b/src/Experimenter/Models.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Models.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Experimenter.Models where + + +import Data.ByteString +import Data.Text +import Data.Time (UTCTime) +import Database.Persist.Postgresql +import Database.Persist.Quasi +import Database.Persist.TH + + +share [mkPersist sqlSettings {mpsGenerateLenses = True}, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"] + $(persistFileWith lowerCaseSettings "config/models") diff --git a/src/Experimenter/Parameter.hs b/src/Experimenter/Parameter.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Parameter.hs @@ -0,0 +1,7 @@ +module Experimenter.Parameter + (module P + ) where + +import Experimenter.Parameter.Ops as P +import Experimenter.Parameter.Query as P +import Experimenter.Parameter.Type as P diff --git a/src/Experimenter/Parameter/Ops.hs b/src/Experimenter/Parameter/Ops.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Parameter/Ops.hs @@ -0,0 +1,12 @@ +module Experimenter.Parameter.Ops + ( convertParameterSetup + ) where + +import Data.Serialize + +import Experimenter.Models +import Experimenter.Parameter.Type + +convertParameterSetup :: ExpsId -> ParameterSetup a -> Param +convertParameterSetup expsId (ParameterSetup name _ _ _ (Just (minB,maxB)) _ _) = Param expsId name (Just $ runPut $ put minB) (Just $ runPut $ put maxB) +convertParameterSetup expsId (ParameterSetup name _ _ _ Nothing _ _) = Param expsId name Nothing Nothing diff --git a/src/Experimenter/Parameter/Query.hs b/src/Experimenter/Parameter/Query.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Parameter/Query.hs @@ -0,0 +1,21 @@ + + +module Experimenter.Parameter.Query + ( queryParamSettings + ) where + +import Control.Monad.Reader +import Database.Esqueleto +import Prelude hiding (exp) + +import Experimenter.Models + + +queryParamSettings :: (MonadIO m) => Key Exp -> ReaderT SqlBackend m [(Entity Exp, Entity ParamSetting)] +queryParamSettings kExp = + select $ + from $ \(exp, paramSet) -> do + where_ (exp ^. ExpId ==. paramSet ^. ParamSettingExp) + where_ (exp ^. ExpId ==. val kExp) + orderBy [asc (exp ^. ExpNumber)] + return (exp, paramSet) diff --git a/src/Experimenter/Parameter/Type.hs b/src/Experimenter/Parameter/Type.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Parameter/Type.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +module Experimenter.Parameter.Type where + +import Control.DeepSeq +import Control.Lens +import qualified Data.ByteString as BS +import Data.Serialize as S +import qualified Data.Text as T +import GHC.Generics + + +data ExperimentDesign + = FullFactory + | SingleInstance + deriving (Bounded, Enum, Eq, Ord, Generic, NFData) + +data ParameterSetup a = + forall b . (Show b, Ord b, Serialize b) => + ParameterSetup + { parameterName :: !T.Text -- ^ Name of parameter. + , setParameter :: !(b -> a -> a) -- ^ Set the parameter. + , getParameter :: !(a -> b) -- ^ Get the parameter from the current state. + , modifyParameter :: !(Maybe (b -> IO [b])) -- ^ Either no modification or function. + , bounds :: !(Maybe (b, b)) -- ^ Bounds (inclusive). + , skipPreparationPhase :: !(Maybe (b -> Bool)) -- ^ Skip the preparation phase if True (e.g. to skip learning phase). Default: False. + , alterExperimentDesign :: !(Maybe (b -> ExperimentDesign)) -- ^ Change the experiment design. Default: Full-Factory design. + } +-- makeLenses ''ParameterSetup -- does not work with ExistentialQuantification + + +data ParameterSetting a = + ParameterSetting + { _parameterSettingName :: !T.Text + , _parameterSettingValue :: !BS.ByteString + , _parameterSettingSkipPreparationPhase :: !Bool + , _parameterSettingExperimentDesign :: !ExperimentDesign + } deriving (Eq, Generic, NFData) +makeLenses ''ParameterSetting + + +getParameterData :: ParameterSetup a -> a -> BS.ByteString +getParameterData (ParameterSetup _ _ getter _ _ _ _) a = runPut $ put $ getter a + + +mkParameterSetting :: ParameterSetup a -> a -> ParameterSetting a +mkParameterSetting (ParameterSetup n _ getter _ _ drp design) a = ParameterSetting n (runPut $ put aVal) (maybe False (\x -> x aVal) drp) (maybe FullFactory (\x -> x aVal) design) + where aVal = getter a diff --git a/src/Experimenter/Result.hs b/src/Experimenter/Result.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Result.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Experimenter.Result + ( module R + ) where + +import Experimenter.Result.Query as R +import Experimenter.Result.Type as R diff --git a/src/Experimenter/Result/Query.hs b/src/Experimenter/Result/Query.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Result/Query.hs @@ -0,0 +1,610 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module Experimenter.Result.Query + ( loadExperiments + , loadExperimentResults + , loadExperimentsResults + , loadPreparationInputWhere + , loadPreparationMeasuresWhere + , loadPreparationAggregateWhere + , loadReplicationWarmUpInputWhere + , loadReplicationWarmUpMeasuresWhere + , loadReplicationWarmUpAggregateWhere + , loadReplicationInputWhere + , loadReplicationMeasuresWhere + , loadReparationAggregateWhere + , loadResDataEndState + , loadResDataStartState + , loadParamSetup + , deserialise + , mDeserialise + , setParams + , fromRandGen + , toRandGen + , serialiseSeed + , deserialiseSeed + , StartStateType (..) + , EndStateType (..) + , setResDataStartState + , setResDataEndState + ) where + +import Conduit as C +import Control.DeepSeq +import Control.Lens (view) +import Control.Monad.Logger +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.Conduit.List as CL +import Data.Either (isLeft) +import Data.Function (on) +import qualified Data.List as L +import Data.Maybe (fromMaybe) +import Data.Serialize as S (Serialize, get, put, runGet, runPut) +import qualified Data.Text as T +import Data.Time (getCurrentTime) +import Data.Vector.Serialize () +import qualified Data.Vector.Unboxed as V +import Data.Word (Word32) +import qualified Database.Esqueleto as E +import Database.Persist as P +import Database.Persist.Postgresql (SqlBackend) +import Database.Persist.Sql (transactionSave) +import Prelude hiding (exp) +import System.Random.MWC + +import Experimenter.Availability +import Experimenter.DB +import Experimenter.Experiment +import Experimenter.Input +import Experimenter.Measure +import Experimenter.Models +import Experimenter.Parameter +import Experimenter.Result.Type +import Experimenter.Setting +import Experimenter.StepResult +import Experimenter.Util + + +data EndStateType + = EndStatePrep !(Key PrepResultData) + | EndStateWarmUp !(Key WarmUpResultData) + | EndStateRep !(Key RepResultData) + + +data StartStateType + = StartStatePrep !(Key PrepResultData) + | StartStateWarmUp !(Key WarmUpResultData) + | StartStateRep !(Key RepResultData) + + +loadExperimentsResults :: (ExperimentDef a) => ExperimentSetting -> InputState a -> a -> Key Exps -> DB (ExpM a) (Maybe (Experiments a)) +loadExperimentsResults setup initInpSt initSt key = + runMaybeT $ do + e <- MaybeT $ P.get key + exps <- lift (L.sortBy (compare `on` view experimentNumber) <$> loadExperimentList key) + expInfoParams <- lift (map entityVal <$> selectList [ExpsInfoParamExps ==. key] []) + eSetup <- lift (fromMaybe (error "Setup not found. Your DB is corrupted!") <$> getBy (UniqueExpsSetup key)) + infoParms <- lift (mapM fromInfoParam expInfoParams) + return $ + Experiments + key + (view expsName e) + (view expsStartTime e) + (view expsEndTime e) + (entityVal eSetup) + (parameters initSt) + (concat infoParms) + initSt + initInpSt + exps + where + infoParams = view experimentInfoParameters setup + fromInfoParam (ExpsInfoParam _ n bs) = + case L.find ((== n) . infoParameterName) infoParams of + Nothing -> do + $(logDebug) $ "Could not find parameter " <> n <> " in settings while loading values from the DB. It will not be reported therefore!" + return [] + Just (ExperimentInfoParameter _ v) -> return [ExperimentInfoParameter n (fromEitherDef v $ S.runGet S.get bs)] + fromEitherDef _ (Right x) = x + fromEitherDef d (Left _) = d + + +loadExperiments :: (ExperimentDef a) => ExperimentSetting -> InputState a -> a -> DB (ExpM a) (Experiments a) +loadExperiments setup initInpSt initSt = do + eExp <- getOrCreateExps setup initInpSt initSt + let e = entityVal eExp + exps <- L.sortBy (compare `on` view experimentNumber) <$> loadExperimentList (entityKey eExp) + eSetup <- fromMaybe (error "Setup not found. Your DB is corrupted!") <$> getBy (UniqueExpsSetup (entityKey eExp)) + return $!! + Experiments + (entityKey eExp) + (view expsName e) + (view expsStartTime e) + (view expsEndTime e) + (entityVal eSetup) + (parameters initSt) + (view experimentInfoParameters setup) + initSt + initInpSt + exps + + +loadExperimentList :: (ExperimentDef a) => Key Exps -> DB (ExpM a) [Experiment a] +loadExperimentList expsKey = selectList [ExpExps ==. expsKey] [] >>= mapM mkExperiment + where mkExperiment (Entity k exp) = do + paramSetting <- loadParamSetup k + Experiment k (view expNumber exp) (view expStartTime exp) (view expEndTime exp) paramSetting <$> loadExperimentResults k + + +mDeserialise :: (MonadIO m, MonadLogger m ,Serialize a) => T.Text -> Maybe ByteString -> m (Maybe (Maybe a)) +mDeserialise n mBs = sequence (deserialise n <$> mBs) + + +deserialise :: (MonadIO m, MonadLogger m, Serialize a) => T.Text -> ByteString -> m (Maybe a) +deserialise n bs = + let !res = runGet S.get bs + in case res of + Left err -> do + $(logError) $ "Could not deserialise " <> n <> "! Discarding saved experiment result. Data length: " <> tshow (B.length bs) <> ". Error Message: " <> tshow err + return Nothing + Right r -> return $! Just r + + +loadExperimentResults :: (ExperimentDef a) => Key Exp -> DB (ExpM a) [ExperimentResult a] +loadExperimentResults kExp = do + xs <- selectList [ExpResultExp ==. kExp] [Asc ExpResultRepetition] + mapM loadExperimentResult xs + + +loadResDataEndState :: + forall a. (ExperimentDef a) + => Key Exp + -> EndStateType + -> DB (ExpM a) (Maybe a) +loadResDataEndState expId endSt = do + !parts <- + fmap force $! + case endSt of + EndStatePrep k -> fmap (view prepEndStatePartData . entityVal) <$> selectList [PrepEndStatePartResultData ==. k] [Asc PrepEndStatePartNumber] + EndStateWarmUp k -> fmap (view warmUpEndStatePartData . entityVal) <$> selectList [WarmUpEndStatePartResultData ==. k] [Asc WarmUpEndStatePartNumber] + EndStateRep k -> fmap (view repEndStatePartData . entityVal) <$> selectList [RepEndStatePartResultData ==. k] [Asc RepEndStatePartNumber] + !res <- + if null parts + then return Nothing + else do + !mSer <- deserialise (T.pack "end state") (B.concat parts) + lift $! lift $! lift $! maybe (return Nothing) (fmap Just . deserialisable) mSer + force <$!> traverse (setParams expId) res + +loadResDataStartState :: (ExperimentDef a) => Key Exp -> StartStateType -> DB (ExpM a) a +loadResDataStartState expId startSt = do + !parts <- + fmap force $! + case startSt of + StartStatePrep k -> fmap (view prepStartStatePartData . entityVal) <$> selectList [PrepStartStatePartResultData ==. k] [Asc PrepStartStatePartNumber] + StartStateWarmUp k -> fmap (view warmUpStartStatePartData . entityVal) <$> selectList [WarmUpStartStatePartResultData ==. k] [Asc WarmUpStartStatePartNumber] + StartStateRep k -> fmap (view repStartStatePartData . entityVal) <$> selectList [RepStartStatePartResultData ==. k] [Asc RepStartStatePartNumber] + !res <- + if null parts + then error "Could not get start state" + else do + !ser <- fromMaybe (error "Could not deserialise start state ") <$> deserialise "prep start state" (B.concat parts) + lift $! lift $! lift $! deserialisable ser + force <$!> setParams expId res + + +setResDataEndState :: (MonadIO m) => EndStateType -> Maybe ByteString -> ReaderT SqlBackend m () +setResDataEndState (EndStatePrep k) (Just bs) = do + -- liftIO $ B.writeFile "/tmp/EndState" bs + let parts = splitState bs + mapM_ (\(nr, part) -> upsert (PrepEndStatePart k nr part) [PrepEndStatePartData =. part]) (zip [0..] parts) + deleteWhere [PrepEndStatePartResultData ==. k, PrepEndStatePartNumber >=. length parts] +setResDataEndState (EndStateWarmUp k) (Just bs) = do + let parts = splitState bs + mapM_ (\(nr, part) -> upsert (WarmUpEndStatePart k nr part) [WarmUpEndStatePartData =. part]) (zip [0..] parts) + deleteWhere [WarmUpEndStatePartResultData ==. k, WarmUpEndStatePartNumber >=. length parts] +setResDataEndState (EndStateRep k) (Just bs) = do + let parts = splitState bs + mapM_ (\(nr, part) -> upsert (RepEndStatePart k nr part) [RepEndStatePartData =. part]) (zip [0..] parts) + deleteWhere [RepEndStatePartResultData ==. k, RepEndStatePartNumber >=. length parts] +setResDataEndState (EndStatePrep k) Nothing = deleteWhere [PrepEndStatePartResultData ==. k] +setResDataEndState (EndStateWarmUp k) Nothing = deleteWhere [WarmUpEndStatePartResultData ==. k] +setResDataEndState (EndStateRep k) Nothing = deleteWhere [RepEndStatePartResultData ==. k] + + +setResDataStartState :: (MonadIO m) => StartStateType -> ByteString -> ReaderT SqlBackend m () +setResDataStartState (StartStatePrep k) bs = do + let parts = splitState bs + mapM_ (\(nr, part) -> upsert (PrepStartStatePart k nr part) [PrepStartStatePartData =. part]) (zip [0..] parts) + deleteWhere [PrepStartStatePartResultData ==. k, PrepStartStatePartNumber >=. length parts] +setResDataStartState (StartStateWarmUp k) bs = do + let parts = splitState bs + mapM_ (\(nr, part) -> upsert (WarmUpStartStatePart k nr part) [WarmUpStartStatePartData =. part]) (zip [0..] parts) + deleteWhere [WarmUpStartStatePartResultData ==. k, WarmUpStartStatePartNumber >=. length parts] +setResDataStartState (StartStateRep k) bs = do + let parts = splitState bs + mapM_ (\(nr, part) -> upsert (RepStartStatePart k nr part) [RepStartStatePartData =. part]) (zip [0..] parts) + deleteWhere [RepStartStatePartResultData ==. k, RepStartStatePartNumber >=. length parts] + + +splitState :: ByteString -> [ByteString] +splitState bs + | B.null bs = [] + | otherwise = B.take splitLength bs : splitState (B.drop splitLength bs) + where + splitLength = 128000000 -- 128MB as ByteString is composed of Word8 (8-bit unsigned integer = 1 byte) elements + + +setParams :: (MonadIO m, MonadLogger m, ExperimentDef a) => Key Exp -> a -> ReaderT SqlBackend m a +setParams expId st = do + paramSettings <- loadParamSetup expId + foldM setParams' st paramSettings + where setParams' !state !(ParameterSetting n bs _ _) = + case L.find (\(ParameterSetup name _ _ _ _ _ _) -> name == n) paramSetup of + Nothing -> do + $(logError) $ "Could not find parameter with name " <> n <> " in the current parameter setting. Thus it cannot be modified!" + return state + Just (ParameterSetup _ setter _ _ _ _ _) -> + case runGet S.get bs of + Left err -> error $ "Could not read value of parameter " <> T.unpack n <> ". Aborting! Serializtion error was: " ++ err + Right val -> do + $(logInfo) $ "Loaded parameter '" <> n <> "' value: " <> tshow val + return $ setter val state + paramSetup = parameters st + +loadExperimentResult :: forall a . (ExperimentDef a) => Entity ExpResult -> DB (ExpM a) (ExperimentResult a) +loadExperimentResult (Entity k (ExpResult expId rep mPrepResDataId)) = do + !mEPrepResData <- fmap join $ sequence $ P.getEntity <$> mPrepResDataId + !prepRes <- + case mEPrepResData of + Nothing -> return Nothing + Just (Entity resDataKey (PrepResultData startT endT startRandGenBS endRandGenBS startInpStBS endInpStBS)) -> do + let !startSt = AvailableOnDemand (loadResDataStartState expId (StartStatePrep resDataKey)) + let !endSt = AvailableOnDemand (loadResDataEndState expId (EndStatePrep resDataKey)) + !mStartInpSt <- deserialise "prep start input state" startInpStBS + !mEndInpSt <- mDeserialise "prep end input state" endInpStBS + !inpCount <- loadPreparationInputCount resDataKey + !resultCount <- loadPrepartionMeasuresCount resDataKey + !startRandG <- toRandGen startRandGenBS + !endRandG <- maybe (return Nothing) (fmap Just . toRandGen) endRandGenBS + let !inputVals = AvailableListOnDemand (inpCount, loadPreparationInputWhere resDataKey) + let !res = AvailableListOnDemand (resultCount, loadPreparationMeasuresWhere resDataKey) + return $!! ResultData (ResultDataPrep resDataKey) startT endT startRandG endRandG inputVals res startSt endSt <$> mStartInpSt <*> mEndInpSt + !evalRes <- loadReplicationResults expId k + return $!! ExperimentResult k rep prepRes evalRes + + +serialiseSeed :: Seed -> ByteString +serialiseSeed seed = S.runPut $ S.put (fromSeed seed :: V.Vector Word32) + +deserialiseSeed :: ByteString -> Seed +deserialiseSeed bs = toSeed (fromRight $ S.runGet S.get bs :: V.Vector Word32) + where fromRight (Right s) = s + fromRight (Left err) = error $ "Could not deserialise random generator. Error Message: " <> err + +fromRandGen :: (MonadIO m) => GenIO -> m ByteString +fromRandGen ran = do + vec <- liftIO (fromSeed <$> save ran) + return $ S.runPut (S.put vec) + + +toRandGen :: (MonadIO m) => ByteString -> m GenIO +toRandGen bs = + case S.runGet S.get bs of + Left err -> error $ "Could not deserialise random generator. Error Message: " <> err + Right (vec :: V.Vector Word32) -> liftIO (restore $ toSeed vec) + + +loadParamSetup :: (MonadIO m) => Key Exp -> ReaderT SqlBackend m [ParameterSetting a1] +loadParamSetup kExp = + L.sortBy (compare `on` view parameterSettingName) . map (mkParameterSetting' . entityVal) <$> + E.select (E.from $ \pm -> E.where_ (pm E.^. ParamSettingExp E.==. E.val kExp) >> return pm) + where + mkParameterSetting' (ParamSetting _ n v b design) = ParameterSetting n v b (toEnum design) + +-- fromCount :: [E.Value Int] -> Int +-- fromCount = fromMaybe 0 . listToMaybe . fmap (\(E.Value v) -> v) + +loadPreparationInputCount :: (MonadIO m) => Key PrepResultData -> ReaderT SqlBackend m Int +loadPreparationInputCount kExpRes = count [PrepInputPrepResultData ==. kExpRes] + +loadPreparationInputWhere :: (MonadIO m, ExperimentDef a) => Key PrepResultData -> AvailabilityListWhere -> ConduitM () (Input a) (DB m) () +loadPreparationInputWhere kExpRes (PrepInputWhere where') = do + let src = + E.selectSource $ + E.from $ \(prepI, prepIV) -> do + E.where_ (prepI E.^. PrepInputId E.==. prepIV E.^. PrepInputValuePrepInput) + E.where_ (prepI E.^. PrepInputPrepResultData E.==. E.val kExpRes) + where' prepI prepIV + return (prepI, prepIV) + src C..| C.mapMC mkInput C..| sequenceC [] + -- sequence <$> mapM mkInput res + where + mkInput :: (MonadIO m, MonadLogger m, ExperimentDef a) => (Entity PrepInput, Entity PrepInputValue) -> m (Maybe (Input a)) + mkInput (Entity _ (PrepInput _ p), Entity _ (PrepInputValue _ v)) = do + v' <- deserialise "prep input value" v + return $ Input p <$> v' +loadPreparationInputWhere kExpRes GetAll = loadPreparationInputWhere kExpRes (PrepInputWhere (\_ _ -> return ())) +loadPreparationInputWhere _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where PrepInputWhere was expected" + + +sequenceC :: Monad m => [Maybe o] -> ConduitT (Maybe o) o m () +sequenceC xs = do + mx <- await + case mx of + Nothing -> CL.sourceList (fromMaybe [] $ sequence $ reverse xs) + Just x -> sequenceC (x:xs) + + +loadPrepartionMeasuresCount :: (MonadIO m) => Key PrepResultData -> DB m Int +loadPrepartionMeasuresCount kExpRes = count [PrepMeasurePrepResultData ==. kExpRes] + +-- loadPrepartionMeasures :: (MonadIO m) => Key PrepResultData -> ConduitT () Measure (DB m) () +-- loadPrepartionMeasures = loadPrepartionMeasuresWith (\_ _ -> return ()) + +loadPreparationMeasuresWhere :: (MonadIO m) => Key PrepResultData -> AvailabilityListWhere -> ConduitT () Measure (DB m) () +loadPreparationMeasuresWhere kExpRes (PrepMeasureWhere where') = do + let src = + E.selectSource $ + E.from $ \(prepM, prepRS) -> do + E.where_ (prepM E.^. PrepMeasureId E.==. prepRS E.^. PrepResultStepMeasure) + E.where_ (prepM E.^. PrepMeasurePrepResultData E.==. E.val kExpRes) + where' prepM prepRS + E.orderBy [E.asc (prepM E.^. PrepMeasurePeriod)] + return (prepM, prepRS) + src C..| C.mapC mkMeasure C..| CL.groupBy ((==) `on` view measurePeriod) C..| C.mapC combineMeasures + -- return $ map combineMeasures $ L.groupBy ((==) `on` view measurePeriod) $ map mkMeasure res + where + mkMeasure (Entity _ (PrepMeasure _ p), Entity _ (PrepResultStep _ n x y)) = Measure p [StepResult n x y] + combineMeasures xs@(Measure p _:_) = Measure p (concatMap (view measureResults) xs) + combineMeasures _ = error "not possible" +loadPreparationMeasuresWhere kExpRes GetAll = loadPreparationMeasuresWhere kExpRes (PrepMeasureWhere (\_ _ -> return ())) +loadPreparationMeasuresWhere _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where PrepMeasuresWhere was expected" + + +loadPreparationAggregateWhere :: (MonadIO m) => Key PrepResultData -> AggregateFunction -> AvailabilityListWhere -> DB m Double +loadPreparationAggregateWhere kExpRes agg (PrepMeasureWhere where') = + fmap (fromMaybe 0 . E.unValue . head) $ + E.select $ + E.from $ \(prepM, prepRS) -> do + E.where_ (prepM E.^. PrepMeasureId E.==. prepRS E.^. PrepResultStepMeasure) + E.where_ (prepM E.^. PrepMeasurePrepResultData E.==. E.val kExpRes) + where' prepM prepRS + return (agg $ prepRS E.^. PrepResultStepYValue) +loadPreparationAggregateWhere kExpRes agg GetAll = loadPreparationAggregateWhere kExpRes agg (PrepMeasureWhere (\_ _ -> return ())) +loadPreparationAggregateWhere _ _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where loadPreparationAggregateWhere was expected" + + +loadReplicationResults :: (ExperimentDef a) => Key Exp -> Key ExpResult -> DB (ExpM a) [ReplicationResult a] +loadReplicationResults expId kExpRes = do + xs <- selectList [RepResultExpResult ==. kExpRes] [Asc RepResultRepNr] + mapM (loadReplicationResult expId) xs + + +loadReplicationResult :: (ExperimentDef a) => Key Exp -> Entity RepResult -> DB (ExpM a) (ReplicationResult a) +loadReplicationResult expId (Entity k (RepResult _ repNr mWmUpResId mRepResId)) = do + !mWmUpRes <- fmap join $ sequence $ P.getEntity <$> mWmUpResId + !mRepRes <- fmap join $ sequence $ P.getEntity <$> mRepResId + !wmUp <- + case mWmUpRes of + Nothing -> return Nothing + Just eWmUp -> mkWmUp eWmUp + !rep <- + case mRepRes of + Nothing -> return Nothing + Just eRep -> mkRep eRep + return $!! ReplicationResult k repNr wmUp rep + where + mkWmUp (Entity wmUpResKey wmUpRes) = do + let wmUpStartTime = view warmUpResultDataStartTime wmUpRes + let wmUpEndTime = view warmUpResultDataEndTime wmUpRes + !wmUpStartRandGen <- toRandGen (view warmUpResultDataStartRandGen wmUpRes) + !wmUpEndRandGen <- maybe (return Nothing) (fmap Just . toRandGen) (view warmUpResultDataEndRandGen wmUpRes) + let !wmUpStartSt = AvailableOnDemand (loadResDataStartState expId (StartStateWarmUp wmUpResKey)) + let !wmUpEndSt = AvailableOnDemand (loadResDataEndState expId (EndStateWarmUp wmUpResKey)) + !mWmUpStartInpSt <- deserialise "warm up start input state" (view warmUpResultDataStartInputState wmUpRes) + !mWmUpEndInpSt <- mDeserialise "warm up end input state" (view warmUpResultDataEndInputState wmUpRes) + !wmUpInpValsCount <- loadReplicationWarmUpInputCount wmUpResKey + !wmUpMeasuresCount <- loadReplicationWarmUpMeasuresCount wmUpResKey + let !wmUpInpVals = AvailableListOnDemand (wmUpInpValsCount, loadReplicationWarmUpInputWhere wmUpResKey) + !wmUpMeasures = AvailableListOnDemand (wmUpMeasuresCount, loadReplicationWarmUpMeasuresWhere wmUpResKey) + return $! + ResultData (ResultDataWarmUp wmUpResKey) wmUpStartTime wmUpEndTime wmUpStartRandGen wmUpEndRandGen wmUpInpVals wmUpMeasures wmUpStartSt wmUpEndSt <$> mWmUpStartInpSt <*> + mWmUpEndInpSt + mkRep (Entity repResKey repRes) = do + let repStartTime = view repResultDataStartTime repRes + let repEndTime = view repResultDataEndTime repRes + !repStartRandGen <- toRandGen (view repResultDataStartRandGen repRes) + !repEndRandGen <- maybe (return Nothing) (fmap Just . toRandGen) (view repResultDataEndRandGen repRes) + !mRepStartInpSt <- deserialise "rep start input state" (view repResultDataStartInputState repRes) + !mRepEndInpSt <- mDeserialise "rep end input state" (view repResultDataEndInputState repRes) + !repInpValsCount <- loadReplicationInputCount repResKey + !repMeasuresCount <- loadReplicationMeasuresCount repResKey + let !repInpVals = AvailableListOnDemand (repInpValsCount, loadReplicationInputWhere repResKey) + !repMeasures = AvailableListOnDemand (repMeasuresCount, loadReplicationMeasuresWhere repResKey) + let !repStartSt = AvailableOnDemand (loadResDataStartState expId (StartStateRep repResKey)) + let !repEndSt = AvailableOnDemand (loadResDataEndState expId (EndStateRep repResKey)) + return $! + ResultData (ResultDataRep repResKey) repStartTime repEndTime repStartRandGen repEndRandGen repInpVals repMeasures repStartSt repEndSt <$> mRepStartInpSt <*> mRepEndInpSt + + +loadReplicationWarmUpInputCount :: (MonadIO m) => Key WarmUpResultData -> ReaderT SqlBackend m Int +loadReplicationWarmUpInputCount kExpRes = count [WarmUpInputRepResult ==. kExpRes] + + +loadReplicationWarmUpInputWhere :: (ExperimentDef a, MonadIO m) => Key WarmUpResultData -> AvailabilityListWhere -> ConduitT () (Input a) (DB m) () +loadReplicationWarmUpInputWhere kExpRes (WarmUpInputWhere where') = do + let src = + E.selectSource $ + E.from $ \(warmUpI, warmUpIV) -> do + E.where_ (warmUpI E.^. WarmUpInputId E.==. warmUpIV E.^. WarmUpInputValueWarmUpInput) + E.where_ (warmUpI E.^. WarmUpInputRepResult E.==. E.val kExpRes) + where' warmUpI warmUpIV + return (warmUpI, warmUpIV) + src C..| C.mapMC mkInput C..| sequenceC [] + -- sequence <$> mapM mkInput res + where + mkInput (Entity _ (WarmUpInput _ p), Entity _ (WarmUpInputValue _ v)) = do + v' <- deserialise "warm up input value" v + return $ Input p <$> v' +loadReplicationWarmUpInputWhere kExpRes GetAll = loadReplicationWarmUpInputWhere kExpRes (WarmUpInputWhere (\_ _ -> return ())) +loadReplicationWarmUpInputWhere _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where PrepInputWhere was expected" + + +loadReplicationWarmUpMeasuresCount :: (MonadIO m) => Key WarmUpResultData -> ReaderT SqlBackend m Int +loadReplicationWarmUpMeasuresCount kExpRes = count [WarmUpMeasureRepResult ==. kExpRes] + +loadReplicationWarmUpMeasuresWhere :: (MonadIO m) => Key WarmUpResultData -> AvailabilityListWhere -> ConduitM () Measure (DB m) () +loadReplicationWarmUpMeasuresWhere kExpRes (WarmUpMeasureWhere where') = do + let src = + E.selectSource $ + E.from $ \(warmUpM, warmUpRS) -> do + E.where_ (warmUpM E.^. WarmUpMeasureId E.==. warmUpRS E.^. WarmUpResultStepMeasure) + E.where_ (warmUpM E.^. WarmUpMeasureRepResult E.==. E.val kExpRes) + where' warmUpM warmUpRS + E.orderBy [E.asc (warmUpM E.^. WarmUpMeasurePeriod)] + return (warmUpM, warmUpRS) + src C..| C.mapC mkMeasure C..| CL.groupBy ((==) `on` view measurePeriod) C..| C.mapC combineMeasures + where + mkMeasure (Entity _ (WarmUpMeasure _ p), Entity _ (WarmUpResultStep _ n x y)) = Measure p [StepResult n x y] + combineMeasures xs@(Measure p _:_) = Measure p (concatMap (view measureResults) xs) + combineMeasures _ = error "not possible" +loadReplicationWarmUpMeasuresWhere kExpRes GetAll = loadReplicationWarmUpMeasuresWhere kExpRes (WarmUpMeasureWhere (\_ _ -> return ())) +loadReplicationWarmUpMeasuresWhere _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where PrepMeasuresWhere was expected" + +loadReplicationWarmUpAggregateWhere :: (MonadIO m) => Key WarmUpResultData -> AggregateFunction -> AvailabilityListWhere -> DB m Double +loadReplicationWarmUpAggregateWhere kExpRes agg (WarmUpMeasureWhere where') = + fmap (fromMaybe 0 . E.unValue . head) $ + E.select $ + E.from $ \(warmUpM, warmUpRS) -> do + E.where_ (warmUpM E.^. WarmUpMeasureId E.==. warmUpRS E.^. WarmUpResultStepMeasure) + E.where_ (warmUpM E.^. WarmUpMeasureRepResult E.==. E.val kExpRes) + where' warmUpM warmUpRS + return (agg $ warmUpRS E.^. WarmUpResultStepYValue) +loadReplicationWarmUpAggregateWhere kExpRes agg GetAll = loadReplicationWarmUpAggregateWhere kExpRes agg (WarmUpMeasureWhere (\_ _ -> return ())) +loadReplicationWarmUpAggregateWhere _ _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where loadReplicationWarmUpAggregateWhere was expected" + + +loadReplicationInputCount :: (MonadIO m) => Key RepResultData -> ReaderT SqlBackend m Int +loadReplicationInputCount kExpRes = count [RepInputRepResult ==. kExpRes] + +loadReplicationInputWhere :: (ExperimentDef a, MonadIO m) => Key RepResultData -> AvailabilityListWhere -> ConduitT () (Input a) (DB m) () +loadReplicationInputWhere kExpRes (RepInputWhere where') = do + let src = + E.selectSource $ + E.from $ \(repI, repIV) -> do + E.where_ (repI E.^. RepInputId E.==. repIV E.^. RepInputValueRepInput) + E.where_ (repI E.^. RepInputRepResult E.==. E.val kExpRes) + where' repI repIV + return (repI, repIV) + src C..| C.mapMC mkInput C..| sequenceC [] + -- sequence <$> mapM mkInput res + where + mkInput (Entity _ (RepInput _ p), Entity _ (RepInputValue _ v)) = do + v' <- deserialise "eval input value" v + return $ Input p <$> v' +loadReplicationInputWhere kExpRes GetAll = loadReplicationInputWhere kExpRes (RepInputWhere (\_ _ -> return ())) +loadReplicationInputWhere _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where RepInputWhere was expected" + + +loadReplicationMeasuresCount :: (MonadIO m) => Key RepResultData -> ReaderT SqlBackend m Int +loadReplicationMeasuresCount kExpRes = count [RepMeasureRepResult ==. kExpRes] + + +loadReplicationMeasuresWhere :: (MonadIO m) => Key RepResultData -> AvailabilityListWhere -> ConduitT () Measure (DB m) () +loadReplicationMeasuresWhere kExpRes (RepMeasureWhere where') = do + let src = + E.selectSource $ + E.from $ \(repM, repRS) -> do + E.where_ (repM E.^. RepMeasureId E.==. repRS E.^. RepResultStepMeasure) + E.where_ (repM E.^. RepMeasureRepResult E.==. E.val kExpRes) + where' repM repRS + E.orderBy [E.asc (repM E.^. RepMeasurePeriod)] + return (repM, repRS) + src C..| C.mapC mkMeasure C..| CL.groupBy ((==) `on` view measurePeriod) C..| C.mapC combineMeasures + where + mkMeasure (Entity _ (RepMeasure _ p), Entity _ (RepResultStep _ n x y)) = Measure p [StepResult n x y] + combineMeasures xs@(Measure p _:_) = Measure p (concatMap (view measureResults) xs) + combineMeasures _ = error "not possible" +loadReplicationMeasuresWhere kExpRes GetAll = loadReplicationMeasuresWhere kExpRes (RepMeasureWhere (\_ _ -> return ())) +loadReplicationMeasuresWhere _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where RepMeasuresWhere was expected" + + +loadReparationAggregateWhere :: (MonadIO m) => Key RepResultData -> AggregateFunction -> AvailabilityListWhere -> DB m Double +loadReparationAggregateWhere kExpRes agg (RepMeasureWhere where') = + fmap (fromMaybe 0 . E.unValue . head) $ + E.select $ + E.from $ \(repM, repRS) -> do + E.where_ (repM E.^. RepMeasureId E.==. repRS E.^. RepResultStepMeasure) + E.where_ (repM E.^. RepMeasureRepResult E.==. E.val kExpRes) + where' repM repRS + return (agg $ repRS E.^. RepResultStepYValue) +loadReparationAggregateWhere kExpRes agg GetAll = loadReparationAggregateWhere kExpRes agg (RepMeasureWhere (\_ _ -> return ())) +loadReparationAggregateWhere _ _ where' = error $ "Wrong Where clause: " ++ show where' ++ " where RepAggregateWhere was expected" + + +getOrCreateExps :: forall a . (ExperimentDef a) => ExperimentSetting -> InputState a -> a -> DB (ExpM a) (Entity Exps) +getOrCreateExps setup initInpSt initSt = do + let name = view experimentBaseName setup + expsList <- selectList [ExpsName ==. name] [] + expsInfoParams <- map (map entityVal) <$> mapM (\(Entity e _) -> selectList [ExpsInfoParamExps ==. e] []) expsList + let expsList' = map fst $ filter ((\xs -> length infoParams >= length xs && all matchesExpsInfoParam xs) . snd) (zip expsList expsInfoParams) + when (null expsList') $ $(logInfo) "No experiment with same Experiment Info Parameters found!" + exps <- + filterM + (\(Entity _ (Exps _ _ _ s iS)) -> do + serSt <- lift $ lift $ lift $ sequence $ deserialisable <$> runGet S.get s + let other = (,) <$> serSt <*> runGet S.get iS + when (isLeft other) $ $(logInfo) "Could not deserialise experiment with same name" + return $ fromEither False (equalExperiments (initSt, initInpSt) <$> other)) + expsList' + when (not (null expsList') && null exps) $ $(logInfo) "Found experiments with same name, but the are different or not deserialisable!" + params <- mapM (\e -> selectList [ParamExps ==. entityKey e] [Asc ParamName]) exps + let mkParamTpl (Param _ n _ _) = n + let ~myParams = L.sort $ map (mkParamTpl . convertParameterSetup (entityKey (head exps))) (parameters initSt) + case L.find ((== myParams) . L.sort . map (mkParamTpl . entityVal) . snd) (zip exps params) of + Nothing -> do + $(logInfo) "Starting new experiment..." + time <- liftIO getCurrentTime + !serInitSt <- lift $ lift $ lift $ serialisable initSt + eExp <- insertEntity $ Exps name time Nothing (runPut $ put serInitSt) (runPut $ put initInpSt) + void transactionSave + void $ insert $ mkExpSetup eExp + mapM_ (insertInfoParam (entityKey eExp)) infoParams + mapM_ (insertParam (entityKey eExp)) (parameters initSt) + return eExp + Just (eExp, _) -> do + $(logInfo) "Found experiment with same name and parameter settings. Continuing experiment ..." + expInfoParams <- map entityVal <$> selectList [ExpsInfoParamExps ==. entityKey eExp] [] + mapM_ (insertInfoParam (entityKey eExp)) (filter ((`notElem` map (view expsInfoParamName) expInfoParams) . infoParameterName) infoParams) + putMany [mkExpSetup eExp] + return eExp + where + mkExpSetup eExp = + ExpsSetup + (entityKey eExp) + (max 1 $ view experimentRepetitions setup) + (max 0 $ view preparationSteps setup) + (max 0 $ view evaluationWarmUpSteps setup) + (max 0 $ view evaluationSteps setup) + (max 1 $ view evaluationReplications setup) + (max 1 <$> view evaluationMaxStepsBetweenSaves setup) + insertInfoParam k (ExperimentInfoParameter n v) = insert $ ExpsInfoParam k n (S.runPut $ S.put v) + insertParam :: Key Exps -> ParameterSetup a -> DB (ExpM a) (Key Param) + insertParam eExp (ParameterSetup n _ _ _ (Just (minVal, maxVal)) _ _) = insert $ Param eExp n (Just $ runPut $ put minVal) (Just $ runPut $ put maxVal) + insertParam eExp (ParameterSetup n _ _ _ Nothing _ _) = insert $ Param eExp n Nothing Nothing + infoParams = view experimentInfoParameters setup + matchesExpsInfoParam (ExpsInfoParam _ n bs) = + case L.find ((== n) . infoParameterName) infoParams of + Nothing -> False + Just (ExperimentInfoParameter _ p) -> fromEither False ((p ==) <$> S.runGet S.get bs) diff --git a/src/Experimenter/Result/Type.hs b/src/Experimenter/Result/Type.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Result/Type.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Experimenter.Result.Type where + +import Experimenter.Availability +import Experimenter.Experiment +import Experimenter.Input +import Experimenter.Measure +import Experimenter.Models +import Experimenter.Parameter +import Experimenter.Setting + +import Control.DeepSeq +import Control.Lens +import qualified Data.Text as T +import Data.Time +import System.Random.MWC + + +phaseFromResultDataKey :: ResultDataKey -> Phase +phaseFromResultDataKey ResultDataPrep{} = PreparationPhase +phaseFromResultDataKey ResultDataWarmUp{} = WarmUpPhase +phaseFromResultDataKey ResultDataRep{} = EvaluationPhase + +data ResultDataKey + = ResultDataPrep !(Key PrepResultData) + | ResultDataWarmUp !(Key WarmUpResultData) + | ResultDataRep !(Key RepResultData) + deriving (Eq, Ord, Show) + +instance NFData ResultDataKey where + rnf (ResultDataPrep !_) = () + rnf (ResultDataWarmUp !_) = () + rnf (ResultDataRep !_) = () + + +data ResultData a = ResultData + { _resultDataKey :: !ResultDataKey + , _startTime :: !UTCTime + , _endTime :: !(Maybe UTCTime) + , _startRandGen :: !GenIO + , _endRandGen :: !(Maybe GenIO) + , _inputValues :: !(AvailabilityList (ExpM a) (Input a)) + , _results :: !(AvailabilityList (ExpM a) Measure) + , _startState :: !(Availability (ExpM a) a) + , _endState :: !(Availability (ExpM a) (Maybe a)) -- ^ state at end of run + , _startInputState :: !(InputState a) + , _endInputState :: !(Maybe (InputState a)) + } +makeLenses ''ResultData + +instance (ExperimentDef a) => NFData (ResultData a) where + rnf (ResultData !k st end !_ !_ !inpVal !res _ endSt !_ !_) = rnf k `seq` rnf st `seq` rnf end `seq` rnf inpVal `seq` rnf res `seq` rnf endSt -- `seq` rnf stSt + +data ReplicationResult a = ReplicationResult + { _replicationResultKey :: !(Key RepResult) + , _replicationNumber :: !Int + , _warmUpResults :: !(Maybe (ResultData a)) + , _evalResults :: !(Maybe (ResultData a)) + } +makeLenses ''ReplicationResult + +instance (ExperimentDef a) => NFData (ReplicationResult a) where + rnf (ReplicationResult !_ nr wm ev) = rnf nr `seq` rnf1 wm `seq` rnf1 ev + +data ExperimentResult a = ExperimentResult + { _experimentResultKey :: !(Key ExpResult) + , _repetitionNumber :: !Int + , _preparationResults :: !(Maybe (ResultData a)) + , _evaluationResults :: ![ReplicationResult a] + } +makeLenses ''ExperimentResult + +instance (ExperimentDef a) => NFData (ExperimentResult a) where + rnf (ExperimentResult !_ nr prep ev) = rnf nr `seq` rnf1 prep `seq` rnf1 ev + +data Experiment a = Experiment + { _experimentKey :: !(Key Exp) + , _experimentNumber :: !Int + , _experimentStartTime :: !UTCTime + , _experimentEndTime :: !(Maybe UTCTime) + , _parameterSetup :: ![ParameterSetting a] + , _experimentResults :: ![ExperimentResult a] + } +makeLenses ''Experiment + +instance (ExperimentDef a) => NFData (Experiment a) where + rnf (Experiment !_ nr stT endT setup res) = rnf nr `seq` rnf stT `seq` rnf1 endT `seq` rnf1 setup `seq` rnf1 res + + +data Experiments a = Experiments + { _experimentsKey :: !(Key Exps) + , _experimentsName :: !T.Text + , _experimentsStartTime :: !UTCTime + , _experimentsEndTime :: !(Maybe UTCTime) + , _experimentsSetup :: !ExpsSetup + , _experimentsParameters :: ![ParameterSetup a] + , _experimentsInfoParameters :: ![ExperimentInfoParameter] + , _experimentsInitialState :: !a -- ^ state at period 0 + , _experimentsInitialInputState :: !(InputState a) + , _experiments :: ![Experiment a] + } +makeLenses ''Experiments + +instance (ExperimentDef a) => NFData (Experiments a) where + rnf (Experiments !_ name ~stT !endT !_ !param !infoParams !initSt !initInp exps) = + rnf name `seq` rnf stT `seq` rnf endT `seq` map rwhnf param `seq` rnf1 infoParams `seq` rnf initSt `seq` rnf initInp `seq` rnf1 exps + +-- instance Serialize GenIO where +-- put g = put (show g) +-- get = do +-- gTxt <- get +-- return (read gTxt) diff --git a/src/Experimenter/Run.hs b/src/Experimenter/Run.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Run.hs @@ -0,0 +1,948 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Experimenter.Run + ( DatabaseSetting (..) + , MkExperimentSetting + , execExperiments + , runExperiments + , runExperimentsM + , runExperimentsIO + , loadExperimentsResultsM + , loadStateAfterPreparation + , loadStateAfterPreparation2 + ) where + +import Control.Arrow (first, (&&&), (***)) +import Control.Arrow (second) +import Control.Concurrent.MVar +import Control.DeepSeq +import Control.Lens +import Control.Monad.IO.Class +import Control.Monad.Logger (filterLogger, logDebug, logError, logInfo, + runStdoutLoggingT) +import Control.Monad.Reader +import qualified Data.ByteString as B +import Data.Function (on) +import Data.Int (Int64) +import Data.IORef +import Data.List (foldl') +import qualified Data.List as L +import Data.Maybe (fromJust, fromMaybe, isNothing) +import Data.Serialize hiding (get) +import qualified Data.Serialize as S +import qualified Data.Text as T +import Data.Time (addUTCTime, diffUTCTime, getCurrentTime) +import qualified Data.Vector as V +import Database.Persist.Postgresql +import GHC.Generics +import Network.HostName (getHostName) +import Prelude hiding (exp) +import System.IO +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Process +import System.Random.MWC + + +import Experimenter.Availability +import Experimenter.DatabaseSetting +import Experimenter.DB +import Experimenter.Experiment +import Experimenter.Input +import Experimenter.MasterSlave +import Experimenter.Measure +import Experimenter.Models +import Experimenter.Parameter +import Experimenter.Result +import Experimenter.Setting +import Experimenter.StepResult +import Experimenter.Util + + +type Updated = Bool +type InitialState a = a +type InitialInputState a = InputState a +type SkipPreparation = Bool +type Rands = ([Seed],[Seed],[Seed]) -- ^ Preparation, Warm Up and Evaluation random generators + +data Mode = Master | Slave + deriving (Eq, Show) + +execExperiments :: (ExperimentDef a) => (ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)) -> DatabaseSetting -> MkExperimentSetting a -> InputState a -> a -> IO (Experiments a) +execExperiments runExpM dbSetup setup initInpSt initSt = force . snd <$> runExperiments runExpM dbSetup setup initInpSt initSt + +-- | Run an experiment with non-monadic initial state. In case the initial state requires monadic effect (e.g. building +-- a Tensorflow model), use `runExperimentsM`! +runExperiments :: (ExperimentDef a) => (ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)) -> DatabaseSetting -> MkExperimentSetting a -> InputState a -> a -> IO (Bool, Experiments a) +runExperiments runExpM dbSetup setup initInpSt initSt = second force <$> runner runExpM dbSetup setup initInpSt (return initSt) + +runExperimentsM :: (ExperimentDef a) => (ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)) -> DatabaseSetting -> MkExperimentSetting a -> InputState a -> ExpM a a -> IO (Bool, Experiments a) +runExperimentsM = runner + +runExperimentsIO :: (ExperimentDef a, IO ~ ExpM a) => DatabaseSetting -> MkExperimentSetting a -> InputState a -> a -> IO (Bool, Experiments a) +runExperimentsIO dbSetup setup initInpSt initSt = runner id dbSetup setup initInpSt (return initSt) + +runner :: (ExperimentDef a) => (ExpM a (Bool, Experiments a) -> IO (Bool, Experiments a)) -> DatabaseSetting -> MkExperimentSetting a -> InputState a -> ExpM a a -> IO (Bool, Experiments a) +runner runExpM dbSetup setup initInpSt mkInitSt = + fmap (second force) $ do + runStdoutLoggingT $ withPostgresqlPool (connectionString dbSetup) (parallelConnections dbSetup) $ liftSqlPersistMPool $ runMigration migrateAll >> indexCreation + runExpM $ + runDB dbSetup $ do + initSt <- lift $ lift $ lift mkInitSt + $(logInfo) "Created initial state and will now check the DB for loading or creating experiments" + let expSetting = setup initSt + loadExperiments expSetting initInpSt initSt >>= checkUniqueParamNames >>= runExperimenter dbSetup expSetting initInpSt initSt + + +loadStateAfterPreparation2 :: + ExperimentDef a => (ExpM a b -> IO b) -> DatabaseSetting -> (a -> ExperimentSetting) -> InputState a -> ExpM a a -> Int -> Int -> (a -> ExpM a b) -> IO b +loadStateAfterPreparation2 runExpM dbSetup setup initInpSt mkInitSt expNr repNr runOnExperiments = do + runStdoutLoggingT $ withPostgresqlPool (connectionString dbSetup) (parallelConnections dbSetup) $ liftSqlPersistMPool $ runMigration migrateAll + runExpM $ runDB dbSetup $ do + initSt <- lift $ lift $ lift mkInitSt + $(logInfo) "Created initial state and will now check the DB for loading or creating experiments" + let expSetting = setup initSt + exps <- loadExperiments expSetting initInpSt initSt + let xs = exps ^.. experiments . traversed . filtered isExp . experimentResults . traversed . filtered isExpRep . preparationResults . traversed . endState + isExp x = x ^. experimentNumber == expNr + isExpRep x = x ^. repetitionNumber == repNr + fromAvailable (Available x) = x + fromAvailable _ = error "unexpected AvailableOnDemand in loadStateAfterPreparation" + borl <- fromAvailable <$> mkAvailable (head xs) + $(logInfo) "Made BORL available" + lift $ lift $ lift $ runOnExperiments (fromJust borl) + + +loadStateAfterPreparation :: (ExperimentDef a) => DatabaseSetting -> Int64 -> Int -> Int -> ExpM a (Maybe a) +loadStateAfterPreparation dbSetup expsId expNr _ = + runStdoutLoggingT $ + filterLogger (\s _ -> s /= "SQL") $ + withPostgresqlConn (connectionString dbSetup) $ \(backend :: SqlBackend) -> + flip runSqlConn backend $ do + (Entity expId _) <- fromMaybe (error "experiments not found") <$> selectFirst [ExpExps ==. toSqlKey expsId, ExpNumber ==. expNr] [] + (Entity _ expRes) <- fromMaybe (error "experiment not found") <$> selectFirst [ExpResultExp ==. expId] [] + case expRes ^. expResultPrepResultData of + Nothing -> return Nothing + Just prepResDataId -> do + parts' <- fmap (view prepEndStatePartData . entityVal) <$> selectList [PrepEndStatePartResultData ==. prepResDataId] [Asc PrepEndStatePartNumber] + if null parts' + then return Nothing + else do + !mSer <- lift $! deserialise (T.pack "end state") (B.concat parts') + !res <- lift $! lift $ maybe (return Nothing) (fmap Just . deserialisable) mSer + force <$!> traverse (setParams expId) res + +type OnlyFinishedExperiments = Bool + +loadExperimentsResultsM :: + (ExperimentDef a) + => OnlyFinishedExperiments + -> (ExpM a (Maybe (Experiments a)) -> IO (Maybe (Experiments a))) + -> DatabaseSetting + -> MkExperimentSetting a + -> InputState a + -> ExpM a a + -> Int64 + -> IO (Maybe (Experiments a)) +loadExperimentsResultsM filtFin runExpM dbSetup setup initInpSt mkInitSt key = + runExpM $ runDB dbSetup $ do + initSt <- lift $ lift $ lift mkInitSt + let sett = setup initSt + skipPrep exp' = any (^. parameterSettingSkipPreparationPhase) (exp' ^. parameterSetup) + isFinished exp' = + length (exp' ^. experimentResults) == sett ^. experimentRepetitions && -- repetitions + (skipPrep exp' || all (\expRes -> maybe 0 (lengthAvailabilityList . view results) (expRes ^. preparationResults) == sett ^. preparationSteps) (exp' ^. experimentResults)) && -- preparation length + all (\expRes -> length (expRes ^. evaluationResults) == sett ^. evaluationReplications) (exp' ^. experimentResults) && -- replications + all + (\expRes -> maybe 0 (lengthAvailabilityList . view results) (expRes ^. warmUpResults) == sett ^. evaluationWarmUpSteps) + (exp' ^. experimentResults . traversed . evaluationResults) && -- warm up length + all + (\expRes -> maybe 0 (lengthAvailabilityList . view results) (expRes ^. evalResults) == sett ^. evaluationSteps) + (exp' ^. experimentResults . traversed . evaluationResults) -- eval length + filterFinished = + over + experiments + (if filtFin + then filter isFinished + else id) + fmap filterFinished <$> loadExperimentsResults sett initInpSt initSt (toSqlKey key) + + +checkUniqueParamNames :: (Monad m) => Experiments a -> m (Experiments a) +checkUniqueParamNames exps = do + let paramNames = map parameterName (view experimentsParameters exps) + when (any ((> 1) . length) (L.group $ L.sort paramNames)) $ error $ "Parameter names must be unique! " ++ show (filter ((>1) . length) (L.group $ L.sort paramNames)) + return exps + + +runExperimenter :: (ExperimentDef a) => DatabaseSetting -> ExperimentSetting -> InputState a -> a -> Experiments a -> DB (ExpM a) (Bool, Experiments a) +runExperimenter dbSetup setup initInpSt initSt exps = do + !pid <- liftIO getProcessID + !hostName <- liftIO getHostName + !time <- liftIO getCurrentTime + deleteWhere [ExpsMasterLastAliveSign <=. addUTCTime (-2*keepAliveTimeout) time] + !maybeMaster <- insertUnique $ ExpsMaster (exps ^. experimentsKey) (T.pack hostName) (fromIntegral pid) time + transactionSave + case maybeMaster of + Just masterId -> do + !ref <- liftIO $ createKeepAliveFork dbSetup (\t -> update masterId [ExpsMasterLastAliveSign =. t]) (delete masterId) + $(logInfo) "Running in MASTER mode!" + !res <- runExperiment dbSetup Master exps + !waitResult <- waitForSlaves exps + if waitResult + then do + liftIO (writeIORef ref Finished) + exps' <- loadExperiments setup initInpSt initSt -- done, reload all data! + return (fst res, exps') + else delete masterId >> restartExperimenter -- slave died + Nothing -> do + $(logInfo) "Running in SLAVE mode!" + runExperiment dbSetup Slave exps + where + restartExperimenter = loadExperiments setup initInpSt initSt >>= runExperimenter dbSetup setup initInpSt initSt + +runExperiment :: (ExperimentDef a) => DatabaseSetting -> Mode -> Experiments a -> DB (ExpM a) (Bool, Experiments a) +runExperiment dbSetup mode exps = do + (anyChange, exps') <- continueExperiments dbSetup mode exps + if anyChange + then first (const True) <$> runExperiment dbSetup mode exps' + else return (anyChange, exps') + + +continueExperiments :: (ExperimentDef a) => DatabaseSetting -> Mode -> Experiments a -> DB (ExpM a) (Bool, Experiments a) +continueExperiments dbSetup mode exp = do + $(logInfo) $ "Processing set of experiments with ID " <> tshow (unSqlBackendKey $ unExpsKey $ exp ^. experimentsKey) + liftIO $ hFlush stdout + let exps = exp ^. experiments + if mode == Slave && null exps + then do + $(logInfo) "No experiments found and running in slave mode. Check whether the master has initialised the experiment yet!" + return (False, exp) + else do + printInfoParamSetup + rands <- liftIO $ mkRands exps + newExps <- + if mode == Slave + then return [] + else mkNewExps exp exps + let expsList = exps ++ newExps + $(logInfo) $ "Number of experiments loaded: " <> tshow (length exps) + $(logInfo) $ "Number of new experiments: " <> tshow (length newExps) + expRes <- mapM (continueExperiment dbSetup rands exp) expsList + let updated = any fst expRes + res = map snd expRes + if updated + then do + endT <- return <$> liftIO getCurrentTime + update (exp ^. experimentsKey) [ExpsEndTime =. endT] + return (updated, set experiments res $ set experimentsEndTime endT exp) + else return (updated, set experiments res exp) + where + printInfoParamSetup = do + $(logInfo) "------------------------------" + $(logInfo) "-- INFO PARAMETER SETUP --" + $(logInfo) "------------------------------" + if null (view experimentsInfoParameters exp) + then $(logDebug) "No info parameters set." + else mapM_ printInfoParam (view experimentsInfoParameters exp) + $(logInfo) "------------------------------" + printInfoParam (ExperimentInfoParameter p v) = $(logInfo) $ p <> ": " <> tshow v + mkRands :: [Experiment a] -> IO Rands + mkRands [] = do + prep <- replicateM repetits (createSystemRandom >>= save) + wmUp <- replicateM (repetits * replicats) (createSystemRandom >>= save) + repl <- replicateM (repetits * replicats) (createSystemRandom >>= save) + return (prep, wmUp, repl) + mkRands (x:_) = do + currentPrep <- mapM save (x ^.. experimentResults . traversed . preparationResults . traversed . startRandGen) + currentWmUp <- mapM save (x ^.. experimentResults . traversed . evaluationResults . traversed . warmUpResults . traversed . startRandGen) + currentRepl <- mapM save (x ^.. experimentResults . traversed . evaluationResults . traversed . evalResults . traversed . startRandGen) + prepNew <- replicateM (repetits - length currentPrep) (createSystemRandom >>= save) + wmUpNew <- replicateM (repetits * replicats - length currentWmUp) (createSystemRandom >>= save) + replNew <- replicateM (repetits * replicats - length currentRepl) (createSystemRandom >>= save) + return (currentPrep ++ prepNew, currentWmUp ++ wmUpNew, currentRepl ++ replNew) + repetits = exp ^. experimentsSetup . expsSetupRepetitions + replicats = exp ^. experimentsSetup . expsSetupEvaluationReplications + +saveParamSettings :: (MonadIO m) =>Key Exp -> [ParameterSetting a] -> DB m () +saveParamSettings kExp = mapM_ (\(ParameterSetting n bs drp design) -> insert $ ParamSetting kExp n bs drp (fromEnum design)) + + +initParams :: Experiments a -> [ParameterSetting a] +initParams exp = map (mkParamSetting exp) (view experimentsParameters exp) + where + mkParamSetting :: Experiments a -> ParameterSetup a -> ParameterSetting a + mkParamSetting exp' (ParameterSetup name _ getter _ _ drp design) = + let v = getter (exp' ^. experimentsInitialState) + in ParameterSetting name (runPut $ put $ getter (exp' ^. experimentsInitialState)) (maybe False (\x -> x v) drp) (maybe FullFactory (\x -> x v) design) + + +mkNoParamExp :: (ExperimentDef a) => Experiments a -> DB (ExpM a) [Experiment a] +mkNoParamExp exp = do + $(logInfo) "Initializing new experiment without any parameters..." + existing <- selectList [ExpExps ==. (exp ^. experimentsKey)] [] + if not (null existing) + then return [] + else do + startT <- liftIO getCurrentTime + kExp <- insert $ Exp (exp ^. experimentsKey) 1 startT Nothing + saveParamSettings kExp (initParams exp) + return [Experiment kExp 1 startT Nothing (initParams exp) []] + + +mkNewExps :: (ExperimentDef a) => Experiments a -> [Experiment a] -> DB (ExpM a) [Experiment a] +mkNewExps exp expsDone = do + $(logInfo) "Checking whether adding further experiments is necessary..." + let params = parameters (exp ^. experimentsInitialState) + if null params + then mkNoParamExp exp + else do + $(logInfo) "Creating new experiment variants" + startT <- liftIO getCurrentTime + let sortParamSettings = map (L.sortBy (compare `on` view parameterSettingName)) + existParamSettings <- sortParamSettings <$> existingParamSettings exp + -- $(logInfo) $ "Existing Parameter settings: " <> tshow (map (map showVal) $ map (\xs -> zip (L.sortBy (compare `on` parameterName) params) xs) existParamSettings) + paramSettings <- mapM (mkParamModifications exp) params + let paramCombs = combinations paramSettings + let paramSingleInstances = map (filter ((== SingleInstance) . view parameterSettingExperimentDesign)) paramSettings + let settings = filter (`notElem` existParamSettings) $ sortParamSettings $ foldl' mkSingleInstance paramCombs (concat paramSingleInstances) + mkSingleInstance combs param = + let occurrences = filter (param `elem`) combs + noOccurances = filter (param `notElem`) combs + in noOccurances ++ take 1 occurrences + let nrs = [1 + length expsDone .. length expsDone + length settings] + kExps <- mapM (\nr -> insert $ Exp (exp ^. experimentsKey) nr startT Nothing) nrs + zipWithM_ saveParamSettings kExps settings + let exps = zipWith3 (\key nr parms -> Experiment key nr startT Nothing parms []) kExps nrs settings + unless (null exps) $ $(logInfo) $ "Created " <> tshow (length exps) <> " new experiments variations!" + transactionSave + return exps + + +combinations :: [[a]] -> [[a]] +combinations [] = [] +combinations [xs] = map return xs +combinations (xs:xss) = concatMap (\x -> map (x:) ys) xs + where ys = combinations xss + + +mkParamModifications :: (MonadIO m) => Experiments a -> ParameterSetup a -> DB m [ParameterSetting a] +mkParamModifications exps setup@(ParameterSetup n _ getter _ _ drp design) = modifyParam setup [] (ParameterSetting n bs (maybe False (\x -> x v) drp) (maybe FullFactory (\x -> x v) design)) + where v = getter (exps ^. experimentsInitialState) + bs = runPut $ put v + +modifyParam :: (MonadIO m) => ParameterSetup a -> [ParameterSetting a] -> ParameterSetting a -> DB m [ParameterSetting a] +modifyParam (ParameterSetup _ _ _ Nothing _ _ _) !_ !sett = return [sett] +modifyParam setup@(ParameterSetup n _ _ (Just modifier) mBounds drp design) !acc !sett = do + case S.runGet S.get (view parameterSettingValue sett) of + Left err -> error $ "Could not deserialize a value for parameter " <> T.unpack n <> ". Cannot proceed! The error was: " <> err + Right val -> do + let filterBounds x = + case mBounds of + Nothing -> True + Just (minB, maxB) -> x <= maxB && x >= minB + filterExperimentDesign xs = concatMap filt' $ L.groupBy ((==) `on` fst) $ L.sortBy (compare `on` fst) xs + filt' xs@((v, _):_) = + case design of + Just dsgn + | dsgn v == SingleInstance -> take 1 xs + _ -> xs + filt' _ = error "Empty list in filt', e.g. in filtering of the experiments design, in modifyParam in Run.hs" + bss <- liftIO $ filterExperimentDesign . fmap (id &&& runPut . put) . filter filterBounds <$> modifier val + let params' = filter (`notElem` acc) $ map (\(v, bs) -> ParameterSetting n bs (maybe False (\x -> x v) drp) (maybe FullFactory (\x -> x v) design)) bss + foldM' (modifyParam setup) (acc ++ params') params' + + +existingParamSettings :: (ExperimentDef a, MonadIO m) => Experiments a -> DB m [[ParameterSetting a]] +existingParamSettings exp = do + let params = parameters (exp ^. experimentsInitialState) + expIds <- selectKeysList [ExpExps ==. exp ^. experimentsKey] [] + fmap (concatMap (toParameterSetting params . entityVal)) <$> mapM (\e -> selectList [ParamSettingExp ==. e] []) expIds + where + toParameterSetting params (ParamSetting _ n vBs drp dsgn) = + case L.find ((== n) . parameterName) params of + Nothing -> [] + _ -> [ParameterSetting n vBs drp (toEnum dsgn)] + +-- deleteExperiment :: (MonadIO m) => Experiment a -> DB m () +-- deleteExperiment (Experiment k _ _ _ _ expRes) = mapM_ deleteExperimentResult expRes >> deleteCascade k + + +deleteExperimentResult :: (MonadIO m) => ExperimentResult a -> DB m () +deleteExperimentResult (ExperimentResult k _ _ repls) = mapM_ deleteReplicationResult repls >> deleteCascade k + + +-- | Loads parameters of an experiment into all initial and end states of the given experiments variable. +loadParameters :: (ExperimentDef a) => Experiments a -> Experiment a -> DB (ExpM a) (Experiments a) +loadParameters exps exp = foldM' setParam exps (exp ^. parameterSetup) + where + setParam e (ParameterSetting n bs _ _) = + case L.find (\(ParameterSetup name _ _ _ _ _ _) -> name == n) parameterSetups of + Nothing -> do + $(logError) $ "Could not find parameter with name " <> n <> " in the current parameter setting. Thus it cannot be modified!" + return e + Just (ParameterSetup _ setter _ _ _ _ _) -> + case runGet S.get bs of + Left err -> error $ "Could not read value of parameter " <> T.unpack n <> ". Aborting! Serializtion error was: " ++ err + Right val -> do + $(logInfo) $ "Loaded parameter '" <> n <> "' value: " <> tshow val + return $ over experimentsInitialState (setter val) e + parameterSetups = parameters (exps ^. experimentsInitialState) + + +continueExperiment :: (ExperimentDef a) => DatabaseSetting -> Rands -> Experiments a -> Experiment a -> DB (ExpM a) (Updated, Experiment a) +continueExperiment dbSetup rands exps expIn = do + pid <- liftIO getProcessID + hostName <- liftIO getHostName + time <- liftIO getCurrentTime + deleteWhere [ExpExecutionLockLastAliveSign <=. addUTCTime (-2 * keepAliveTimeout) time] + maybeLocked <- insertUnique $ ExpExecutionLock expId (T.pack hostName) (fromIntegral pid) time + transactionSave + case maybeLocked of + Nothing -> do + $(logInfo) $ "Skipping experiment with ID " <> tshow (fromSqlKey expId) <> " as it is currently locked by another worker." + return (False, expIn) + Just lock -> do + expResults <- loadExperimentResults expId -- update data + let exp = set experimentResults expResults expIn + printParamSetup exp + $(logInfo) $ "Processing experiment with ID " <> tshow (fromSqlKey expId) <> "." + ref <- liftIO $ createKeepAliveFork dbSetup (\t -> update lock [ExpExecutionLockLastAliveSign =. t]) (delete lock) + liftIO (writeIORef ref Working) + exps' <- loadParameters exps exp -- loads parameters into the init state + $(logInfo) "Checking if new experiments repetitions can be created" + !expResList <- force <$> (getExpRes (exp ^. experimentResults) >>= truncateExperiments repetits) + $(logInfo) $ "Number of experiment repetition results loaded: " <> tshow (length expResList) + let skipPrep = any (^. parameterSettingSkipPreparationPhase) (exp ^. parameterSetup) + expRes <- force <$> mapM (runExperimentResult skipPrep rands exps' expId expNr) expResList + let updated = any fst expRes + res = map snd expRes + expRes `seq` liftIO (writeIORef ref Finished) + if updated + then do + eTime <- return <$> liftIO getCurrentTime + update (exp ^. experimentKey) [ExpEndTime =. eTime] + delete lock + return (updated, set experimentResults res $ set experimentEndTime eTime exp) + else delete lock >> return (updated, set experimentResults res exp) + where + printParamSetup exp = do + $(logInfo) "------------------------------" + $(logInfo) "-- LOADED PARAMETER SETUP --" + $(logInfo) "------------------------------" + if null (view parameterSetup expIn) + then $(logDebug) "No info parameters set." + else mapM_ (printParamSetting exps) (view parameterSetup exp) + $(logInfo) "------------------------------" + expNr = expIn ^. experimentNumber + expId = expIn ^. experimentKey + repetits = exps ^. experimentsSetup . expsSetupRepetitions + getExpRes :: (MonadIO m) => [ExperimentResult a] -> DB m [ExperimentResult a] + getExpRes expResDone = + (expResDone ++) <$> + forM + [length expResDone + 1 .. repetits] + (\nr -> do + kExpRes <- insert $ ExpResult expId nr Nothing + return $ ExperimentResult kExpRes nr Nothing []) + truncateExperiments nr xs = do + let dels = filter ((> nr) . view repetitionNumber) xs + unless (null dels) $ $(logInfo) $ "Number of experiment repetitions being deleted " <> tshow (length dels) + mapM_ deleteExperimentResult dels + unless (null dels) transactionSave + return $ filter ((<= nr) . view repetitionNumber) xs + +printParamSetting :: (ExperimentDef a) => Experiments a -> ParameterSetting a -> DB (ExpM a) () +printParamSetting exps (ParameterSetting n bs skipPrep expDes) = + case L.find ((== n) . parameterName) (exps ^. experimentsParameters) of + (Just (ParameterSetup _ setter _ _ _ _ _)) -> + case S.runGet S.get bs of + Left _ -> err + Right val -> do + let _ = setter val (exps ^. experimentsInitialState) -- only needed for type inference + $(logInfo) $ + n <> ": " <> tshow val <> + if skipPrep + then " [SkipPreparation] " + else "" <> + if expDes == SingleInstance + then " [SingleInstance] " + else "" + _ -> err + where + err = $(logInfo) $ n <> ": Could not deserialise value as this parameter does not exist anymore. Thus keeping it unchanged." + + +data RepResultType + = Prep !(Key ExpResult) + | WarmUp !(Key RepResult) + | Rep !(Key RepResult) + + +newResultData :: (ExperimentDef a) => Seed -> RepResultType -> a -> InputState a -> DB (ExpM a) (ResultData a) +newResultData seed repResType st inpSt = do + time <- liftIO getCurrentTime + k <- + case repResType of + Prep expResId -> do + serSt <- lift $ lift $ lift $ serialisable st + prepId <- insert (PrepResultData time Nothing (serialiseSeed seed) Nothing (runPut $ put inpSt) Nothing) + setResDataStartState (StartStatePrep prepId) (runPut $ put serSt) + update expResId [ExpResultPrepResultData =. Just prepId] + return $ ResultDataPrep prepId + WarmUp repResId -> do + serSt <- lift $ lift $ lift $ serialisable st + wmUpId <- insert (WarmUpResultData time Nothing (serialiseSeed seed) Nothing (runPut $ put inpSt) Nothing) + setResDataStartState (StartStateWarmUp wmUpId) (runPut $ put serSt) + update repResId [RepResultWarmUpResultData =. Just wmUpId] + return $ ResultDataWarmUp wmUpId + Rep repResId -> do + serSt <- lift $ lift $ lift $ serialisable st + repResDataId <- insert (RepResultData time Nothing (serialiseSeed seed) Nothing (runPut $ put inpSt) Nothing) + setResDataStartState (StartStateRep repResDataId) (runPut $ put serSt) + update repResId [RepResultRepResultData =. Just repResDataId] + return $ ResultDataRep repResDataId + let (fInp, fMeas) = (error "called Conduit for input on unsaved result data", error "called Conduit for measures on unsaved result data") + g <- liftIO $ restore seed + return $ ResultData k time Nothing g Nothing (AvailableList (0, []) fInp) (AvailableList (0, []) fMeas) (Available st) (Available Nothing) inpSt Nothing + + +runExperimentResult :: + (ExperimentDef a) + => SkipPreparation + -> Rands + -> Experiments a + -> Key Exp + -> ExperimentNumber + -> ExperimentResult a + -> DB (ExpM a) (Updated, ExperimentResult a) +runExperimentResult skipPrep rands@(prepRands, _, _) exps expId expNr expRes = do + let repetNr = expRes ^. repetitionNumber + let prepSeed = prepRands !! (repetNr - 1) + (prepInitSt, delPrep) <- + maybe (return (expInitSt, False)) (fmap (maybe (expInitSt, True) (, False)) . mkTransientlyAvailable) (expRes ^? preparationResults . traversed . endState) + (prepUpdated, prepRes) <- + if skipPrep + then do + $(logInfo) "Skipping preparation phase as provided by the parameter setting (skipPreparationPhase)." + return (False, Nothing) + else runPreparation prepSeed exps expId expResId (expNr, repetNr) delPrep prepInitSt (expRes ^. preparationResults) + repsDone <- + if prepUpdated + then do + mapM_ deleteReplicationResult (expRes ^. evaluationResults) + return [] + else return (expRes ^. evaluationResults) + transactionSave + mEndSt <- maybe (return Nothing) (mkTransientlyAvailable . view endState) prepRes + let initSt = fromMaybe expInitSt mEndSt + let initInpSt = fromMaybe (exps ^. experimentsInitialInputState) (view endInputState =<< prepRes) + let runRepl e repRess = do + res <- runReplicationResult rands e expId (expNr, repetNr) initSt initInpSt repRess + transactionSave + return res + repRes <- getRepRes exps repsDone >>= mapM (runRepl exps) + let updated = any fst repRes + res = map snd repRes + return (prepUpdated || updated, set preparationResults prepRes $ set evaluationResults res expRes) + where + expInitSt = exps ^. experimentsInitialState + expResId = expRes ^. experimentResultKey + getRepRes :: (MonadIO m) => Experiments a -> [ReplicationResult a] -> DB m [ReplicationResult a] + getRepRes exps' repsDone = do + $(logInfo) $ "Number of loaded replications: " <> tshow (length repsDone) + $(logInfo) $ "Number of new replications: " <> tshow (length [length repsDone + 1 .. exps ^. experimentsSetup . expsSetupEvaluationReplications]) + (repsDone ++) <$> + forM + [length repsDone + 1 .. exps' ^. experimentsSetup . expsSetupEvaluationReplications] + (\nr -> do + kRepRes <- insert $ RepResult (expRes ^. experimentResultKey) nr Nothing Nothing + return $ ReplicationResult kRepRes nr Nothing Nothing) + + +runPreparation :: + (ExperimentDef a) + => Seed + -> Experiments a + -> Key Exp + -> Key ExpResult + -> (ExperimentNumber, RepetitionNumber) + -> Bool + -> a + -> Maybe (ResultData a) + -> DB (ExpM a) (Updated, Maybe (ResultData a)) +runPreparation seed exps expId expResId (expNr, repetNr) prepDelNeeded prepInitSt mResData = do + g <- liftIO $ restore seed + initSt <- lift $ lift $ lift $ beforePreparationHook expNr repetNr g prepInitSt + let len = maybe 0 (lengthAvailabilityList . view results) mResData + mResData' <- + if delNeeded len + then deleteResultData (Prep expResId) >> return Nothing + else return mResData + when (len > 0 && delNeeded len) $ $(logInfo) $ "Deletion of preparation data needed. Len: " <> tshow len + when (runNeeded len) $ $(logInfo) "Preparation run is needed" + when (not (delNeeded len) && not (runNeeded len) && prepSteps > 0) $ $(logInfo) "preparation phase needs no change" + if runNeeded len + then do + res <- maybe (new initSt) return mResData' >>= run' len + liftIO $ afterPreparationHook initSt expNr repetNr + return res + else return (delNeeded len || runNeeded len, mResData') + where + delNeeded len = prepDelNeeded || maybe False (\_ -> prepSteps < len) mResData + runNeeded len = maybe (prepSteps > 0) (\_ -> prepSteps > len || (delNeeded len && prepSteps > 0)) mResData + prepSteps = exps ^. experimentsSetup . expsSetupPreparationSteps + maxSteps = exps ^. experimentsSetup . expsSetupEvaluationMaxStepsBetweenSaves + initInpSt = exps ^. experimentsInitialInputState + new initSt = newResultData seed (Prep expResId) initSt initInpSt + run' len rD = ((delNeeded len ||) *** Just) <$> runResultData expId maxSteps prepSteps (Prep expResId) rD + + +runReplicationResult :: + (ExperimentDef a) + => Rands + -> Experiments a + -> Key Exp + -> (ExperimentNumber, RepetitionNumber) + -> InitialState a + -> InitialInputState a + -> ReplicationResult a + -> DB (ExpM a) (Updated, ReplicationResult a) +runReplicationResult (_, wmUpRands, replRands) exps expId (expNr, repetNr) initSt initInpSt repRes = do + let repliNr = repRes ^. replicationNumber + let randGenIdx = (repetNr - 1) * replicats + (repliNr - 1) + let wmUpRand = wmUpRands !! randGenIdx + let repRand = replRands !! randGenIdx + $(logInfo) $ "Running replication " <> tshow repliNr <> " for experiment repetition " <> tshow repetNr + (wmUpChange, mWmUp) <- runWarmUp wmUpRand exps expId (repRes ^. replicationResultKey) (expNr, repetNr, repliNr) initSt initInpSt (repRes ^. warmUpResults) + initStEval <- maybe (return initSt) (fmap (fromMaybe initSt) . mkTransientlyAvailable . view endState) mWmUp + let initInpStEval = fromMaybe initInpSt (view endInputState =<< mWmUp) + mEval <- + if wmUpChange + then deleteResultData (Rep repResId) >> return Nothing + else return (repRes ^. evalResults) + (evalChange, mEval') <- runEval repRand exps expId wmUpChange (repRes ^. replicationResultKey) (expNr, repetNr, repliNr) initStEval initInpStEval mEval + return (wmUpChange || evalChange, set warmUpResults mWmUp $ set evalResults mEval' repRes) + where + !repResId = repRes ^. replicationResultKey + !replicats = exps ^. experimentsSetup . expsSetupEvaluationReplications + + +runWarmUp :: + (ExperimentDef a) + => Seed + -> Experiments a + -> Key Exp + -> Key RepResult + -> (ExperimentNumber, RepetitionNumber, ReplicationNumber) + -> InitialState a + -> InitialInputState a + -> Maybe (ResultData a) + -> DB (ExpM a) (Updated, Maybe (ResultData a)) +runWarmUp seed exps expId repResId (expNr, repetNr, repliNr) initSt initInpSt mResData = do + !g <- liftIO $ restore seed + !initStWmUp <- lift $ lift $ lift $ beforeWarmUpHook expNr repetNr repliNr g initSt + let len = maybe 0 (lengthAvailabilityList . view results) mResData + when (len > 0 && delNeeded len) $ $(logInfo) "Deletion of warm up data needed" + when (runNeeded len) $ $(logInfo) "Warm up run is needed" + when (not (delNeeded len) && not (runNeeded len) && wmUpSteps > 0) $ $(logInfo) "Warm up phase needs no change" + !mResData' <- + if delNeeded len + then deleteResultData (WarmUp repResId) >> return Nothing + else return mResData + if runNeeded len + then do + !res <- maybe (new initStWmUp) return mResData' >>= run' len + liftIO $ afterWarmUpHook initSt expNr repetNr repliNr + return res + else do + when (delNeeded len) $ $(logInfo) "Deleted warm up data." + return (delNeeded len, mResData') + where + delNeeded len = maybe False (\_ -> wmUpSteps < len) mResData -- || maybe False ((>0) . lengthAvailabilityList) (mResData ^? traversed.results) + runNeeded len = maybe (wmUpSteps > 0) (\_ -> wmUpSteps > len || (delNeeded len && wmUpSteps > 0)) mResData + !wmUpSteps = exps ^. experimentsSetup . expsSetupEvaluationWarmUpSteps + !maxSteps = exps ^. experimentsSetup . expsSetupEvaluationMaxStepsBetweenSaves + new !initStWmUp = newResultData seed (WarmUp repResId) initStWmUp initInpSt + run' !len !rD = ((delNeeded len ||) *** Just) <$> runResultData expId maxSteps wmUpSteps (WarmUp repResId) rD + + +runEval :: + (ExperimentDef a) + => Seed + -> Experiments a + -> Key Exp + -> Updated + -> Key RepResult + -> (ExperimentNumber, RepetitionNumber, ReplicationNumber) + -> InitialState a + -> InitialInputState a + -> Maybe (ResultData a) + -> DB (ExpM a) (Updated, Maybe (ResultData a)) +runEval seed exps expId warmUpUpdated repResId (expNr, repetNr, repliNr) initSt initInpSt mResData = do + !g <- liftIO $ restore seed + !initStEval <- lift $ lift $ lift $ beforeEvaluationHook expNr repetNr repliNr g initSt + let len = maybe 0 (lengthAvailabilityList . view results) mResData + !mResData' <- + if delNeeded len + then deleteResultData (Rep repResId) >> return Nothing + else return mResData + when (len > 0 && delNeeded len) $ $(logInfo) "Deletion of evaluation data needed" + when (runNeeded len) $ $(logInfo) "Evaluation run is needed" + when (not (delNeeded len) && not (runNeeded len) && evalSteps > 0) $ $(logInfo) "Evaluation phase needs no change" + if runNeeded len + then do + $(logInfo) $ "An evaluation run is needed for replication with ID " <> tshow (unSqlBackendKey $ unRepResultKey repResId) + !res <- maybe (new initStEval) return mResData' >>= run' len + liftIO $ afterEvaluationHook initSt expNr repetNr repliNr + return res + else do + $(logInfo) $ "No evaluation run needed for replication with ID " <> tshow (unSqlBackendKey $ unRepResultKey repResId) <> ". All needed data comes from the DB!" + return (delNeeded len, mResData') + where + delNeeded len = warmUpUpdated || maybe False (\_ -> evalSteps < len) mResData + runNeeded len = maybe (evalSteps > 0) (\_ -> evalSteps > len || (delNeeded len && evalSteps > 0)) mResData + !evalSteps = exps ^. experimentsSetup . expsSetupEvaluationSteps + !maxSteps = exps ^. experimentsSetup . expsSetupEvaluationMaxStepsBetweenSaves + new initStEval = newResultData seed (Rep repResId) initStEval initInpSt + run' !len !rD = ((delNeeded len ||) *** Just) <$> runResultData expId maxSteps evalSteps (Rep repResId) rD + + +deleteReplicationResult :: (MonadIO m) => ReplicationResult a -> DB m () +deleteReplicationResult (ReplicationResult repResId _ _ _) = + deleteResultData (WarmUp repResId) >> + deleteResultData (Rep repResId) >> + deleteCascade repResId + + +deleteResultData :: (MonadIO m) => RepResultType -> DB m () +deleteResultData repResType = do + case repResType of + Prep expResId -> do + update expResId [ExpResultPrepResultData =. Nothing] + exp <- get expResId + sequence_ $ deleteCascade <$> (view expResultPrepResultData =<< exp) + WarmUp repResId -> do + update repResId [RepResultWarmUpResultData =. Nothing] + repRes <- get repResId + sequence_ $ deleteCascade <$> (view repResultWarmUpResultData =<< repRes) + Rep repResId -> do + update repResId [RepResultRepResultData =. Nothing] + repRes <- get repResId + sequence_ $ deleteCascade <$> (view repResultRepResultData =<< repRes) + +foldM' :: (NFData a, Monad m) => (a -> b -> m a) -> a -> [b] -> m a +foldM' _ !acc [] = return acc +foldM' f !acc (x:xs) = do + (force -> acc') <- f acc x + foldM' f acc' xs + + +splitSizeMVar :: MVar Int +splitSizeMVar = unsafePerformIO $ newMVar 2000 +{-# NOINLINE splitSizeMVar #-} + +increaseSplitSize :: IO () +increaseSplitSize = liftIO $ modifyMVar_ splitSizeMVar (return . min 128000 . (*2)) + +decreaseSplitSize :: IO () +decreaseSplitSize = liftIO $ modifyMVar_ splitSizeMVar (return . max 500 . (`div` 2)) + +getSplitSize :: IO Int +getSplitSize = liftIO $ fromMaybe 5000 <$> tryReadMVar splitSizeMVar + + +data RunData a = + RunData + -- GenIO, a, InputState a, [Input a], [Measure]) + { dataRandG :: !GenIO + , dataState :: !a + , dataInpState :: !(InputState a) + , dataInputs :: !(V.Vector (Input a)) + , dataMeasures :: !(V.Vector Measure) + } deriving (Generic) + +instance (ExperimentDef a) => NFData (RunData a) where + rnf (RunData !_ st inpSt inps meas) = rnf st `seq` rnf inpSt `seq` rnf inps `seq` rnf meas + +-- | We need to sepearte @runResultData@ into two functions, as a simple recursive structure causes a space leak if it is not in IO. See +-- https://stackoverflow.com/questions/41306593/memory-leak-in-recursive-io-function-pap +-- https://ro-che.info/articles/2017-01-10-nested-loop-space-leak +-- https://gitlab.haskell.org/ghc/ghc/-/issues/13080 +runResultData :: (ExperimentDef a) => Key Exp -> Maybe Int -> Int -> RepResultType -> ResultData a -> DB (ExpM a) (Updated, ResultData a) +runResultData !expId !maxSteps !len !repResType !resData = do + (!done, !upd, !resData') <- runResultData' expId maxSteps len repResType resData + if done + then return (upd, resData') + else runResultData expId maxSteps len repResType resData' +{-# NOINLINE runResultData #-} +{-# NOINLINE runResultData' #-} + +-- | Wrapper due to GHC Bug. See @runResultData@. +runResultData' :: (ExperimentDef a) => Key Exp -> Maybe Int -> Int -> RepResultType -> ResultData a -> DB (ExpM a) (Bool, Updated, ResultData a) +runResultData' !expId !maxSteps !len !repResType !resData = do + startStAvail <- + (if isNew + then mkAvailable + else return) + (resData ^. startState) + st <- mkTransientlyAvailable (resData ^. endState) >>= maybe (mkTransientlyAvailable startStAvail) return + let stInp = fromMaybe (resData ^. startInputState) (resData ^. endInputState) + let g = fromMaybe (resData ^. startRandGen) (resData ^. endRandGen) + splitPeriods <- maybe (liftIO getSplitSize) return maxSteps + let nrOfPeriodsToRun = min splitPeriods (len - curLen) + periodsToRun = map (+ curLen) [1 .. nrOfPeriodsToRun] + printInfo = splitPeriods > 100 || any (\p -> (p - 1) `mod` 100 == 0) periodsToRun + when printInfo $ $(logInfo) $ "Number of steps already run is " <> tshow curLen <> ", thus still need to run " <> tshow (len - curLen) <> " steps." + let updated = not (null periodsToRun) + sTime <- liftIO getCurrentTime + let phase = phaseFromResultDataKey (resData ^. resultDataKey) + phaseNr = fromEnum phase + void $ upsertBy (UniqueExpProgress expId) (ExpProgress expId phaseNr curLen) [ExpProgressPhase =. phaseNr, ExpProgressStep =. curLen] + !(RunData g' st' stInp' inputs measures) <- foldM' (run phase) (RunData g st stInp V.empty V.empty) periodsToRun + when updated $ void $ + upsertBy (UniqueExpProgress expId) (ExpProgress expId phaseNr (curLen + nrOfPeriodsToRun)) [ExpProgressPhase =. phaseNr, ExpProgressStep =. curLen + nrOfPeriodsToRun] + if updated + then do + eTime <- pure <$> liftIO getCurrentTime + sTime' <- liftIO getCurrentTime + !resData' <- + addInputValsAndMeasure (V.reverse inputs) (V.reverse measures) $ doIf isNew (set startTime sTime) $ set endInputState (Just stInp') $ set endState (Available $ Just st') $ + doIf isNew (set startState startStAvail) $ -- make available once for saving + set endRandGen (Just g') $ + set endTime eTime resData + upd repResType resData' + transactionSave + eTime' <- liftIO getCurrentTime + let runTime = diffUTCTime (fromJust eTime) sTime + saveTime = diffUTCTime eTime' sTime' + when (isNothing maxSteps && nrOfPeriodsToRun == splitPeriods) $ liftIO $ do + when (runTime < 60 * max 5 saveTime) increaseSplitSize + when (runTime > 120 * max 5 saveTime) decreaseSplitSize + when printInfo $ $(logInfo) $ "Done and saved. Computation Time of " <> tshow (length periodsToRun) <> ": " <> tshow runTime <> ". Saving Time: " <> tshow saveTime + if len - curLen - length periodsToRun > 0 + then return (False, True, force resData') -- runResultData expId maxSteps len repResType (force resData') + else return $! (True, True, set endState mkEndStateAvailableOnDemand $ set startState mkStartStateAvailableOnDemand resData') + else return (True, False, force $ set endState mkEndStateAvailableOnDemand $ set startState mkStartStateAvailableOnDemand resData) + where + doIf predicate ~f + | predicate = f + | otherwise = id + curLen = lengthAvailabilityList (resData ^. results) + delInputs = lengthAvailabilityList (resData ^. results) - lengthAvailabilityList (resData ^. inputValues) > 0 + isNew = curLen == 0 + mkStartStateAvailableOnDemand = + case resData ^. resultDataKey of + ResultDataPrep key -> AvailableOnDemand $ loadResDataStartState expId (StartStatePrep key) + ResultDataWarmUp key -> AvailableOnDemand $ loadResDataStartState expId (StartStateWarmUp key) + ResultDataRep key -> AvailableOnDemand $ loadResDataStartState expId (StartStateRep key) + mkEndStateAvailableOnDemand = + case resData ^. resultDataKey of + ResultDataPrep key -> AvailableOnDemand $ loadResDataEndState expId (EndStatePrep key) + ResultDataWarmUp key -> AvailableOnDemand $ loadResDataEndState expId (EndStateWarmUp key) + ResultDataRep key -> AvailableOnDemand $ loadResDataEndState expId (EndStateRep key) + addInputValsAndMeasure !inputVals !measures !resData' = + let countResults' = lengthAvailabilityList (resData' ^. results) + V.length measures + countInputValues' = lengthAvailabilityList (resData' ^. inputValues) + V.length inputVals + measuresList = V.toList measures + inputValsList = V.toList inputVals + in case resData' ^. resultDataKey of + ResultDataPrep key -> do + when delInputs $ deleteCascadeWhere [PrepInputPrepResultData ==. key, PrepInputPeriod >=. curLen + 1] + inpKeys <- insertMany $ map (PrepInput key . view inputValuePeriod) inputValsList + insertMany_ $ zipWith (\k v -> PrepInputValue k (runPut . put . view inputValue $ v)) inpKeys inputValsList + measureKeys <- insertMany . map (PrepMeasure key . view measurePeriod) $ measuresList + insertMany_ $ concat $ zipWith (\k (Measure _ xs) -> map (\(StepResult n mX y) -> PrepResultStep k n mX y) xs) measureKeys measuresList + return $! results .~ AvailableListOnDemand (countResults', loadPreparationMeasuresWhere key) $ inputValues .~ + AvailableListOnDemand (countInputValues', loadPreparationInputWhere key) $ + resData' + ResultDataWarmUp key -> do + when delInputs $ deleteCascadeWhere [WarmUpInputRepResult ==. key, WarmUpInputPeriod >=. curLen + 1] + inpKeys <- insertMany $ map (WarmUpInput key . view inputValuePeriod) inputValsList + insertMany_ $ zipWith (\k v -> WarmUpInputValue k (runPut . put . view inputValue $ v)) inpKeys inputValsList + measureKeys <- insertMany $ map (WarmUpMeasure key . view measurePeriod) measuresList + insertMany_ $ concat $ zipWith (\k (Measure _ xs) -> map (\(StepResult n mX y) -> WarmUpResultStep k n mX y) xs) measureKeys measuresList + return $! results .~ AvailableListOnDemand (countResults', loadReplicationWarmUpMeasuresWhere key) $ inputValues .~ + AvailableListOnDemand (countInputValues', loadReplicationWarmUpInputWhere key) $ + resData' + ResultDataRep key -> do + when delInputs $ deleteCascadeWhere [RepInputRepResult ==. key, RepInputPeriod >=. curLen + 1] + inpKeys <- insertMany $ map (RepInput key . view inputValuePeriod) inputValsList + insertMany_ $ zipWith (\k v -> RepInputValue k (runPut . put . view inputValue $ v)) inpKeys inputValsList + measureKeys <- insertMany $ map (RepMeasure key . view measurePeriod) measuresList + insertMany_ $ concat $ zipWith (\k (Measure _ xs) -> map (\(StepResult n mX y) -> RepResultStep k n mX y) xs) measureKeys measuresList + return $! results .~ AvailableListOnDemand (countResults', loadReplicationMeasuresWhere key) $ inputValues .~ + AvailableListOnDemand (countInputValues', loadReplicationInputWhere key) $ + resData' + upd :: (ExperimentDef a) => RepResultType -> ResultData a -> DB (ExpM a) () + upd Prep{} (ResultData (ResultDataPrep k) sTime eTime sG eG !_ !_ sSt eSt sInpSt eInpSt) = do + !sGBS <- liftIO $ fromRandGen sG + !eGBS <- liftIO $ maybe (return Nothing) (fmap Just . fromRandGen) eG + update + k + [ PrepResultDataStartTime =. sTime + , PrepResultDataEndTime =. eTime + , PrepResultDataStartRandGen =. sGBS + , PrepResultDataEndRandGen =. eGBS + , PrepResultDataStartInputState =. runPut (put sInpSt) + , PrepResultDataEndInputState =. runPut . put <$> eInpSt + ] + when (curLen == 0) $ do + ~serSt <- mkTransientlyAvailable sSt >>= lift . lift . lift . serialisable + setResDataStartState (StartStatePrep k) (runPut $ put serSt) + !serESt <- mkTransientlyAvailable eSt >>= lift . lift . lift . traverse serialisable + setResDataEndState (EndStatePrep k) (runPut . put <$> serESt) + upd WarmUp{} (ResultData (ResultDataWarmUp k) sTime eTime sG eG !_ !_ sSt eSt sInpSt eInpSt) = do + !sGBS <- liftIO $ fromRandGen sG + !eGBS <- liftIO $ maybe (return Nothing) (fmap Just . fromRandGen) eG + update + k + [ WarmUpResultDataStartTime =. sTime + , WarmUpResultDataEndTime =. eTime + , WarmUpResultDataStartRandGen =. sGBS + , WarmUpResultDataEndRandGen =. eGBS + , WarmUpResultDataStartInputState =. runPut (put sInpSt) + , WarmUpResultDataEndInputState =. runPut . put <$> eInpSt + ] + when (curLen == 0) $ do + ~serSt <- mkTransientlyAvailable sSt >>= lift . lift . lift . serialisable + setResDataStartState (StartStateWarmUp k) (runPut $ put serSt) + !serESt <- mkTransientlyAvailable eSt >>= lift . lift . lift . traverse serialisable + setResDataEndState (EndStateWarmUp k) (runPut . put <$> serESt) + upd Rep{} (ResultData (ResultDataRep k) sTime eTime sG eG !_ !_ sSt eSt sInpSt eInpSt) = do + !sGBS <- liftIO $ fromRandGen sG + !eGBS <- liftIO $ maybe (return Nothing) (fmap Just . fromRandGen) eG + update + k + [ RepResultDataStartTime =. sTime + , RepResultDataEndTime =. eTime + , RepResultDataStartRandGen =. sGBS + , RepResultDataEndRandGen =. eGBS + , RepResultDataStartInputState =. runPut (put sInpSt) + , RepResultDataEndInputState =. runPut . put <$> eInpSt + ] + when (curLen == 0) $ do + ~serSt <- mkTransientlyAvailable sSt >>= lift . lift . lift . serialisable + setResDataStartState (StartStateRep k) (runPut $ put serSt) + !serESt <- mkTransientlyAvailable eSt >>= lift . lift . lift . traverse serialisable + setResDataEndState (EndStateRep k) (runPut . put <$> serESt) + upd _ _ = error "Unexpected update combination. This is a bug, please report it!" + + +run :: (ExperimentDef a) => Phase -> RunData a -> Int -> DB (ExpM a) (RunData a) +run ph (RunData g st stInp inpVals res) period = do + -- let (randGen, g') = split g + (!inpVal', !inpSt') <- lift $! lift $! lift $! generateInput g st stInp period + (!res', !st') <- lift $! lift $! lift $! runStep ph st inpVal' period + return $! force $! RunData g st' inpSt' (Input period inpVal' `V.cons` inpVals) (Measure period res' `V.cons` res) diff --git a/src/Experimenter/Setting.hs b/src/Experimenter/Setting.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Setting.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TemplateHaskell #-} +module Experimenter.Setting where + +import Control.DeepSeq +import Control.Lens +import Data.Serialize +import qualified Data.Text as T +import GHC.Generics + + +-- ^ ExperimentInfoParameters can be used to separate experiments from each other. These parameters will be shown in the +-- evaluation output. E.g. testing different feature extraction settings. +data ExperimentInfoParameter = + forall b. (Show b, Eq b, Serialize b) => + ExperimentInfoParameter + { infoParameterName :: !T.Text + , infoParameter :: !b + } + +instance NFData ExperimentInfoParameter where + rnf (ExperimentInfoParameter t !_) = rnf t + + +-- ^ Creating an experiment setting with the input state as parameter. This allows dynamically setting values. +type MkExperimentSetting a = a -> ExperimentSetting + +data ExperimentSetting = ExperimentSetting + { _experimentBaseName :: !T.Text -- ^ Base name of experiment. + , _experimentInfoParameters :: ![ExperimentInfoParameter] -- ^ List of information parameters defining the experiment. Adding more information does not effect equality. Thus, this is only used + -- as information on the report. + , _experimentRepetitions :: !Int -- ^ Repetitions of each experiment (>=1). + , _preparationSteps :: !Int -- ^ Preparation phase length (e.g. learning phase) (>=0). + , _evaluationWarmUpSteps :: !Int -- ^ Warm up phase length before each evaluation of each experiment (>=0). + , _evaluationSteps :: !Int -- ^ Evaluation phase length (>=0). + , _evaluationReplications :: !Int -- ^ Replications of evaluation for each experiment (>=1). + , _evaluationMaxStepsBetweenSaves :: !(Maybe Int) -- ^ Maximum number of steps to take until the data is saved. If nothing then something between 500 and 50000 will be used, depending on the time + -- required for saving and running. Setting a value may slow down the execution, but limits the memory requirement tremendously. + } deriving (Generic, NFData) +makeLenses ''ExperimentSetting diff --git a/src/Experimenter/State.hs b/src/Experimenter/State.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/State.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +module Experimenter.State where + +import Data.Aeson +import Database.Persist.TH +import GHC.Generics + +data ExperimentState = InProgress | Finished + deriving (Show, Read, Eq, ToJSON, FromJSON, Generic) + +derivePersistField "ExperimentState" diff --git a/src/Experimenter/StepResult.hs b/src/Experimenter/StepResult.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/StepResult.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +module Experimenter.StepResult where + +import Control.DeepSeq +import Control.Lens +import qualified Data.Text as T +import GHC.Generics + +data StepResult = StepResult + { _resultName :: !T.Text + , _resultXValue :: !(Maybe Double) -- ^ If not specified number of steps + , _resultYValue :: !Double + } deriving (Generic) +makeLenses ''StepResult + + +instance NFData StepResult where + rnf (StepResult n x y) = rnf n `seq` rnf1 x `seq` rnf y diff --git a/src/Experimenter/Util.hs b/src/Experimenter/Util.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Util.hs @@ -0,0 +1,16 @@ +module Experimenter.Util where + +import qualified Data.Text as T + + +tshow :: (Show a) => a -> T.Text +tshow = T.pack . show + + +tread :: (Read a) => T.Text -> a +tread = read . T.unpack + + +fromEither :: b -> Either a b -> b +fromEither def Left{} = def +fromEither _ (Right b) = b diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +-- file test/Spec.hs +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TestExperimenter/Serialise/Instances.hs b/test/TestExperimenter/Serialise/Instances.hs new file mode 100644 --- /dev/null +++ b/test/TestExperimenter/Serialise/Instances.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + + +module TestExperimenter.Serialise.Instances + ( St (..) + ) where + + +import Control.DeepSeq +import Data.Serialize +import GHC.Generics +import Test.Hspec +import Test.QuickCheck + + +data St = St Int Double + deriving (Show, Eq, Ord, Generic, Serialize, NFData) + + +instance Arbitrary St where + arbitrary = St <$> arbitrary <*> arbitrary + +instance CoArbitrary St where + coarbitrary (St int double) = variant 0 . coarbitrary (int, double) diff --git a/test/TestExperimenter/Serialise/SerialiseSpec.hs b/test/TestExperimenter/Serialise/SerialiseSpec.hs new file mode 100644 --- /dev/null +++ b/test/TestExperimenter/Serialise/SerialiseSpec.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module TestExperimenter.Serialise.SerialiseSpec (spec) where + + +import Control.Monad +import Control.Monad.Logger +import Control.Monad.Trans +import Data.Serialize +import qualified Data.Text as T +import GHC.Generics +import Prelude +import Test.Hspec +import Test.QuickCheck + +import Experimenter +import Experimenter.Result.Query + +import TestExperimenter.Serialise.Instances + +spec :: Spec +spec = do + describe "Serialise and deserialisation properties" $ + do it "serialises & deserialises a start state" $ property prop_serialiseStartSt + it "serialises & deserialises an end state (Just st)" $ property prop_serialiseEndSt + it "serialises & deserialises an end state with serialisable/deserialisable conversions" $ property prop_serialisableEndSt + + +prop_serialiseStartSt :: St -> Property +prop_serialiseStartSt st = ioProperty $ runStdoutLoggingT $ do + let bsStart = runPut $ put st + mSt' <- deserialise (T.pack "prop_serialiseStartSt") bsStart + return (Just st === mSt') + + +prop_serialiseEndSt :: Maybe St -> Property +prop_serialiseEndSt mSt = ioProperty $ runStdoutLoggingT $ do + let bsEnd = runPut . put <$> mSt + mmSt' <- mDeserialise (T.pack "prop_serialiseEndSt") bsEnd + return $ (Just <$> mSt) == mmSt' + + +prop_serialisableEndSt :: Maybe St -> Property +prop_serialisableEndSt mSt = ioProperty $ runStdoutLoggingT $ do + serESt <- lift $ traverse serialisable mSt + let bsEnd = runPut . put <$> serESt + (mmSt' :: Maybe (Maybe St')) <- mDeserialise (T.pack "prop_serialiseEndSt") bsEnd + mmSt <- lift $ maybe (return Nothing) (fmap Just . deserialisable) (join mmSt') + return $ mSt == mmSt + +data St' = St' Int Double + deriving (Generic, Serialize) + + +instance ExperimentDef St where + type ExpM St = IO + type Serializable St = St' + serialisable (St x y) = return $ St' x y + deserialisable (St' x y) = return $ St x y + type InputValue St = () + type InputState St = () + generateInput _ _ _ _ = return ((),()) + runStep _ (St x y) _ _ = return ([], St x y) + parameters _ = []