Add ui function $ support

nlmixr2 · Nov 1, 2023 · 9c1b1df · 9c1b1df
1 parent a210d84
commit 9c1b1df
Show file tree

Hide file tree

Showing 3 changed files with 88 additions and 6 deletions.
diff --git 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
@@ -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
@@ -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)
+  })
+
+
 })