Merge pull request #21 from nlmixr2/17-put-the-original-data-into-the…

…-final-fit-model

Put the original data into the final fit model

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)

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
+}

R/tar_nlmixr_multimodel.R

@@ -70,6 +70,7 @@ tar_nlmixr_multimodel_single <- function(object, name, data, est, control, table
       table = table,
       object_simple_name = paste0(name_hash, "_osimple"),
       data_simple_name = paste0(name_hash, "_dsimple"),
+      fit_simple_name = paste0(name_hash, "_fitsimple"),
       env = env
     )
   list(

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

tests/testthat/test-tar_nlmixr_multimodel.R

@@ -45,9 +45,9 @@ test_that("tar_nlmixr_multimodel", {
   # One for each model and then one for combining everything
   expect_length(target_list, 3)
   # Data and object simplification, then the fitting
-  expect_length(target_list[[1]], 3)
+  expect_length(target_list[[1]], 4)
   # Data and object simplification, then the fitting
-  expect_length(target_list[[2]], 3)
+  expect_length(target_list[[2]], 4)
   # Combine the fit models as a single step
   expect_s3_class(target_list[[3]], "tar_stem")
   expect_equal(target_list[[3]]$settings$name, "foo")
@@ -59,8 +59,8 @@ test_that("tar_nlmixr_multimodel", {
   expect_equal(names(collating_call), c("", "my first model", "my second model"))
 
   # Verify the targets created are the ones being collated
-  expect_equal(collating_call[[2]], as.name(target_list[[1]][[3]]$settings$name))
-  expect_equal(collating_call[[3]], as.name(target_list[[2]][[3]]$settings$name))
+  expect_equal(collating_call[[2]], as.name(target_list[[1]][[4]]$settings$name))
+  expect_equal(collating_call[[3]], as.name(target_list[[2]][[4]]$settings$name))
 })
 
 test_that("tar_nlmixr_multimodel works with long model names", {