diff --git a/NEWS.md b/NEWS.md index 2b6947a23..8a70b08dc 100644 --- a/NEWS.md +++ b/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) <- diff --git a/R/piping-ini.R b/R/piping-ini.R index ffa89fe51..7bdbc8627 100644 --- a/R/piping-ini.R +++ b/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() } @@ -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( diff --git a/R/piping-model.R b/R/piping-model.R index c6633755f..d6c63fe01 100644 --- a/R/piping-model.R +++ b/R/piping-model.R @@ -236,7 +236,8 @@ model.rxModelVars <- model.rxode2 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 @@ model.rxModelVars <- model.rxode2 .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 @@ attr(rxUiGet.mvFromExpression, "desc") <- "Calculate model variables from stored } 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 @@ attr(rxUiGet.mvFromExpression, "desc") <- "Calculate model variables from stored .err <- NULL .env <- environment() lapply(lines, function(line) { + line <- .changeDropNullLine(line) if (modifyIni && .isQuotedLineRhsModifiesEstimates(line, rxui)) { .iniHandleFixOrUnfix(line, rxui, envir=envir) } else { diff --git a/tests/testthat/test-piping-ini.R b/tests/testthat/test-piping-ini.R index a0b63fedf..e504a239e 100644 --- a/tests/testthat/test-piping-ini.R +++ b/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({ diff --git a/tests/testthat/test-ui-piping.R b/tests/testthat/test-ui-piping.R index 0103e6420..2107aa0f1 100644 --- a/tests/testthat/test-ui-piping.R +++ b/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)