diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,10 @@ + # Changelog for experimenter -Release 0.1.0.12 n 22.03.2021: +Release 0.1.0.14: + - Vacuuming + +Release 0.1.0.12 on 22.03.2021: - Bug fix when decreasing number of evaluations Release 0.1.0.10 on 15.03.2021: diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,3 +1,29 @@ -Copyright Manuel Schneckenreither (c) 2020 +BSD 3-Clause License -BSD3, see https://opensource.org/licenses/BSD-3-Clause +Copyright (c) 2021, Manuel +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/config/models b/config/models --- a/config/models +++ b/config/models @@ -6,20 +6,20 @@ initialInputState ByteString ExpsInfoParam - exps ExpsId + exps ExpsId OnDeleteCascade name Text value ByteString UniqueExpsInfoParam exps name ExpsMaster - exps ExpsId + exps ExpsId OnDeleteCascade hostname Text pid Int lastAliveSign UTCTime UniqueExpsMaster exps ExpsSetup - exps ExpsId + exps ExpsId OnDeleteCascade repetitions Int preparationSteps Int evaluationWarmUpSteps Int @@ -29,34 +29,34 @@ UniqueExpsSetup exps Param - exps ExpsId + exps ExpsId OnDeleteCascade name Text minBound ByteString Maybe maxBound ByteString Maybe deriving Show Eq Ord Exp -- Adding "json" causes ToJSON and FromJSON instances to be derived. - exps ExpsId + exps ExpsId OnDeleteCascade number Int startTime UTCTime endTime UTCTime Maybe deriving Eq Ord ExpExecutionLock - exp ExpId + exp ExpId OnDeleteCascade hostname Text pid Int lastAliveSign UTCTime UniqueExpExecutionLock exp ExpProgress - exp ExpId + exp ExpId OnDeleteCascade phase Int step Int UniqueExpProgress exp ParamSetting - exp ExpId + exp ExpId OnDeleteCascade name Text value ByteString skipPreparationPhase Bool @@ -64,7 +64,7 @@ ExpResult - exp ExpId + exp ExpId OnDeleteCascade repetition Int prepResultData PrepResultDataId Maybe @@ -79,39 +79,39 @@ endInputState ByteString Maybe PrepStartStatePart -- need to split big states into pieces - resultData PrepResultDataId + resultData PrepResultDataId OnDeleteCascade number Int data ByteString UniquePrepStartStatePart resultData number PrepEndStatePart - resultData PrepResultDataId + resultData PrepResultDataId OnDeleteCascade number Int data ByteString UniquePrepEndStatePart resultData number PrepInput - prepResultData PrepResultDataId + prepResultData PrepResultDataId OnDeleteCascade period Int UniquePrepInput prepResultData period PrepInputValue - prepInput PrepInputId + prepInput PrepInputId OnDeleteCascade value ByteString PrepMeasure - prepResultData PrepResultDataId + prepResultData PrepResultDataId OnDeleteCascade period Int UniquePrepMeasure prepResultData period PrepResultStep - measure PrepMeasureId + measure PrepMeasureId OnDeleteCascade name Text xValue Double Maybe yValue Double RepResult - expResult ExpResultId + expResult ExpResultId OnDeleteCascade repNr Int warmUpResultData WarmUpResultDataId Maybe repResultData RepResultDataId Maybe @@ -128,13 +128,13 @@ endInputState ByteString Maybe WarmUpStartStatePart -- need to split big states into pieces - resultData WarmUpResultDataId + resultData WarmUpResultDataId OnDeleteCascade number Int data ByteString UniqueWarmUpStartStatePart resultData number WarmUpEndStatePart - resultData WarmUpResultDataId + resultData WarmUpResultDataId OnDeleteCascade number Int data ByteString UniqueWarmUpEndStatePart resultData number @@ -151,54 +151,54 @@ RepStartStatePart -- need to split big states into pieces - resultData RepResultDataId + resultData RepResultDataId OnDeleteCascade number Int data ByteString UniqueRepStartStatePart resultData number RepEndStatePart - resultData RepResultDataId + resultData RepResultDataId OnDeleteCascade number Int data ByteString UniqueRepEndStatePart resultData number WarmUpInput - repResult WarmUpResultDataId + repResult WarmUpResultDataId OnDeleteCascade period Int UniqueWarmUpInput repResult period WarmUpInputValue - warmUpInput WarmUpInputId + warmUpInput WarmUpInputId OnDeleteCascade value ByteString WarmUpMeasure - repResult WarmUpResultDataId + repResult WarmUpResultDataId OnDeleteCascade period Int UniqueWarmUpMeasure repResult period WarmUpResultStep - measure WarmUpMeasureId + measure WarmUpMeasureId OnDeleteCascade name Text xValue Double Maybe yValue Double RepInput - repResult RepResultDataId + repResult RepResultDataId OnDeleteCascade period Int UniqueRepInput repResult period RepInputValue - repInput RepInputId + repInput RepInputId OnDeleteCascade value ByteString RepMeasure - repResult RepResultDataId + repResult RepResultDataId OnDeleteCascade period Int UniqueRepMeasure repResult period RepResultStep - measure RepMeasureId + measure RepMeasureId OnDeleteCascade name Text xValue Double Maybe yValue Double diff --git a/experimenter.cabal b/experimenter.cabal --- a/experimenter.cabal +++ b/experimenter.cabal @@ -1,21 +1,21 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 74babbc2a0932968985e7a2b1535fb195c4303a3485ec96ba414c071efdc6f9e +-- hash: 09483e763a09034ab405201665dd8f5879d6938c3109181575ec01111ea2b2bd name: experimenter -version: 0.1.0.12 +version: 0.1.0.14 synopsis: Perform scientific experiments stored in a DB, and generate reports. description: Please see the README on GitHub at category: Experiment homepage: https://github.com/schnecki/experimenter#readme bug-reports: https://github.com/schnecki/experimenter/issues author: Manuel Schneckenreither -maintainer: manuel.schneckenreither@uibk.ac.at -copyright: 2021 Manuel Schneckenreither +maintainer: manuel.schneckenreither@student.uibk.ac.at +copyright: 2022 Manuel Schneckenreither license: BSD3 license-file: LICENSE build-type: Simple @@ -52,6 +52,7 @@ Experimenter.Eval.Util Experimenter.Experiment Experimenter.Input + Experimenter.Load Experimenter.MasterSlave Experimenter.Measure Experimenter.Models diff --git a/src/Experimenter.hs b/src/Experimenter.hs --- a/src/Experimenter.hs +++ b/src/Experimenter.hs @@ -6,6 +6,7 @@ import Experimenter.Eval as E import Experimenter.Experiment as E import Experimenter.Input as E +import Experimenter.Load as E import Experimenter.Measure as E import Experimenter.Models as E import Experimenter.Parameter as E diff --git a/src/Experimenter/Eval/Latex.hs b/src/Experimenter/Eval/Latex.hs --- a/src/Experimenter/Eval/Latex.hs +++ b/src/Experimenter/Eval/Latex.hs @@ -34,8 +34,8 @@ import Text.LaTeX.Packages.TabularX import Experimenter.Availability -import Experimenter.DatabaseSetting import Experimenter.DB +import Experimenter.DatabaseSetting import Experimenter.Eval.Table import Experimenter.Eval.Type import Experimenter.Eval.Util @@ -84,7 +84,7 @@ documentclass [] article user <- liftIO getLoginName author ("Username: " <> fromString user) - title $ "Evaluation for ``" <> raw n <> "''" + title $ "Evaluation for ``" <> raw (dereferLatex n) <> "''" usepackage [utf8] inputenc usepackage [] "fullpage" usepackage [] "array" @@ -189,7 +189,7 @@ printTableWithName :: (MonadLogger m) => (StatsDef a, Table) -> LaTeXT m () printTableWithName (nm, tbl) = do - paragraph (raw $ prettyStatsDef nm) + paragraph (raw $ dereferLatex $ prettyStatsDef nm) printTable tbl @@ -298,7 +298,7 @@ [ CellT n , CellL $ raw (dereferLatex $ tshow val) <> (case mBounds of - Nothing -> "" + Nothing -> "" Just (minVal, maxVal) -> math (text " " `in_` autoParens (text (raw (dereferLatex $ tshow minVal)) <> ", " <> text (raw (dereferLatex $ tshow maxVal))))) <> (if drp then " [SkipPrepPhase]" diff --git a/src/Experimenter/Eval/Table.hs b/src/Experimenter/Eval/Table.hs --- a/src/Experimenter/Eval/Table.hs +++ b/src/Experimenter/Eval/Table.hs @@ -46,7 +46,10 @@ fromString = CellT . T.pack dereferLatex :: T.Text -> T.Text -dereferLatex = protectText . T.replace "{" "\\{" . T.replace "}" "\\}" . T.replace "_" "\\_" +dereferLatex x = protectText $ foldl' (\x' (f, t) -> T.replace f t x') x list + where + list :: [(T.Text, T.Text)] + list = [("{", "\\{"), ("}", "\\}"), ("_", "\\_"), ("_", "\\_"), ("%", "\\%"), ("^", "\\^"), ("~", "\\~"), ("$", "\\$")] printTextwidthTable :: (MonadLogger m) => Table -> LaTeXT m () printTextwidthTable = printTableTabularX True @@ -64,7 +67,7 @@ where content = hline <> printRow textbf header <> hline <> mconcat (map (printRow id) rows) <> hline printRow :: (LaTeXC l) => (l -> l) -> Row -> l - printRow _ (Row []) = mempty + 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) diff --git a/src/Experimenter/Experiment.hs b/src/Experimenter/Experiment.hs --- a/src/Experimenter/Experiment.hs +++ b/src/Experimenter/Experiment.hs @@ -10,8 +10,8 @@ import Control.DeepSeq import Control.Monad.IO.Unlift -import Data.Serialize (Serialize) import Data.Kind +import Data.Serialize (Serialize) import System.Random.MWC import Experimenter.Parameter @@ -81,6 +81,10 @@ deserialisable = return -- HOOKS + + -- | Function to call before starting the experiment, but after setting the parameters. E.g. one could recereate an ANN, if the structure may have changed with a parameter. + beforeExperimentStartHook :: ExperimentNumber -> a -> ExpM a a + beforeExperimentStartHook _ = return -- | 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! diff --git a/src/Experimenter/Load.hs b/src/Experimenter/Load.hs new file mode 100644 --- /dev/null +++ b/src/Experimenter/Load.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Experimenter.Load + ( OnlyFinishedExperiments + , DatabaseSetting (..) + , loadExperimentsResultsM + , loadExperimentPrepEndStateIO + , loadExperimentPrepEndState + ) where + + +import Control.Arrow (first, 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 Control.Monad.Trans.Maybe +import qualified Data.ByteString as B +import Data.Function (on) +import Data.IORef +import Data.Int (Int64) +import Data.List (foldl') +import qualified Data.List as L +import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, 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 Text.Read (readMaybe) + +import Experimenter.Availability +import Experimenter.DB +import Experimenter.DatabaseSetting +import Experimenter.Experiment +import Experimenter.Input +import Experimenter.MasterSlave +import Experimenter.Measure +import Experimenter.Models +import Experimenter.Parameter +import Experimenter.Result +import Experimenter.Result.Query +import Experimenter.Setting +import Experimenter.StepResult +import Experimenter.Util + + +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) + + +readValueSafe :: (Read a) => IO (Maybe a) +readValueSafe = do + liftIO $ putStr "Enter value: " >> hFlush stdout + readMaybe <$> getLine + + +readListValueSafeName :: [(a, T.Text)] -> IO (Maybe a) +readListValueSafeName xs = do + mapM_ (\(nr, (_, n)) -> putStrLn $ show nr <> ":\t " <> T.unpack n) $ zip [(0 :: Int) ..] xs + mNr <- readValueSafe + return $ + case mNr of + Just nr + | nr >= 0 && nr < length xs -> Just $ fst $ xs !! nr + _ -> Nothing + + +-- | Convert a 'Maybe' computation to 'MaybeT'. +hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b +hoistMaybe = MaybeT . pure + + +loadExperimentPrepEndStateIO :: (ExpM a ~ IO, ExperimentDef a) => DatabaseSetting -> IO (Maybe a) +loadExperimentPrepEndStateIO = loadExperimentPrepEndState id + + +loadExperimentPrepEndState :: + forall a. (ExperimentDef a) + => (ExpM a (Maybe a) -> IO (Maybe a)) + -> DatabaseSetting + -> IO (Maybe a) +loadExperimentPrepEndState runExpM dbSetup = + runExpM $ + runDB dbSetup $ + runMaybeT $ do + liftIO $ putStrLn "From which experiment do you want to load the data? " + exps <- lift $ selectList [] [] + let expsNames :: [(Key Exps, T.Text)] + expsNames = map (entityKey &&& (^. expsName) . entityVal) exps + (expsKey :: Key Exps) <- MaybeT $ liftIO $ readListValueSafeName expsNames + exp <- lift $ selectList [ExpExps ==. expsKey] [] + (expKey :: Key Exp) <- + if length exp == 1 + then return $ entityKey $ head exp + else do + liftIO $ putStrLn "Which experiment number?" + let expNrs = sortOnSnd $ map (entityKey &&& tshow . (^. expNumber) . entityVal) exp + MaybeT $ liftIO $ readListValueSafeName expNrs + reps <- lift $ selectList [ExpResultExp ==. expKey] [] + liftIO $ putStrLn "And from which experiment repetition?" + + let + repNames :: [(Key PrepResultData, T.Text)] + repNames = sortOnSnd $ map (first fromJust) $ filter (isJust . fst) $ map ((^. expResultPrepResultData) . entityVal &&& tshow . (^. expResultRepetition) . entityVal) reps + rep <- MaybeT $ liftIO $ readListValueSafeName repNames + let endStateType = EndStatePrep rep + ma <- lift (loadResDataEndState expKey endStateType :: DB (ExpM a) (Maybe a)) + hoistMaybe ma + where sortOnSnd = L.sortBy (compare `on` snd) diff --git a/src/Experimenter/Models.hs b/src/Experimenter/Models.hs --- a/src/Experimenter/Models.hs +++ b/src/Experimenter/Models.hs @@ -24,5 +24,6 @@ import Database.Persist.TH -share [mkPersist sqlSettings {mpsGenerateLenses = True}, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"] +share [mkPersist sqlSettings {mpsGenerateLenses = True}, -- mkDeleteCascade sqlSettings, + mkMigrate "migrateAll"] $(persistFileWith lowerCaseSettings "config/models") diff --git a/src/Experimenter/Run.hs b/src/Experimenter/Run.hs --- a/src/Experimenter/Run.hs +++ b/src/Experimenter/Run.hs @@ -19,30 +19,28 @@ , runExperiments , runExperimentsM , runExperimentsIO - , loadExperimentsResultsM - , loadStateAfterPreparation - , loadStateAfterPreparation2 + -- , loadStateAfterPreparation + -- , loadStateAfterPreparation2 ) where -import Control.Arrow (first, (&&&), (***)) -import Control.Arrow (second) +import Control.Arrow (first, 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.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.Int (Int64) 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 qualified Data.Text.Encoding as E import Data.Time (addUTCTime, diffUTCTime, getCurrentTime) import qualified Data.Vector as V import Database.Persist.Postgresql @@ -52,12 +50,13 @@ import System.IO import System.IO.Unsafe (unsafePerformIO) import System.Posix.Process +import System.Process (callProcess, spawnProcess) import System.Random.MWC import Experimenter.Availability -import Experimenter.DatabaseSetting import Experimenter.DB +import Experimenter.DatabaseSetting import Experimenter.Experiment import Experimenter.Input import Experimenter.MasterSlave @@ -99,86 +98,67 @@ runStdoutLoggingT $ withPostgresqlPool (connectionString dbSetup) (parallelConnections dbSetup) $ liftSqlPersistMPool $ runMigration migrateAll >> indexCreation runExpM $ runDB dbSetup $ do + -- liftIO $ putStrLn "Running maintainance command: VACUUM" + -- rawExecute "VACUUM" [] + liftIO $ vacuum dbSetup 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 +-- | Vacuum the database. Usually you should not use 'full'! As it takes much longer and the table is locked for the duration of the process.. +vacuum :: DatabaseSetting -> IO () +vacuum (DatabaseSetting bs _) = do + let baseTxt = foldl' (\ts (from, to) -> map (T.strip . T.replace from to) ts) (T.splitOn " " $ E.decodeUtf8 bs) [("dbname=", "--dbname="), ("host=", "--host="), ("port=", "--port="), ("user=", "--username=")] + txts = filter (not . T.isInfixOf "password=") baseTxt ++ ["-w"] -- Do *not* use full! ["-f" | full] + runStdoutLoggingT $ $(logInfo) $ "Running: vacuumdb " <> T.intercalate " " txts + callProcess "vacuumdb" (map T.unpack txts) -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) + -- vacuumdb --host=localhost --port=5432 --username=experimenter -w experimenter + -- [-d experimenter - f - h HOST - p PORT - u USER - q] + -- "host=localhost dbname=experimenter user=experimenter password= port=5432" -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 +-- 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) -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) +-- 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 + checkUniqueParamNames :: (Monad m) => Experiments a -> m (Experiments a) checkUniqueParamNames exps = do let paramNames = map parameterName (view experimentsParameters exps) @@ -376,11 +356,11 @@ _ -> [ParameterSetting n vBs drp (toEnum dsgn)] -- deleteExperiment :: (MonadIO m) => Experiment a -> DB m () --- deleteExperiment (Experiment k _ _ _ _ expRes) = mapM_ deleteExperimentResult expRes >> deleteCascade k +-- deleteExperiment (Experiment k _ _ _ _ expRes) = mapM_ deleteExperimentResult expRes >> delete k deleteExperimentResult :: (MonadIO m) => ExperimentResult a -> DB m () -deleteExperimentResult (ExperimentResult k _ _ repls) = mapM_ deleteReplicationResult repls >> deleteCascade k +deleteExperimentResult (ExperimentResult k _ _ repls) = mapM_ deleteReplicationResult repls >> delete k -- | Loads parameters of an experiment into all initial and end states of the given experiments variable. @@ -434,6 +414,7 @@ eTime <- return <$> liftIO getCurrentTime update (exp ^. experimentKey) [ExpEndTime =. eTime] delete lock + liftIO $ vacuum dbSetup return (updated, set experimentResults res $ set experimentEndTime eTime exp) else delete lock >> return (updated, set experimentResults res exp) where @@ -528,6 +509,7 @@ -> ExperimentResult a -> DB (ExpM a) (Updated, ExperimentResult a) runExperimentResult skipPrep rands@(prepRands, _, _) exps expId expNr expRes = do + expInitSt <- lift $ lift $ lift $ beforeExperimentStartHook expNr (exps ^. experimentsInitialState) let repetNr = expRes ^. repetitionNumber let prepSeed = prepRands !! (repetNr - 1) (prepInitSt, delPrep) <- @@ -557,7 +539,6 @@ res = map snd repRes return (prepUpdated || updated, set preparationResults prepRes $ set evaluationResults res expRes) where - expInitSt = exps ^. experimentsInitialState expResId = expRes ^. experimentResultKey deleteTruncatedRepRes :: (MonadIO m) => Experiments a -> [ReplicationResult a] -> DB m [ReplicationResult a] deleteTruncatedRepRes exps' xs @@ -731,7 +712,7 @@ deleteReplicationResult (ReplicationResult repResId _ _ _) = deleteResultData (WarmUp repResId) >> deleteResultData (Rep repResId) >> - deleteCascade repResId + delete repResId deleteResultData :: (MonadIO m) => RepResultType -> DB m () @@ -740,15 +721,15 @@ Prep expResId -> do update expResId [ExpResultPrepResultData =. Nothing] exp <- get expResId - sequence_ $ deleteCascade <$> (view expResultPrepResultData =<< exp) + sequence_ $ delete <$> (view expResultPrepResultData =<< exp) WarmUp repResId -> do update repResId [RepResultWarmUpResultData =. Nothing] repRes <- get repResId - sequence_ $ deleteCascade <$> (view repResultWarmUpResultData =<< repRes) + sequence_ $ delete <$> (view repResultWarmUpResultData =<< repRes) Rep repResId -> do update repResId [RepResultRepResultData =. Nothing] repRes <- get repResId - sequence_ $ deleteCascade <$> (view repResultRepResultData =<< repRes) + sequence_ $ delete <$> (view repResultRepResultData =<< repRes) foldM' :: (NFData a, Monad m) => (a -> b -> m a) -> a -> [b] -> m a foldM' _ !acc [] = return acc @@ -852,14 +833,14 @@ isNew = curLen == 0 mkStartStateAvailableOnDemand = case resData ^. resultDataKey of - ResultDataPrep key -> AvailableOnDemand $ loadResDataStartState expId (StartStatePrep key) + ResultDataPrep key -> AvailableOnDemand $ loadResDataStartState expId (StartStatePrep key) ResultDataWarmUp key -> AvailableOnDemand $ loadResDataStartState expId (StartStateWarmUp key) - ResultDataRep key -> AvailableOnDemand $ loadResDataStartState expId (StartStateRep key) + ResultDataRep key -> AvailableOnDemand $ loadResDataStartState expId (StartStateRep key) mkEndStateAvailableOnDemand = case resData ^. resultDataKey of - ResultDataPrep key -> AvailableOnDemand $ loadResDataEndState expId (EndStatePrep key) + ResultDataPrep key -> AvailableOnDemand $ loadResDataEndState expId (EndStatePrep key) ResultDataWarmUp key -> AvailableOnDemand $ loadResDataEndState expId (EndStateWarmUp key) - ResultDataRep key -> AvailableOnDemand $ loadResDataEndState expId (EndStateRep 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 @@ -867,7 +848,7 @@ inputValsList = V.toList inputVals in case resData' ^. resultDataKey of ResultDataPrep key -> do - when delInputs $ deleteCascadeWhere [PrepInputPrepResultData ==. key, PrepInputPeriod >=. curLen + 1] + when delInputs $ deleteWhere [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 @@ -876,7 +857,7 @@ AvailableListOnDemand (countInputValues', loadPreparationInputWhere key) $ resData' ResultDataWarmUp key -> do - when delInputs $ deleteCascadeWhere [WarmUpInputRepResult ==. key, WarmUpInputPeriod >=. curLen + 1] + when delInputs $ deleteWhere [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 @@ -885,7 +866,7 @@ AvailableListOnDemand (countInputValues', loadReplicationWarmUpInputWhere key) $ resData' ResultDataRep key -> do - when delInputs $ deleteCascadeWhere [RepInputRepResult ==. key, RepInputPeriod >=. curLen + 1] + when delInputs $ deleteWhere [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