experimenter (empty) → 0.1.0.0
raw patch · 40 files changed
+4120/−0 lines, 40 filesdep +HaTeXdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HaTeX, QuickCheck, aeson, base, bytestring, cereal, cereal-vector, conduit, containers, deepseq, directory, esqueleto, experimenter, filepath, foundation, hostname, hspec, lens, matrix, monad-logger, mtl, mwc-random, parallel, persistent, persistent-postgresql, persistent-template, process, resource-pool, resourcet, stm, text, time, transformers, unix, unliftio-core, vector
Files
- ChangeLog.md +3/−0
- LICENSE +3/−0
- README.md +103/−0
- Setup.hs +2/−0
- experimenter.cabal +160/−0
- src/Experimenter.hs +16/−0
- src/Experimenter/Availability.hs +6/−0
- src/Experimenter/Availability/Ops.hs +41/−0
- src/Experimenter/Availability/Type.hs +61/−0
- src/Experimenter/ConcurrentIO.hs +58/−0
- src/Experimenter/DB.hs +88/−0
- src/Experimenter/DatabaseSetting.hs +9/−0
- src/Experimenter/Eval.hs +11/−0
- src/Experimenter/Eval/Csv.hs +267/−0
- src/Experimenter/Eval/Latex.hs +302/−0
- src/Experimenter/Eval/Ops.hs +252/−0
- src/Experimenter/Eval/Reduce.hs +107/−0
- src/Experimenter/Eval/Table.hs +89/−0
- src/Experimenter/Eval/Type.hs +236/−0
- src/Experimenter/Eval/Util.hs +53/−0
- src/Experimenter/Experiment.hs +123/−0
- src/Experimenter/Input.hs +25/−0
- src/Experimenter/MasterSlave.hs +89/−0
- src/Experimenter/Measure.hs +21/−0
- src/Experimenter/Models.hs +27/−0
- src/Experimenter/Parameter.hs +7/−0
- src/Experimenter/Parameter/Ops.hs +12/−0
- src/Experimenter/Parameter/Query.hs +21/−0
- src/Experimenter/Parameter/Type.hs +53/−0
- src/Experimenter/Result.hs +10/−0
- src/Experimenter/Result/Query.hs +610/−0
- src/Experimenter/Result/Type.hs +121/−0
- src/Experimenter/Run.hs +948/−0
- src/Experimenter/Setting.hs +43/−0
- src/Experimenter/State.hs +13/−0
- src/Experimenter/StepResult.hs +21/−0
- src/Experimenter/Util.hs +16/−0
- test/Spec.hs +2/−0
- test/TestExperimenter/Serialise/Instances.hs +25/−0
- test/TestExperimenter/Serialise/SerialiseSpec.hs +66/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for experimenter++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,3 @@+Copyright Manuel Schneckenreither (c) 2020++BSD3, see https://opensource.org/licenses/BSD-3-Clause
+ README.md view
@@ -0,0 +1,103 @@+# Experimenter: Scientific experiments made easy++[](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 :)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ experimenter.cabal view
@@ -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 <https://github.com/schnecki/experimenter#readme>+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
+ src/Experimenter.hs view
@@ -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
+ src/Experimenter/Availability.hs view
@@ -0,0 +1,6 @@+module Experimenter.Availability+ ( module A+ ) where++import Experimenter.Availability.Ops as A+import Experimenter.Availability.Type as A
+ src/Experimenter/Availability/Ops.hs view
@@ -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'+
+ src/Experimenter/Availability/Type.hs view
@@ -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
+ src/Experimenter/ConcurrentIO.hs view
@@ -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
+ src/Experimenter/DB.hs view
@@ -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!+ ]
+ src/Experimenter/DatabaseSetting.hs view
@@ -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+ }
+ src/Experimenter/Eval.hs view
@@ -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
+ src/Experimenter/Eval/Csv.hs view
@@ -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 "+ ]
+ src/Experimenter/Eval/Latex.hs view
@@ -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]
+ src/Experimenter/Eval/Ops.hs view
@@ -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
+ src/Experimenter/Eval/Reduce.hs view
@@ -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
+ src/Experimenter/Eval/Table.hs view
@@ -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
+ src/Experimenter/Eval/Type.hs view
@@ -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
+ src/Experimenter/Eval/Util.hs view
@@ -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
+ src/Experimenter/Experiment.hs view
@@ -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 ()
+ src/Experimenter/Input.hs view
@@ -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
+ src/Experimenter/MasterSlave.hs view
@@ -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
+ src/Experimenter/Measure.hs view
@@ -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
+ src/Experimenter/Models.hs view
@@ -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")
+ src/Experimenter/Parameter.hs view
@@ -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
+ src/Experimenter/Parameter/Ops.hs view
@@ -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
+ src/Experimenter/Parameter/Query.hs view
@@ -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)
+ src/Experimenter/Parameter/Type.hs view
@@ -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
+ src/Experimenter/Result.hs view
@@ -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
+ src/Experimenter/Result/Query.hs view
@@ -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)
+ src/Experimenter/Result/Type.hs view
@@ -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)
+ src/Experimenter/Run.hs view
@@ -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)
+ src/Experimenter/Setting.hs view
@@ -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
+ src/Experimenter/State.hs view
@@ -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"
+ src/Experimenter/StepResult.hs view
@@ -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
+ src/Experimenter/Util.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,2 @@+-- file test/Spec.hs+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TestExperimenter/Serialise/Instances.hs view
@@ -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)
+ test/TestExperimenter/Serialise/SerialiseSpec.hs view
@@ -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 _ = []