Merge pull request #626 from nlmixr2/625-inconsistent-append-behavior…

…-between-ini-and-model-in-model-piping

625 inconsistent append behavior between ini and model in model piping

NAMESPACE

@@ -197,6 +197,7 @@ export(.copyUi)
 export(.expandPars)
 export(.getLastIdLvl)
 export(.handleSingleErrTypeNormOrTFoceiBase)
+export(.iniGetAppendArg)
 export(.iniHandleFixOrUnfix)
 export(.iniHandleLine)
 export(.malert)

NEWS.md

@@ -150,6 +150,20 @@ mu-referencing style to run the optimization.
   be kept carrying more information with it (for example ordered
   factors, data frame columns with unit information, etc)
 
+- Piping arguments `append` for `ini()` and `model()` have been
+  aligned to perform similarly.  Therefore `ini(append=)` now can take
+  expressions instead of simply strings and `model(append=)` can also
+  take strings.  Also model piping now can specify the integer line
+  number to be modified just like the `ini()` could.  Also
+  `model(append=FALSE)` has been changed to `model(append=NULL)`.
+  While the behavior is the same when you don't specify the argument,
+  the behavior has changed to align with `ini()` when piping.  Hence
+  `model(append=TRUE)` will append and `model(append=FALSE)` will now
+  pre-pend to the model.  `model(append=NULL)` will modify lines like
+  the behavior of `ini(append=NULL)`.  The default of `model(line)`
+  modifying a line in-place still applies.  While this is a breaking
+  change, most code will perform the same.
+
 ## Internal new features
 
 - Add `as.model()` for list expressions, which implies `model(ui) <-

R/piping-ini.R

@@ -331,7 +331,8 @@
   if (length(.w) != 1) {
     stop("cannot find parameter '", lhs, "'", call.=FALSE)
   } else if (!is.character(newLabel) || !(length(newLabel) == 1)) {
-    stop("the new label for '", lhs, "' must be a character string")
+    stop("the new label for '", lhs, "' must be a character string",
+         call.=FALSE)
   }
   ini$label[.w] <- newLabel
   assign("iniDf", ini, envir=rxui)
@@ -369,7 +370,8 @@
     checkmate::assert_choice(append, choices = ini$name)
     appendClean <- which(ini$name == append)
   } else {
-    stop("'append' must be NULL, logical, numeric, or character", call. = FALSE)
+    stop("'append' must be NULL, logical, numeric, or character/expression of variable in model",
+         call. = FALSE)
   }
 
   lhs <- as.character(expr[[2]])
@@ -667,16 +669,59 @@
   }
   expr
 }
+#' This gets the append arg for the ini({}) piping
+#'
+#' @param f this is the `try(force(append))` argument,
+#' @param s this is the `as.character(substitute(append))` argument
+#' @return corrected ini piping argument
+#'
+#' This is exported for creating new ini methods that have the same
+#' requirements for piping
+#'
+#' @export
+#' @author Matthew L. Fidler
+#' @keywords internal
+.iniGetAppendArg <- function(f, s) {
+  if (inherits(f, "try-error") &&
+        checkmate::testCharacter(s, len=1, any.missing=FALSE,
+                                 pattern="^[.]*[a-zA-Z]+[a-zA-Z0-9._]*$",
+                                 min.chars = 1)) {
+    return(s)
+  }
+  if (is.null(f)) {
+    return(NULL)
+  } else if (checkmate::testCharacter(f, len=1, any.missing=FALSE,
+                                      pattern="^[.]*[a-zA-Z]+[a-zA-Z0-9._]*$",
+                                      min.chars = 1)) {
+    return(f)
+  } else if (is.infinite(f)) {
+    return(f)
+  } else if (checkmate::testIntegerish(f, len=1, any.missing=FALSE)) {
+    if (f < 0) {
+      stop("'append' cannot be a negative integer", call.=FALSE)
+    }
+    return(f)
+  } else if (checkmate::testLogical(f, len=1)) {
+    # NA for model piping prepends
+    if (is.na(f)) return(FALSE)
+    return(f)
+  }
+  stop("'append' must be NULL, logical, numeric, or character/expression of variable in model",
+       call.=FALSE)
+}
 
 #' @export
 #' @rdname ini
 ini.rxUi <- function(x, ..., envir=parent.frame(), append = NULL) {
+  .s  <- as.character(substitute(append))
+  .f <- try(force(append), silent=TRUE)
+  append <- .iniGetAppendArg(.f, .s)
   .ret <- rxUiDecompress(.copyUi(x)) # copy so (as expected) old UI isn't affected by the call
   .iniDf <- .ret$iniDf
   .iniLines <- .quoteCallInfoLines(match.call(expand.dots = TRUE)[-(1:2)], envir=envir, iniDf= .iniDf)
   if (length(.iniLines) == 0L) return(.ret$iniFun)
   lapply(.iniLines, function(line) {
-    .iniHandleLine(expr = line, rxui = .ret, envir = envir, append = append)
+    .iniHandleLine(expr = line, rxui = .ret, envir = envir, append=append)
   })
   if (inherits(x, "rxUi")) {
     .x <- rxUiDecompress(x)
@@ -695,6 +740,9 @@ ini.rxUi <- function(x, ..., envir=parent.frame(), append = NULL) {
 #' @rdname ini
 #' @export
 ini.default <- function(x, ..., envir=parent.frame(), append = NULL) {
+  .s  <- as.character(substitute(append))
+  .f <- try(force(append), silent=TRUE)
+  append <- .iniGetAppendArg(.f, .s)
   .ret <- try(as.rxUi(x), silent = TRUE)
   if (inherits(.ret, "try-error")) {
     stop("cannot figure out what to do with the ini({}) function", call.=FALSE)

R/piping-model.R

@@ -1,6 +1,6 @@
 #' @export
 #' @rdname model
-model.function <- function(x, ..., append=FALSE, auto=getOption("rxode2.autoVarPiping", TRUE),
+model.function <- function(x, ..., append=NULL, auto=getOption("rxode2.autoVarPiping", TRUE),
                            cov=NULL, envir=parent.frame()) {
   .modelLines <- .quoteCallInfoLines(match.call(expand.dots = TRUE)[-(1:2)], envir=envir)
   .ret <- rxUiDecompress(rxode2(x))
@@ -11,7 +11,7 @@ model.function <- function(x, ..., append=FALSE, auto=getOption("rxode2.autoVarP
 
 #' @export
 #' @rdname model
-model.rxUi <- function(x, ..., append=FALSE, auto=getOption("rxode2.autoVarPiping", TRUE),
+model.rxUi <- function(x, ..., append=NULL, auto=getOption("rxode2.autoVarPiping", TRUE),
                        cov=NULL, envir=parent.frame()) {
   .modelLines <- .quoteCallInfoLines(match.call(expand.dots = TRUE)[-(1:2)], envir=envir)
   .ret <- rxUiDecompress(.copyUi(x)) # copy so (as expected) old UI isn't affected by the call
@@ -32,7 +32,7 @@ model.rxUi <- function(x, ..., append=FALSE, auto=getOption("rxode2.autoVarPipin
 
 #' @export
 #' @rdname model
-model.rxode2 <- function(x, ..., append=FALSE, auto=getOption("rxode2.autoVarPiping", TRUE),
+model.rxode2 <- function(x, ..., append=NULL, auto=getOption("rxode2.autoVarPiping", TRUE),
                          cov=NULL, envir=parent.frame()) {
   .modelLines <- .quoteCallInfoLines(match.call(expand.dots = TRUE)[-(1:2)], envir=envir)
   x <- as.function(x)
@@ -56,7 +56,7 @@ model.rxModelVars <- model.rxode2
 #' @return New UI
 #' @author Matthew L. Fidler
 #' @export
-.modelHandleModelLines <- function(modelLines, rxui, modifyIni=FALSE, append=FALSE,
+.modelHandleModelLines <- function(modelLines, rxui, modifyIni=FALSE, append=NULL,
                                    auto=getOption("rxode2.autoVarPiping", TRUE),
                                    cov=NULL, envir) {
   checkmate::assertLogical(modifyIni, any.missing=FALSE, len=1)
@@ -66,8 +66,34 @@ model.rxModelVars <- model.rxode2
   .varSelect$cov <- cov
   .doAppend <- FALSE
   rxui <- rxUiDecompress(rxui)
+  .ll <- length(rxui$lstExpr)
   if (!is.null(.nsEnv$.quoteCallInfoLinesAppend)) {
-    .ll <- length(rxui$lstExpr)
+    if (identical(.nsEnv$.quoteCallInfoLinesAppend, quote(Inf))) {
+      .nsEnv$.quoteCallInfoLinesAppend <- NULL
+      append <- TRUE
+    } else if (identical(.nsEnv$.quoteCallInfoLinesAppend, quote(-Inf))) {
+      .nsEnv$.quoteCallInfoLinesAppend <- NULL
+      append <- NA
+    } else if (identical(.nsEnv$.quoteCallInfoLinesAppend, quote(0))) {
+      .nsEnv$.quoteCallInfoLinesAppend <- NULL
+      append <- NA
+    } else if (checkmate::testIntegerish(.nsEnv$.quoteCallInfoLinesAppend, lower=.ll)) {
+      .nsEnv$.quoteCallInfoLinesAppend <- NULL
+      append <- TRUE
+    }
+  }
+  if (!is.null(.nsEnv$.quoteCallInfoLinesAppend)) {
+    if (checkmate::testIntegerish(.nsEnv$.quoteCallInfoLinesAppend, lower=0, upper=.ll)) {
+      .nsEnv$.quoteCallInfoLinesAppend <- .getLhs(rxui$lstExpr[[.nsEnv$.quoteCallInfoLinesAppend]])
+    } else if (checkmate::testCharacter(.nsEnv$.quoteCallInfoLinesAppend, len=1, any.missing=FALSE,
+                                        min.chars = 1)) {
+      .tmp <- try(str2lang(.nsEnv$.quoteCallInfoLinesAppend), silent=TRUE)
+      if (inherits(.tmp, "try-error")) {
+        stop("'append' must refer to a LHS model line when a character",
+             call. = FALSE)
+      }
+      .nsEnv$.quoteCallInfoLinesAppend <- .tmp
+    }
     .w <- which(vapply(seq_len(.ll),
                        function(i) {
                          .lhs <- .getLhs(rxui$lstExpr[[i]])
@@ -112,7 +138,7 @@ model.rxModelVars <- model.rxode2
              envir=rxui)
     }
     .doAppend <- TRUE
-  } else if (is.logical(append) && length(append) == 1L && is.na(append)) {
+  } else if (is.logical(append) && length(append) == 1L && (is.na(append) || !append)) {
     assign("lstExpr", c(modelLines, rxui$lstExpr), envir=rxui)
     .doAppend <- TRUE
   } else if (isTRUE(append)) {

R/piping.R

@@ -1,4 +1,4 @@
-#'  This copies the rxode2 UI object so it can be modified
+#' This copies the rxode2 UI object so it can be modified
 #'
 #' @param ui Original UI object
 #' @return Copied UI object

tests/testthat/test-piping-ini.R

@@ -145,6 +145,7 @@ test_that(".iniSimplifyAssignArrow", {
 })
 
 test_that("piping with ini can update reorder parameters (rxode2/issues#352)", {
+
   mod <- function() {
     ini({
       a <- 1
@@ -157,7 +158,9 @@ test_that("piping with ini can update reorder parameters (rxode2/issues#352)", {
       b ~ add(addSd)
     })
   }
+
   ui <- rxode2(mod)
+
   # No modification
   expect_equal(ui$iniDf$name, c("a", "b", "c", "addSd"))
   # b to the top by number
@@ -170,6 +173,9 @@ test_that("piping with ini can update reorder parameters (rxode2/issues#352)", {
   expect_equal(suppressMessages(ini(ui, b <- 1, append = TRUE))$iniDf$name, c("a", "c", "addSd", "b"))
   # b to the bottom by name
   expect_equal(suppressMessages(ini(ui, b <- 1, append = "addSd"))$iniDf$name, c("a", "c", "addSd", "b"))
+
+  expect_equal(suppressMessages(ini(ui, b <- 1, append = addSd))$iniDf$name, c("a", "c", "addSd", "b"))
+
   # b after c
   expect_equal(suppressMessages(ini(ui, b <- 1, append = "c"))$iniDf$name, c("a", "c", "b", "addSd"))
   # a and b after c; counter-intuitive: the order of a and b are reversed
@@ -180,11 +186,16 @@ test_that("piping with ini can update reorder parameters (rxode2/issues#352)", {
     regexp = "parameter 'b' set to be moved after itself, no change in order made"
   )
 
+  expect_error(
+    ini(ui, b <- 1, append = d/dt(fun)),
+  "append")
+
   # Invalid parameter is correctly caught
   expect_error(
     ini(ui, b <- 1, append = "foo"),
     "append"
   )
+
 })
 
 test_that(".iniAddCovarianceBetweenTwoEtaValues", {
@@ -275,9 +286,10 @@ test_that(".iniHandleAppend", {
       b ~ add(addSd)
     })
   }
+
   expect_error(
     ini(mod, a <- 1, append=factor("A")),
-    regexp = "'append' must be NULL, logical, numeric, or character"
+    regexp = "'append' must be NULL, logical, numeric, or character/expression of variable in model"
   )
   expect_error(
     ini(mod, q <- 1, append=0),