tar_nlmixr now reassigns the original data back into the fit

nlmixr2 · Mar 17, 2024 · a59fcd9 · a59fcd9
1 parent dabb708
commit a59fcd9
Show file tree

Hide file tree

Showing 5 changed files with 89 additions and 92 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+export(assign_origData)
 export(nlmixr_data_simplify)
 export(nlmixr_object_simplify)
 export(tar_nlmixr)

diff --git a/R/tar_nlmixr.R b/R/tar_nlmixr.R
@@ -63,15 +63,18 @@ tar_nlmixr <- function(name, object, data, est = NULL, control = list(), table =
     table = substitute(table),
     object_simple_name = paste(name_parsed, "object_simple", sep = "_tar_"),
     data_simple_name = paste(name_parsed, "data_simple", sep = "_tar_"),
+    fit_simple_name = paste(name_parsed, "fit_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
+#' @param object_simple_name,data_simple_name,fit_simple_name target names to
+#'   use for the simplified object, simplified data, fit of the simplified
+#'   object with the simplified data, and fit with the original data
+#'   re-inserted.
 #' @export
-tar_nlmixr_raw <- function(name, object, data, est, control, table, object_simple_name, data_simple_name, env) {
+tar_nlmixr_raw <- function(name, object, data, est, control, table, object_simple_name, data_simple_name, fit_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)
@@ -86,7 +89,7 @@ tar_nlmixr_raw <- function(name, object, data, est, control, table, object_simpl
           nlmixr_object_simplify(object = object),
           list(object = object)
         ),
-      packages = "nlmixr2est"
+      packages = c("nlmixr2targets", "nlmixr2est")
     ),
     targets::tar_target_raw(
       name = data_simple_name,
@@ -98,10 +101,11 @@ tar_nlmixr_raw <- function(name, object, data, est, control, table, object_simpl
             data = data,
             table = table
           )
-        )
+        ),
+      packages = "nlmixr2targets"
     ),
     targets::tar_target_raw(
-      name = name,
+      name = fit_simple_name,
       command =
         substitute(
           nlmixr2est::nlmixr(
@@ -119,6 +123,18 @@ tar_nlmixr_raw <- function(name, object, data, est, control, table, object_simpl
           )
         ),
       packages = "nlmixr2est"
+    ),
+    targets::tar_target_raw(
+      name = name,
+      command =
+        substitute(
+          assign_origData(fit = fit, data = data),
+          list(
+            fit = as.name(fit_simple_name),
+            data = data
+          )
+        ),
+      packages = "nlmixr2targets"
     )
   )
 }
@@ -147,3 +163,21 @@ set_env_object_noinitial <- function(object, env) {
   # it or its sub-objects.
   NULL
 }
+
+#' Replace the fit data with the original data, then return the modified fit
+#'
+#' This function is intended for use within `nlmixr2targets` target creation,
+#' and it's not typically invoked by users.
+#'
+#' @param fit an estimated `nlmixr2` object
+#' @param data the data from the original fit
+#' @returns The fit with the data added back in as `fit$env$origData`
+#' @keywords Internal
+#' @export
+assign_origData <- function(fit, data) {
+  # The data being replaced must have the same number of rows as the original
+  # data
+  checkmate::assert_data_frame(data, nrows = nrow(fit$env$origData))
+  assign(x = "origData", value = data, envir = fit$env)
+  fit
+}
diff --git a/man/assign_origData.Rd b/man/assign_origData.Rd
diff --git a/man/tar_nlmixr.Rd b/man/tar_nlmixr.Rd
diff --git a/tests/testthat/test-tar_nlmixr.R b/tests/testthat/test-tar_nlmixr.R
@@ -32,6 +32,7 @@ test_that("tar_nlmixr expected errors", {
 # to avoid accidentally writing to the user's file space.
 targets::tar_test("tar_nlmixr execution", {
   targets::tar_script({
+    library(nlmixr2targets)
     pheno <- function() {
       ini({
         lcl <- log(0.008); label("Typical value of clearance")
@@ -60,58 +61,32 @@ targets::tar_test("tar_nlmixr execution", {
     )
   })
   expect_equal(
-    targets::tar_outdated(callr_function = NULL),
-    c("pheno_model_tar_object_simple", "pheno_model_tar_data_simple", "pheno_model")
+    targets::tar_manifest()$name,
+    c("pheno_model_tar_object_simple", "pheno_model_tar_data_simple", "pheno_model_tar_fit_simple", "pheno_model")
   )
-  suppressWarnings(targets::tar_make(callr_function = NULL))
+  suppressMessages(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_s3_class(targets::tar_read(pheno_model_tar_object_simple), class = "rxUi")
+  expect_s3_class(targets::tar_read(pheno_model_tar_data_simple), class = "data.frame")
   expect_true(
-    inherits(tar_read(pheno_model), "nlmixr2FitCore")
+    inherits(targets::tar_read(pheno_model_tar_fit_simple), "nlmixr2FitCore")
   )
-})
-
-# 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(initial)", {
-  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(initial) <- 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_true(
+    inherits(targets::tar_read(pheno_model), "nlmixr2FitCore")
+  )
+  # tar_nlmixr sets the original data back into the object (#17)
+  expect_false(
+    identical(
+      tar_read(pheno_model_tar_fit_simple)$env$origData,
+      tar_read(pheno_model)$env$origData
     )
-  })
-  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")
+  expect_equal(
+    tar_read(pheno_model)$env$origData,
+    nlmixr2data::pheno_sd
   )
 })
 
@@ -212,8 +187,8 @@ targets::tar_test("tar_nlmixr handling with initial conditions central(0), with
     )
   })
   expect_equal(
-    targets::tar_outdated(callr_function = NULL),
-    c("pheno_model_tar_object_simple", "pheno_model_tar_data_simple", "pheno_model")
+    targets::tar_manifest()$name,
+    c("pheno_model_tar_object_simple", "pheno_model_tar_data_simple", "pheno_model_tar_fit_simple", "pheno_model")
   )
   suppressWarnings(targets::tar_make(callr_function = NULL))
   # A successful model estimation step should return an nlmixr2FitCore object
@@ -222,40 +197,3 @@ targets::tar_test("tar_nlmixr handling with initial conditions central(0), with
     inherits(tar_read(pheno_model), "nlmixr2FitCore")
   )
 })
-
-# 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 sets the original data back into the object (#17)", {
-  targets::tar_script({
-    library(nlmixr2targets)
-    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)
-    )
-  })
-  targets::tar_make()
-  expect_equal(targets::tar_read(pheno_model)$env$origData, nlmixr2data::pheno_sd)
-})