Using low-level rCrl methods in getOutputValues

NAMESPACE

@@ -100,6 +100,7 @@ export(setMoleculeScaleDivisors)
 export(setOutputInterval)
 export(setParameterValues)
 export(setParameterValuesByPath)
+export(setQuantityValuesByPath)
 export(splitPopulationFile)
 export(toBaseUnit)
 export(toDisplayUnit)

R/error-checks.R

@@ -138,3 +138,10 @@ validateIsSameLength <- function(...) {
 
   stop(messages$errorDifferentLength(arguments))
 }
+
+validatePathIsAbsolute <- function(path){
+  wildcardChar <- "*"
+  if (any(unlist(strsplit(path, ""), use.names = FALSE) == wildcardChar)){
+    stop(messages$errorEntityPathNotAbsolute(path))
+  }
+}

R/messages.R

@@ -67,6 +67,10 @@ messages <- list(
   errorPKParameterNotFound = function(pkParameterName, allPKParameterNames) {
     paste0("PK-Parameter '", pkParameterName, "' not found.\nAvailable PK-Parameters are:\n", paste0(allPKParameterNames, collapse = ", "))
   },
+  errorEntityPathNotAbsolute = function(path){
+    paste0("Only absolut paths (i.e. without the wildcard(s) `*`) are allowed, but the passed path is: ",
+           path)
+  },
   pkSimRPathInvalid = function(pksimPath) {
     paste0("Path to PKSim.R.dll '", pksimPath, "' is invalid.")
   },
@@ -91,6 +95,6 @@ formatNumerics <- function(numerics, digits = ospsuiteEnv$formatNumericsDigits,
 
 .getCallingFunctionName <- function() {
   callingFunctions <- sys.calls()
-  callingFunction <- sys.call(-length(callingFunctions) + 1)[[1]]
+  callingFunction <- sys.call(-length(callingFunctions) + 2)[[1]]
   return(deparse(callingFunction))
 }

R/utilities-output-selections.R

@@ -3,6 +3,9 @@
 #'
 #' @param quantitiesOrPaths Quantity instances (element or vector) (typically retrieved using \code{getAllQuantitiesMatching}) or quantity path (element or vector) to add.
 #' @param simulation Instance of a simulation for which output selection should be updated.
+#' @param returnQuantities Boolean. If \code{TRUE} (default), list of quantities that have been
+#' added is returned. If \code{FALSE}, \code{NULL} is (invisibly) returned, but the function
+#' performes much faster.
 #'
 #' @return A list of quantities added as output (Especially useful when a wildcard was used to verify)
 #'
@@ -17,24 +20,32 @@
 #' parameter <- getParameter("Organism|Liver|Volume", sim)
 #' addOutputs(parameter, sim)
 #' @export
-addOutputs <- function(quantitiesOrPaths, simulation) {
+addOutputs <- function(quantitiesOrPaths, simulation, returnQuantities = TRUE) {
   quantitiesOrPaths <- c(quantitiesOrPaths)
 
   validateIsOfType(quantitiesOrPaths, c(Quantity, "character"))
   validateIsOfType(simulation, Simulation)
-  quantities <- quantitiesOrPaths
 
-  if (isOfType(quantitiesOrPaths, "character")) {
-    quantities <- getAllQuantitiesMatching(quantitiesOrPaths, simulation)
+  # If quantities are provided, get their paths
+  paths <- vector("character", length(quantitiesOrPaths))
+  if (isOfType(quantitiesOrPaths, Quantity)) {
+    for (idx in seq_along(quantitiesOrPaths)) {
+      paths[[idx]] <- quantitiesOrPaths[[idx]]$path
+    }
+  } else {
+    paths <- quantitiesOrPaths
   }
+  paths <- unique(paths)
 
-  quantities <- uniqueEntities(quantities, compareBy = "path")
-  outputSelections <- simulation$outputSelections
-
-  for (quantity in quantities) {
-    outputSelections$addQuantity(quantity)
+  task <- getContainerTask()
+  for (path in paths) {
+    rClr::clrCall(task, "AddQuantitiesToSimulationOutputFromPath", simulation$ref, enc2utf8(path))
   }
 
+  quantities <- NULL
+  if (returnQuantities) {
+    quantities <- getAllQuantitiesMatching(paths = paths, container = simulation)
+  }
   invisible(quantities)
 }
 

R/utilities-parameter.R

@@ -120,11 +120,8 @@ setParameterValues <- function(parameters, values) {
 #' setParameterValuesByPath(c("Organism|Liver|Volume", "Organism|Volume"), c(2, 3), sim)
 #' @export
 setParameterValuesByPath <- function(parameterPaths, values, simulation) {
-  validateIsString(parameterPaths)
-  validateIsNumeric(values)
-  validateIsOfType(simulation, Simulation)
-  parameters <- sapply(parameterPaths, function(p) getParameter(p, simulation))
-  setParameterValues(parameters, values)
+  setQuantityValuesByPath(quantityPaths = parameterPaths, values = values,
+                          simulation = simulation)
 }
 
 #' Scale current values of parameters using a factor

R/utilities-quantity.R

@@ -96,6 +96,34 @@ setQuantityValues <- function(quantities, values) {
   }
 }
 
+#' Set the values of parameters in the simulation by path
+#'
+#' @param quantityPaths A single or a list of absolute quantity path
+#' @param values A numeric value that should be assigned to the quantities or a vector
+#' of numeric values, if the value of more than one quantity should be changed. Must have the same
+#' length as 'quantityPaths'
+#' @param simulation Simulation uses to retrieve quantity instances from given paths.
+#' @examples
+#'
+#' simPath <- system.file("extdata", "simple.pkml", package = "ospsuite")
+#' sim <- loadSimulation(simPath)
+#' setQuantityValuesByPath("Organism|Liver|Volume", 1, sim)
+#'
+#' setParameterValuesByPath(list("Organism|Liver|Volume", "Organism|Liver|A"), c(2, 3), sim)
+#' @export
+setQuantityValuesByPath <- function(quantityPaths, values, simulation) {
+  validateIsString(quantityPaths)
+  validateIsNumeric(values)
+  validateIsSameLength(quantityPaths, values)
+  validateIsOfType(simulation, Simulation)
+
+  task <- getContainerTask()
+  for (i in seq_along(quantityPaths)){
+    rClr::clrCall(task, "SetValueByPath", simulation$ref,
+                  enc2utf8(quantityPaths[[i]]), values[[i]])
+  }
+}
+
 #' Scale current values of quantities using a factor
 #'
 #' @param quantities A single or a list of \code{Quantity}

R/utilities-simulation-results.R

@@ -18,14 +18,18 @@
 #' @param population population used to calculate the simulationResults (optional). This is used only to add the population covariates to the resulting data table.
 #'
 #' @param stopIfNotFound Boolean. If TRUE and no result exist for the given path, an error is thrown. Default is \code{TRUE}
-#' @param stopIfNotFound If \code{TRUE} (default) an error is thrown if no results exist for any `path`
-#' If \code{FALSE}, a list of \code{NA} values is returned for the repsecitve path.
+#' @param stopIfNotFound If \code{TRUE} (default) an error is thrown if no results exist for any `path`. If \code{FALSE}, a list of \code{NA} values is returned for the respective path.
+#' @param withMetaData If \code{TRUE} (default), the output is a list two sublists `data`and
+#' `metaData`, with latter storing information about units and dimensions of the outputs. If \code{FALSE}, \code{metaData} is \code{NULL}. Setting this option to \code{FALSE} might improve
+#' the performance of the function.
+#'
 #' @export
 getOutputValues <- function(simulationResults,
                             quantitiesOrPaths = NULL,
                             population = NULL,
                             individualIds = NULL,
-                            stopIfNotFound = TRUE) {
+                            stopIfNotFound = TRUE,
+                            withMetaData = TRUE) {
   validateIsOfType(simulationResults, SimulationResults)
   validateIsOfType(population, Population, nullAllowed = TRUE)
   validateIsNumeric(individualIds, nullAllowed = TRUE)
@@ -38,17 +42,16 @@ getOutputValues <- function(simulationResults,
     return(list(data = NULL, metaData = NULL))
   }
 
-  # If quantities are passed, get their paths.
+  # If quantities are provided, get their paths
+  paths <- vector("character", length(quantitiesOrPaths))
   if (isOfType(quantitiesOrPaths, Quantity)) {
-    quantities <- uniqueEntities(quantitiesOrPaths)
-    paths <- unlist(lapply(quantities, function(x) x$path), use.names = FALSE)
+    for (idx in seq_along(quantitiesOrPaths)) {
+      paths[[idx]] <- quantitiesOrPaths[[idx]]$path
+    }
   } else {
-    paths <- unique(quantitiesOrPaths)
-    quantities <- lapply(paths, function(path) {
-      getQuantity(path, simulationResults$simulation, stopIfNotFound)
-    })
+    paths <- quantitiesOrPaths
   }
-  names(quantities) <- paths
+  paths <- unique(paths)
 
   # If no specific individual ids are passed, iterate through all individuals
   individualIds <- ifNotNull(individualIds, unique(individualIds), simulationResults$allIndividualIds)
@@ -77,18 +80,29 @@ getOutputValues <- function(simulationResults,
   # Cache of all individual properties over all individual that will be duplicated in all resulting data.frame
   allIndividualProperties <- do.call(rbind.data.frame, c(individualPropertiesCache, stringsAsFactors = FALSE))
 
-
   values <- lapply(paths, function(path) {
     simulationResults$getValuesByPath(path, individualIds, stopIfNotFound)
   })
   names(values) <- paths
 
-  metaData <- lapply(paths, function(path) {
-    quantity <- quantities[[path]]
-    list(unit = quantity$unit, dimension = quantity$dimension)
-  })
-  names(metaData) <- paths
-  metaData[["Time"]] <- list(unit = "min", dimension = "Time")
+  # Use low-level methods to get unit and dimension
+  task <- getContainerTask()
+  metaData <- NULL
+  if (withMetaData) {
+    metaData <- lapply(paths, function(path) {
+      unit <- NULL
+      dimension <- NULL
+      # Get the dimension and unit from path if the results are obtained. If the results
+      # are NA, the entity with such path does not exist
+      if (!all(is.na(values[[path]]))) {
+        unit <- rClr::clrCall(task, "BaseUnitNamesFromPath", simulationResults$simulation$ref, enc2utf8(path))[[1]]
+        dimension <- rClr::clrCall(task, "DimensionNamesFromPath", simulationResults$simulation$ref, enc2utf8(path))[[1]]
+      }
+      list(unit = unit, dimension = dimension)
+    })
+    names(metaData) <- paths
+    metaData[["Time"]] <- list(unit = "min", dimension = "Time")
+  }
 
   data <- data.frame(allIndividualProperties, values, stringsAsFactors = FALSE, check.names = FALSE)
   return(list(data = data, metaData = metaData))

R/utilities.R

@@ -1,7 +1,7 @@
-#' Transforms a single .NET object  or a list of .NET Object to their correpsonding wrapper class in R.
+#' Transforms a single .NET object  or a list of .NET Object to their corresponding wrapper class in R.
 #' Note that if the object is a single object, NULL will be returned if the .NET object is null. This allows semantic equivalence between .NET and R
 #'
-#' @param netObject The .NET object instances (single or list) to wrapp
+#' @param netObject The .NET object instances (single or list) to wrap
 #' @param class The class definition that will be used to convert the parameter
 #'
 #' @return The wrapped object (single or list)

packages.config

@@ -1,11 +1,11 @@
 <?xml version="1.0" encoding="utf-8"?>
 <packages>
-  <package id="OSPSuite.Assets" version="10.0.191"/>
-  <package id="OSPSuite.Core" version="10.0.191"/>
-  <package id="OSPSuite.Infrastructure" version="10.0.191"/>
-  <package id="OSPSuite.Infrastructure.Import" version="10.0.191"/>
-  <package id="OSPSuite.Infrastructure.Autofac" version="10.0.191"/>
-  <package id="OSPSuite.R" version="10.0.191 "/>
+  <package id="OSPSuite.Assets" version="10.0.203"/>
+  <package id="OSPSuite.Core" version="10.0.203"/>
+  <package id="OSPSuite.Infrastructure" version="10.0.203"/>
+  <package id="OSPSuite.Infrastructure.Import" version="10.0.203"/>
+  <package id="OSPSuite.Infrastructure.Autofac" version="10.0.203"/>
+  <package id="OSPSuite.R" version="10.0.202"/>
   <package id="OSPSuite.Serializer" version="3.0.0.1"/>
   <package id="OSPSuite.Utility" version="4.0.0.4"/>
   <package id="LumenWorksCsvReader" version="4.0.0"/>

tests/testthat/test-error-checks.R

@@ -13,7 +13,21 @@ test_that("it can validate that an integer array type is an integer", {
   expect_true(TRUE)
 })
 
-test_that("it throws a vlaidatin error when an object is not an integer", {
+test_that("it throws a validation error when an object is not an integer", {
   expect_that(validateIsInteger(c(1.5, 5)), throws_error())
   expect_that(validateIsInteger(2.4), throws_error())
 })
+
+test_that("It accepts an empty string", {
+  expect_error(validatePathIsAbsolute(""), NA)
+})
+
+test_that("It accepts a path without wildcard", {
+  path <- "Organism|path"
+  expect_error(validatePathIsAbsolute(path), NA)
+})
+
+test_that("It throws an error for a path with a wildcard", {
+  path <- "Organism|*path"
+  expect_error(validatePathIsAbsolute(path), messages$errorEntityPathNotAbsolute(path))
+})

tests/testthat/test-utilities-output-selections.R

@@ -34,7 +34,7 @@ test_that("It can add single output by reference", {
   quantities <- addOutputs(parameter, sim)
   expect_equal(length(quantities), 1)
   expect_equal(length(outputSelections$allOutputs), 1)
-  expect_equal(quantities[[1]], parameter)
+  expect_equal(quantities[[1]]$path, parameter$path)
 })
 
 test_that("It throws an exception if the parameters do not have the expect type", {