627 remove labels in piping

NEWS.md

@@ -164,6 +164,11 @@ mu-referencing style to run the optimization.
   modifying a line in-place still applies.  While this is a breaking
   change, most code will perform the same.
 
+- Labels can now be dropped by `ini(param=label(NULL))`. Also
+  parameters can be dropped with the idiom `model(param=NULL)` or
+  `ini(param=NULL)` changes the parameter to a covariate to align with
+  this idiom of dropping parameters
+
 ## Internal new features
 
 - Add `as.model()` for list expressions, which implies `model(ui) <-

R/piping-ini.R

@@ -321,21 +321,67 @@
 #'
 #' @inheritParams .iniHandleLine
 #' @return Nothing, called for side effects
+#' @author Bill Denney & Matthew Fidler
 #' @keywords internal
 #' @noRd
 .iniHandleLabel <- function(expr, rxui, envir) {
-  lhs <- as.character(expr[[2]])
-  newLabel <- expr[[3]][[2]]
-  ini <- rxui$ini
-  .w <- which(ini$name == lhs)
+  .lhs <- as.character(expr[[2]])
+  .newLabel <- expr[[3]][[2]]
+  .ini <- rxui$ini
+  .w <- which(.ini$name == .lhs)
   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("cannot find parameter '", .lhs, "'", call.=FALSE)
+  } else if (is.null(.newLabel)) {
+    .newLabel <- NA_character_
+  } else if (!is.character(.newLabel) || !(length(.newLabel) == 1)) {
+    stop("the new label for '", .lhs, "' must be a character string",
          call.=FALSE)
   }
-  ini$label[.w] <- newLabel
-  assign("iniDf", ini, envir=rxui)
+  .ini$label[.w] <- .newLabel
+  assign("iniDf", .ini, envir=rxui)
+  invisible()
+}
+#' This handles the backTransform() piping calls
+#'
+#' @param expr expression for backTransform() in `ini()` piping
+#' @param rxui rxode2 ui function
+#' @param envir evaluation environment
+#' @return nothing, called for side effects
+#' @noRd
+#' @author Matthew L. Fidler
+.iniHandleBackTransform <- function(expr, rxui, envir) {
+  .lhs <- as.character(expr[[2]])
+  .newExpr <- expr[[3]][[2]]
+  .ini <- rxui$ini
+  .w <- which(.ini$name == .lhs)
+  .good <- TRUE
+  if (length(.w) != 1) {
+    stop("cannot find parameter '", .lhs, "'", call.=FALSE)
+  } else if (is.null(.newExpr)) {
+    .newExpr <- NA_character_
+  } else if (checkmate::testCharacter(.newExpr, len=1, any.missing=FALSE,
+                                      pattern="^[.]*[a-zA-Z]+[a-zA-Z0-9._]*$",
+                                      min.chars = 1)) {
+  } else {
+    .newExpr <- deparse1(.newExpr)
+    if (!checkmate::testCharacter(.newExpr, len=1, any.missing=FALSE,
+                                 pattern="^[.]*[a-zA-Z]+[a-zA-Z0-9._]*$",
+                                 min.chars = 1)) {
+      .good <- FALSE
+    }
+  }
+  if (!.good) {
+    stop("backTransform specification malformed",
+         call.=FALSE)
+  }
+  if (!is.na(.newExpr)) {
+    if (!exists(.newExpr, envir=envir, mode="function")) {
+      stop("tried use a backTransform(\"", .newExpr, "\") when the function does not exist",
+           call.=FALSE)
+    }
+  }
+  .ini$backTransform[.w] <- .newExpr
+  assign("iniDf", .ini, envir=rxui)
   invisible()
 }
 
@@ -370,8 +416,8 @@
     checkmate::assert_choice(append, choices = ini$name)
     appendClean <- which(ini$name == append)
   } else {
     stop("'append' must be NULL, logical, numeric, or character/expression of variable in model",
          call. = FALSE)
   }
 
   lhs <- as.character(expr[[2]])
@@ -549,10 +595,10 @@
   # downstream operations
   expr <- .iniSimplifyAssignArrow(expr)
 
-  # Capture errors
   if (.matchesLangTemplate(expr, str2lang(".name <- NULL"))) {
-    stop("a NULL value for '", as.character(expr[[2]]), "' piping does not make sense",
-         call. = FALSE)
+    expr <- as.call(list(quote(`-`), expr[[2]]))
+  } else if (.matchesLangTemplate(expr, str2lang(".name ~ NULL"))) {
+    expr <- as.call(list(quote(`-`), expr[[2]]))
   }
 
   # Convert fix(name) or unfix(name) to name <- fix or name <- unfix
@@ -564,6 +610,8 @@
 
   if (.matchesLangTemplate(expr, str2lang(".name <- label(.)"))) {
     .iniHandleLabel(expr=expr, rxui=rxui, envir=envir)
+  } else if (.matchesLangTemplate(expr, str2lang(".name <- backTransform(.)"))) {
+    .iniHandleBackTransform(expr=expr, rxui=rxui, envir=envir)
   } else if (.isAssignment(expr) && is.character(expr[[3]])) {
     stop(
       sprintf(
@@ -698,12 +746,12 @@
     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",

R/piping-model.R

@@ -72,8 +72,8 @@
       .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
@@ -84,13 +84,13 @@
   }
   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
     }
@@ -236,7 +236,8 @@
   ret <- NULL
   if (.isEndpoint(expr)) {
     lhs <- .getLhs(expr)
-    if (.matchesLangTemplate(lhs, str2lang("-."))) {
+    if (.matchesLangTemplate(lhs, str2lang("-.")) ||
+          .matchesLangTemplate(lhs, str2lang(". <- NULL"))) {
       # If it is a drop expression with a minus sign, grab the non-minus part
       ret <- lhs[[2]]
     }
@@ -246,7 +247,8 @@
 
 .getModelLineEquivalentLhsExpressionDropDdt <- function(expr) {
   .expr3 <- NULL
-  if (.matchesLangTemplate(x = expr, template = str2lang("-d/dt(.name)"))) {
+  if (.matchesLangTemplate(x = expr, template = str2lang("-d/dt(.name)")) ||
+        .matchesLangTemplate(x = expr, template = str2lang("d/dt(.name) <- NULL"))) {
     .expr3 <- expr
     # remove the minus sign from the numerator
     .expr3[[2]] <- .expr3[[2]][[2]]
@@ -521,6 +523,48 @@
   }
   NULL
 }
+#' This checks the different types of drop assignments
+#'
+#'
+#' @param prefix The prefix of the drop assignment
+#' @param line The line expression to check
+#' @return logical to say if this matches the prefix
+#' @author Matthew L. Fidler
+#' @noRd
+.isDropNullType <- function(prefix, line) {
+  .e1 <- str2lang(paste0(prefix, " <- NULL"))
+  .e2 <- str2lang(paste0(prefix, " = NULL"))
+  .e3 <- str2lang(paste0(prefix, " ~ NULL"))
+  if (.matchesLangTemplate(line, .e1)) return(TRUE)
+  if (.matchesLangTemplate(line, .e3)) return(TRUE)
+  if (.matchesLangTemplate(line, .e2)) return(TRUE)
+  FALSE
+}
+#' This changes NULL assignment line to a -drop line
+#'
+#' @param line Line to change if necessary
+#' @return Drop line normalized to be `-line` instead of  `line <- NULL`
+#' @author Matthew L. Fidler
+#' @noRd
+.changeDropNullLine <- function(line) {
+  if (.isDropNullType("d/dt(.name)", line)) {
+    .ret <- line[[2]]
+    .ret[[2]] <- as.call(list(quote(`-`), .ret[[2]]))
+    return(.ret)
+  }
+  if (.isDropNullType(".name", line) ||
+        .isDropNullType("lag(.name)", line) ||
+        .isDropNullType("alag(.name)", line) ||
+        .isDropNullType("f(.name)", line) ||
+        .isDropNullType("F(.name)", line) ||
+        .isDropNullType("rate(.name)", line) ||
+        .isDropNullType("dur(.name)", line) ||
+        .isDropNullType(".name(0)", line)
+        ) {
+    return(as.call(list(quote(`-`), line[[2]])))
+  }
+  line
+}
 
 #'  Modify the error lines/expression
 #'
@@ -535,6 +579,7 @@
   .err <- NULL
   .env <- environment()
   lapply(lines, function(line) {
+    line <- .changeDropNullLine(line)
     if (modifyIni && .isQuotedLineRhsModifiesEstimates(line, rxui)) {
       .iniHandleFixOrUnfix(line, rxui, envir=envir)
     } else {

tests/testthat/test-piping-ini.R

@@ -1,3 +1,59 @@
+test_that("back transformation piping", {
+
+  mod1 <- function() {
+    ini({
+      # central
+      KA <- 2.94E-01
+      backTransform("exp")
+      CL <- 1.86E+01
+      V2 <- 4.02E+01
+      # peripheral
+      Q <- 1.05E+01
+      V3 <- 2.97E+02
+      # effects
+      Kin <- 1
+      Kout <- 1
+      EC50 <- 200
+    })
+    model({
+      C2 <- 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
+      eff(0) <- 1
+      d/dt(eff)   <- Kin - Kout*(1-C2/(EC50+C2))*eff
+    })
+  }
+
+  ui <- rxode(mod1)
+
+  expect_equal(ui$iniDf$backTransform[ui$iniDf$name == "KA"], "exp")
+
+  p1 <- ui %>%
+    ini(
+      KA <- backTransform("log")
+    )
+
+  expect_equal(p1$iniDf$backTransform[ui$iniDf$name == "KA"], "log")
+
+  p2 <-ui %>%
+    ini(
+      KA <- backTransform(log)
+    )
+
+  expect_equal(p2$iniDf$backTransform[ui$iniDf$name == "KA"], "log")
+
+  p3 <- ui |>
+    ini(KA <- backTransform(NULL))
+
+  expect_equal(p3$iniDf$backTransform[ui$iniDf$name == "KA"], NA_character_)
+
+  expect_error(ui |>
+                 ini(KA <- backTransform(matt)), "matt")
+
+})
+
 test_that("piping with ini can update labels (rxode2/issues#351)", {
   mod <- function() {
     ini({
@@ -16,6 +72,25 @@ test_that("piping with ini can update labels (rxode2/issues#351)", {
   expect_equal(newLabelUi$iniDf$label[newLabelUi$iniDf$name == "a"], "bar")
 })
 
+test_that("piping with ini can remove labels (#627)", {
+
+  mod <- function() {
+    ini({
+      a <- 1
+      label("foo")
+      addSd <- 2
+    })
+    model({
+      b <- a
+      b ~ add(addSd)
+    })
+  }
+  ui <- rxode2(mod)
+  expect_equal(ui$iniDf$label[ui$iniDf$name == "a"], "foo")
+  newLabelUi <- ini(ui, a = label(NULL))
+  expect_equal(newLabelUi$iniDf$label[ui$iniDf$name == "a"], NA_character_)
+})
+
 test_that("piping with ini gives an error pointing the user to use label for character rhs (rxode2/issues#351)", {
   mod <- function() {
     ini({

tests/testthat/test-ui-piping.R

@@ -37,6 +37,73 @@ rxTest({
                  list(quote(d/dt(depot))))
   })
 
+  test_that("equivalent drop statements", {
+
+    expect_equal(.changeDropNullLine(quote(a <- NULL)),
+                 quote(-a))
+    expect_equal(.changeDropNullLine(quote(a ~ NULL)),
+                 quote(-a))
+    expect_equal(.changeDropNullLine(str2lang("a = NULL")),
+                 quote(-a))
+
+    expect_equal(.changeDropNullLine(quote(d/dt(a) <- NULL)),
+                 quote(-d/dt(a)))
+    expect_equal(.changeDropNullLine(quote(d/dt(a) ~ NULL)),
+                 quote(-d/dt(a)))
+    expect_equal(.changeDropNullLine(str2lang("d/dt(a) = NULL")),
+                 quote(-d/dt(a)))
+
+    expect_equal(.changeDropNullLine(quote(lag(a) <- NULL)),
+                 quote(-lag(a)))
+    expect_equal(.changeDropNullLine(quote(lag(a) ~ NULL)),
+                 quote(-lag(a)))
+    expect_equal(.changeDropNullLine(str2lang("lag(a) = NULL")),
+                 quote(-lag(a)))
+
+    expect_equal(.changeDropNullLine(quote(alag(a) <- NULL)),
+                 quote(-alag(a)))
+    expect_equal(.changeDropNullLine(quote(alag(a) ~ NULL)),
+                 quote(-alag(a)))
+    expect_equal(.changeDropNullLine(str2lang("alag(a) = NULL")),
+                 quote(-alag(a)))
+
+    expect_equal(.changeDropNullLine(quote(F(a) <- NULL)),
+                 quote(-F(a)))
+    expect_equal(.changeDropNullLine(quote(F(a) ~ NULL)),
+                 quote(-F(a)))
+    expect_equal(.changeDropNullLine(str2lang("F(a) = NULL")),
+                 quote(-F(a)))
+
+    expect_equal(.changeDropNullLine(quote(f(a) <- NULL)),
+                 quote(-f(a)))
+    expect_equal(.changeDropNullLine(quote(f(a) ~ NULL)),
+                 quote(-f(a)))
+    expect_equal(.changeDropNullLine(str2lang("f(a) = NULL")),
+                 quote(-f(a)))
+
+    expect_equal(.changeDropNullLine(quote(rate(a) <- NULL)),
+                 quote(-rate(a)))
+    expect_equal(.changeDropNullLine(quote(rate(a) ~ NULL)),
+                 quote(-rate(a)))
+    expect_equal(.changeDropNullLine(str2lang("rate(a) = NULL")),
+                 quote(-rate(a)))
+
+    expect_equal(.changeDropNullLine(quote(dur(a) <- NULL)),
+                 quote(-dur(a)))
+    expect_equal(.changeDropNullLine(quote(dur(a) ~ NULL)),
+                 quote(-dur(a)))
+    expect_equal(.changeDropNullLine(str2lang("dur(a) = NULL")),
+                 quote(-dur(a)))
+
+    expect_equal(.changeDropNullLine(quote(a(0) <- NULL)),
+                 quote(-a(0)))
+    expect_equal(.changeDropNullLine(quote(a(0) ~ NULL)),
+                 quote(-a(0)))
+    expect_equal(.changeDropNullLine(str2lang("a(0) = NULL")),
+                 quote(-a(0)))
+
+  })
+
   test_that("test fix/unfix for eta", {
     expect_equal(testPipeQuote(a~fix),
                  list(quote(a<-fix)))
@@ -762,7 +829,6 @@ rxTest({
 
     expect_error(f %>% ini(tka=c(0, 0.5, 1, 4)), "tka")
 
-    expect_error(f %>% ini(tka=NULL), "tka")
     expect_error(f %>% ini(tka=c(3,2,1)), "tka")
 
     suppressMessages(
@@ -841,7 +907,6 @@ rxTest({
 
     expect_error(f %>% ini(tka=c(0, 0.5, 1, 4)), "tka")
 
-    expect_error(f %>% ini(tka=NULL), "tka")
     expect_error(f %>% ini(tka=c(3,2,1)), "tka")
 
     suppressMessages(
@@ -912,7 +977,6 @@ rxTest({
 
     expect_error(f %>% ini(tka=c(0, 0.5, 1, 4)), "tka")
 
-    expect_error(f %>% ini(tka=NULL), "tka")
     expect_error(f %>% ini(tka=c(3,2,1)), "tka")
 
     suppressMessages(
@@ -2038,6 +2102,12 @@ test_that("piping append", {
   t <- c("-cp","-d/dt(depot)")
   expect_error(mod |> model(t), NA)
 
+  t <- c("cp <- NULL","d/dt(depot) = NULL")
+  expect_error(mod |> model(t), NA)
+
+  t <- c("cp <- NULL","d/dt(depot) ~ NULL")
+  expect_error(mod |> model(t), NA)
+
   mod5 <- mod |>
     model({
       PD <- 1-emax*cp/(ec50+cp)