diff --git a/NAMESPACE b/NAMESPACE index 42acca6..9b516e9 100644 --- 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 index 7e7bad2..e243b05 100644 --- 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 new file mode 100644 index 0000000..44068a3 --- /dev/null +++ b/man/assign_origData.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tar_nlmixr.R +\name{assign_origData} +\alias{assign_origData} +\title{Replace the fit data with the original data, then return the modified fit} +\usage{ +assign_origData(fit, data) +} +\arguments{ +\item{fit}{an estimated \code{nlmixr2} object} + +\item{data}{the data from the original fit} +} +\value{ +The fit with the data added back in as \code{fit$env$origData} +} +\description{ +This function is intended for use within \code{nlmixr2targets} target creation, +and it's not typically invoked by users. +} +\keyword{Internal} diff --git a/man/tar_nlmixr.Rd b/man/tar_nlmixr.Rd index 3b6fd69..3f21241 100644 --- a/man/tar_nlmixr.Rd +++ b/man/tar_nlmixr.Rd @@ -24,6 +24,7 @@ tar_nlmixr_raw( table, object_simple_name, data_simple_name, + fit_simple_name, env ) } @@ -60,8 +61,10 @@ to be different for each type of estimation method} \item{env}{The environment where the model is setup (not needed for typical use)} -\item{object_simple_name, data_simple_name}{target names to use for the object -and data} +\item{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.} } \value{ A list of targets for the model simplification, data simplification, diff --git a/tests/testthat/test-tar_nlmixr.R b/tests/testthat/test-tar_nlmixr.R index 0905e06..20e4e3f 100644 --- 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) -})