Merge pull request #746 from nlmixr2/745-model-extract-does-not-work-…

…on-model-properties 745 model extract does not work on model properties
nlmixr2 · Jul 31, 2024 · 2d1e96a · 2d1e96a
2 parents 1ec26fa + d74550f
commit 2d1e96a
Show file tree

Hide file tree

Showing 3 changed files with 81 additions and 12 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -29,6 +29,8 @@
 
 - Fix `ui$params` when the ui is a linear compartment model without `ka` defined.
 
+- Model extraction `modelExtract()` will now extract model properties.  Note that the model property of `alag(cmt)` and `lag(cmt)` will give the same value. See #745
+
 ## Big change
 
 - At the request of CRAN, combine `rxode2parse`, `rxode2random`, and

diff --git a/R/modelExtract.R b/R/modelExtract.R
@@ -12,7 +12,7 @@
 #' @param endpoint include endpoint.  This can be:
 #'
 #'  - `NA`    -- Missing means include both the endpoint and non-endpoint lines
-#' 
+#'
 #'  - `TRUE`  -- Only include endpoint lines
 #'
 #'  - `FALSE` -- Only include non-endpoint lines
@@ -27,9 +27,9 @@
 #'   lines
 #'
 #' @export
-#' 
+#'
 #' @author Matthew L. Fidler
-#' 
+#'
 #' @examples
 #'
 #' one.compartment <- function() {
@@ -73,7 +73,7 @@ modelExtract <- function(x, ..., expression=FALSE, endpoint=FALSE, lines=FALSE,
   UseMethod("modelExtract")
 }
 #' Common extract model lines
-#'  
+#'
 #' @param modelLines Model lines, in this case it is the variables
 #' @param rxui rxode2 parsed ui
 #' @param expression Should an expression list be returned
