From 7dc72448e6685eefe04ee21b411893d356a42238 Mon Sep 17 00:00:00 2001
From: "Matthew L. Fidler" <matthew.fidler@gmail.com>
Date: Thu, 30 Nov 2023 11:58:44 -0600
Subject: [PATCH] Add rxui control (and test for it too)

---
 R/rxsolve.R                    | 28 ++++++++++++++++++--
 tests/testthat/test-rxui-ctl.R | 48 ++++++++++++++++++++++++++++++++++
 2 files changed, 74 insertions(+), 2 deletions(-)
 create mode 100644 tests/testthat/test-rxui-ctl.R

diff --git a/R/rxsolve.R b/R/rxsolve.R
index ff76c83e3..b38150bb4 100644
--- a/R/rxsolve.R
+++ b/R/rxsolve.R
@@ -1146,10 +1146,33 @@ rxSolve.function <- function(object, params = NULL, events = NULL, inits = NULL,
                        list(theta = theta, eta = eta, envir=envir)))
 }
 
+.uiRxControl <- function(ui, params = NULL, events = NULL, inits = NULL, ...,
+                         theta = NULL, eta = NULL) {
+  .ctl <- rxControl()
+  .meta <- get("meta", ui)
+  .lst <- list(...)
+  .nlst <- names(.lst)
+  .w <- which(vapply(names(.ctl), function(x) {
+    !(x %in% names(.nlst)) && exists(x, envir=.meta)
+  }, logical(1), USE.NAMES=FALSE))
+  .extra <- NULL
+  if (length(.w) > 0) {
+    .v <- names(.ctl)[.w]
+    .minfo(paste0("rxControl items read from fun: '",
+           paste(.v, collapse="', '"), "'"))
+    .extra <- setNames(lapply(.v, function(x) {
+      get(x, envir=.meta)
+    }), .v)
+  }
+  do.call(rxSolve, c(list(NULL, params = NULL, events = NULL, inits = NULL),
+                     .lst, .extra,
+                     list(theta=theta, eta=eta)))
+}
+
 .rxSolveFromUi <- function(object, params = NULL, events = NULL, inits = NULL, ...,
                            theta = NULL, eta = NULL) {
-  .rxControl <- rxSolve(NULL, params = params, events = events, inits = inits, ...,
-                        theta = theta, eta = eta)
+  .rxControl <- .uiRxControl(object, params = params, events = events, inits = inits, ...,
+                             theta = theta, eta=eta)
   if (rxIs(params, "rx.event")) {
     if (!is.null(events)) {
       .tmp <- events
@@ -2065,6 +2088,7 @@ odeMethodToInt <- function(method = c("liblsoda", "lsoda", "dop853", "indLin"))
 }
 
 
+
 #' This updates the tolerances based on the sensitivity equations
 #'
 #' This assumes the normal ODE equations are the first equations and
diff --git a/tests/testthat/test-rxui-ctl.R b/tests/testthat/test-rxui-ctl.R
new file mode 100644
index 000000000..619bb2078
--- /dev/null
+++ b/tests/testthat/test-rxui-ctl.R
@@ -0,0 +1,48 @@
+rxTest({
+  test_that("get information from rxUi", {
+
+    ## Test mixed solved and ODEs
+    mod2 <- function() {
+      sigma <- lotri({
+        err1 ~ 0.05
+        err2 ~ 0.05
+      })
+      ini({
+        KA = 2.94E-01
+        TCL = 1.86E+01
+        V2 = 4.02E+01
+        Q = 1.05E+01
+        V3 = 2.97E+02
+        Kin = 1
+        Kout = 1
+        EC50 = 200
+        eta.Cl ~ 0.2
+      })
+      model({
+        ## the order of variables do not matter, the type of compartmental
+        ## model is determined by the parameters specified.
+        CL <- TCL * exp(eta.Cl)
+        C2 <- linCmt(KA, CL, V2, Q, V3)
+        eff(0) <- 1 ## This specifies that the effect compartment starts at 1.
+        d/dt(eff) <- Kin - Kout * (1 - C2 / (EC50 + C2)) * eff
+        ##
+        resp <- eff + err1
+        pk <- C2 * exp(err2)
+      })
+    }
+
+    f <- mod2()
+
+    ev <- eventTable() %>%
+      add.dosing(dose = 10000, nbr.doses = 10, dosing.interval = 12, dosing.to = 2) %>%
+      add.dosing(dose = 20000, nbr.doses = 5, start.time = 120, dosing.interval = 24, dosing.to = 2) %>%
+      add.sampling(0:240)
+
+    ev <- ev %>% et(0.5, evid = 2)
+
+    pk4 <- rxSolve(f, events=ev, nSub=4, cores = 1, addDosing = TRUE)
+    expect_true(inherits(pk4, "rxSolve"))
+
+  })
+
+})