Skip to content

Commit

Permalink
Merge pull request #774 from nlmixr2/774-assign-str
Browse files Browse the repository at this point in the history 
Feature request: Allow assignment to strings
  • Loading branch information
@mattfidler
mattfidler authored Aug 28, 2024
2 parents 6812c3b + 39481bc commit 8e65f68
Show file tree
Hide file tree
Showing 44 changed files with 5,548 additions and 3,773 deletions.
2 changes: 2 additions & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -170,6 +170,7 @@ S3method(rxUiGet,funTxt)
S3method(rxUiGet,ini)
S3method(rxUiGet,iniFun)
S3method(rxUiGet,interpLines)
S3method(rxUiGet,levels)
S3method(rxUiGet,lhsCov)
S3method(rxUiGet,lhsEta)
S3method(rxUiGet,lhsTheta)
Expand All @@ -190,6 +191,7 @@ S3method(rxUiGet,simulationModel)
S3method(rxUiGet,simulationSigma)
S3method(rxUiGet,state)
S3method(rxUiGet,stateDf)
S3method(rxUiGet,statePropDf)
S3method(rxUiGet,symengineModelNoPrune)
S3method(rxUiGet,symengineModelPrune)
S3method(rxUiGet,theta)
Expand Down
26 changes: 25 additions & 1 deletion NEWS.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,11 +15,17 @@
the algorithm will look forward until it finds the first non-missing
value (or if all are missing, start looking backward).

- The order of ODEs is now only determined by the order of `cmt()` and
`d/dt()`. Compartment properties, `tad()` and other compartment
related variables no no longer affect compartment sorting. The
option `rxode2.syntax.require.ode.first` no longer does anything.

## Possible breaking changes (though unlikely)