@@ -92,12 +92,13 @@ modelExtract <- function(x, ..., expression=FALSE, endpoint=FALSE, lines=FALSE,
   } else {
     .ret <- do.call(`c`, lapply(seq_along(modelLines),
                                 function(i) {
-                                  .w <- .getModelLineFromExpression(modelLines[[i]], rxui, errorLine=FALSE,
+                                  .w <- .getModelLineFromExpression(modelLines[[i]],
+                                                                    rxui, errorLine=FALSE,
                                                                     returnAllLines=TRUE)
                                   .w <- .w[.w>0]
                                   .w
                                 }))
-    
+
   }
   .ret <- sort(unique(.ret))
   .endPointLines <- rxui$predDf
@@ -135,7 +136,10 @@ modelExtract <- function(x, ..., expression=FALSE, endpoint=FALSE, lines=FALSE,
 #' @author Matthew L. Fidler
 .quoteCallVars <- function(callInfo, ..., envir=parent.frame()) {
   if (length(callInfo) == 0L) return(NULL)
-  lapply(seq_along(callInfo),
+  .env <- new.env(parent=emptyenv())
+  .env$alag <- list()
+  .env$lag <- list()
+  c(lapply(seq_along(callInfo),
          function(i) {
            .name <- names(callInfo)[i]
            .cur <- callInfo[[i]]
@@ -167,12 +171,28 @@ modelExtract <- function(x, ..., expression=FALSE, endpoint=FALSE, lines=FALSE,
            if (is.name(.cur)) {
              return(str2lang(paste0("-",deparse1(.cur))))
            } else if (is.call(.cur) &&
-                        .matchesLangTemplate(.cur, str2lang("d/dt(.name)"))) {
+                        (.matchesLangTemplate(.cur, str2lang("d/dt(.name)")) ||
+                           .matchesLangTemplate(.cur, str2lang("f(.name)")) ||
+                           .matchesLangTemplate(.cur, str2lang(".name(0)")) ||
+                           .matchesLangTemplate(.cur, str2lang("rate(.name)")) ||
+                           .matchesLangTemplate(.cur, str2lang("dur(.name)")))) {
+             return(str2lang(paste0("-", deparse1(.cur))))
+           } else if (is.call(.cur) &&
+                        .matchesLangTemplate(.cur, str2lang("alag(.name)"))) {
+             .env$lag <- c(.env$lag,
+                           list(str2lang(paste0("-", sub("alag", "lag", deparse1(.cur))))))
+              return(str2lang(paste0("-", deparse1(.cur))))
+           } else if (is.call(.cur) &&
+                        .matchesLangTemplate(.cur, str2lang("lag(.name)"))) {
+             .env$alag <- c(.env$alag,
+                            list(str2lang(paste0("-", sub("lag", "alag", deparse1(.cur))))))
              return(str2lang(paste0("-", deparse1(.cur))))
            }
            stop("unknown variable expression: ", deparse1(.cur),
                 call.=FALSE)
-         })
+         }),
+    .env$alag,
+    .env$lag)
 }
 
 #' @export
@@ -206,4 +226,3 @@ modelExtract.default <- function(x, ..., expression=FALSE, endpoint=FALSE, lines
   stop("rxode2 does not know how to handle this modelExtract object",
        call.=FALSE)
 }
-
diff --git a/tests/testthat/test-ui-modelExtract.R b/tests/testthat/test-ui-modelExtract.R
@@ -5,6 +5,7 @@ test_that("modelExtract and related functions", {
       tka <- 0.45 # Log Ka
       tcl <- 1 # Log Cl
       tv <- 3.45    # Log V
+      fDepot <-1
       eta.ka ~ 0.6
       eta.cl ~ 0.3
       eta.v ~ 0.1
@@ -15,6 +16,11 @@ test_that("modelExtract and related functions", {
       cl <- exp(tcl + eta.cl)
       v <- exp(tv + eta.v)
       d/dt(depot) = -ka * depot
+      f(depot) <- fDepot
+      depot(0) <- fDepot
+      dur(depot) <- fDepot
+      rate(depot) <- fDepot
+      lag(depot) <- fDepot
       d/dt(center) = ka * depot - cl / v * center
       cp = center / v
       cp ~ add(add.sd)
@@ -32,10 +38,52 @@ test_that("modelExtract and related functions", {
   expect_equal(modelExtract(f, tmp$tmp),
                "d/dt(center) = ka * depot - cl/v * center")
 
+
   tmp <- list(tmp=list(tmp="d/dt(center)"))
   expect_equal(modelExtract(f, tmp$tmp$tmp),
                "d/dt(center) = ka * depot - cl/v * center")
 
+  expect_equal(modelExtract(f, "f(depot)"),
+               "f(depot) <- fDepot")
+
+  expect_equal(modelExtract(f, "alag(depot)"),
+               "lag(depot) <- fDepot")
+
+  expect_equal(modelExtract(f, "lag(depot)"),
+               "lag(depot) <- fDepot")
+
+  expect_equal(modelExtract(f, "dur(depot)"),
+               "dur(depot) <- fDepot")
+
+  expect_equal(modelExtract(f, "rate(depot)"),
+               "rate(depot) <- fDepot")
+
+  expect_equal(modelExtract(f, "depot(0)"),
+               "depot(0) <- fDepot")
+
+  one.compartment <- function() {
+    ini({
+      tka <- 0.45 # Log Ka
+      tcl <- 1 # Log Cl
+      tv <- 3.45    # Log V
+      eta.ka ~ 0.6
+      eta.cl ~ 0.3
+      eta.v ~ 0.1
+      add.sd <- 0.7
+    })
+    model({
+      ka <- exp(tka + eta.ka)
+      cl <- exp(tcl + eta.cl)
+      v <- exp(tv + eta.v)
+      d/dt(depot) = -ka * depot
+      d/dt(center) = ka * depot - cl / v * center
+      cp = center / v
+      cp ~ add(add.sd)
+    })
+  }
+
+  f <- one.compartment()
+
   expect_equal(modelExtract(f, endpoint=NA, lines=TRUE, expression=TRUE),
                structure(list(quote(ka <- exp(tka + eta.ka)),
                               quote(cl <- exp(tcl + eta.cl)),
@@ -45,7 +93,7 @@ test_that("modelExtract and related functions", {
                               str2lang("cp = center/v"),
                               quote(cp ~ add(add.sd))),
                          lines = 1:7))
-  
+
   expect_equal(modelExtract(f, "ka", expression=FALSE, endpoint=FALSE, lines=TRUE),
                structure("ka <- exp(tka + eta.ka)", lines = 1L))
 
@@ -85,7 +133,7 @@ test_that("modelExtract and related functions", {
       cp ~ add(add.sd)
     })
   }
-  
+
   expect_equal(modelExtract(one.compartment, "cl", expression=FALSE, endpoint=FALSE),
                c("cl <- tcl", "cl <- cl * exp(eta.cl)"))