From 756a1a5913b05b6889d24506e735a198c95a8a22 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Mon, 30 Jun 2025 10:49:32 -0400 Subject: [PATCH 1/8] `fit |> model(-a ~ NULL)` can now remove a model estimation line --- NEWS.md | 5 +++++ R/piping-model.R | 2 +- tests/testthat/test-piping-model.R | 12 ++++++++++++ 3 files changed, 18 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/test-piping-model.R diff --git a/NEWS.md b/NEWS.md index dffe7d5e4c..185a071851 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) + +- Bug fix where model piping would not remove an endpoint by `NULL` assignment. + `fit |> model(-a ~ NULL)` now works. # rxode2 3.0.4 diff --git a/R/piping-model.R b/R/piping-model.R index 4b33430b73..a920dca8a0 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]] } diff --git a/tests/testthat/test-piping-model.R b/tests/testthat/test-piping-model.R new file mode 100644 index 0000000000..2d80a48b14 --- /dev/null +++ b/tests/testthat/test-piping-model.R @@ -0,0 +1,12 @@ +test_that(".isDropExpression", { + # Testing .getModelLineEquivalentLhsExpressionDropDdt + expect_true(.isDropExpression(str2lang("-d/dt(a)"))) + expect_true(.isDropExpression(str2lang("d/dt(a) <- NULL"))) + expect_false(.isDropExpression(str2lang("d/dt(a)"))) + # Testing .getModelLineEquivalentLhsExpressionDropEndpoint + expect_true(.isDropExpression(str2lang("-a ~ ."))) + expect_true(.isDropExpression(str2lang("-a ~ NULL"))) + expect_false(.isDropExpression(str2lang("a ~ ."))) + + # expect_true(.isDropExpression(str2lang("a <- NULL"))) +}) From daff702899223d3c6a5595483326fd792b72bf24 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Mon, 30 Jun 2025 11:17:11 -0400 Subject: [PATCH 2/8] Capture any NULL assignment for dropping --- NEWS.md | 4 ++-- R/piping-model.R | 8 ++++++++ tests/testthat/test-piping-model.R | 16 +++++++++++++--- 3 files changed, 23 insertions(+), 5 deletions(-) diff --git a/NEWS.md b/NEWS.md index 185a071851..480e3baeba 100644 --- a/NEWS.md +++ b/NEWS.md @@ -37,8 +37,8 @@ - `if()` blocks may be removed by model piping (#878) -- Bug fix where model piping would not remove an endpoint by `NULL` assignment. - `fit |> model(-a ~ NULL)` now works. +- 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 a920dca8a0..d421822bc1 100644 --- a/R/piping-model.R +++ b/R/piping-model.R @@ -478,6 +478,12 @@ attr(rxUiGet.mvFromExpression, "desc") <- "Calculate model variables from stored if (!is.null(.getModelLineEquivalentLhsExpressionDropEndpoint(line))) { 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) + } + if (length(line) == 2L) { if (identical(line[[1]], quote(`-`))) { if (is.name(line[[2]])) { @@ -485,8 +491,10 @@ attr(rxUiGet.mvFromExpression, "desc") <- "Calculate model variables from stored } 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")) { + # special assignments like -lag(cmt) return(TRUE) } else if (identical(line[[2]][[2]], 0)) { + # initial conditions return(TRUE) } } diff --git a/tests/testthat/test-piping-model.R b/tests/testthat/test-piping-model.R index 2d80a48b14..5898244d03 100644 --- a/tests/testthat/test-piping-model.R +++ b/tests/testthat/test-piping-model.R @@ -1,12 +1,22 @@ test_that(".isDropExpression", { - # Testing .getModelLineEquivalentLhsExpressionDropDdt + # 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)"))) - # Testing .getModelLineEquivalentLhsExpressionDropEndpoint + # Test .getModelLineEquivalentLhsExpressionDropEndpoint expect_true(.isDropExpression(str2lang("-a ~ ."))) expect_true(.isDropExpression(str2lang("-a ~ NULL"))) expect_false(.isDropExpression(str2lang("a ~ ."))) - # expect_true(.isDropExpression(str2lang("a <- NULL"))) + # 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"))) }) From 27192bcea4a108624eeb1e0a83ca7f1e79d702d5 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Mon, 30 Jun 2025 14:29:25 -0400 Subject: [PATCH 3/8] Generalize any subtraction is a removal --- R/piping-model.R | 17 +++-------------- tests/testthat/test-piping-model.R | 24 ++++++++++++++++++++++++ 2 files changed, 27 insertions(+), 14 deletions(-) diff --git a/R/piping-model.R b/R/piping-model.R index d421822bc1..7d680bb35e 100644 --- a/R/piping-model.R +++ b/R/piping-model.R @@ -483,21 +483,10 @@ attr(rxUiGet.mvFromExpression, "desc") <- "Calculate model variables from stored .matchesLangTemplate(x = line, template = str2lang(". = NULL"))) { return(TRUE) } - + # Any line with `-something` 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")) { - # special assignments like -lag(cmt) - return(TRUE) - } else if (identical(line[[2]][[2]], 0)) { - # initial conditions - return(TRUE) - } - } + if (.matchesLangTemplate(line, template = str2lang("-."))) { + return(TRUE) } } FALSE diff --git a/tests/testthat/test-piping-model.R b/tests/testthat/test-piping-model.R index 5898244d03..632ae44f62 100644 --- a/tests/testthat/test-piping-model.R +++ b/tests/testthat/test-piping-model.R @@ -19,4 +19,28 @@ test_that(".isDropExpression", { 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_true(.isDropExpression(str2lang("-if (.) ."))) + expect_false(.isDropExpression(str2lang("if (.) ."))) +}) + +test_that("model piping can change or remove an if block (#878)", { + mod <- function() { + ini({ + a <- 1 + }) + model({ + d <- a + g <- a + if (b > 1) { + d <- 2 + } + }) + } + # modChangeD <- model(mod, d <- b) + # expect_equal(modelExtract(modChangeD), c("d <- b", "g <- a", "if (b > 1) { d <- b }")) + # modNoD <- model(mod, -d) + # expect_equal(modelExtract(modNoD), "g <- a") + modNoIf <- model(mod, -if (.) .) }) From 0789627bc55205bd8e7bd1b2539f91d7cdcf3ac2 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Mon, 30 Jun 2025 15:56:38 -0400 Subject: [PATCH 4/8] Code reformatting (no changes) --- R/piping-model.R | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/R/piping-model.R b/R/piping-model.R index 7d680bb35e..8cf82c75da 100644 --- a/R/piping-model.R +++ b/R/piping-model.R @@ -441,7 +441,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, + rxui = rxui, + returnAllLines = returnAllLines + ) if (is.null(.ret)) { return(NULL) } else if (length(.ret) > 1) { From bd5b7c931e42df8916c04432050a74cbad5b66fa Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Tue, 1 Jul 2025 12:30:38 -0400 Subject: [PATCH 5/8] Change input to `modelVars` from `rxui` to simplify testing; add many tests --- R/piping-model.R | 11 +-- tests/testthat/test-piping-model.R | 147 +++++++++++++++++++++++++---- 2 files changed, 134 insertions(+), 24 deletions(-) diff --git a/R/piping-model.R b/R/piping-model.R index 8cf82c75da..665c0d9e49 100644 --- a/R/piping-model.R +++ b/R/piping-model.R @@ -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) } } @@ -448,7 +447,7 @@ model.rxModelVars <- model.rxode2 useErrorLine = errorLine, errLines = .errLines, origLines = .origLines, - rxui = rxui, + modelVars = c(rxui$mv0$lhs, rxui$mv0$state), returnAllLines = returnAllLines ) if (is.null(.ret)) { diff --git a/tests/testthat/test-piping-model.R b/tests/testthat/test-piping-model.R index 632ae44f62..0d7aa55dcb 100644 --- a/tests/testthat/test-piping-model.R +++ b/tests/testthat/test-piping-model.R @@ -25,22 +25,133 @@ test_that(".isDropExpression", { expect_false(.isDropExpression(str2lang("if (.) ."))) }) -test_that("model piping can change or remove an if block (#878)", { - mod <- function() { - ini({ - a <- 1 - }) - model({ - d <- a - g <- a - if (b > 1) { - d <- 2 - } - }) - } - # modChangeD <- model(mod, d <- b) - # expect_equal(modelExtract(modChangeD), c("d <- b", "g <- a", "if (b > 1) { d <- b }")) - # modNoD <- model(mod, -d) - # expect_equal(modelExtract(modNoD), "g <- a") - modNoIf <- model(mod, -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 + # TODO: Unclear why this does not return 3 + expect_equal( + .getModelineFromExpressionsAndOriginalLines( + expr = as.name("a"), + altExpr = NULL, + useErrorLine = TRUE, + errLines = 4, + origLines = origLines[2:4], + modelVars = c(), + returnAllLines = FALSE + ), + NA_real_ + ) }) + +# test_that("model piping can change or remove an if block (#878)", { +# mod <- function() { +# ini({ +# a <- 1 +# }) +# model({ +# d <- a +# g <- a +# if (b > 1) { +# d <- 2 +# } +# }) +# } +# # modChangeD <- model(mod, d <- b) +# # expect_equal(modelExtract(modChangeD), c("d <- b", "g <- a", "if (b > 1) { d <- b }")) +# # modNoD <- model(mod, -d) +# # expect_equal(modelExtract(modNoD), "g <- a") +# modNoIf <- model(mod, -if (.) .) +# }) From b7d60f32e5262ccd2b3977e88c53a320f2429240 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Tue, 1 Jul 2025 12:34:12 -0400 Subject: [PATCH 6/8] Fix test --- tests/testthat/test-piping-model.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-piping-model.R b/tests/testthat/test-piping-model.R index 0d7aa55dcb..d7da64880d 100644 --- a/tests/testthat/test-piping-model.R +++ b/tests/testthat/test-piping-model.R @@ -121,18 +121,18 @@ test_that(".getModelineFromExpressionsAndOriginalLines", { ) # `useErrorLine = TRUE` and `returnAllLines = FALSE`; variable is the LHS of the error expression but not part of the modelVars - # TODO: Unclear why this does not return 3 + # Returns 3 expect_equal( .getModelineFromExpressionsAndOriginalLines( expr = as.name("a"), altExpr = NULL, useErrorLine = TRUE, - errLines = 4, + errLines = 3, origLines = origLines[2:4], modelVars = c(), returnAllLines = FALSE ), - NA_real_ + 3 ) }) From 7eca306fa7f0ce798205d70ebaac90244dfb926b Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Tue, 1 Jul 2025 13:25:33 -0400 Subject: [PATCH 7/8] Enumerate all expected combinations of drop lines --- R/piping-model.R | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/R/piping-model.R b/R/piping-model.R index 665c0d9e49..8066d8db3e 100644 --- a/R/piping-model.R +++ b/R/piping-model.R @@ -491,11 +491,16 @@ attr(rxUiGet.mvFromExpression, "desc") <- "Calculate model variables from stored .matchesLangTemplate(x = line, template = str2lang(". = NULL"))) { return(TRUE) } - # Any line with `-something` - if (length(line) == 2L) { - if (.matchesLangTemplate(line, template = str2lang("-."))) { - 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 } From 95e4607ebd0dd3835c3a6333b6b7de05421c14a0 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Tue, 1 Jul 2025 14:33:27 -0400 Subject: [PATCH 8/8] Remove tests for dropping if blocks --- tests/testthat/test-piping-model.R | 21 --------------------- 1 file changed, 21 deletions(-) diff --git a/tests/testthat/test-piping-model.R b/tests/testthat/test-piping-model.R index d7da64880d..cd1f52d2aa 100644 --- a/tests/testthat/test-piping-model.R +++ b/tests/testthat/test-piping-model.R @@ -21,7 +21,6 @@ test_that(".isDropExpression", { expect_false(.isDropExpression(str2lang("lag(a) <- b"))) # Test for if blocks - expect_true(.isDropExpression(str2lang("-if (.) ."))) expect_false(.isDropExpression(str2lang("if (.) ."))) }) @@ -135,23 +134,3 @@ test_that(".getModelineFromExpressionsAndOriginalLines", { 3 ) }) - -# test_that("model piping can change or remove an if block (#878)", { -# mod <- function() { -# ini({ -# a <- 1 -# }) -# model({ -# d <- a -# g <- a -# if (b > 1) { -# d <- 2 -# } -# }) -# } -# # modChangeD <- model(mod, d <- b) -# # expect_equal(modelExtract(modChangeD), c("d <- b", "g <- a", "if (b > 1) { d <- b }")) -# # modNoD <- model(mod, -d) -# # expect_equal(modelExtract(modNoD), "g <- a") -# modNoIf <- model(mod, -if (.) .) -# })