Concurrent simulation batch (#513)

* Methods for concurrent running of simulations. * Dimensions utilities * -WIP * Implement runSimulationsConcurrently * Remov obsolete code * Run styler * Build options * Docu update * Project change * SimulationBatch is OSPSuite.R.Services.SettingsForConcurrentRunSimulationBatch * Working on concurrent batch runner * Added function to run simulation batches concurrently * Add example for concurrent batch runner * Update dll version to match those used by PKSim * Missing comment in examples * Update example * Update docu again... * Dontrun example * Reversed change of isOfType behavior when checking an empty list() * Update comment regarding dispose * Update binaries * Address review comments. * Rename SettingsForConcurrentRunSimulationBatch to ConcurrentRunSimulationBatch in comments. Co-authored-by: Michael Sevestre <michael@design2code.ca>
Open-Systems-Pharmacology · May 10, 2021 · 607bbf1 · 607bbf1
1 parent b057513
commit 607bbf1
Show file tree

Hide file tree

Showing 24 changed files with 606 additions and 186 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -91,6 +91,7 @@ export(removeSimulationFromCache)
 export(resetSimulationCache)
 export(runSensitivityAnalysis)
 export(runSimulation)
+export(runSimulationBatches)
 export(runSimulationsConcurrently)
 export(saveSimulation)
 export(scaleParameterValues)

diff --git a/R/error-checks.R b/R/error-checks.R
@@ -8,18 +8,24 @@ isSameLength <- function(...) {
 #' Check if the provided object is of certain type
 #'
 #' @param object An object or a list of objects
-#' @param type String  representation or Class of the type that should be checked for
+#' @param type String representation or Class of the type that should be checked for
+#' @param nullAllowed Boolean flag if \code{NULL} is accepted for the \code{object}. If \code{TRUE},
+#' \code{NULL} always returns \code{TRUE}, otherwise \code{NULL} returns \code{FALSE}. Default is \code{FALSE}
 #'
 #' @return TRUE if the object or all objects inside the list are of the given type.
 #' Only the first level of the given list is considered.
-isOfType <- function(object, type) {
+isOfType <- function(object, type, nullAllowed = FALSE) {
   if (is.null(object)) {
-    return(FALSE)
+    return(nullAllowed)
   }
 
   type <- typeNamesFrom(type)
-  inheritType <- function(x) inherits(x, type)
-
+  inheritType <- function(x) {
+    if (is.null(x) && nullAllowed) {
+      return(TRUE)
+    }
+    inherits(x, type)
+  }
   if (inheritType(object)) {
     return(TRUE)
   }
@@ -28,12 +34,14 @@ isOfType <- function(object, type) {
   all(sapply(object, inheritType))
 }
 
+#' Check if the provided object is of certain type. If not, stop with an error.
+#'
+#' @param object An object or a list of objects
+#' @param type String representation or Class of the type that should be checked for
+#' @param nullAllowed Boolean flag if \code{NULL} is accepted for the \code{object}. If \code{TRUE},
+#' \code{NULL} is always valid, otherwise the error is thrown. Default is \code{FALSE}
 validateIsOfType <- function(object, type, nullAllowed = FALSE) {
-  if (nullAllowed && is.null(object)) {
-    return()
-  }
-
-  if (isOfType(object, type)) {
+  if (isOfType(object, type, nullAllowed)) {
     return()
   }
   # Name of the variable in the calling function
@@ -43,12 +51,17 @@ validateIsOfType <- function(object, type, nullAllowed = FALSE) {
   stop(messages$errorWrongType(objectName, class(object)[1], objectTypes))
 }
 
+#' Check if \code{value} is in the given {enum}. If not, stops with an error.
+#'
+#' @param enum \code{enum} where the \code{value} should be contained
+#' @param value \code{value} to search for in the \code{enum}
+#' @param nullAllowed If TRUE, \code{value} can be \code{NULL} and the test always passes.
+#' If \code{FALSE} (default), NULL is not accepted and the test fails.
 validateEnumValue <- function(value, enum, nullAllowed = FALSE) {
-  if (nullAllowed && is.null(value)) {
-    return()
-  }
-
   if (is.null(value)) {
+    if (nullAllowed) {
+      return()
+    }
     stop(messages$errorEnumValueUndefined(enum))
   }
 

diff --git a/R/messages.R b/R/messages.R
@@ -1,21 +1,14 @@
 messages <- list(
   errorWrongType = function(objectName, type, expectedType, optionalMessage = NULL) {
-    # Name of the calling function
-    callingFunctions <- sys.calls()
-    callingFunction <- sys.call(-length(callingFunctions) + 1)[[1]]
-
+    callingFunction <- .getCallingFunctionName()
     expectedTypeMsg <- paste0(expectedType, collapse = ", or ")
-
     paste0(
       callingFunction, ": argument '", objectName,
       "' is of type '", type, "', but expected '", expectedTypeMsg, "'!", optionalMessage
     )
   },
   errorGetEntityMultipleOutputs = function(path, container, optionalMessage = NULL) {
-    # Name of the calling function
-    callingFunctions <- sys.calls()
-    callingFunction <- sys.call(-length(callingFunctions) + 1)[[1]]
-
+    callingFunction <- .getCallingFunctionName()
     paste0(
       callingFunction, ": the path '", toString(path), "' located under container '",
       container$path,
@@ -24,31 +17,22 @@ messages <- list(
     )
   },
   errorEntityNotFound = function(path, container, optionalMessage = NULL) {
-    # Name of the calling function
-    callingFunctions <- sys.calls()
-    callingFunction <- sys.call(-length(callingFunctions) + 1)[[1]]
-
+    callingFunction <- .getCallingFunctionName()
     paste0(
       callingFunction, ": No entity exists for path '", toString(path), "' located under container '",
       container$path,
       "'!", optionalMessage
     )
   },
   errorResultNotFound = function(path, individualId, optionalMessage = NULL) {
-    # Name of the calling function
-    callingFunctions <- sys.calls()
-    callingFunction <- sys.call(-length(callingFunctions) + 1)[[1]]
-
+    callingFunction <- .getCallingFunctionName()
     paste0(
       callingFunction, ": No results exists for path '", toString(path), "' for individual IDs ",
       "'", individualId, "'!", optionalMessage
     )
   },
   errorDifferentLength = function(objectNames, optionalMessage = NULL) {
-    # Name of the calling function
-    callingFunctions <- sys.calls()
-    callingFunction <- sys.call(-length(callingFunctions) + 1)[[1]]
-
+    callingFunction <- .getCallingFunctionName()
     paste0(
       callingFunction, ": Arguments '", objectNames,
       "' must have the same length, but they don't!", optionalMessage
@@ -90,10 +74,23 @@ messages <- list(
   errorOSPSuiteSettingNotFound = function(settingName) {
     paste0("No global setting with the name '", settingName, "' exists. Available global settings are:\n", paste0(names(ospsuiteEnv), collapse = ", "))
   },
-  errorSimulationBatchNothingToVary = "You need to vary at least one parameter or one molecule in order to use the SimulationBatch"
+  errorSimulationBatchNothingToVary = "You need to vary at least one parameter or one molecule in order to use the SimulationBatch",
+  errorOnlyOneValuesSetAllowed = function(argumentName) {
+    callingFunction <- .getCallingFunctionName()
+    paste0(
+      callingFunction, ": argument '", argumentName,
+      "' is a list with multiple values sets, but only one value set is allowed!"
+    )
+  }
 )
 
 formatNumerics <- function(numerics, digits = ospsuiteEnv$formatNumericsDigits,
                            nsmall = ospsuiteEnv$formatNumericsSmall) {
   format(numerics, digits = digits, nsmall = nsmall)
 }
+
+.getCallingFunctionName <- function() {
+  callingFunctions <- sys.calls()
+  callingFunction <- sys.call(-length(callingFunctions) + 1)[[1]]
+  return(deparse(callingFunction))
+}
diff --git a/R/simulation-batch.R b/R/simulation-batch.R
@@ -1,6 +1,7 @@
 #' @title SimulationBatch
 #' @docType class
-#' @description  Options to be passed to the SimulationBatch
+#' @description  An optimized simulation with faster loading. The corresponding .NET class is
+#' "OSPSuite.R.Services.ConcurrentRunSimulationBatch"
 #' @export
 #' @format NULL
 SimulationBatch <- R6::R6Class(
@@ -19,36 +20,74 @@ SimulationBatch <- R6::R6Class(
     initialize = function(ref, simulation) {
       validateIsOfType(simulation, Simulation)
       super$initialize(ref)
-      self$simulation <- simulation
+      private$.simulation <- simulation
     },
 
-    #' @description Set the parameter and initial values in the simulation and run the simulation
+    #' @description Add a set of parameter and start values for next execution.
+    #' @details Intended for the use with \code{runSimulationBatches}. The simulation batch is executed
+    #' with the sets of parameter and initial values that have been scheduled. The set of run values is cleared after successful run.
+    #'
     #' @param parameterValues Vector of parameter values to set in the simulation (default is `NULL`)
     #' @param initialValues Vector of initial values to set in the simulation  (default is `NULL`)
-    #' @return A `SimulationResults` object containing the result of the simulation run
-    run = function(parameterValues = NULL, initialValues = NULL) {
+    #'
+    #' @return Id of the values set that can be used to get the correct result from \code{runSimulationBatches}.
+    #' @export
+    #'
+    #' @examples
+    #' \dontrun{
+    #' sim1 <- loadSimulation("sim1", loadFromCache = TRUE)
+    #' sim2 <- loadSimulation("sim2", loadFromCache = TRUE)
+    #' parameters <- c("Organism|Liver|Volume", "R1|k1")
+    #' molecules <- "Organism|Liver|A"
+    #' # Create two simulation batches.
+    #' simulationBatch1 <- createSimulationBatch(simulation = sim1,
+    #' parametersOrPaths = parameters,
+    #' moleculesOrPaths = molecules)
+    #' simulationBatch2 <- createSimulationBatch(simulation = sim2,
+    #' parametersOrPaths = parameters,
+    #' moleculesOrPaths = molecules)
+    #' #Ids of run values
+    #' ids <- c()
+    #' ids[[1]] <- simulationBatch1$addRunValues(parameterValues = c(1, 2), initialValues = 1)
+    #' ids[[2]] <- simulationBatch1$addRunValues(parameterValues = c(1.6, 2.4), initialValues = 3)
+    #' ids[[3]] <- simulationBatch2$addRunValues(parameterValues = c(4, 2), initialValues = 4)
+    #' ids[[4]] <- simulationBatch2$addRunValues(parameterValues = c(2.6, 4.4), initialValues = 5)
+    #' res <- runSimulationBatches(simulationBatches = list(simulationBatch1, simulationBatch2))
+    #' }
+    addRunValues = function(parameterValues = NULL, initialValues = NULL) {
       validateIsNumeric(parameterValues, nullAllowed = TRUE)
       validateIsNumeric(initialValues, nullAllowed = TRUE)
-      batchRunValues <- SimulationBatchRunValues$new(parameterValues, initialValues)
+      # Only one values set is allowed - no lists of values
+      if (is.list(parameterValues) || is.list(initialValues)) {
+        stop(messages$errorOnlyOneValuesSetAllowed("parameterValues, initialValues"))
+      }
 
-      results <- rClr::clrCall(self$ref, "Run", batchRunValues$ref)
-      SimulationResults$new(results, self$simulation)
+      batchRunValues <- SimulationBatchRunValues$new(parameterValues, initialValues)
+      rClr::clrCall(self$ref, "AddSimulationBatchRunValues", batchRunValues$ref)
     },
+
     #' @description
     #' Clears the reference to the wrapped .NET object
     finalize = function() {
-      rClr::clrCall(self$ref, "Dispose")
       private$.simulation <- NULL
       super$finalize()
     }
   ),
   active = list(
-    #' @field simulation Underlying simulation used for the batch run
+    #' @field simulation Underlying simulation used for the batch run. Read only.
     simulation = function(value) {
       if (missing(value)) {
         private$.simulation
       } else {
-        private$.simulation <- value
+        private$throwPropertyIsReadonly("simulation")
+      }
+    },
+    #' @field runValuesIds Ids of the run values that will be executed on next run
+    runValuesIds = function(value) {
+      if (missing(value)) {
+        rClr::clrGet(self$ref, "RunValuesIds")
+      } else {
+        private$throwPropertyIsReadonly("runValuesIds")
       }
     }
   ),

diff --git a/R/utilities-pk-parameter.R b/R/utilities-pk-parameter.R
@@ -11,13 +11,19 @@
 #'
 #' # Adds a user defined parameter named MyAuc that will calculate the value of AUC
 #' # between t=50 min and t=80min
-#' myAUC <- addUserDefinedPKParameter(name = "MyAUC", standardPKParameter = StandardPKParameter$AUC_tEnd)
+#' myAUC <- addUserDefinedPKParameter(
+#'   name = "MyAUC",
+#'   standardPKParameter = StandardPKParameter$AUC_tEnd
+#' )
 #' myAUC$startTime <- 50
 #' myAUC$endTime <- 80
 #'
 #' # Adds a user defined parameter named MyCMax that will calculate the value of Cmax
 #' # between the 4th and 5th application
-#' myCMax <- addUserDefinedPKParameter(name = "MyCMax", standardPKParameter = StandardPKParameter$C_max)
+#' myCMax <- addUserDefinedPKParameter(
+#'   name = "MyCMax",
+#'   standardPKParameter = StandardPKParameter$C_max
+#' )
 #' myCMax$startApplicationIndex <- 4
 #' myCMax$endApplicationIndex <- 5
 #' @export