- `iCov` is no longer merged to the event dataset. This makes solving
with `iCov` slightly faster (#743)


## New features

- You can specify the type of interpolation applied for added dosing
Expand Down Expand Up @@ -48,6 +54,16 @@
and `dvid()` declarations are now ignored when loading a `rxode2`
model with `rxS()`

- Strings can be assigned to variables in `rxode2`.

- Strings can now be enclosed with a single quote as well as a double
quote. This limitation was only in the rxode2 using string since
the R-parser changes single quotes to double quotes. (This has no
impact with `rxode2({})` and ui/function form).

- More robust string encoding for symengine (adapted from
`utils::URLencode()` and `utils::URLdecode()`)

- Empty arguments to `rxRename()` give a warning (#688)

- Promoting from covariates to parameters with model piping (via `ini()`) now
Expand Down Expand Up @@ -80,9 +96,17 @@
making changes in dparser less likely to cause segmentation faults
in `rxode2` if it wasn't recompiled.

- A new model property has been added to `$props$cmtProp` and
`$statePropDf`. Both are data-frames showing which compartment has
properties (currently `ini`, `f`, `alag`, `rate` and `dur`)
in the `rxode2` ui model. This comes from the lower
level model variable `$stateProp` which has this information
encoded in integers for each state.

## Bug fixes

- Fix `ui$props$endpoint` when the ui endpoint is defined in terms of the ode instead of lhs. See #754
- Fix `ui$props$endpoint` when the ui endpoint is defined in terms of
the ode instead of lhs. See #754

- Fix `ui$props` when the ui is a linear compartment model without `ka` defined.

Expand Down
21 changes: 20 additions & 1 deletion R/err-sim.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -429,6 +429,8 @@ attr(rxUiGet.simulationIniModel, "desc") <- "simulation model with the ini value
#' `uiModel$lstExpr`.
#' @param useIf Use an `if (CMT == X)` for endpoints
#' @param interpLines Interpolation lines, if not present
#' @param levelLines Levels lines for assigned strings. If not
#' present, use the interpolation lines from the current model.
#' @return quoted expression that can be evaluated to compiled rxode2
#' model
#' @export
Expand Down Expand Up @@ -541,7 +543,7 @@ rxCombineErrorLines <- function(uiModel, errLines=NULL, prefixLines=NULL, params
modelVars=FALSE, cmtLines=TRUE, dvidLine=TRUE,
lstExpr=NULL,
useIf=TRUE,
interpLines=NULL) {
interpLines=NULL, levelLines=NULL) {
if(!inherits(uiModel, "rxUi")) {
stop("uiModel must be a evaluated UI model by rxode2(modelFunction) or modelFunction()",
call.=FALSE)
Expand Down Expand Up @@ -583,6 +585,17 @@ rxCombineErrorLines <- function(uiModel, errLines=NULL, prefixLines=NULL, params
.lenLines <- .lenLines - 1
.k <- 1 + dvidLine * 1
}
if (is.null(levelLines)) {
.levelLines <- rxUiGet.levels(list(uiModel))
.lenLines <- .lenLines - length(.levelLines)
.k <- .k + length(.levelLines)
} else if (is.na(levelLines)) {
.levelLines <- list()
} else {
.levelLines <- levelLines
.lenLines <- .lenLines - length(.levelLines)
.k <- .k + length(.levelLines)
}
if (is.null(interpLines)) {
.interpLines <- rxUiGet.interpLines(list(uiModel))
.lenLines <- .lenLines - length(.interpLines)
Expand All @@ -605,6 +618,12 @@ rxCombineErrorLines <- function(uiModel, errLines=NULL, prefixLines=NULL, params
} else {
.ret[[2]] <- paramsLine
}
if (length(.levelLines) > 0) {
for (.i in seq_along(.levelLines)) {
.ret[[.k]] <- .levelLines[[.i]]
.k <- .k + 1
}
}
if (length(.interpLines) > 0) {
for (.i in seq_along(.interpLines)) {
.ret[[.k]] <- .interpLines[[.i]]
Expand Down
111 changes: 76 additions & 35 deletions R/rxPrune.R
View file
Original file line number Diff line number Diff line change
@@ -1,13 +1,42 @@
#' Internal Pruning function
#' Replace strings with numbers for the strAssign
#'
#' @param lhs string for the left hand side of equation or variable
#' that is trying to be replaced with an integer
#' @param ret expression that will be returned if no replacement is
#' made
#' @param strAssign The `strAssign` list from the model variables
#' @return either `ret` or the integer that corresponds to the string
#' assignment
#' @noRd
#' @author Matthew L. Fidler
.rxPruneStrAssign <- function(lhs, ret, strAssign=list()) {
if (length(strAssign) == 0L) return(ret)
.w <- which(lhs %in% names(strAssign))
if (length(.w) == 1L) {
# Replace with integer
.w <- which(vapply(seq_along(strAssign[[.w]]),
function(i) {
identical(ret, strAssign[[.w]][i])
},
logical(1)))
if (length(.w) == 1L) {
return(as.numeric(.w))
}
}
ret
}

#' Internal Pruning function
#'
#' @param x List of quoted lines
#' @param envir Environment where information is stored
#' @param strAssign string assignment list from model variables
#' @return Pruned model code
#' @author Matthew L. Fidler
#' @keywords internal
#' @export
.rxPrune <- function(x, envir = parent.frame()) {
.rxPrune <- function(x, envir = parent.frame(),
strAssign=list()) {
if (is.name(x) || is.atomic(x)) {
if (is.character(x)) {
return(deparse1(x))
Expand All @@ -16,60 +45,71 @@
} else if (is.call(x)) {
if (identical(x[[1]], quote(`if`))) {
.if <- envir$.if
.if[length(.if) + 1] <- .rxPrune(x[[2]], envir = envir)
.if[length(.if) + 1] <- .rxPrune(x[[2]], envir = envir, strAssign=strAssign)
envir$.if <- .if
.x2 <- x[-(1:2)]
if (length(.x2) == 2) {
.ret1 <- .rxPrune(.x2[[1]], envir = envir)
.ret1 <- .rxPrune(.x2[[1]], envir = envir, strAssign=strAssign)
.if[length(.if)] <- paste0("1-(", .if[length(.if)], ")")
envir$.if <- .if
.else <- envir$.else
envir$.else <- unique(c(findLhs(eval(parse(text = paste0("quote({", .ret1, "})"))))))
.ret2 <- .rxPrune(.x2[[2]], envir = envir)
.ret2 <- .rxPrune(.x2[[2]], envir = envir, strAssign=strAssign)
envir$.else <- .else
.ret <- paste0(.ret1, "\n", .ret2)
} else if (length(.x2) == 1) {
.ret <- .rxPrune(.x2[[1]], envir = envir)
.ret <- .rxPrune(.x2[[1]], envir = envir, strAssign=strAssign)
}
.if <- .if[-length(.if)]
envir$.if <- .if
return(.ret)
} else if (identical(x[[1]], quote(`(`))) {
return(paste0("(", .rxPrune(x[[2]], envir = envir), ")"))
return(paste0("(", .rxPrune(x[[2]], envir = envir, strAssign=strAssign), ")"))
} else if (identical(x[[1]], quote(`{`))) {
.x2 <- x[-1]
return(paste0(lapply(.x2, .rxPrune, envir = envir), collapse = "\n"))
return(paste0(lapply(.x2, .rxPrune, envir = envir, strAssign=strAssign), collapse = "\n"))
} else if (identical(x[[1]], quote(`==`)) ||
identical(x[[1]], quote(`>=`)) ||
identical(x[[1]], quote(`<=`)) ||
identical(x[[1]], quote(`>`)) ||
identical(x[[1]], quote(`<`)) ||
identical(x[[1]], quote(`!=`)) ||
identical(x[[1]], quote(`&&`)) ||
identical(x[[1]], quote(`||`)) ||
identical(x[[1]], quote(`&`)) ||
identical(x[[1]], quote(`|`))) {
identical(x[[1]], quote(`!=`))) {
## These cases can be strings that are assigned to integers.
## Here we need to check left/right hand sides
.x2 <- deparse1(x[[2]])
.x3 <- deparse1(x[[3]])
x[[2]] <- .rxPruneStrAssign(.x3, x[[2]], strAssign=strAssign)
x[[3]] <- .rxPruneStrAssign(.x2, x[[3]], strAssign=strAssign)
.ret <- paste0(
.rxPrune(x[[2]], envir = envir, strAssign=strAssign), as.character(x[[1]]),
.rxPrune(x[[3]], envir = envir, strAssign=strAssign))
return(.ret)
} else if (identical(x[[1]], quote(`>=`)) ||
identical(x[[1]], quote(`<=`)) ||
identical(x[[1]], quote(`>`)) ||
identical(x[[1]], quote(`<`)) ||
identical(x[[1]], quote(`&&`)) ||
identical(x[[1]], quote(`||`)) ||
identical(x[[1]], quote(`&`)) ||
identical(x[[1]], quote(`|`))) {
.ret <- paste0(
.rxPrune(x[[2]], envir = envir), as.character(x[[1]]),
.rxPrune(x[[3]], envir = envir)
)
.rxPrune(x[[2]], envir = envir, strAssign=strAssign), as.character(x[[1]]),
.rxPrune(x[[3]], envir = envir, strAssign=strAssign))
return(.ret)
} else if (identical(x[[1]], quote(`=`)) ||
identical(x[[1]], quote(`<-`)) ||
identical(x[[1]], quote(`~`))) {
identical(x[[1]], quote(`<-`)) ||
identical(x[[1]], quote(`~`))) {
.lhs <- deparse1(x[[2]])
x[[3]] <- .rxPruneStrAssign(.lhs, x[[3]], strAssign=strAssign)
if (length(envir$.if > 0)) {
.f2 <- .rxPrune(x[[2]], envir = envir)
.f2 <- .rxPrune(x[[2]], envir = envir, strAssign=strAssign)
.if <- paste0(paste0("(", envir$.if, ")"), collapse = "*")
if (any(envir$.def1 == .f2)) {
.ret <- paste0(
.f2, as.character(x[[1]]), .if, "*(",
.rxPrune(x[[3]], envir = envir), ")+(1-(", .if, "))*(",
.rxPrune(x[[3]], envir = envir, strAssign), ")+(1-(", .if, "))*(",
.f2, ")"
)
} else {
.ret <- paste0(
.f2, as.character(x[[1]]), .if, "*(",
.rxPrune(x[[3]], envir = envir), ")",
.rxPrune(x[[3]], envir = envir, strAssign=strAssign), ")",
ifelse(any(envir$.else == .f2),
paste0("+", .f2), ""
)
Expand All @@ -78,11 +118,11 @@
assign(".def1", unique(c(envir$.def1, .f2)), envir)
return(.ret)
} else {
.f2 <- .rxPrune(x[[2]], envir = envir)
.f2 <- .rxPrune(x[[2]], envir = envir, strAssign=strAssign)
assign(".def1", unique(c(envir$.def1, .f2)), envir)
return(paste0(
.f2, as.character(x[[1]]),
.rxPrune(x[[3]], envir = envir)
.rxPrune(x[[3]], envir = envir, strAssign=strAssign)
))
}
} else if (identical(x[[1]], quote(`*`)) ||
Expand All @@ -92,28 +132,28 @@
identical(x[[1]], quote(`/`))) {
if (length(x) == 3) {
return(paste0(
.rxPrune(x[[2]], envir = envir), as.character(x[[1]]),
.rxPrune(x[[3]], envir = envir)
.rxPrune(x[[2]], envir = envir, strAssign=strAssign), as.character(x[[1]]),
.rxPrune(x[[3]], envir = envir, strAssign=strAssign)
))
} else {
## Unary Operators
return(paste0(
as.character(x[[1]]),
.rxPrune(x[[2]], envir = envir)
.rxPrune(x[[2]], envir = envir, strAssign=strAssign)
))
}
} else if (identical(x[[1]], quote(`ifelse`))) {
.f2 <- .rxPrune(x[[2]], envir = envir)
.f3 <- .rxPrune(x[[3]], envir = envir)
.f4 <- .rxPrune(x[[4]], envir = envir)
.f2 <- .rxPrune(x[[2]], envir = envir, strAssign=strAssign)
.f3 <- .rxPrune(x[[3]], envir = envir, strAssign=strAssign)
.f4 <- .rxPrune(x[[4]], envir = envir, strAssign=strAssign)
return(paste0("((", .f2, ")*(", .f3, ")+(1-(", .f2, "))*(", .f4, "))"))
} else if (identical(x[[1]], quote(`[`))) {
.type <- toupper(as.character(x[[2]]))
## Since only THETA/ETA are allowed with rxode2 pruning
## only will take legal rxode2; Therefore just paste these.
return(paste0(.type, "[", x[[3]], "]"))
} else {
.ret0 <- lapply(x, .rxPrune, envir = envir)
.ret0 <- lapply(x, .rxPrune, envir = envir, strAssign=strAssign)
.ret <- paste0(.ret0[[1]], "(")
.ret0 <- .ret0[-1]
.ret <- paste0(.ret, paste0(unlist(.ret0), collapse = ", "), ")")
Expand All @@ -137,8 +177,9 @@
#' @export
rxPrune <- function(x) {
.env <- new.env(parent = emptyenv())
.mv <- rxModelVars(x)
.env$.if <- NULL
.env$.def1 <- NULL
.ret <- .rxPrune(eval(parse(text = paste0("quote({", rxNorm(x), "})"))), envir = .env)
.ret <- .rxPrune(eval(parse(text = paste0("quote({", rxNorm(x), "})"))), envir = .env, strAssign=.mv$strAssign)
return(.ret)
}
50 changes: 49 additions & 1 deletion R/rxUiGet.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -49,13 +49,29 @@ rxUiGet <- function(x, ...) {
UseMethod("rxUiGet")
}

#' @rdname rxUiGet
#' @export
rxUiGet.levels <- function(x, ...) {
.x <- x[[1]]
.mv <- rxModelVars(.x)
.str <- .mv$strAssign
.names <- names(.str)
lapply(vapply(seq_along(.str), function(i) {
paste0("levels(", .names[i], ") <- ",
deparse1(.str[[i]]))
}, character(1), USE.NAMES=FALSE),
str2lang)
}

#' @rdname rxUiGet
#' @export
rxUiGet.state <- function(x, ...) {
.ui <- x[[1]]
rxModelVars(.ui)$state
}
attr(rxUiGet.state, "desc") <- "states associated with the model (in order)"

#' @rdname rxUiGet
#' @export
rxUiGet.stateDf <- function(x, ...) {
.ui <- x[[1]]
Expand All @@ -65,6 +81,37 @@ rxUiGet.stateDf <- function(x, ...) {
}
attr(rxUiGet.stateDf, "desc") <- "states and cmt number data.frame"

#' @export
#' @rdname rxUiGet
rxUiGet.statePropDf <- function(x,...) {
.ui <- x[[1]]
.mv <- rxModelVars(.ui)
do.call(rbind, lapply(seq_along(.mv$stateProp),
function(i) {
.prop <- .mv$stateProp[i]
if (.prop == 0) return(NULL)
.name <- names(.mv$stateProp)[i]
.props <- character(0)
if (bitwAnd(.prop, 1)) {
.props <- c(.props, "ini")
}
if (bitwAnd(.prop, 2)) {
.props <- c(.props, "f")
}
if (bitwAnd(.prop, 4)) {
.props <- c(.props, "alag")
}
if (bitwAnd(.prop, 8)) {
.props <- c(.props, "rate")
}
if (bitwAnd(.prop, 16)) {
.props <- c(.props, "dur")
}
data.frame("Compartment"=.name,
"Property"=.props)
}))
}

#' @export
#' @rdname rxUiGet
rxUiGet.props <- function(x, ...) {
Expand Down Expand Up @@ -121,7 +168,8 @@ rxUiGet.props <- function(x, ...) {
output=list(primary=.primary,
secondary=.secondary,
endpoint=.end,
state=.x$state))
state=.x$state),
cmtProp=rxUiGet.statePropDf(x,...))
}
attr(rxUiGet.props, "desc") <- "rxode2 model properties"

Expand Down
Loading

0 comments on commit 8e65f68

Please sign in to comment.