#' @export
#' @rdname model
model.function <- function(x, ..., append=NULL, auto=getOption("rxode2.autoVarPiping", TRUE),
cov=NULL, envir=parent.frame()) {
.modelLines <- .quoteCallInfoLines(match.call(expand.dots = TRUE)[-(1:2)], envir=envir)
.ret <- rxUiDecompress(rxode2(x))
if (length(.modelLines) == 0) return(.ret$modelFun)
.modelHandleModelLines(.modelLines, .ret, modifyIni=FALSE, append=append, auto=auto,
cov=cov, envir=envir)
}
#' @export
#' @rdname model
model.rxUi <- function(x, ..., append=NULL, auto=getOption("rxode2.autoVarPiping", TRUE),
cov=NULL, envir=parent.frame()) {
.modelLines <- .quoteCallInfoLines(match.call(expand.dots = TRUE)[-(1:2)], envir=envir)
.ret <- rxUiDecompress(.copyUi(x)) # copy so (as expected) old UI isn't affected by the call
if (length(.modelLines) == 0) return(.ret$modelFun)
.ret <- .modelHandleModelLines(.modelLines, .ret, modifyIni=FALSE, append=append, auto=auto,
cov=cov, envir=envir)
# need to adjust since the model function was from a rxui object
.x <- rxUiDecompress(x)
.ret <- rxUiDecompress(.ret)
.ret <- .newModelAdjust(.ret, .x)
.ret <- rxUiCompress(.ret)
.cls <- setdiff(class(x), class(.ret))
if (length(.cls) > 0) {
class(.ret) <- c(.cls, class(.ret))
}
.ret
}
#' @export
#' @rdname model
model.rxode2 <- function(x, ..., append=NULL, auto=getOption("rxode2.autoVarPiping", TRUE),
cov=NULL, envir=parent.frame()) {
.modelLines <- .quoteCallInfoLines(match.call(expand.dots = TRUE)[-(1:2)], envir=envir)
x <- as.function(x)
.ret <- suppressMessages(rxUiDecompress(rxode2(x)))
if (length(.modelLines) == 0) return(.ret$modelFun)
.modelHandleModelLines(.modelLines, .ret, modifyIni=FALSE, append=append, auto=auto,
cov=cov, envir=envir)
}
#' @export
#' @rdname model
model.rxModelVars <- model.rxode2
#' Handle model lines
#'
#' @param modelLines The model lines that are being considered
#' @param rxui The rxode2 UI object
#' @param modifyIni Should the ini({}) be considered
#' @param envir Environment for evaluation
#' @inheritParams model
#' @return New UI
#' @author Matthew L. Fidler
#' @export
.modelHandleModelLines <- function(modelLines, rxui, modifyIni=FALSE, append=NULL,
auto=getOption("rxode2.autoVarPiping", TRUE),
cov=NULL, envir) {
checkmate::assertLogical(modifyIni, any.missing=FALSE, len=1)
## checkmate::assertLogical(append, any.missing=TRUE, len=1)
checkmate::assertLogical(auto, any.missing=TRUE, len=1)
checkmate::assertCharacter(cov, pattern="^[.]*[a-zA-Z]+[a-zA-Z0-9._]*$", null.ok=TRUE)
.varSelect$cov <- cov
.doAppend <- FALSE
rxui <- rxUiDecompress(rxui)
.ll <- length(rxui$lstExpr)
if (!is.null(.nsEnv$.quoteCallInfoLinesAppend)) {
if (identical(.nsEnv$.quoteCallInfoLinesAppend, quote(Inf))) {
.nsEnv$.quoteCallInfoLinesAppend <- NULL
append <- TRUE
} else if (identical(.nsEnv$.quoteCallInfoLinesAppend, quote(-Inf))) {
.nsEnv$.quoteCallInfoLinesAppend <- NULL
append <- NA
} else if (identical(.nsEnv$.quoteCallInfoLinesAppend, quote(0))) {
.nsEnv$.quoteCallInfoLinesAppend <- NULL
append <- NA
} else if (checkmate::testIntegerish(.nsEnv$.quoteCallInfoLinesAppend, lower=.ll)) {
.nsEnv$.quoteCallInfoLinesAppend <- NULL
append <- TRUE
}
}
if (!is.null(.nsEnv$.quoteCallInfoLinesAppend)) {
if (checkmate::testIntegerish(.nsEnv$.quoteCallInfoLinesAppend, lower=0, upper=.ll)) {
.nsEnv$.quoteCallInfoLinesAppend <- .getLhs(rxui$lstExpr[[.nsEnv$.quoteCallInfoLinesAppend]])
} else if (checkmate::testCharacter(.nsEnv$.quoteCallInfoLinesAppend, len=1, any.missing=FALSE,
min.chars = 1)) {
.tmp <- try(str2lang(.nsEnv$.quoteCallInfoLinesAppend), silent=TRUE)
if (inherits(.tmp, "try-error")) {
stop("'append' must refer to a LHS model line when a character",
call. = FALSE)
}
.nsEnv$.quoteCallInfoLinesAppend <- .tmp
}
.w <- which(vapply(seq_len(.ll),
function(i) {
.lhs <- .getLhs(rxui$lstExpr[[i]])
identical(.lhs, .nsEnv$.quoteCallInfoLinesAppend)
}, logical(1), USE.NAMES=FALSE))
if (length(.w) == 0) {
.var <- deparse1(.nsEnv$.quoteCallInfoLinesAppend)
.stop <- TRUE
if (!is.null(.asFunctionEnv$rx)) {
if (any(.asFunctionEnv$rx$lhs == .var)) {
.iniDf <- rxui$iniDf
.tmp <- .asFunctionEnv$rx
.cls <- class(.asFunctionEnv$rx)
class(.asFunctionEnv$rx) <- "rxode2"
.fun <- suppressMessages(as.function(.asFunctionEnv$rx))
class(.asFunctionEnv$rx) <- .cls
rxui <- suppressMessages(as.rxUi(.fun))
ini(rxui) <- .iniDf
rxui <- rxUiDecompress(rxui)
.ll <- length(rxui$lstExpr)
.w <- which(vapply(seq_len(.ll),
function(i) {
.lhs <- .getLhs(rxui$lstExpr[[i]])
identical(.lhs, .nsEnv$.quoteCallInfoLinesAppend)
}, logical(1), USE.NAMES=FALSE))
if (length(.w) == 0) {
.stop <- TRUE
} else {
.stop <- FALSE
}
}
}
if (.stop) {
stop("cannot find '", .var, "' in lhs model, cannot append", call.=FALSE)
}
}
.w <- max(.w)
if (.w == .ll) {
assign("lstExpr", c(rxui$lstExpr, modelLines), envir=rxui)
} else {
assign("lstExpr", c(rxui$lstExpr[seq(1, .w)], modelLines, rxui$lstExpr[seq(.w+1, .ll)]),
envir=rxui)
}
.doAppend <- TRUE
} else if (is.logical(append) && length(append) == 1L && (is.na(append) || !append)) {
assign("lstExpr", c(modelLines, rxui$lstExpr), envir=rxui)
.doAppend <- TRUE
} else if (isTRUE(append)) {
assign("lstExpr", c(rxui$lstExpr, modelLines), envir=rxui)
.doAppend <- TRUE
}
if (.doAppend) {
# in pre-pending or appending, lines are only added
.lhs <- character(0)
.rhs <- character(0)
.lhs0 <- c(rxui$mv0$lhs, rxui$mv0$state, rxui$allCovs, rxui$iniDf$name)
for (x in modelLines) {
.isTilde <- .isEndpoint(x)
if (.isTilde || .isAssignment(x)) {
.rhs <- unique(c(.getVariablesFromExpression(.getRhs(x), ignorePipe=.isTilde), .rhs))
.lhs <- unique(c(.getVariablesFromExpression(.getLhs(x)), .lhs))
}
.rhs <- setdiff(.rhs, c(.lhs, .lhs0))
if (isTRUE(auto)) {
for (v in .rhs) {
.isCov <- grepl(.varSelect$covariateExceptions, tolower(v))
.isTheta <- !.isCov && grepl(.varSelect$thetaModelReg, v)
.isEta <- !.isCov && grepl(.varSelect$etaModelReg, v)
if (.isTilde || .isTheta || .isEta) {
.addVariableToIniDf(v, rxui,
promote=ifelse(.isTilde,NA,
TRUE))
.lhs <- c(.lhs, v)
}
}
}
}
return(rxUiCompress(rxui$fun()))
}
.modifyModelLines(lines = modelLines, rxui = rxui, modifyIni = modifyIni, envir = envir)
.v <- .getAddedOrRemovedVariablesFromNonErrorLines(rxui)
if (length(.v$rm) > 0) {
lapply(.v$rm, function(x) {
.removeVariableFromIniDf(x, rxui, promote=ifelse(x %in% .v$err, NA, FALSE))
})
}
if (length(.v$new) > 0) {
lapply(.v$new, function(x) {
.isErr <- x %in% .v$err
if (auto || .isErr) {
.addVariableToIniDf(x, rxui, promote=ifelse(.isErr, NA, FALSE))
} else if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
.minfo(paste0("add covariate {.code ", x, "}"))
}
})
}
rxUiCompress(rxui$fun())
}
# Determine if the input is an endpoint by being 3 long and the call part being
# a tilde
.isEndpoint <- function(expr) {
.matchesLangTemplate(expr, str2lang(". ~ ."))
}
# Determine if the input is an assignment by being 3 long and the call part
# being either the left arrow, right arrow, or equal sign
.isAssignment <- function(expr) {
.matchesLangTemplate(expr, str2lang(". <- .")) ||
.matchesLangTemplate(expr, str2lang(". = ."))
}
.isTildeExpr <- function(expr) {
.matchesLangTemplate(expr, str2lang("~ ."))
}
.isIniDropExpression <- function(expr) {
.matchesLangTemplate(expr, str2lang("- ."))
}
# get the left hand side of an assignment or endpoint; returns NULL if the input
# is not an assignment or endpoint
.getLhs <- function(expr) {
ret <- NULL
if (.isAssignment(expr) || .isEndpoint(expr)) {
ret <- expr[[2]]
}
ret
}
.getRhs <- function(expr, ignorePipe=FALSE) {
ret <- NULL
if (.isAssignment(expr) || .isEndpoint(expr)) {
ret <- expr[[3]]
}
ret
}
.getModelLineEquivalentLhsExpressionDropEndpoint <- function(expr) {
ret <- NULL
if (.isEndpoint(expr)) {
lhs <- .getLhs(expr)
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]]
}
}
ret
}
.getModelLineEquivalentLhsExpressionDropDdt <- function(expr) {
.expr3 <- NULL
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]]
}
.expr3
}
#' This gives a equivalent left handed expression
#'
#' @param expr This exchanges expressions ie f() to F()
#' @return NULL if there isn't an equivalent expression, or the
#' equivalent expression.
#' @author Matthew L. Fidler
#' @noRd
.getModelLineEquivalentLhsExpression <- function(expr) {
.expr3 <- .getModelLineEquivalentLhsExpressionDropDdt(expr)
if (is.null(.expr3)) .expr3 <- .getModelLineEquivalentLhsExpressionDropEndpoint(expr)
if (length(expr) == 2L) {
.expr1 <- expr[[1]]
.expr2 <- expr[[2]]
if (identical(.expr1, quote(`f`))) {
.expr3 <- eval(parse(text=paste0("quote(F(",as.character(.expr2),"))")))
}
if (identical(.expr1, quote(`F`))) {
.expr3 <- eval(parse(text=paste0("quote(f(",as.character(.expr2),"))")))
}
if (identical(.expr1, quote(`lag`))) {
.expr3 <- eval(parse(text=paste0("quote(alag(",as.character(.expr2),"))")))
}
if (identical(.expr1, quote(`alag`))) {
.expr3 <- eval(parse(text=paste0("quote(lag(",as.character(.expr2),"))")))
}
if (identical(.expr1, quote(`-`))) {
.expr3 <- .expr2
}
}
.expr3
}
#' Get the model line number from the expression
#'
#' @param expr The Left handed expression to find
#' @param altExpr The alternate expression to find (or `NULL`), this
#' is for expressions that are equivalent like `f(center)` and
#' `F(center)`.
#' @param useErrorLine This is a boolean indicating if error lines
#' should be considered (`TRUE`).
#' @param errLines This is an integer vector of the lines where an
#' 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 returnAllLines Return all line numbers for the lhs, even
#' when there are duplicates. (default `FALSE`)
#' @return For duplicated lines: `NULL` for duplicated lines (when
#' `returnAllLines` is FALSE) or all the line numbers (when
#' `returnAllLines` is TRUE).
#'
#' For non-duplicated lines return the line number (if
#' it is found) and `NA` if it is not found.
#'
#' @author Matthew L. Fidler
#' @noRd
.getModelineFromExpressionsAndOriginalLines <- function(expr, altExpr, useErrorLine,
errLines, origLines, rxui,
returnAllLines=FALSE) {
.ret <- NA_integer_
.multipleEndpointModel <- length(errLines) != 1L
for (.i in seq_along(origLines)) {
.isErrorLine <- .i %in% errLines
if (returnAllLines ||
(useErrorLine && .isErrorLine) ||
(!useErrorLine && !.isErrorLine)) {
.expr <- origLines[[.i]]
if (identical(.expr[[2]], expr)) {
if (is.na(.ret)) {
.ret <- .i
} else if (returnAllLines) {
.ret <- c(.ret, .i)
} else {
return(NULL)
}
} else if (!is.null(altExpr)) {
if (identical(.expr[[2]], altExpr)) {
if (is.na(.ret)) {
.ret <- .i
} else if (returnAllLines) {
.ret <- c(.ret, .i)
} else {
return(NULL)
}
}
} else if (useErrorLine && !.multipleEndpointModel) {
if (is.na(.ret)) {
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), "'",
call.=FALSE)
}
}
if (!identical(.expr[[2]], expr)) {
warning("with single endpoint model prediction '", deparse1(.expr[[2]]), "' is changed to '", expr, "'",
call.=FALSE)
}
.ret <- .i
} else {
return(NULL)
}
}
}
}
.ret
}
#' Get the negative model line for ode based on ode property
#'
#' @param expr Left handed expression
#' @param origLines List of original lines (expressions)
#' @param errorLine Consider error lines
#' @return `NA` if the ODE isn't found. Negative number for the lowest
#' line of the ODE compartment.
#' @author Matthew L. Fidler
#' @noRd
.getNegativeModelLineForDiffFromProperty <- function(expr, origLines, errorLine) {
.ret <- NA_integer_
if (!errorLine && length(expr) == 2L) {
.expr1 <- expr[[1]]
.expr2 <- expr[[2]]
if (is.numeric(.expr2)) {
.state <- as.character(.expr1)
} else {
.state <- as.character(.expr2)
}
if (is.numeric(.expr2) ||
identical(.expr1, quote(`f`)) ||
identical(.expr1, quote(`F`)) ||
identical(.expr1, quote(`alag`)) ||
identical(.expr1, quote(`lag`)) ||
identical(.expr1, quote(`rate`)) ||
identical(.expr1, quote(`dur`))) {
.expr3 <- eval(parse(text=paste0("quote(d/dt(",.state,"))")))
for (.i in seq_along(origLines)) {
.expr <- origLines[[.i]]
if (identical(.expr[[2]], .expr3)) {
if (is.na(.ret)) {
.ret <- -.i
} else {
.ret <- min(-.i, .ret)
}
}
}
}
}
.ret
}
#' Find the line of the original expression
#'
#' @param expr Expression
#'
#' @param rxui rxode2 UI
#'
#' @param errorLine When TRUE, Should the error line be considered, or
#' consider the non-error line
#'
#' @param returnAllLines A boolean to determine if all line numbers
#' should be returned, by default `FALSE`
#'
#' @return The return can be:
#'
#' - Line number of from the original model, if the model matches one
#' line uniquely (or an integer vector of all the lines matching when `returnAllLines=TRUE`)
#'
#' - Negative number; This indicates the model property (ie
#' `f(depot)`) is not found in the model, but the differential
#' equation `d/dt(depot)` is defined uniquely i the model and is
#' found at the -(line number) returned.
#'
#' - `NA` which means the line (or related line) was not found in the
#' model
#'
#' - `NULL` which means a line is duplicated in the model
#'
#' @author Matthew L. Fidler
#'
#' @noRd
.getModelLineFromExpression <- function(lhsExpr, rxui, errorLine=FALSE, returnAllLines=FALSE) {
.origLines <- rxui$lstExpr
.errLines <- rxui$predDf$line
.expr3 <- .getModelLineEquivalentLhsExpression(lhsExpr)
.ret <- .getModelineFromExpressionsAndOriginalLines(lhsExpr, .expr3, errorLine, .errLines, .origLines, rxui, returnAllLines)
if (is.null(.ret)) {
return(NULL)
} else if (length(.ret) > 1) {
return(.ret)
} else if (!is.na(.ret)) {
return(.ret)
}
.getNegativeModelLineForDiffFromProperty(lhsExpr, .origLines, errorLine)
}
#' @export
rxUiGet.mvFromExpression <- function(x, ...) {
.x <- x[[1]]
.exact <- x[[2]]
if (is.null(.x$predDf)) {
eval(call("rxModelVars",as.call(c(list(quote(`{`)), .x$lstExpr))))
} else {
eval(call("rxModelVars",as.call(c(list(quote(`{`)), .x$lstExpr[-.x$predDf$line]))))
}
}
attr(rxUiGet.mvFromExpression, "desc") <- "Calculate model variables from stored (possibly changed) expression"
#' Describe if the piping expression is a drop expression
#'
#' @param line expression for line/expression
#' @return `TRUE` if this is a drop expression like `%>% model(-v)`, otherwise `FALSE`
#' @author Matthew L. Fidler
#' @noRd
.isDropExpression <- function(line) {
if (!is.null(.getModelLineEquivalentLhsExpressionDropDdt(line))) {
return(TRUE)
}
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)
}
}
}
}
FALSE
}
.getAdditionalDropLines <- function(line, rxui, isErr, isDrop) {
.dropCmt <- .getModelLineEquivalentLhsExpressionDropDdt(line)
if (!is.null(.dropCmt)) {
.state <- .dropCmt[[3]][[2]]
.types <- list(quote(`f`), quote(`F`), quote(`alag`),
quote(`lag`), quote(`dur`), quote(`rate`), NULL)
.types <- lapply(seq_along(.types),
function(i) {
.cur <- .types[[i]]
if (is.null(.cur)) {
as.call(list(.state, 0))
} else {
as.call(list(.cur, .state))
}
})
return(unique(do.call("c", lapply(seq_along(.types), function(i) {
.v <- .getModelLineFromExpression(.types[[i]], rxui, isErr, isDrop)
if (is.na(.v[1])) {
return(NULL)
} else if (.v[1] < 0) {
return(NULL)
} else {
return(.v)
}
}))))
}
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
#'
#' @param lines quoted lines to modify
#' @param rxui UI to save information
#' @param modifyIni Modify ini({}) types of calls
#' @param envir Environment
#' @return Nothing, called for the side effects
#' @author Matthew L. Fidler
#' @noRd
.modifyModelLines <- function(lines, rxui, modifyIni=FALSE, envir) {
.err <- NULL
.env <- environment()
lapply(lines, function(line) {
line <- .changeDropNullLine(line)
if (modifyIni && .isQuotedLineRhsModifiesEstimates(line, rxui)) {
.iniHandleFixOrUnfix(line, rxui, envir=envir)
} else {
.isErr <- .isErrorExpression(line)
.isDrop <- .isDropExpression(line)
if (.isDrop && .isErr) {
.ret <- .getModelLineFromExpression(.getModelLineEquivalentLhsExpression(line), rxui, .isErr, FALSE)
} else if (.isDrop) {
.ret <- .getModelLineFromExpression(.getModelLineEquivalentLhsExpression(line), rxui, .isErr, .isDrop)
.ret <- c(.ret, .getAdditionalDropLines(line, rxui, .isErr, .isDrop))
} else {
.ret <- .getModelLineFromExpression(.getLhs(line), rxui, .isErr, .isDrop)
}
if (length(.ret) == 1) {
if (.isErr && is.na(.ret)) {
stop("the error '", deparse1(line[[2]]), "' is not in the multiple-endpoint model and cannot be modified",
call.=FALSE)
}
}
if (is.null(.ret)) {
assign(".err",
c(.err, paste0("the lhs expression '", deparse1(line[[2]]), "' is duplicated in the model and cannot be modified by piping")),
envir=.env)
} else if (is.na(.ret[1])) {
assign(".err",
c(.err, paste0("the lhs expression '", deparse1(line[[2]]), "' is not in the model and cannot be modified by piping")),
envir=.env)
} else if (all(.ret > 0)) {
if (.isDrop) {
.lstExpr <- get("lstExpr", rxui)
.predDf <- get("predDf", rxui)
.ret0 <- sort(.ret, decreasing=TRUE)
if (length(.predDf$cond) == 1L && any(.ret0 %in% .predDf$line)) {
.predDf <- NULL
.lstExpr <- .lstExpr[-.ret]
} else {
for (.i in .ret0) {
## Drop lines that match
.w <- which(.predDf$line == .i)
if (length(.w) > 0) {
.predDf <- .predDf[-.w,, drop = FALSE]
}
# renumber lines greater
.w <- which(.predDf$line > .i)
if (length(.w) > 0) {
.predDf$line[.w] <- .predDf$line[.w] - 1L
}
.lstExpr <- .lstExpr[-.i]
}
}
assign("predDf", .predDf, rxui)
assign("lstExpr", .lstExpr, rxui)
assign(".recalculate", TRUE, rxui)
} else {
if (.isErr) {
.throwIfInvalidTilde(line)
}
.lstExpr <- get("lstExpr", rxui)
.lstExpr[[.ret]] <- line
assign("lstExpr", .lstExpr, rxui)
assign(".recalculate", TRUE, rxui)
}
} else {
if (.isErr) {
.throwIfInvalidTilde(line)
}
.lstExpr <- get("lstExpr", rxui)
.lstExpr[[length(.lstExpr) + 1]] <- line
assign("lstExpr", .lstExpr, rxui)
assign(".recalculate", TRUE, rxui)
}
}
NULL
})
if (!is.null(.err)) {
stop(paste(.err, collapse="\n"), call.=FALSE)
}
}
#' Get the Variables from the expression
#'
#' @param x Expression
#' @return Character vector of variables
#' @author Matthew L. Fidler
#' @noRd
.getVariablesFromExpression <- function(x, ignorePipe=FALSE) {
if (is.atomic(x)) {
character()
} else if (is.name(x)) {
return(as.character(x))
} else if (.matchesLangTemplate(x, str2lang("d/dt(.name)"))) {
# ODE expressions only pull out the state name and not "d" or "dt"
return(as.character(x[[3]][[2]]))
} else {
if (is.call(x)) {
if (ignorePipe && identical(x[[1]], quote(`|`))) {
return(.getVariablesFromExpression(x[[2]]))
} else {
x1 <- x[-1]
}
} else {
x1 <- x
}
unique(unlist(lapply(x1, .getVariablesFromExpression, ignorePipe=ignorePipe)))
}
}
#' @export
rxUiGet.errParams <- function(x, ...) {
.x <- x[[1]]
.exact <- x[[2]]
unlist(lapply(.x$lstExpr[.x$predDf$line], function(x) {
.getVariablesFromExpression(x[[3]])
}))
}
attr(rxUiGet.errParams, "desc") <- "Get the error-associated variables"
#' Get the added or removed variables
#'
#' @param rxui This is the rxode2 UI object
#'
#' @return A list with the removed and added error objects
#'
#' @author Matthew L. Fidler
#'
#' @noRd
.getAddedOrRemovedVariablesFromNonErrorLines <- function(rxui) {
.old <- rxui$mv0$params
.new <- rxui$mvFromExpression$params
.both <- intersect(.old, .new)
.rm1 <- setdiff(.old, .both)
.new1 <- setdiff(.new, .both)
.old <- rxui$errParams0
.err <- rxui$errParams
.new <- rxui$errParams
.both <- intersect(.old, .new)
.rm2 <- setdiff(.old, .both)
.new2 <- setdiff(.new, .both)
.new <- c(.new1, .new2)
.new <- setdiff(.new, rxui$mv0$lhs)
.rm <- c(.rm1, .rm2)
.rm <- setdiff(.rm, .err)
list(rm=.rm, new=.new, err=.err)
}
#' Remove a single variable from the initialization data frame
#'
#' @param var Variable that is removed
#' @param rxui UI function where the initial estimate data frame is modified
#' @inheritParams .addVariableToIniDf
#' @return Nothing, called for side effects
#' @author Matthew L. Fidler
#' @noRd
.removeVariableFromIniDf <- function(var, rxui, promote=FALSE) {
.iniDf <- rxui$iniDf
.w <- which(.iniDf$name == var)
if (length(.w) == 1L) {
.neta <- .iniDf$neta1[.w]
.iniDf <- .iniDf[-.w, ]
if (!is.na(.neta)) {
# Here we remove any assocaited covariance terms that remain
.w1 <- which(.iniDf$neta1 == .neta)
if (length(.w1) > 0) .iniDf <- .iniDf[-.w1, ]
.w1 <- which(.iniDf$neta2 == .neta)
if (length(.w1) > 0) .iniDf <- .iniDf[-.w1, ]
if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
.mwarn(paste0("remove between subject variability {.code ", var, "}"))
}
} else if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
if (is.na(promote)) {
.mwarn(paste0("remove residual parameter {.code ", var, "}"))
} else {
.mwarn(paste0("remove population parameter {.code ", var, "}"))
}
}
assign("iniDf", .iniDf, rxui)
}
invisible()
}
.varSelect <- new.env(parent=emptyenv())
#' Set the variables for the model piping automatic covarite selection
#'
#' @param thetamodelVars This is the prefixes for the theta model
#' variables in a regular expression
#' @param covariateExceptions This is a regular expression of
#' covariates that should always be covariates
#' @param etaParts This is the list of eta prefixes/post-fixes that
#' identify a variable as a between subject variability
#' @return Nothing, called for side effects
#' @export
#' @author Matthew L. Fidler
#' @details
#'
#' This is called once at startup to set the defaults, though you can
#' change this if you wish so that piping can work differently for
#' your individual setup
#'
rxSetPipingAuto <- function(thetamodelVars=rex::rex(or("tv", "t", "pop", "POP", "Pop",
"TV", "T", "cov", "err", "eff")),
covariateExceptions = rex::rex(start, or("wt", "sex", "crcl", "kout"), end),
etaParts=c("eta", "ETA", "Eta", "ppv", "PPV", "Ppv", "iiv", "Iiv",
"bsv", "Bsv", "BSV","bpv", "Bpv", "BPV", "psv", "PSV",
"Psv")
) {
.varSelect$thetamodelVars <- thetamodelVars
.varSelect$thetaModelReg <- rex::rex(or(
group(start, thetamodelVars),
group(thetamodelVars, end)))
.varSelect$covariateExceptions <- covariateExceptions
.varSelect$etaParts <- etaParts
.varSelect$etaModelReg <- rex::rex(or(group(start, or(etaParts)),
group(or(etaParts), end)))
.varSelect$covariateNames <- NULL
.varSelect$cov <- NULL
}
rxSetPipingAuto()
.rxIniDfTemplate <-
data.frame(
ntheta = NA_integer_,
neta1 = NA_real_,
neta2 = NA_real_,
name = NA_character_,
lower = -Inf,
est = NA_real_,
upper = Inf,
fix = FALSE,
label = NA_character_,
backTransform = NA_character_,
condition = NA_character_,
err = NA_character_
)
#' Assign covariates for piping
#'
#' @param covariates NULL (for no covariates), or the list of
#' covariates. nlmixr uses this function to set covariates if you
#' pipe from a nlmixr fit.
#'
#' @return Nothing, called for side effects
#'
#' @author Matthew L. Fidler
#'
#' @export
#'
#' @examples
#'
#' # First set the name of known covariates
#' # Note this is case sensitive
#'
#' rxSetCovariateNamesForPiping(c("WT","HT", "TC"))
#'
#' one.compartment <- function() {
#' ini({
#' tka <- 0.45 ; label("Log Ka")
#' tcl <- 1 ; label("Log Cl")
#' tv <- 3.45 ; label("Log V")
#' eta.ka ~ 0.6
#' eta.cl ~ 0.3
#' eta.v ~ 0.1
#' add.err <- 0.7
#' })
#' model({
#' ka <- exp(tka + eta.ka)
#' cl <- exp(tcl + eta.cl)
#' v <- exp(tv + eta.v)
#' d / dt(depot) <- -ka * depot
#' d/dt(depot) <- -ka * depot
#' d / dt(center) <- ka * depot - cl / v * center
#' cp <- center / v
#' cp ~ add(add.err)
#' })
#' }
#'
#' # now TC is detected as a covariate instead of a population parameter
#'
#' one.compartment %>%
#' model({ka <- exp(tka + eta.ka + TC * cov_C)})
#'
#' # You can turn it off by simply adding it back
#'
#' rxSetCovariateNamesForPiping()
#'
#' one.compartment %>%
#' model({ka <- exp(tka + eta.ka + TC * cov_C)})
#'
#' # The covariates you set with `rxSetCovariateNamesForPiping()`
#' # are turned off every time you solve (or fit in nlmixr)
#'
#' @export
rxSetCovariateNamesForPiping <- function(covariates=NULL) {
if (!is.null(covariates)) {
checkmate::assertCharacter(covariates, any.missing=FALSE, unique=TRUE)
}
.varSelect$covariateNames <- covariates
}
#' Add a single variable from the initialization data frame
#'
#' @param var Variable that is added
#' @param rxui UI function where the initial estimate data frame is
#' modified
#' @param toEta This boolean determines if it should be added to the
#' etas (`TRUE`), thetas (`FALSE`) or determined by `.etaModelReg`
#' (`NA`)
#' @param value This is the value to assign to the ini block
#' @param promote This boolean determines if the parameter was
#' promoted from an initial covariate parameter (`TRUE`). If so it
#' changes the verbose message to the user. If not, (`FALSE`) it
#' will only add if it is a covariate. If `NA` it will assume that
#' the parameter is an error term. When `promote` is `TRUE`, it will
#' also remove the parameter from the `$allCovs`.
#' @return Nothing, called for side effects
#' @author Matthew L. Fidler
#' @noRd
.addVariableToIniDf <- function(var, rxui, toEta=NA, value=1, promote=FALSE) {
if (var %in% c("pi", "M_E", "M_E", "E", "M_PI", "M_PI_2",
"M_PI_4", "M_1_PI", "M_2_PI", "M_2PI", "M_SQRT_PI",
"M_2_SQRTPI", "M_1_SQRT_2PI", "M_SQRT2", "M_SQRT_3",
"M_SQRT_32", "M_SQRT_2dPI", "M_LN_SQRT_PI",
"M_LN_SQRT_2PI", "M_LN_SQRT_PId2", "M_LOG10_2",
"M_LOG2E", "M_LOG10E", "M_LN2", "M_LN10")) {
return(invisible())
}
if (!is.null(.varSelect$cov)) {
if (var %in% .varSelect$cov) {
if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
.minfo(paste0("add covariate {.code ", var, "} (as requested by cov option)"))
}
return(invisible())
}
}
.mv <- rxModelVars(rxui)
.ini <- .mv$ini
.ini <- .ini[which(!is.na(.ini))]
if (var %in% names(.ini)) {
return(invisible())
}
.iniDf <- rxui$iniDf
.isEta <- TRUE
checkmate::assertLogical(toEta, len=1)
if (is.na(promote)) {
checkmate::assertNumeric(value, len=1, any.missing=FALSE)
} else if (promote) {
if (is.na(toEta)) {
checkmate::assertNumeric(value, len=1, any.missing=FALSE)
} else if (toEta) {
checkmate::assertNumeric(value, len=1, any.missing=TRUE)
} else {
if (length(value) %in% c(2, 3)) {
# This is for promotion to parameter, only. Additional bound setting
# happens elsewhere.
value <- value[2]
}
checkmate::assertNumeric(value, len=1, any.missing=FALSE)
}
} else {
checkmate::assertNumeric(value, len=1, any.missing=FALSE)
}
checkmate::assertLogical(promote, len=1)
if (is.na(toEta)) {
.isEta <- (regexpr(.varSelect$etaModelReg, var) != -1)
} else {
.isEta <- toEta
}
if (.isEta) {
if (all(is.na(.iniDf$neta1))) {
.eta <- 1
} else {
.eta <- max(.iniDf$neta1, na.rm=TRUE) + 1
}
.extra <- .rxIniDfTemplate
.extra$est <- value
.extra$neta1 <- .eta
.extra$neta2 <- .eta
.extra$name <- var
.extra$condition <- "id"
if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
if (is.na(promote)) {
} else if (promote) {
if (is.na(value)) {
value <- 1
.minfo(paste0("promote {.code ", var, "} to between subject variability"))
} else {
.minfo(paste0("promote {.code ", var, "} to between subject variability with initial estimate {.number ", value, "}"))
}
.cov <- get("covariates", envir=rxui)
.cov <- .cov[.cov != var]
assign("covariates", .cov, envir=rxui)
} else {
.minfo(paste0("add between subject variability {.code ", var, "} and set estimate to {.number ", value, "}"))
}
}
assign("iniDf", rbind(.iniDf, .extra), envir=rxui)
} else {
if (is.na(promote)) {
} else if (!promote) {
if (regexpr(.varSelect$covariateExceptions, tolower(var)) != -1 ||
regexpr(.varSelect$thetaModelReg, var, perl=TRUE) == -1) {
if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
.minfo(paste0("add covariate {.code ", var, "}"))
}
return(invisible())
}
if (!is.null(.varSelect$covariateNames)) {
if (var %in% .varSelect$covariateNames) {
if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
.minfo(paste0("add covariate {.code ", var, "} (known covariate)"))
}
return(invisible())
}
}
}
if (all(is.na(.iniDf$ntheta))) {
.theta <- 1
} else {
.theta <- max(.iniDf$ntheta, na.rm=TRUE) + 1
}
.extra <- .rxIniDfTemplate
.extra$est <- value
.extra$ntheta <- .theta
.extra$name <- var
if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
if (is.na(promote)) {
.minfo(paste0("add residual parameter {.code ", var, "} and set estimate to {.number ", value, "}"))
} else if (promote) {
.minfo(paste0("promote {.code ", var, "} to population parameter with initial estimate {.number ", value, "}"))
# need to reassess model for mu2 enhancement
assign("iniDf", rbind(.iniDf, .extra), envir=rxui)
rxui2 <- rxui
model(rxui2) <- rxui$lstExpr
rxui2 <- rxUiDecompress(rxui2)
for (i in ls(envir=rxui2, all.names=TRUE)) {
assign(i, get(i, envir=rxui2), envir=rxui)
}
return(invisible())
} else {
.minfo(paste0("add population parameter {.code ", var, "} and set estimate to {.number ", value, "}"))
}
}
assign("iniDf", rbind(.iniDf, .extra), envir=rxui)
}
invisible()
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.