diff --git a/NEWS.md b/NEWS.md index dffe7d5e4c..480e3baeba 100644 --- a/NEWS.md +++ b/NEWS.md @@ -34,6 +34,11 @@ - Bug fix for parameters that are in both input (`$params`) and output (`$lhs`) that respects the order of the `$lhs` declaration (Fixes #876) + +- `if()` blocks may be removed by model piping (#878) + +- Model piping now removes endpoint and assignments using `NULL` assignment. For + example, `fit |> model(a ~ NULL)` and `fit |> model(a <- NULL)` now work. # rxode2 3.0.4 diff --git a/R/piping-model.R b/R/piping-model.R index 4b33430b73..8066d8db3e 100644 --- a/R/piping-model.R +++ b/R/piping-model.R @@ -237,7 +237,7 @@ model.rxModelVars <- model.rxode2 if (.isEndpoint(expr)) { lhs <- .getLhs(expr) if (.matchesLangTemplate(lhs, str2lang("-.")) || - .matchesLangTemplate(lhs, str2lang(". <- NULL"))) { + .matchesLangTemplate(lhs, str2lang(". ~ NULL"))) { # If it is a drop expression with a minus sign, grab the non-minus part ret <- lhs[[2]] } @@ -300,7 +300,7 @@ model.rxModelVars <- model.rxode2 #' error is defined in the model. #' @param origLines This is a list of lines in the `model({})` block #' of the equation. -#' @param rxui the UI model +#' @param modelVars The model variables from the UI model (`c(rxui$mv0$lhs, rxui$mv0$state)`) #' @param returnAllLines Return all line numbers for the lhs, even #' when there are duplicates. (default `FALSE`) #' @return For duplicated lines: `NULL` for duplicated lines (when @@ -313,7 +313,7 @@ model.rxModelVars <- model.rxode2 #' @author Matthew L. Fidler #' @noRd .getModelineFromExpressionsAndOriginalLines <- function(expr, altExpr, useErrorLine, - errLines, origLines, rxui, + errLines, origLines, modelVars, returnAllLines=FALSE) { .ret <- NA_integer_ .multipleEndpointModel <- length(errLines) != 1L @@ -346,9 +346,8 @@ model.rxModelVars <- model.rxode2 if (.isNormOrTErrorExpression(.expr)) { # Make sure the lhs is included in the model prediction .var <- deparse1(expr) - .modelVars <- c(rxui$mv0$lhs, rxui$mv0$state) - if (!(.var %in% .modelVars)) { - stop("the variable '", .var, "' must be in the defined the model for piping this: '",deparse(.expr), "'", + if (!(.var %in% modelVars)) { + stop("the variable '", .var, "' must be in the defined the model for piping this: '", deparse(.expr), "'", call.=FALSE) } } @@ -441,7 +440,16 @@ model.rxModelVars <- model.rxode2 .origLines <- rxui$lstExpr .errLines <- rxui$predDf$line .expr3 <- .getModelLineEquivalentLhsExpression(lhsExpr) - .ret <- .getModelineFromExpressionsAndOriginalLines(lhsExpr, .expr3, errorLine, .errLines, .origLines, rxui, returnAllLines) + .ret <- + .getModelineFromExpressionsAndOriginalLines( + expr = lhsExpr, + altExpr = .expr3, + useErrorLine = errorLine, + errLines = .errLines, + origLines = .origLines, + modelVars = c(rxui$mv0$lhs, rxui$mv0$state), + returnAllLines = returnAllLines + ) if (is.null(.ret)) { return(NULL) } else if (length(.ret) > 1) { @@ -478,19 +486,21 @@ attr(rxUiGet.mvFromExpression, "desc") <- "Calculate model variables from stored if (!is.null(.getModelLineEquivalentLhsExpressionDropEndpoint(line))) { return(TRUE) } - if (length(line) == 2L) { - if (identical(line[[1]], quote(`-`))) { - if (is.name(line[[2]])) { - return(TRUE) - } else if (is.call(line[[2]]) && length(line[[2]]) == 2L) { - if (is.name(line[[2]][[2]]) && - as.character(line[[2]][[1]]) %in% c("F", "f", "alag", "lag", "dur", "rate")) { - return(TRUE) - } else if (identical(line[[2]][[2]], 0)) { - return(TRUE) - } - } - } + # Any NULL assignment should be a drop line + if (.matchesLangTemplate(x = line, template = str2lang(". <- NULL")) || + .matchesLangTemplate(x = line, template = str2lang(". = NULL"))) { + return(TRUE) + } + # `-something` for specific values of `something` can be dropped + if (.matchesLangTemplate(line, template = str2lang("-.name")) || + .matchesLangTemplate(line, template = str2lang("-.name(0)")) || + .matchesLangTemplate(line, template = str2lang("-F(.name)")) || + .matchesLangTemplate(line, template = str2lang("-f(.name)")) || + .matchesLangTemplate(line, template = str2lang("-alag(.name)")) || + .matchesLangTemplate(line, template = str2lang("-lag(.name)")) || + .matchesLangTemplate(line, template = str2lang("-dur(.name)")) || + .matchesLangTemplate(line, template = str2lang("-rate(.name)"))) { + return(TRUE) } FALSE } diff --git a/tests/testthat/test-piping-model.R b/tests/testthat/test-piping-model.R new file mode 100644 index 0000000000..cd1f52d2aa --- /dev/null +++ b/tests/testthat/test-piping-model.R @@ -0,0 +1,136 @@ +test_that(".isDropExpression", { + # Test .getModelLineEquivalentLhsExpressionDropDdt + expect_true(.isDropExpression(str2lang("-d/dt(a)"))) + expect_true(.isDropExpression(str2lang("d/dt(a) <- NULL"))) + expect_true(.isDropExpression(str2lang("d/dt(a) = NULL"))) + expect_false(.isDropExpression(str2lang("d/dt(a)"))) + # Test .getModelLineEquivalentLhsExpressionDropEndpoint + expect_true(.isDropExpression(str2lang("-a ~ ."))) + expect_true(.isDropExpression(str2lang("-a ~ NULL"))) + expect_false(.isDropExpression(str2lang("a ~ ."))) + + # Test assignment dropping + expect_true(.isDropExpression(str2lang("-a"))) + expect_true(.isDropExpression(str2lang("a <- NULL"))) + expect_true(.isDropExpression(str2lang("a = NULL"))) + expect_false(.isDropExpression(str2lang("a <- ."))) + + # Test special assignment dropping + expect_true(.isDropExpression(str2lang("-lag(a)"))) + expect_true(.isDropExpression(str2lang("lag(a) <- NULL"))) + expect_false(.isDropExpression(str2lang("lag(a) <- b"))) + + # Test for if blocks + expect_false(.isDropExpression(str2lang("if (.) ."))) +}) + +test_that(".getModelineFromExpressionsAndOriginalLines", { + origLines <- + list( + str2lang("a <- 1"), + str2lang("b <- 2"), + str2lang("if (a == 1) { b <- 2}"), + str2lang("a~foo") + ) + + # `useErrorLine = FALSE` (all lines with `a` on the LHS are returned) + expect_equal( + .getModelineFromExpressionsAndOriginalLines( + expr = as.name("a"), + altExpr = NULL, + useErrorLine = FALSE, + errLines = 4, + origLines = origLines, + modelVars = "a", + returnAllLines = TRUE + ), + c(1, 4) + ) + # `useErrorLine = TRUE` and `returnAllLines = FALSE` + # no lines with `a` on the LHS are returned + ## TODO: Is this the intended behavior? I expected line 1 to be returned. + expect_null( + .getModelineFromExpressionsAndOriginalLines( + expr = as.name("a"), + altExpr = NULL, + useErrorLine = TRUE, + errLines = 4, + origLines = origLines, + modelVars = "a", + returnAllLines = TRUE + ) + ) + # `useErrorLine = FALSE` and `returnAllLines = FALSE` + # only the first line with `a` on the LHS is returned + expect_equal( + .getModelineFromExpressionsAndOriginalLines( + expr = as.name("a"), + altExpr = NULL, + useErrorLine = FALSE, + errLines = 4, + origLines = origLines, + modelVars = "a", + returnAllLines = FALSE + ), + 1 + ) + # `useErrorLine = TRUE` and `returnAllLines = FALSE` + # only the error model line with `a` on the LHS is returned + expect_equal( + .getModelineFromExpressionsAndOriginalLines( + expr = as.name("a"), + altExpr = NULL, + useErrorLine = TRUE, + errLines = 4, + origLines = origLines, + modelVars = "a", + returnAllLines = FALSE + ), + 4 + ) + + # `useErrorLine = TRUE` and `returnAllLines = FALSE`; altExpr gives the actual value + # `d` is never an LHS value so NULL is returned + # TODO: It's unclear why the warning "with single endpoint model prediction 'a' is changed to 'd'" occurs. + expect_null( + .getModelineFromExpressionsAndOriginalLines( + expr = as.name("d"), + altExpr = NULL, + useErrorLine = TRUE, + errLines = 4, + origLines = origLines, + modelVars = "a", + returnAllLines = TRUE + ) + ) + + # `useErrorLine = TRUE` and `returnAllLines = FALSE`; altExpr gives the actual value + # It ends up working the same as if `a` were the `expr` argument. + expect_equal( + .getModelineFromExpressionsAndOriginalLines( + expr = as.name("d"), + altExpr = as.name("a"), + useErrorLine = TRUE, + errLines = 4, + origLines = origLines, + modelVars = "a", + returnAllLines = TRUE + ), + c(1, 4) + ) + + # `useErrorLine = TRUE` and `returnAllLines = FALSE`; variable is the LHS of the error expression but not part of the modelVars + # Returns 3 + expect_equal( + .getModelineFromExpressionsAndOriginalLines( + expr = as.name("a"), + altExpr = NULL, + useErrorLine = TRUE, + errLines = 3, + origLines = origLines[2:4], + modelVars = c(), + returnAllLines = FALSE + ), + 3 + ) +})