diff --git a/R/rxUiGet.R b/R/rxUiGet.R index 2e4c79a71..d132d3c03 100644 --- a/R/rxUiGet.R +++ b/R/rxUiGet.R @@ -25,10 +25,20 @@ #' @export `$.rxUi` <- function(obj, arg, exact = TRUE) { # need to assign environment correctly for UDF - rxode2parse::.udfEnvSet(parent.frame(1)) - # Keep it locked to avoid environment nesting nightmare - rxode2parse::.udfEnvLock() - on.exit(rxode2parse::.udfEnvLock(FALSE)) + # + # The model() and rxode2() assign the parent environments for UDF + # parsing, if the object is in that environment lock it and then + # unlock on exit + if (rxode2parse::.udfEnvLockIfExists(obj)) { + # If locked unlock when exiting + on.exit(rxode2parse::.udfEnvLock(FALSE)) + } else if (!rxode2parse::.udfEnvLock(NULL)) { + ## unlocked, look for object in parent frame until global or empty environment + if (rxode2parse::.udfEnvLockIfExists(obj, parent.frame(1))) { + # if locked by this, unlock when exiting + on.exit(rxode2parse::.udfEnvLock(FALSE)) + } + } rxUiGet(.uiToRxUiGet(obj=obj, arg=arg, exact=exact)) } diff --git a/R/ui.R b/R/ui.R index 2cb51aa18..c6f26a7f3 100644 --- a/R/ui.R +++ b/R/ui.R @@ -276,7 +276,11 @@ model <- function(x, ..., append=FALSE, auto=getOption("rxode2.autoVarPiping", T cov=NULL, envir=parent.frame()) { if (is(substitute(x), "{")) { .funName <- try(as.character(as.list(with(envir, match.call()))[[1]]), silent=TRUE) - if (inherits(.funName, "try-error")) .funName <- NULL + if (inherits(.funName, "try-error")){ + .funName <- NULL + } else if (any(.funName == ls(envir=parent.env(envir), all=TRUE))) { + rxode2parse::.udfEnvSet(parent.env(envir)) + } .ini <- .lastIni .iniQ <- .lastIniQ if (is.null(.ini)) { @@ -427,7 +431,7 @@ print.rxUi <-function(x, ...) { #' f <- rxUiCompress(f) #' print(class(f)) #' print(is.environment(f)) -#' +#' rxUiDecompress <- function(ui) { if (!inherits(ui, "rxUi")) return(ui) if (is.environment(ui)) return(ui) diff --git a/tests/testthat/test-udf.R b/tests/testthat/test-udf.R index d0e1fad8c..7360f0f87 100644 --- a/tests/testthat/test-udf.R +++ b/tests/testthat/test-udf.R @@ -225,4 +225,72 @@ rxTest({ expect_error(rxFun2c(udf)$cCode) }) + + test_that("udf with model functions", { + + gg <- function(x, y) { + x/y + } + + # Step 1 - Create a model specification + f <- function() { + ini({ + KA <- .291 + CL <- 18.6 + V2 <- 40.2 + Q <- 10.5 + V3 <- 297.0 + Kin <- 1.0 + Kout <- 1.0 + EC50 <- 200.0 + }) + model({ + # A 4-compartment model, 3 PK and a PD (effect) compartment + # (notice state variable names 'depot', 'centr', 'peri', 'eff') + C2 <- gg(centr, V2) + C3 <- peri/V3 + d/dt(depot) <- -KA*depot + d/dt(centr) <- KA*depot - CL*C2 - Q*C2 + Q*C3 + d/dt(peri) <- Q*C2 - Q*C3 + d/dt(eff) <- Kin - Kout*(1-C2/(EC50+C2))*eff + eff(0) <- 1 + }) + } + + u <- f() + + # this pre-compiles and displays the simulation model + u$simulationModel + + # Step 2 - Create the model input as an EventTable, + # including dosing and observation (sampling) events + + # QD (once daily) dosing for 5 days. + + qd <- eventTable(amount.units = "ug", time.units = "hours") + qd$add.dosing(dose = 10000, nbr.doses = 5, dosing.interval = 24) + + # Sample the system hourly during the first day, every 8 hours + # then after + + qd$add.sampling(0:24) + qd$add.sampling(seq(from = 24 + 8, to = 5 * 24, by = 8)) + + # Step 3 - set starting parameter estimates and initial + # values of the state + + # Step 4 - Fit the model to the data + expect_error(suppressWarnings(solve(u, qd)), NA) + + u1 <- u$simulationModel + + expect_error(suppressWarnings(solve(u1, qd)), NA) + + u2 <- u$simulationIniModel + expect_error(suppressWarnings(solve(u2, qd)), NA) + + expect_error(suppressWarnings(rxSolve(f, qd)), NA) + }) + + })