Merge pull request #16 from nlmixr2/15-dont-require-model-modificatio…

…n-to-set-initial-conditions

Don't require model modification to set initial conditions

R/tar_nlmixr.R

@@ -12,6 +12,8 @@
 #'
 #' @inheritParams nlmixr2est::nlmixr
 #' @inheritParams targets::tar_target
+#' @param env The environment where the model is setup (not needed for typical
+#'   use)
 #' @return A list of targets for the model simplification, data simplification,
 #'   and model estimation.
 #' @examples
@@ -47,7 +49,7 @@
 #' targets::tar_make()
 #' }
 #' @export
-tar_nlmixr <- function(name, object, data, est = NULL, control = list(), table = nlmixr2est::tableControl()) {
+tar_nlmixr <- function(name, object, data, est = NULL, control = list(), table = nlmixr2est::tableControl(), env = parent.frame()) {
   if (is.null(est)) {
     stop("'est' must not be null")
   }
@@ -60,25 +62,29 @@ tar_nlmixr <- function(name, object, data, est = NULL, control = list(), table =
     control = substitute(control),
     table = substitute(table),
     object_simple_name = paste(name_parsed, "object_simple", sep = "_tar_"),
-    data_simple_name = paste(name_parsed, "data_simple", sep = "_tar_")
+    data_simple_name = paste(name_parsed, "data_simple", sep = "_tar_"),
+    env = env
   )
 }
 
 #' @describeIn tar_nlmixr An internal function to generate the targets
 #' @param object_simple_name,data_simple_name target names to use for the object
 #'   and data
 #' @export
-tar_nlmixr_raw <- function(name, object, data, est, control, table, object_simple_name, data_simple_name) {
+tar_nlmixr_raw <- function(name, object, data, est, control, table, object_simple_name, data_simple_name, env) {
   checkmate::assert_character(name, len = 1, min.chars = 1, any.missing = FALSE)
   checkmate::assert_character(object_simple_name, len = 1, min.chars = 1, any.missing = FALSE)
   checkmate::assert_character(data_simple_name, len = 1, min.chars = 1, any.missing = FALSE)
+
+  # Make models with initial conditions set work within `targets` (see #15)
+  set_env_object_noinitial(object = object, env = env)
   list(
     targets::tar_target_raw(
       name = object_simple_name,
       command =
         substitute(
           nlmixr_object_simplify(object = object),
-          list(object = as.name(object))
+          list(object = object)
         ),
       packages = "nlmixr2est"
     ),
@@ -116,3 +122,28 @@ tar_nlmixr_raw <- function(name, object, data, est, control, table, object_simpl
     )
   )
 }
+
+#' Ensure that an object is set in its initial environment so that it is
+#' protected from the `targets` domain-specific-language issue of
+#' `pd(0) <- initial`
+#'
+#' @inheritParams tar_nlmixr
+#' @return NULL (called for side effects)
+#' @noRd
+set_env_object_noinitial <- function(object, env) {
+  if (is.name(object)) {
+    object_env <- env[[as.character(object)]]
+    if (is.function(object_env)) {
+      object_result <- try(rxode2::assertRxUi(object_env), silent = TRUE)
+      if (inherits(object_result, "rxUi")) {
+        assign(x = as.character(object), value = object_result, envir = env)
+      }
+    }
+  } else if (is.call(object)) {
+    # Recursively iterate over all parts of the call
+    lapply(X = object, FUN = set_env_object_noinitial, env = env)
+  }
+  # If it's anything other than a name or a call, then we don't need to modify
+  # it or its sub-objects.
+  NULL
+}

R/tar_nlmixr_multimodel.R

@@ -4,12 +4,11 @@
 #'   modelFunction`
 #' @inheritParams nlmixr2est::nlmixr
 #' @inheritParams targets::tar_target
-#' @param envir The environment where models are defined (usually doesn't need
-#'   to be modified)
+#' @inheritParams tar_nlmixr
 #' @return A list of targets for the model simplification, data simplification,
 #'   and model estimation.
 #' @export
-tar_nlmixr_multimodel <- function(name, ..., data, est, control = list(), table = nlmixr2est::tableControl(), envir = parent.frame()) {
+tar_nlmixr_multimodel <- function(name, ..., data, est, control = list(), table = nlmixr2est::tableControl(), env = parent.frame()) {
   tar_nlmixr_multimodel_parse(
     name = targets::tar_deparse_language(substitute(name)),
     data = substitute(data),
@@ -19,11 +18,11 @@ tar_nlmixr_multimodel <- function(name, ..., data, est, control = list(), table
     # This extracts the ... argument similarly to using `substitute()`.  From
     # https://stackoverflow.com/questions/55019441/deparse-substitute-with-three-dots-arguments
     model_list = match.call(expand.dots = FALSE)$...,
-    envir = envir
+    env = env
   )
 }
 
-tar_nlmixr_multimodel_parse <- function(name, data, est, control, table, model_list, envir) {
+tar_nlmixr_multimodel_parse <- function(name, data, est, control, table, model_list, env) {
   checkmate::assert_named(model_list, type = "unique")
   ret_prep <-
     lapply(
@@ -34,7 +33,7 @@ tar_nlmixr_multimodel_parse <- function(name, data, est, control, table, model_l
       est = est,
       control = control,
       table = table,
-      envir = envir
+      env = env
     )
   # Extract the targets to fit.  This will be a list of lists.  The inner list
   # will have the three targets for fitting the model, and the outer list will
@@ -55,10 +54,10 @@ tar_nlmixr_multimodel_parse <- function(name, data, est, control, table, model_l
   )
 }
 
-tar_nlmixr_multimodel_single <- function(object, name, data, est, control, table, envir) {
+tar_nlmixr_multimodel_single <- function(object, name, data, est, control, table, env) {
   # Hash the model itself without its description.  Then, if the description
   # changes, the model will not need to rerun.
-  hash_long <- digest::digest(eval(object, envir = envir))
+  hash_long <- digest::digest(eval(object, envir = env))
   hash <- substr(hash_long, 1, 8)
   name_hash <- paste(name, hash, sep = "_")
   tar_prep <-
@@ -70,7 +69,8 @@ tar_nlmixr_multimodel_single <- function(object, name, data, est, control, table
       control = control,
       table = table,
       object_simple_name = paste0(name_hash, "_osimple"),
-      data_simple_name = paste0(name_hash, "_dsimple")
+      data_simple_name = paste0(name_hash, "_dsimple"),
+      env = env
     )
   list(
     target = tar_prep,

tests/testthat/test-tar_nlmixr.R

@@ -114,3 +114,111 @@ targets::tar_test("tar_nlmixr handling with initial conditions central(initial)"
     inherits(tar_read(pheno_model), "nlmixr2FitCore")
   )
 })
+
+targets::tar_test("tar_nlmixr handling with initial conditions central(0), without running the target", {
+  pheno <- function() {
+    ini({
+      lcl <- log(0.008); label("Typical value of clearance")
+      lvc <-  log(0.6); label("Typical value of volume of distribution")
+      etalcl + etalvc ~ c(1,
+                          0.01, 1)
+      cpaddSd <- 0.1; label("residual variability")
+    })
+    model({
+      cl <- exp(lcl + etalcl)
+      vc <- exp(lvc + etalvc)
+      kel <- cl/vc
+      d/dt(central) <- -kel*central
+      cp <- central/vc
+      central(0) <- 0
+      cp ~ add(cpaddSd)
+    })
+  }
+
+  nlmixr2targets::tar_nlmixr(
+    name=pheno_model,
+    object=pheno,
+    data=nlmixr2data::pheno_sd,
+    est="saem",
+    # Minimize time spent
+    control=nlmixr2est::saemControl(nBurn=1, nEm=1)
+  )
+
+  expect_s3_class(pheno, "rxUi")
+})
+
+targets::tar_test("tar_nlmixr handling with initial conditions central(0) including model piping, without running the target", {
+  pheno <- function() {
+    ini({
+      lcl <- log(0.008); label("Typical value of clearance")
+      lvc <-  log(0.6); label("Typical value of volume of distribution")
+      etalcl + etalvc ~ c(1,
+                          0.01, 1)
+      cpaddSd <- 0.1; label("residual variability")
+    })
+    model({
+      cl <- exp(lcl + etalcl)
+      vc <- exp(lvc + etalvc)
+      kel <- cl/vc
+      d/dt(central) <- -kel*central
+      cp <- central/vc
+      central(0) <- 0
+      cp ~ add(cpaddSd)
+    })
+  }
+
+  nlmixr2targets::tar_nlmixr(
+    name=pheno_model,
+    object=pheno |> ini(lcl = log(0.1)),
+    data=nlmixr2data::pheno_sd,
+    est="saem",
+    # Minimize time spent
+    control=nlmixr2est::saemControl(nBurn=1, nEm=1)
+  )
+
+  expect_s3_class(pheno, "rxUi")
+})
+
+# targets::tar_test() runs the test code inside a temporary directory
+# to avoid accidentally writing to the user's file space.
+targets::tar_test("tar_nlmixr handling with initial conditions central(0), with running the target", {
+  targets::tar_script({
+    pheno <- function() {
+      ini({
+        lcl <- log(0.008); label("Typical value of clearance")
+        lvc <-  log(0.6); label("Typical value of volume of distribution")
+        etalcl + etalvc ~ c(1,
+                            0.01, 1)
+        cpaddSd <- 0.1; label("residual variability")
+      })
+      model({
+        cl <- exp(lcl + etalcl)
+        vc <- exp(lvc + etalvc)
+        kel <- cl/vc
+        d/dt(central) <- -kel*central
+        cp <- central/vc
+        central(0) <- 0
+        cp ~ add(cpaddSd)
+      })
+    }
+
+    nlmixr2targets::tar_nlmixr(
+      name=pheno_model,
+      object=pheno,
+      data=nlmixr2data::pheno_sd,
+      est="saem",
+      # Minimize time spent
+      control=nlmixr2est::saemControl(nBurn=1, nEm=1)
+    )
+  })
+  expect_equal(
+    targets::tar_outdated(callr_function = NULL),
+    c("pheno_model_tar_object_simple", "pheno_model_tar_data_simple", "pheno_model")
+  )
+  suppressWarnings(targets::tar_make(callr_function = NULL))
+  # A successful model estimation step should return an nlmixr2FitCore object
+  # (testing of model results is outside the scope of nlmixr2targets)
+  expect_true(
+    inherits(tar_read(pheno_model), "nlmixr2FitCore")
+  )
+})

tests/testthat/test-tar_nlmixr_multimodel.R

@@ -109,3 +109,63 @@ test_that("tar_nlmixr_multimodel works with long model names", {
     )
   expect_true(inherits(target_list, "list"))
 })
+
+test_that("tar_nlmixr_multimodel works with initial condition setting `central(0) <- 0`", {
+  pheno <- function() {
+    ini({
+      lcl <- log(0.008); label("Typical value of clearance")
+      lvc <-  log(0.6); label("Typical value of volume of distribution")
+      etalcl + etalvc ~ c(1,
+                          0.01, 1)
+      cpaddSd <- 0.1; label("residual variability")
+    })
+    model({
+      cl <- exp(lcl + etalcl)
+      vc <- exp(lvc + etalvc)
+      kel <- cl/vc
+      d/dt(central) <- -kel*central
+      central(0) <- 0
+      cp <- central/vc
+      cp ~ add(cpaddSd)
+    })
+  }
+
+  target_list <-
+    tar_nlmixr_multimodel(
+      name = foo, data = nlmixr2data::pheno_sd, est = "saem",
+      "my first model" = pheno
+    )
+  expect_s3_class(pheno, "rxUi")
+})
+
+targets::tar_test("tar_nlmixr_multimodel works with initial condition setting `central(0) <- 0`, running the targets", {
+  targets::tar_script({
+    pheno <- function() {
+      ini({
+        lcl <- log(0.008); label("Typical value of clearance")
+        lvc <-  log(0.6); label("Typical value of volume of distribution")
+        etalcl + etalvc ~ c(1,
+                            0.01, 1)
+        cpaddSd <- 0.1; label("residual variability")
+      })
+      model({
+        cl <- exp(lcl + etalcl)
+        vc <- exp(lvc + etalvc)
+        kel <- cl/vc
+        d/dt(central) <- -kel*central
+        central(0) <- 0
+        cp <- central/vc
+        cp ~ add(cpaddSd)
+      })
+    }
+
+    target_list <-
+      tar_nlmixr_multimodel(
+        name = foo, data = nlmixr2data::pheno_sd, est = "saem",
+        "my first model" = pheno
+      )
+  })
+  # This is really testing that there was no error when running the targets due
+  # to the `central(0) <- 0` line
+  expect_type(targets::tar_outdated(callr_function = NULL), "character")
+})

vignettes/estimating.Rmd

@@ -33,16 +33,6 @@ Using `nlmixr2targets` requires the use of the `targets` package.  To learn
 about the `targets` package, see
 (https://docs.ropensci.org/targets/)[the targets website].
 
-# Model modifications to use `nlmixr2targets`
-
-When running a model with `nlmixr2targets`, it must be interpretable by the
-`targets` package.  The only notable issue comes from setting initial conditions
-for a compartment, such as using `pd(0) <- initialConc`.  The reason this
-doesn't work is the `targets` package does not allow the assignment into zero.
-So, for any initial conditions, you will need to set them with `initial` instead
-of `0`.  The example above would be `pd(initial) <- initialConc`, and
-`nlmixr2targets` will convert it to the model `nlmixr2` expects for you.
-
 # Running one model with one dataset (`tar_nlmixr()`)
 
 The `tar_nlmixr()` function allows you to estimate one model with one dataset.