Skip to content

Commit

Permalink
Merge pull request #628 from nlmixr2/627-remove-labels-in-piping
Browse files Browse the repository at this point in the history 
627 remove labels in piping
  • Loading branch information
@mattfidler
mattfidler authored Dec 6, 2023
2 parents 7b1adc2 + 1eec52e commit dd99ee0
Show file tree
Hide file tree
Showing 5 changed files with 260 additions and 17 deletions.
5 changes: 5 additions & 0 deletions NEWS.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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) <-
Expand Down
72 changes: 60 additions & 12 deletions R/piping-ini.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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()
}

Expand Down Expand Up @@ -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
Expand All @@ -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(
Expand Down
49 changes: 47 additions & 2 deletions R/piping-model.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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]]
}
Expand All @@ -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]]
Expand Down Expand Up @@ -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
#'
Expand All @@ -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 {
Expand Down
75 changes: 75 additions & 0 deletions tests/testthat/test-piping-ini.R
View file
Original file line number Diff line number Diff line change
@@ -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({
Expand All @@ -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({
Expand Down
76 changes: 73 additions & 3 deletions tests/testthat/test-ui-piping.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)))
Expand Down Expand Up @@ -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(
Expand Down Expand Up @@ -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(
Expand Down Expand Up @@ -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(
Expand Down Expand Up @@ -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)
Expand Down

0 comments on commit dd99ee0

Please sign in to comment.