diff --git a/R/tar_nlmixr.R b/R/tar_nlmixr.R index ec17c62..7e7bad2 100644 --- a/R/tar_nlmixr.R +++ b/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,7 +62,8 @@ 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 ) } @@ -68,17 +71,20 @@ tar_nlmixr <- function(name, object, data, est = NULL, control = list(), table = #' @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 +} diff --git a/R/tar_nlmixr_multimodel.R b/R/tar_nlmixr_multimodel.R index 7d0dead..2fc3c01 100644 --- a/R/tar_nlmixr_multimodel.R +++ b/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, diff --git a/man/tar_nlmixr.Rd b/man/tar_nlmixr.Rd index bba3a6f..3b6fd69 100644 --- a/man/tar_nlmixr.Rd +++ b/man/tar_nlmixr.Rd @@ -11,7 +11,8 @@ tar_nlmixr( data, est = NULL, control = list(), - table = nlmixr2est::tableControl() + table = nlmixr2est::tableControl(), + env = parent.frame() ) tar_nlmixr_raw( @@ -22,7 +23,8 @@ tar_nlmixr_raw( control, table, object_simple_name, - data_simple_name + data_simple_name, + env ) } \arguments{ @@ -55,6 +57,9 @@ to be different for each type of estimation method} \item{table}{The output table control object (like `tableControl()`)} +\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} } diff --git a/man/tar_nlmixr_multimodel.Rd b/man/tar_nlmixr_multimodel.Rd index 67ebc03..767d008 100644 --- a/man/tar_nlmixr_multimodel.Rd +++ b/man/tar_nlmixr_multimodel.Rd @@ -11,7 +11,7 @@ tar_nlmixr_multimodel( est, control = list(), table = nlmixr2est::tableControl(), - envir = parent.frame() + env = parent.frame() ) } \arguments{ @@ -44,8 +44,8 @@ to be different for each type of estimation method} \item{table}{The output table control object (like `tableControl()`)} -\item{envir}{The environment where models are defined (usually doesn't need -to be modified)} +\item{env}{The environment where the model is setup (not needed for typical +use)} } \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 599032f..9b66f48 100644 --- a/tests/testthat/test-tar_nlmixr.R +++ b/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") + ) +}) diff --git a/tests/testthat/test-tar_nlmixr_multimodel.R b/tests/testthat/test-tar_nlmixr_multimodel.R index 8abc0d7..7a0fa3f 100644 --- a/tests/testthat/test-tar_nlmixr_multimodel.R +++ b/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") +}) diff --git a/vignettes/estimating.Rmd b/vignettes/estimating.Rmd index dce819b..5bec88c 100644 --- a/vignettes/estimating.Rmd +++ b/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.