Merge pull request #546 from nlmixr2/542-allow-an-$-operator-to-autom…

…atically-evaluate-the-expression-for-model-piping

Fix/test $

R/piping.R

@@ -19,15 +19,15 @@
 #' Expand the quoted lines to include relevant lines from UI
 #'
 #' @param cur This is the current piped in `rxUi` interface
-#' 
+#'
 #' @param iniDf This is the ini data frame from the prior ui
 #'
 #' @param charExpression character vector of the current expression
-#' 
+#'
 #' @return `NULL` if there is no lines to add OR a list of the lines
 #'   from the `cur` UI removing parameters that are not in the
 #'   destination `ini()`
-#' 
+#'
 #' @author Matthew L Fidler
 #' @noRd
 .quoteExpandRxUi <- function(cur, iniDf, charExpression) {
@@ -121,15 +121,15 @@
 #' This expands a list of expressions
 #'
 #' @param lines These are the expressions as a list
-#' 
+#'
 #' @param bracketsOrCs This is the indicator of the bracket lines ie
 #'   `{}` or concatenations ie `c()`, that are expanded
-#' 
+#'
 #' @param iniDf initial conditions from the previous/parent rxUi
-#' 
+#'
 #' @return Single list of expressions; `a=b` becomes `a<-b` in this
 #'   expression
-#' 
+#'
 #' @author Matthew L. Fidler
 #' @noRd
 .quoteExpandBracketsOrCs <- function(lines, bracketsOrCs, envir=envir, iniDf=NULL) {
@@ -234,7 +234,7 @@
 #' @param callInfo Call information
 #'
 #' @param envir Environment for evaluation (if needed)
-#' 
+#'
 #' @param iniDf The parent model `iniDf` when piping in a `ini` block
 #'   (`NULL` otherwise)
 #'
@@ -287,11 +287,30 @@
             identical(.quoted[[3]], quote(`unfix`))) {
         .quoted <- as.call(list(quote(`<-`), .quoted[[2]], .quoted[[3]]))
       }
+    } else if (identical(.quoted[[1]], quote(`$`))) {
+      .tmp <- try(eval(.quoted), silent=TRUE)
+      if (!inherits(.tmp, "try-error")) {
+        .quoted <- .tmp
+        if (inherits(.quoted, "character")) {
+          .quoted <- str2lang(.quoted)
+        }
+      }
     }
     .quoted
   })
   .w <- which(.bracket)
   .ret <- .quoteExpandBracketsOrCs(.ret, .w, envir=envir, iniDf=iniDf)
+  .ret <- lapply(seq_along(.ret), function(i) {
+    if (identical(.ret[[i]][[1]], quote(`$`))) {
+      .r <- eval(.ret[[i]], envir=envir)
+      if (inherits(.r, "character")) {
+        .r <- str2lang(.r)
+      }
+      return(.r)
+    }
+    .ret[[i]]
+  })
+
   .ret[vapply(seq_along(.ret), function(i) {
     !is.null(.ret[[i]])
   }, logical(1), USE.NAMES=FALSE)]

tests/testthat/test-ui-piping.R

@@ -6,6 +6,24 @@ testPipeQuote <- function(..., envir=parent.frame(), iniDf = NULL) {
 
 
 rxTest({
+
+  test_that("nse evaluation", {
+
+    tmp <- "d/dt(depot)"
+    expect_equal(testPipeQuote(tmp),
+                 list(quote(d/dt(depot))))
+
+    tmp <- list(tmp="d/dt(depot)")
+
+    expect_equal(testPipeQuote(tmp$tmp),
+                 list(quote(d/dt(depot))))
+
+    tmp <- list(tmp=list(tmp="d/dt(depot)"))
+
+    expect_equal(testPipeQuote(tmp$tmp$tmp),
+                 list(quote(d/dt(depot))))
+  })
+
   test_that("test fix/unfix for eta", {
     expect_equal(testPipeQuote(a~fix),
                  list(quote(a<-fix)))
@@ -1704,7 +1722,7 @@ test_that("piping with append=lhs", {
   expect_true(identical(m3$lstExpr[[4]], quote(cl <- tvcl * 2)))
 
   test_that("piping ui functions", {
-    
+
     m1 <- function() {
       ini({
         tka <- 0.463613555325211
@@ -1845,7 +1863,7 @@ test_that("piping with append=lhs", {
                  list())
 
     expect_equal(testPipeQuote(m1, iniDf=m6$iniDf),
-                 list())    
+                 list())
   })
   test_that("model piping that shares err parameter#427", {
     u <- function() {