Nothing
R/et-helpers.R
In rxode2: Facilities for Simulating from ODE-Based Models
Defines functions
.etSeqHandleWait
.etSeqHandleRxEt
.etHandlePiping
.etHandleObs
.etHandleInfusionNoAmt
.etHandleDose
.etHandleDoseValue
.etConvertUnits
.etHandleCmt
.etHandleEvid
.etHandleId
.etHandleUnits
.etHandlePositional
.etHandlePositionalDataFrame
.etHandlePositionalRange
.etHandleSeq
.etAssertArgsAndReturnId
#' This asserts arguments that should not be used together and returns the resolved ID
#'
#' @param dotArgs The list of the ... arguments passed to the main
#' et() function, used to check for deprecated or alias arguments
#'
#' @param id the id argument passed to et(), which may be modified if
#' an uppercase "ID" is found in dotArgs
#'
#' @param ii the ii argument passed to et()
#'
#' @param amt the amt argument passed to et()
#'
#' @param timeUnits the timeUnits argument passed to et()
#'
#' @param time the time argument passed to et()
#'
#' @param dur the dur argument passed to et()
#'
#' @param idMissing a logical indicating whether the id argument was
#' missing
#'
#' @param iiMissing a logical indicating whether the ii argument was
#' missing
#'
#' @param amtMissing a logical indicating whether the amt argument was
#' missing
#'
#' @param cmtMissing a logical indicating whether the cmt argument was
#' missing
#'
#' @param timeUnitsMissing a logical indicating whether the timeUnits
#' argument was missing
#'
#' @param timeMissing a logical indicating whether the time argument
#' was missing
#'
#' @param durMissing a logical indicating whether the dur argument was
#' missing
#'
#' @return the resolved id value after checking for aliases and conflicts
#' @noRd
.etAssertArgsAndReturnId <- function(dotArgs, id, ii, amt, cmt, timeUnits, time, dur,
idMissing, iiMissing, amtMissing, cmtMissing,
timeUnitsMissing, timeMissing, durMissing) {
# Uppercase ID alias -> id
if (!is.null(dotArgs[["ID"]]) && idMissing) {
id <- dotArgs[["ID"]]
}
if (!is.null(dotArgs[["dosing.interval"]]) && !iiMissing)
stop("cannot specify both 'ii' and 'dosing.interval'", call. = FALSE)
if (!is.null(dotArgs[["dose"]]) && !amtMissing)
stop("cannot specify both 'amt' and 'dose'", call. = FALSE)
if (!is.null(dotArgs[["dosing.to"]]) && !cmtMissing)
stop("cannot specify both 'cmt' and 'dosing.to'", call. = FALSE)
if (!is.null(dotArgs[["dose.to"]]) && !cmtMissing)
stop("cannot specify both 'cmt' and 'dose.to'", call. = FALSE)
if (!is.null(dotArgs[["state"]]) && !cmtMissing)
stop("cannot specify both 'cmt' and 'state'", call. = FALSE)
if (!is.null(dotArgs[["amt.units"]]) && !is.null(dotArgs[["dose.units"]]))
stop("cannot specify both 'amt.units' and 'dose.units'", call. = FALSE)
if (!is.null(dotArgs[["time.units"]]) && !timeUnitsMissing)
stop("cannot specify both 'time.units' and 'timeUnits'", call. = FALSE)
if (!is.null(dotArgs[["start.time"]]) && !timeMissing)
stop("cannot specify both 'time' and 'start.time'", call. = FALSE)
if (!is.null(dotArgs[["nbr.doses"]]) && !is.null(dotArgs[["nbrDoses"]]))
stop("cannot specify both 'nbr.doses' and 'nbrDoses'", call. = FALSE)
if (!is.null(dotArgs[["duration"]]) && !durMissing)
stop("cannot specify both 'dur' and 'duration'", call. = FALSE)
id
}
#' This function handles the sequence type of arguments
#'
#' @param by the by argument passed to et(), used to specify the
#' increment for a sequence of observation times.
#'
#' @param length.out the length.out argument passed to et(), used to specify the number
#' of points in a sequence of observation times.
#'
#' @param xIsRxEt a logical indicating whether the x argument is an
#' rxEt object, which affects how the from/to values for the
#' sequence are resolved.
#'
#' @param envRef a reference to the internal environment of the rxEt
#' object being constructed, used to access and modify the current
#' state of the event table as new chunks are added.
#'
#' @param x the x argument passed to et(), which may be used to
#' resolve the from/to values for the sequence if xIsRxEt is FALSE
#'
#' @param ... the ... arguments passed to et(), which may contain
#' named or unnamed arguments used to resolve the from/to values for
#' the sequence, such as from/to or the first two unnamed numeric
#' arguments.
#'
#' @param envir the environment in which to evaluate any expressions needed to
#' resolve the from/to values for the sequence.
#'
#' @param time the time argument passed to et(), which is used to
#' check for conflicts with the sequence arguments.
#'
#' @param et the current state of the event table being constructed,
#' which may be modified by adding a new chunk of observation times
#' if the sequence arguments are successfully resolved.
#'
#' @param xMissing a logical indicating whether the x argument was
#' missing, which affects how the from/to values for the sequence
#' are resolved.
#'
#' @param timeMissing a logical indicating whether the time argument
#' was missing, which is used to check for conflicts with the
#' sequence arguments.
#'
#' @return a list with components done (a logical indicating whether
#' the sequence was successfully handled and the main et() function
#' should return immediately) and et (the possibly modified event
#' table after handling the sequence arguments)
#'
#' @noRd
#'
#' @author Matthew L. Fidler
#'
.etHandleSeq <- function(by, length.out, xIsRxEt, envRef, x, ..., envir,
time, et, xMissing, timeMissing) {
if (!is.null(by) && !is.null(length.out))
stop("cannot specify both 'by' and 'length.out'", call. = FALSE)
if (!is.null(by) || !is.null(length.out)) {
if (xIsRxEt && length(envRef$ids) > 0L) {
.seqTargetIds <- envRef$ids
} else {
.seqTargetIds <- NULL
}
.fromVal <- NULL
.toVal <- NULL
.seqDots <- list(...)
if (!xMissing && !xIsRxEt) {
.xVal <- x
} else {
.xVal <- NULL
}
.dotsNum <- Filter(function(.v) {
is.numeric(.v) || is.integer(.v)
}, .seqDots)
# Also check named from/to in ...
if (!is.null(.seqDots[["from"]])) {
.fromVal <- .seqDots[["from"]]
} else if (!is.null(.xVal) && (is.numeric(.xVal) || is.integer(.xVal))) {
.fromVal <- .xVal
} else if (xIsRxEt && length(.dotsNum) >= 1L) {
.fromVal <- .dotsNum[[1L]]
}
if (!is.null(.seqDots[["to"]])) {
.toVal <- .seqDots[["to"]]
} else if (!xMissing && !xIsRxEt && length(.dotsNum) >= 1L) {
.toVal <- .dotsNum[[1L]]
} else if (xIsRxEt && length(.dotsNum) >= 2L) {
.toVal <- .dotsNum[[2L]]
}
if (!is.null(.fromVal) &&
(is.numeric(.fromVal) || is.integer(.fromVal))) {
.from <- as.numeric(.fromVal)
if (length(.from) != 1L) {
stop("'from' must be scalar", call. = FALSE)
}
if (!is.null(.toVal)) {
.to <- as.numeric(.toVal)
if (length(.to) != 1L) {
stop("'to' must be scalar", call. = FALSE)
}
if (!is.null(by)) {
.resolvedTime <- seq(from = .from, to = .to, by = by)
} else {
.resolvedTime <- seq(from = .from, to = .to, length.out = length.out)
}
} else if (!is.null(by)) {
.resolvedTime <- seq(from = .from, by = by)
} else {
.resolvedTime <- seq(from = .from, length.out = length.out)
}
} else if (!is.null(time)) {
stop("'by'/'length.out' requires both a 'from' and 'to' value", call. = FALSE)
} else {
.resolvedTime <- numeric(0)
}
.df <- .etObsChunk(.resolvedTime) # nolint
.etAddChunk(envRef, .df, .seqTargetIds) # nolint
envRef$nobs <- envRef$nobs + length(.resolvedTime) * max(1L, length(.seqTargetIds))
return(list(done = TRUE, et = et))
}
list(done = FALSE)
}
#' Get the range sequence with et(1, 20) to seq(1, 20)
#'
#'
#' @param xVal x value
#'
#' @param dots the dots arguments
#'
#' @param envRef the environmental reference for the rxEt
#'
#' @param et event table that may be modified
#'
#' @return Either NULL or a list with `done` and `et` components
#'
#' @noRd
#' @author Matthew L. Fidler
.etHandlePositionalRange <- function(xVal, dots, envRef, et) {
if (length(dots) == 1 &&
!is.null(xVal) &&
length(xVal) == 1 &&
(is.numeric(xVal) || is.integer(xVal)) &&
(is.numeric(dots[[1]]) || is.integer(dots[[1]]))) {
#et(1, 20) add obs seq(1, 20)
.resolvedTime <- seq(from = as.numeric(xVal), to = as.numeric(dots[[1]]))
.df <- .etObsChunk(.resolvedTime) # nolint
.etAddChunk(envRef, .df, NULL) # nolint
envRef$nobs <- envRef$nobs + length(.resolvedTime)
return(list(done = TRUE, et = et))
}
NULL
}
#' Handle the positional data.frame arguments
#'
#' This includes modifying deSolve event data frames to their proper
#' value
#'
#' @param xVal the xVal is the data frame
#'
#' @param envRef environment reference
#'
#' @param et event table
#'
#' @return list of done and et events
#'
#' @noRd
#'
#' @author Matthew L. Fidler
#'
.etHandlePositionalDataFrame <- function(xVal, envRef, et) {
.df <- as.data.frame(xVal)
# as.data.frame() may drop it; re-tag first so the rename below tracks it
.extra <- .etExtraColsAttr(xVal) # nolint
if (length(.extra) > 0L) attr(.df, "rxEtExtraCols") <- .extra
.df <- .etImportNormalizeNames(.df)
# Convert deSolve-style (var/value/method) to canonical rxEt format
if (!is.null(.df$var) && !is.null(.df$value) && is.null(.df$amt) && is.null(.df$evid)) {
.df$cmt <- .df$var
.df$var <- NULL
.df$amt <- .df$value
.df$value <- NULL
if (!is.null(.df$method)) {
.df$evid <- ifelse(.df$method == "rep", 5L,
ifelse(.df$method == "mult", 6L, 1L))
.df$method <- NULL
} else {
.df$evid <- 1L
}
}
if (is.null(.df$evid)) {
if (!is.null(.df$amt)) {
.df$evid <- ifelse(!is.na(.df$amt) & as.numeric(.df$amt) != 0, 1L, 0L)
} else {
.df$evid <- 0L
}
}
.df$evid <- as.integer(.df$evid)
.hadId <- !is.null(.df$id)
if (is.null(.df$id)) {
.df$id <- 1L
}
.df$id <- as.integer(.df$id)
.obsIdx <- .df$evid == 0L
if (any(.obsIdx)) {
if (!is.null(.df$rate)) {
.df$rate[.obsIdx] <- NA_real_
}
if (!is.null(.df$amt)) {
.df$amt[.obsIdx] <- NA_real_
}
}
envRef$ids <- sort(unique(.df$id))
envRef$nobs <- envRef$nobs + sum(.obsIdx)
envRef$ndose <- envRef$ndose + sum(!.obsIdx)
if (length(envRef$ids) > 1L || .hadId) {
envRef$show["id"] <- TRUE
}
if (sum(!.obsIdx) > 0L) {
envRef$show["amt"] <- TRUE
}
if (!is.null(.df$rate) &&
any(.df$rate[!.obsIdx] != 0, na.rm = TRUE)) {
envRef$show["rate"] <- TRUE
}
if (!is.null(.df$ii) && any(.df$ii != 0, na.rm = TRUE)) {
envRef$show["ii"] <- TRUE
envRef$show["addl"] <- TRUE
}
envRef$chunks <- .addRowsToChunks(envRef$chunks, .df) # nolint
.etImportExtraCols(envRef, .df, names(.df)) # nolint
list(done = TRUE, et = et)
}
#' Handle the position arguments (ie ...)
#'
#'
#' @param x the x argument passed to et(), which may be used to
#' resolve the from/to values for a sequence of observation times if
#' xIsRxEt is FALSE
#'
#' @param ... the ... arguments passed to et(), to be resolved
#'
#' @param time the time argument passed to et()
#'
#' @param xIsRxEt a logical indicating whether the x argument is an
#' rxEt object
#'
#' @param envir the environment in which to evaluate any expressions
#' needed to
#'
#' @param envRef the reference to the internal environment of the rxEt
#' object being constructed
#'
#' @param et the current state of the event table being constructed,
#' which may be modified by adding a new chunk of observation times
#' if the sequence arguments are successfully resolved.
#'
#' @param xMissing Is the x argument missing?
#'
#' @param timeMissing Is the time argument missing?
#'
#' @return list with components done (a logical indicating whether the
#' position arguments were successfully handled and the main et()
#' function should return immediately), posCmt (the resolved cmt
#' value from the position arguments, if any), listObs (a list of
#' observation times from the position arguments, if any), time (the
#' resolved time value from the position arguments, if any), and et
#' (the possibly modified event table after handling the position
#' arguments)
#'
#' @noRd
#'
#' @author Matthew L. Fidler
.etHandlePositional <- function(x, ..., time, xIsRxEt, envir, envRef, et,
xMissing, timeMissing) {
.posCmt <- NULL
.listObs <- NULL
if (is.null(time) && !xMissing && !xIsRxEt) {
.xVal <- x
.dots <- list(...)
if (length(.dots) >= 2L) {
# possibly sequence of event tables or waiting times
if (any(vapply(.dots, is.rxEt, logical(1))) || # nolint
any(vapply(.dots, is.numeric, logical(1)))) {
# defer to etSeq handled in HandlePiping
return(list(done = FALSE, posCmt = NULL, listObs = NULL, time = NULL))
}
stop("unused positional arguments", call. = FALSE)
}
if (length(.dots) == 1L && !is.null(names(.dots)) && any(names(.dots) != "")) {
# Has named dots, let standard handler take it
} else {
.res <- .etHandlePositionalRange(.xVal, .dots, envRef, et)
if (!is.null(.res)) return(.res)
if (is.data.frame(.xVal)) return(.etHandlePositionalDataFrame(.xVal, envRef, et))
if (is.list(.xVal)) {
.listObs <- .xVal
} else if (!is.null(.xVal)) {
# single positional arg becomes time
time <- .xVal
# Second positional arg in ... treated as compartment (old API compat)
if (length(.dots) == 1L && is.character(.dots[[1]])) {
.posCmt <- .dots[[1]]
}
}
}
}
list(done = FALSE, posCmt = .posCmt, listObs = .listObs, time = time)
}
#' This function handles any units sent to the et() function.
#'
#'
#' @param envRef this is the reference to the internal environment of
#' the rxEt object being constructed
#'
#' @param amountUnits the amountUnits argument passed to et()
#'
#' @param timeUnits the timeUnits argument passed to et()
#'
#' @param dotArgs The .. arguments passed to et(), which may contain
#' named or unnamed arguments
#'
#' @param amountUnitsMissing a logical indicating whether the
#' amountUnits argument was missing
#'
#' @param timeUnitsMissing a logical indicating whether the timeUnits
#' argument was missing
#'
#' @return nothing, called for side effects
#' @noRd
#' @author Matthew L. Fidler
.etHandleUnits <- function(envRef, amountUnits, timeUnits, dotArgs,
amountUnitsMissing, timeUnitsMissing) {
if (!is.null(amountUnits)) envRef$units["dosing"] <- amountUnits
if (!is.null(timeUnits)) envRef$units["time"] <- timeUnits
# Handle dot-style and underscore aliases from ...
if (!is.null(dotArgs[["amount.units"]]) &&
is.null(amountUnits))
envRef$units["dosing"] <- dotArgs[["amount.units"]]
if (!is.null(dotArgs[["time.units"]]) &&
is.null(timeUnits))
envRef$units["time"] <- dotArgs[["time.units"]]
if (!is.null(dotArgs[["time_units"]]) &&
is.null(timeUnits) &&
is.null(dotArgs[["time.units"]]))
envRef$units["time"] <- dotArgs[["time_units"]]
if (!is.null(dotArgs[["amount_units"]]) &&
is.null(amountUnits) &&
is.null(dotArgs[["amount.units"]]))
envRef$units["dosing"] <- dotArgs[["amount_units"]]
}
#' `et(id=)` handling
#'
#' @param id The id argument
#'
#' @param envRef The `et()` environment
#'
#' @param xIsRxEt Is the object a rxode2 et object?
#'
#' @param envir evaluation environment
#'
#' @return id value for the event table object
#'
#' @noRd
#'
#' @author Matthew L. Fidler
#'
.etHandleId <- function(id, envRef, xIsRxEt, envir, addingEvents = FALSE) {
.resolvedId <- NULL
.addedIds <- integer(0)
.removedIds <- integer(0)
.existingIds <- integer(0)
.doResize <- FALSE
if (!is.null(id)) {
.idInput <- if (is.factor(id)) as.character(id) else id
.idVal <- suppressWarnings(as.integer(.idInput))
if (anyNA(.idVal)) {
stop("'id' must contain integer-like values", call. = FALSE)
}
.posIds <- .idVal[.idVal > 0L]
.negIds <- abs(.idVal[.idVal < 0L])
.existingIds <- envRef$ids
if (length(.posIds) > 0L &&
!xIsRxEt &&
identical(sort(as.integer(envRef$ids)), 1L) &&
envRef$nobs == 0L &&
envRef$ndose == 0L &&
length(.etGroups(envRef)) == 0L &&
length(envRef$chunks) == 0L) {
.addedIds <- setdiff(.posIds, .existingIds)
.removedIds <- setdiff(.existingIds, .posIds)
envRef$ids <- sort(unique(.posIds))
} else if (xIsRxEt && envRef$canResize && length(.idVal) == 0L) {
.removedIds <- .existingIds
.addedIds <- integer(0)
envRef$ids <- integer(0)
.doResize <- length(.removedIds) > 0L
} else if (length(.posIds) > 0L && xIsRxEt && envRef$canResize &&
(!addingEvents || (envRef$nobs == 0L && envRef$ndose == 0L &&
length(envRef$chunks) == 0L && length(.etGroups(envRef)) == 0L))) {
# canResize mode: positive ids define the exact target set, replacing existing
.removedIds <- setdiff(.existingIds, .posIds)
.addedIds <- setdiff(.posIds, .existingIds)
envRef$ids <- sort(unique(.posIds))
.doResize <- length(.addedIds) > 0L || length(.removedIds) > 0L
} else {
.addedIds <- setdiff(.posIds, .existingIds)
.removedIds <- intersect(.negIds, .existingIds)
if (length(.posIds) > 0L) {
envRef$ids <- sort(unique(c(envRef$ids, .posIds)))
}
if (length(.negIds) > 0L) {
envRef$ids <- setdiff(envRef$ids, .negIds)
}
.doResize <- xIsRxEt && (length(.addedIds) > 0L || length(.removedIds) > 0L)
}
envRef$show["id"] <- TRUE
.resolvedId <- .posIds
}
.targetIds <- .resolvedId
if (is.null(.targetIds) && xIsRxEt && length(envRef$ids) > 0L) {
.targetIds <- envRef$ids
}
list(resolvedId = .resolvedId, targetIds = .targetIds, doResize = .doResize,
addedIds = .addedIds, removedIds = .removedIds, existingIds = .existingIds)
}
#' Handle the EVID expression
#'
#' @param evidExpr The evid expression generated from `substitute(evid)`
#'
#' @param evidSym The evid symbol generated from `as.character(evidExpr)`
#'
#' @param envir environment where the evaluation occurs
#'
#' @param evidMissing Is the `evid` argument to `et()` missing
#'
#' @return evid value or NULL
#' @noRd
#' @author Matthew L. Fidler
.etHandleEvid <- function(evidExpr, evidSym, envir, evidMissing) {
.evidVal <- NULL
if (!evidMissing) {
.evidVal <- switch(evidSym,
obs = 0L,
`0` = 0L,
dose = 1L,
`1` = 1L,
other = 2L,
`2` = 2L,
reset = 3L,
`3` = 3L,
doseReset = 4L,
resetDose = 4L,
`4` = 4L,
as.integer(tryCatch(eval(evidExpr, envir = envir),
error = function(e) as.integer(evidSym)))
)
}
.evidVal
}
#' Handle cmt in et(cmt=...)
#'
#' @param cmtExpr Compartment expression (from `substitute(cmt)`)
#'
#' @param cmtSym Compartment symbol (from `as.character(cmtExpr)`)
#'
#' @param posCmt When et(1, "cmt") this is the position of the cmt
#' argument
#'
#' @param envir environment where evaluations are made
#'
#' @param cmtMissing logical value that tells if the cmt argument of
#' `et()` is missing
#'
#' @return The compartment value
#'
#' @noRd
#'
#' @author Matthew L. Fidler
.etHandleCmt <- function(cmtExpr, cmtSym, posCmt, envir, cmtMissing) {
.cmtVal <- posCmt
if (!cmtMissing) {
.cmtTry <- tryCatch(eval(cmtExpr, envir = envir), error = function(e) cmtSym)
.cmtVal <- if (is.character(.cmtTry) || is.numeric(.cmtTry)) .cmtTry else cmtSym
}
.cmtVal
}
#' Handle unit conversion for time and dosing valuess
#'
#' @param val the value to convert, which may be a numeric or a units
#' object
#'
#' @param unitType a character indicating the type of unit to convert,
#' either "time" or "dosing"
#'
#' @param envRef The environment for the event table
#'
#' @return the numeric value after converting units if necessary, or
#' the original numeric value if no conversion is needed
#'
#' @noRd
#'
#' @author Matthew L. Fidler
.etConvertUnits <- function(val, unitType, envRef) {
if (inherits(val, "units") && requireNamespace("units", quietly = TRUE)) {
.u <- envRef$units[unitType]
if (!is.na(.u) && nchar(.u) > 0) {
return(as.numeric(units::set_units(val, .u, mode = "standard")))
}
return(as.numeric(val))
}
as.numeric(val)
}
#' Handle the dose value, including unit conversion if needed
#'
#' @param expr the expression for the dose value
#'
#' @param missing a logical indicating whether the dose value is missing
#'
#' @param envRef the reference to the internal environment of the rxEt
#' object being constructed, used to access unit information for
#' conversion
#'
#' @param envir the environment in which to evaluate the dose expression
#'
#' @param unitType a character indicating the type of unit to convert
#' to, either "time" or "rate"
#'
#' @return the numeric dose value after evaluating the expression and
#' converting units if necessary
#'
#' @noRd
#' @author Matthew L. Fidler
.etHandleDoseValue <- function(expr, missing, envRef, envir, unitType = "time") {
if (missing) return(0.0)
.val <- eval(expr, envir = envir)
if (unitType == "rate") {
if (inherits(.val, "units") && requireNamespace("units", quietly = TRUE)) {
.du <- envRef$units["dosing"]
.tu <- envRef$units["time"]
if (!is.na(.du) && nchar(.du) > 0 && !is.na(.tu) && nchar(.tu) > 0) {
return(as.numeric(units::set_units(.val, paste0(.du, "/", .tu), mode = "standard")))
}
}
return(as.numeric(.val))
}
.etConvertUnits(.val, unitType, envRef)
}
#' Handle dose and related arguments
#'
#' @param amt Amount argument
#'
#' @param amtExpr Amount expression
#'
#' @param dotArgs the ... args (list)
#'
#' @param envRef the rxEt environment
#'
#' @param envir the evaluation environment
#'
#' @param time the time argument
#'
#' @param timeExpr the time expression
#'
#' @param iiExpr the ii expression
#'
#' @param addlExpr the addl expression
#'
#' @param ssExpr the ss expression
#'
#' @param rateExpr the rate expression
#'
#' @param durExpr the dur expression
#'
#' @param untilExpr the until expression
#'
#' @param evidVal the evid value
#'
#' @param cmtVal the cmt value
#'
#' @param resolvedId the resolved id value. When missing it defaults
#' to the ids present in the id environment
#'
#' @param targetIds The target ids
#'
#' @param addSampling the add sampling argument
#'
#' @param et the current state of the event table being constructed,
#' which may be modified by adding a new chunk of observation times
#' if the sequence arguments are successfully resolved.
#'
#' @param rateSym rate symbol (ie character)
#'
#' @param amtMissing is the amt argument missing
#'
#' @param timeMissing is the time argument missing
#'
#' @param iiMissing is the ii argument missing
#'
#' @param addlMissing is the addl argument missing
#'
#' @param ssMissing is the ss argument missing
#'
#' @param rateMissing is the rate argument missing
#'
#' @param durMissing is the duration argument missing?
#'
#' @param untilMissing is the until argument missing?
#'
#' @param addSamplingMissing is the addSampling argument missing?
#'
#' @return A list with components done (a logical indicating whether
#' the dose handling was successful and the main et() function
#' should return immediately) and et (the possibly modified event
#' table after handling the dose arguments)
#'
#' @noRd
#'
#' @author Matthew L. Fidler
#'
.etHandleDose <- function(amt, amtExpr, dotArgs, envRef, envir, time,
timeExpr, iiExpr, addlExpr, ssExpr, rateExpr,
durExpr, untilExpr, evidVal, cmtVal, resolvedId,
targetIds, addSampling, et, rateSym, amtMissing,
timeMissing, iiMissing, addlMissing, ssMissing,
rateMissing, durMissing, untilMissing,
addSamplingMissing) {
if (!is.null(amt) || !is.null(dotArgs[["dose"]])) {
if (!is.null(amt)) {
.amtVal <- amt
} else {
.amtVal <- dotArgs[["dose"]]
}
.amtVal <- .etConvertUnits(.amtVal, "dosing", envRef)
if (!is.null(time)) {
.timeVal <- time
} else {
.timeVal <- 0
}
.iiVal <- .etHandleDoseValue(iiExpr, iiMissing, envRef, envir, "time")
.addlVal <- if (!addlMissing) as.integer(eval(addlExpr, envir = envir)) else 0L
.ssVal <- if (!ssMissing) as.integer(eval(ssExpr, envir = envir)) else 0L
if (!rateMissing) {
if (rateSym == "model") {
.rateVal <- -1.0 # model -> -1, matching NONMEM conventions
} else if (rateSym == "dur") {
.rateVal <- -2.0 # dur -> -2, matching NONMEM conventions
} else {
.rateVal <- .etHandleDoseValue(rateExpr, FALSE, envRef, envir, "rate")
}
} else {
.rateVal <- 0.0
}
if (!durMissing) {
.durVal <- as.numeric(eval(durExpr, envir = envir))
} else {
.durVal <- 0.0
}
if (!untilMissing) {
.untilVal <- .etHandleDoseValue(untilExpr, FALSE, envRef, envir, "time")
} else {
.untilVal <- NULL
}
.df <- .etDoseChunk(time = .timeVal, # nolint
amt = .amtVal,
evid = ifelse((!is.null(evidVal)), evidVal, 1L),
cmt = ifelse((!is.null(cmtVal)), cmtVal, "(default)"),
ii = .iiVal, addl = .addlVal, ss = .ssVal,
rate = .rateVal, dur = .durVal,
until = .untilVal)
if (!durMissing && rateMissing && any(.durVal > 0, na.rm = TRUE)) {
.df$rate <- rep_len(0.0, nrow(.df))
.df$dur <- rep_len(.durVal, nrow(.df))
}
.pairDoseIds <- !is.null(resolvedId) &&
nrow(.df) > 1L &&
nrow(.df) == length(resolvedId)
if (.pairDoseIds) {
.df$id <- as.integer(resolvedId)
envRef$chunks <- .addRowsToChunks(envRef$chunks, .df) # nolint
} else {
.etAddChunk(envRef, .df, targetIds) # nolint
}
.pairIdsN <- if (.pairDoseIds) 1L else max(1L, length(targetIds))
envRef$ndose <- envRef$ndose + max(1L, nrow(.df)) * .pairIdsN
envRef$show["amt"] <- TRUE
if (!is.null(.df$ii) && any(.df$ii > 0, na.rm = TRUE)) {
envRef$show["ii"] <- TRUE
}
if (!is.null(.df$addl) && any(.df$addl > 0L, na.rm = TRUE)) {
envRef$show["addl"] <- TRUE
}
if (!is.null(.ssVal) && .ssVal > 0L) {
envRef$show["ss"] <- TRUE
}
if (!is.null(.df$rate) && any(.df$rate != 0, na.rm = TRUE)) {
envRef$show["rate"] <- TRUE
}
if (!is.null(.df$dur) && any(.df$dur != 0, na.rm = TRUE)) {
envRef$show["dur"] <- TRUE
}
if (!is.null(cmtVal) && cmtVal != "(default)") {
envRef$show["cmt"] <- TRUE
}
if (!addSamplingMissing && isTRUE(addSampling)) {
.obsChunk <- .etObsChunk(.timeVal) # nolint
.etAddChunk(envRef, .obsChunk, targetIds) # nolint
envRef$nobs <- envRef$nobs + length(.obsChunk$time) * max(1L, length(targetIds))
}
return(list(done = TRUE, et = et))
}
list(done = FALSE)
}
#' This handles infusions where amount isn't specified
#'
#' @param amt the amount argument passed to et(), which is expected to
#' be NULL for this handler to do anything
#'
#' @param amtExpr the expression for the amount argument, generated
#' from `substitute(amt)`
#'
#' @param rateExpr the expression for the rate argument, generated
#' from `substitute(rate)`
#'
#' @param ssExpr the expression for the ss argument, generated from
#' `substitute(ss)`
#'
#' @param envRef the reference to the internal environment of the rxEt
#' object being constructed, used to access unit information for
#' conversion
#'
#' @param envir the environment in which to evaluate any expressions
#' needed to handle the infusion dose
#'
#' @param time the time argument passed to `et()`, which may be used as
#' the time for the infusion dose
#'
#' @param timeExpr the expression for the time argument, generated
#' from `substitute(time)`
#'
#' @param iiExpr the expression for the ii argument, generated from
#' `substitute(ii)`
#'
#' @param durExpr the expression for the dur argument, generated from
#' `substitute(dur)`
#'
#' @param evidVal the evid value to use for the infusion dose, which
#' may be NULL
#'
#' @param cmtVal the cmt value to use for the infusion dose, which may
#' be NULL
#'
#' @param targetIds the target ids for the infusion dose, which may be
#' NULL to indicate
#'
#' @param et the current state of the event table being constructed, which may
#' be modified by adding a new chunk for the infusion dose if the
#' handling is successful
#'
#' @param rateSym the rate symbol (ie character) for the infusion dose
#'
#' @param amtMissing is the amt argument missing?
#'
#' @param rateMissing is the rate argument missing?
#'
#' @param ssMissing is the ss argument missing?
#'
#' @param timeMissing is the time argument missing?
#'
#' @param iiMissing is the ii argument missing?
#'
#' @param durMissing is the dur argument missing?
#'
#' @return A list with components done
#'
#' @noRd
#' @author Matthew L. Fidler
.etHandleInfusionNoAmt <- function(amt, amtExpr, rateExpr, ssExpr, envRef, envir,
time, timeExpr, iiExpr, durExpr, evidVal,
cmtVal, targetIds, et, rateSym,
amtMissing, rateMissing, ssMissing,
timeMissing, iiMissing, durMissing) {
if (is.null(amt) && (!rateMissing || !ssMissing)) {
.timeVal <- if (!is.null(time)) time else 0.0
.iiVal <- if (!iiMissing) as.numeric(eval(iiExpr, envir = envir)) else 0.0
.ssVal <- if (!ssMissing) as.integer(eval(ssExpr, envir = envir)) else 0L
if (!rateMissing) {
.rateVal <- switch(rateSym,
model = -1.0,
dur = -2.0,
as.numeric(eval(rateExpr, envir = envir))
)
} else {
.rateVal <- 0.0
}
if (!durMissing) {
.durVal <- as.numeric(eval(durExpr, envir = envir))
} else {
.durVal <- 0.0
}
if (!is.null(evidVal)) {
.evid2 <- evidVal
} else {
.evid2 <- 1L
}
if (!is.null(cmtVal)) {
.cmtVal <- cmtVal
} else {
.cmtVal <- "(default)"
}
.df <- .etDoseChunk( # nolint
time = .timeVal, amt = 0.0,
evid = .evid2,
cmt = .cmtVal,
ii = .iiVal, addl = 0L, ss = .ssVal,
rate = .rateVal, dur = .durVal
)
.etAddChunk(envRef, .df, targetIds) # nolint
envRef$ndose <- envRef$ndose + max(1L, nrow(.df)) * max(1L, length(targetIds))
envRef$show["amt"] <- TRUE
if (!is.null(.ssVal) && .ssVal > 0L) envRef$show["ss"] <- TRUE
if (!is.null(.df$rate) && any(.df$rate != 0, na.rm = TRUE)) envRef$show["rate"] <- TRUE
return(list(done = TRUE, et = et))
}
list(done = FALSE)
}
#' Handle observation times specified in the position arguments or time
#'
#'
#' @param time the time argument passed to et(), which may be used as
#' the observation time if not NULL
#'
#' @param timeExpr the expression for the time argument, generated
#' from `substitute(time)`, which may be evaluated to get the
#' observation time if time is NULL
#'
#' @param envir the environment in which to evaluate any expressions
#'
#' @param envRef the reference to the internal environment of the rxEt
#' object
#'
#' @param evidVal the evid value to use for the observation events,
#' which may be NULL
#'
#' @param cmtVal the cmt value to use for the observation events,
#' which may be NULL
#'
#' @param targetIds the target ids for the observation events, which may be NULL to
#' indicate all ids
#'
#' @param et the current state of the event table being constructed, which may
#' be modified by adding a new chunk for the observation events
#'
#' @param timeMissing is the time argument missing?
#'
#' @return A list with components done
#'
#' @noRd
#'
#' @author Matthew L. Fidler
.etHandleObs <- function(time, timeExpr, envir, envRef, evidVal, cmtVal,
targetIds, et, timeMissing) {
if (!is.null(time) || !timeMissing) {
if (!is.null(time)) {
.timeVal <- time
} else {
.timeVal <- eval(timeExpr, envir = envir)
}
if (!is.list(.timeVal) &&
inherits(.timeVal, "units") &&
requireNamespace("units", quietly = TRUE)) {
.tu2 <- envRef$units["time"]
if (!is.na(.tu2) && nchar(.tu2) > 0) {
.timeVal <- as.numeric(units::set_units(.timeVal, .tu2, mode = "standard"))
} else {
.timeVal <- as.numeric(.timeVal)
}
}
if (!is.null(evidVal)) {
.evid2 <- evidVal
} else {
.evid2 <- 0L
}
.df <- .etObsChunk(.timeVal, cmt = cmtVal) # nolint
if (.evid2 != 0L) {
.df$evid <- as.integer(.evid2)
}
.etAddChunk(envRef, .df, targetIds) # nolint
envRef$nobs <- envRef$nobs + length(.df$time) * max(1L, length(targetIds))
if (!is.null(cmtVal)) {
envRef$show["cmt"] <- TRUE
}
return(list(done = TRUE, et = et))
}
list(done = FALSE)
}
#' Handle piping types of calls
#'
#'
#' @param xIsRxEt is the x argument an rxEt object, implying piping of some sort
#'
#' @param x the x argument passed to et()
#'
#' @param time the time argument passed to et()
#'
#' @param timeExpr the expression for the time argument, generated from `substitute(time)`
#'
#' @param amt the amt argument passed to et()
#'
#' @param amtExpr the expression for the amt argument, generated from `substitute(amt)`
#'
#' @param dotArgs the ... arguments passed to et(), which may contain
#' named or unnamed arguments
#'
#' @param cmtVal the cmt value to use for any events created from the
#' piping arguments, which may be NULL
#'
#' @param targetIds the target ids for any events created from the
#' piping arguments, which may be NULL to indicate all ids
#'
#' @param evidVal the evid value to use for any events created from the piping
#'
#' @param envRef the reference to the internal environment of the rxEt object
#'
#' @param et the current state of the event table
#'
#' @param timeMissing is the time argument missing?
#'
#' @param amtMissing is the amt argument missing?
#'
#' @param envir the environment in which to evaluate any expressions needed to handle
#' the piping arguments
#'
#' @return A list with components done and et, where done is a logical
#' indicating whether the piping arguments were successfully handled
#' and the main et()
#'
#' @noRd
#'
#' @author Matthew L. Fidler
.etHandlePiping <- function(xIsRxEt, x, time, timeExpr, amt, amtExpr, # nolint
dotArgs, cmtVal, targetIds, evidVal,
envRef, et, timeMissing, amtMissing, envir) {
if (xIsRxEt &&
is.null(time) &&
is.null(amt) && timeMissing && amtMissing) {
if (length(dotArgs) >= 1) {
.firstDot <- dotArgs[[1]]
if (is.rxEt(.firstDot) || # nolint
any(vapply(dotArgs, is.rxEt, logical(1)))) {
# Sequence of event tables
.ret <- do.call(etSeq, c(list(x), dotArgs)) # nolint
return(list(done = TRUE, et = .ret))
}
if (length(dotArgs) > 2) {
stop("unused positional arguments", call. = FALSE)
}
if (is.list(.firstDot) && !is.data.frame(.firstDot)) {
.df <- .etObsChunk(.firstDot, cmt = cmtVal) # nolint
.etAddChunk(envRef, .df, targetIds) # nolint
envRef$nobs <- envRef$nobs + length(.df$time) * max(1L, length(targetIds))
if (!is.null(cmtVal)) {
envRef$show["cmt"] <- TRUE
}
return(list(done = TRUE, et = et))
} else if (is.numeric(.firstDot) || is.integer(.firstDot)) {
if (length(dotArgs) >= 2L &&
length(.firstDot) == 1L &&
(is.numeric(dotArgs[[2]]) || is.integer(dotArgs[[2]])) &&
length(dotArgs[[2]]) == 1L) {
# et(0, 10) add obs at times 0, 1, ..., 10
.timeVec <- seq(from = as.numeric(.firstDot), to = as.numeric(dotArgs[[2]]))
} else if (inherits(.firstDot, "units") &&
requireNamespace("units", quietly = TRUE)) {
.tu2 <- envRef$units["time"]
if (!is.na(.tu2) && nchar(.tu2) > 0) {
.timeVec <- as.numeric(units::set_units(.firstDot, .tu2, mode = "standard"))
} else {
.timeVec <- as.numeric(.firstDot)
}
} else {
.timeVec <- as.numeric(.firstDot)
}
.df <- .etObsChunk(.timeVec, cmt = cmtVal) # nolint
if (!is.null(evidVal) && evidVal != 0L) {
.df$evid <- as.integer(evidVal)
}
.etAddChunk(envRef, .df, targetIds) # nolint
envRef$nobs <- envRef$nobs + length(.timeVec) * max(1L, length(targetIds))
return(list(done = TRUE, et = et))
}
}
}
list(done = FALSE)
}
#' Handle etSeq() calls
#'
#'
#' @param item the item argument passed to etSeq(), which is expected
#' to be an rxEt object
#'
#' @param units the units argument passed to etSeq(), which may be NULL
#'
#' @param show the show argument passed to etSeq(), which may be NULL
#'
#' @param ids the ids argument passed to etSeq(), which may be NULL
#'
#' @param timeDelta the timeDelta argument passed to etSeq(), which is
#' expected to be a numeric value
#'
#' @param samples the samples argument passed to etSeq(), which is
#' expected to be a character value of either "use" or "dose"
#'
#' @param chunks the chunks argument passed to etSeq(), which is
#' expected to be a list of data frames
#'
#' @param nobs the nobs argument passed to etSeq(), which is expected
#' to be an integer value
#'
#' @param ndose the ndose argument passed to etSeq(), which is expected to be an
#' integer value
#'
#' @param explicitIi the explicitIi argument passed to etSeq(), which
#' is expected to be a logical value
#'
#' @param ii the ii argument passed to etSeq(), which is expected to be a numeric value
#'
#' @return a list with components units, show, ids, chunks, nobs, ndose, timeDelta,
#' lastIi, and lastDose, which represent the updated state of the event
#'
#' @noRd
#'
#' @author Matthew L. Fidler
.etSeqHandleRxEt <- function(item, units, show, ids, timeDelta, samples, chunks, groups,
nobs, ndose, explicitIi, ii) {
env <- .rxEtEnv(item) # nolint
if (is.null(units)) {
units <- env$units
show <- env$show
} else {
show <- show | env$show
}
.itemGroups <- .etGetGroups(env) # nolint
.keepGrouped <- length(chunks) == 0L &&
length(.itemGroups) == 1L &&
(length(groups) == 0L ||
(length(groups) == 1L && .etGroupIdsEqual(groups[[1]]$ids, .itemGroups[[1]]$ids))) # nolint
if (!.keepGrouped && length(groups) > 0L) {
for (.g in groups) {
chunks <- .addRowsToChunks(chunks, .etMaterializeGroup(.g)) # nolint
}
groups <- list()
}
ids <- sort(unique(c(ids, env$ids)))
if (.keepGrouped) {
.summaryDf <- .etShiftChunk(.itemGroups[[1]]$data, timeDelta) # nolint
if (samples == "use") {
.groupDf <- .summaryDf
nobs <- nobs + env$nobs
} else {
.groupDf <- .summaryDf[.summaryDf$evid != 0L, , drop = FALSE]
}
if (nrow(.groupDf) > 0L) {
if (length(groups) == 0L) {
groups <- list(list(ids = as.integer(.itemGroups[[1]]$ids), data = .groupDf))
} else {
groups[[1]]$data <- as.data.frame(
data.table::rbindlist(list(groups[[1]]$data, .groupDf), fill = TRUE)
)
}
}
mat <- .summaryDf
} else {
mat <- .etShiftChunk(.etMaterialize(item), timeDelta) # nolint
if (samples == "use") {
chunks <- .addRowsToChunks(chunks, mat) # nolint
nobs <- nobs + env$nobs
} else {
doseOnly <- mat[mat$evid != 0L, , drop = FALSE]
chunks <- .addRowsToChunks(chunks, doseOnly) # nolint
}
}
lastIi <- 0.0
lastDose <- 0.0
doseRows <- mat[mat$evid != 0L, , drop = FALSE]
if (nrow(doseRows) > 0L) {
lastDoseRow <- doseRows[nrow(doseRows), ]
if (is.null(lastDoseRow$addl) || is.na(lastDoseRow$addl)) {
addlVal <- 0L
} else {
addlVal <- as.integer(lastDoseRow$addl)
}
if (addlVal > 0L) {
lastIi <- lastDoseRow$ii
}
lastDose <- lastDoseRow$time + addlVal * lastIi
}
maxTime <- max(mat$time, na.rm = TRUE)
ndose <- ndose + env$ndose
# Advance past last dose period; also respect max obs time (for samples="use")
if (!(explicitIi && identical(ii, 0))) {
if (lastIi > 0) {
effectiveIi <- lastIi
} else {
effectiveIi <- ii
}
timeDelta <- max(maxTime, lastDose + effectiveIi)
}
list(units = units, show = show, ids = ids, chunks = chunks, groups = groups,
nobs = nobs, ndose = ndose, timeDelta = timeDelta,
lastIi = lastIi, lastDose = lastDose)
}
#' Handle wait
#'
#'
#' @param item the item argument passed to etSeq(), which is expected
#' to be a numeric value representing the wait time
#'
#' @param waitType the waitType argument passed to etSeq(), which is
#' expected to be a character value of either "+ii" or "smart"
#'
#' @param lastDose the lastDose value from the previous item in the
#' etSeq() sequence
#'
#' @param lastIi the lastIi value from the previous item in the
#' etSeq() sequence
#'
#' @param ii the ii argument passed to etSeq(), which is expected to
#' be a numeric value representing the inter-dose interval
#'
#' @param timeDelta the current timeDelta value in the etSeq() sequence, which may be
#' updated by this function to reflect the wait time
#'
#' @return the updated timeDelta value after applying the wait time
#' according to the specified waitType
#' @noRd
#'
#' @author Matthew L. Fidler
.etSeqHandleWait <- function(item, waitType, lastDose, lastIi, ii, timeDelta) {
wait <- as.numeric(item)
effectiveIi <- if (lastIi > 0) lastIi else ii
if (waitType == "+ii") {
timeDelta <- lastDose + effectiveIi + wait
} else { # smart
if (wait < effectiveIi) {
timeDelta <- lastDose + effectiveIi
} else {
timeDelta <- lastDose + wait
}
}
timeDelta
}
Try the rxode2 package in your browser
Any scripts or data that you put into this service are public.
rxode2 documentation built on July 28, 2026, 5:08 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions .etSeqHandleWait .etSeqHandleRxEt .etHandlePiping .etHandleObs .etHandleInfusionNoAmt .etHandleDose .etHandleDoseValue .etConvertUnits .etHandleCmt .etHandleEvid .etHandleId .etHandleUnits .etHandlePositional .etHandlePositionalDataFrame .etHandlePositionalRange .etHandleSeq .etAssertArgsAndReturnId
#' This asserts arguments that should not be used together and returns the resolved ID
#'
#' @param dotArgs The list of the ... arguments passed to the main
#' et() function, used to check for deprecated or alias arguments
#'
#' @param id the id argument passed to et(), which may be modified if
#' an uppercase "ID" is found in dotArgs
#'
#' @param ii the ii argument passed to et()
#'
#' @param amt the amt argument passed to et()
#'
#' @param timeUnits the timeUnits argument passed to et()
#'
#' @param time the time argument passed to et()
#'
#' @param dur the dur argument passed to et()
#'
#' @param idMissing a logical indicating whether the id argument was
#' missing
#'
#' @param iiMissing a logical indicating whether the ii argument was
#' missing
#'
#' @param amtMissing a logical indicating whether the amt argument was
#' missing
#'
#' @param cmtMissing a logical indicating whether the cmt argument was
#' missing
#'
#' @param timeUnitsMissing a logical indicating whether the timeUnits
#' argument was missing
#'
#' @param timeMissing a logical indicating whether the time argument
#' was missing
#'
#' @param durMissing a logical indicating whether the dur argument was
#' missing
#'
#' @return the resolved id value after checking for aliases and conflicts
#' @noRd
.etAssertArgsAndReturnId <- function(dotArgs, id, ii, amt, cmt, timeUnits, time, dur,
idMissing, iiMissing, amtMissing, cmtMissing,
timeUnitsMissing, timeMissing, durMissing) {
# Uppercase ID alias -> id
if (!is.null(dotArgs[["ID"]]) && idMissing) {
id <- dotArgs[["ID"]]
}
if (!is.null(dotArgs[["dosing.interval"]]) && !iiMissing)
stop("cannot specify both 'ii' and 'dosing.interval'", call. = FALSE)
if (!is.null(dotArgs[["dose"]]) && !amtMissing)
stop("cannot specify both 'amt' and 'dose'", call. = FALSE)
if (!is.null(dotArgs[["dosing.to"]]) && !cmtMissing)
stop("cannot specify both 'cmt' and 'dosing.to'", call. = FALSE)
if (!is.null(dotArgs[["dose.to"]]) && !cmtMissing)
stop("cannot specify both 'cmt' and 'dose.to'", call. = FALSE)
if (!is.null(dotArgs[["state"]]) && !cmtMissing)
stop("cannot specify both 'cmt' and 'state'", call. = FALSE)
if (!is.null(dotArgs[["amt.units"]]) && !is.null(dotArgs[["dose.units"]]))
stop("cannot specify both 'amt.units' and 'dose.units'", call. = FALSE)
if (!is.null(dotArgs[["time.units"]]) && !timeUnitsMissing)
stop("cannot specify both 'time.units' and 'timeUnits'", call. = FALSE)
if (!is.null(dotArgs[["start.time"]]) && !timeMissing)
stop("cannot specify both 'time' and 'start.time'", call. = FALSE)
if (!is.null(dotArgs[["nbr.doses"]]) && !is.null(dotArgs[["nbrDoses"]]))
stop("cannot specify both 'nbr.doses' and 'nbrDoses'", call. = FALSE)
if (!is.null(dotArgs[["duration"]]) && !durMissing)
stop("cannot specify both 'dur' and 'duration'", call. = FALSE)
id
}
#' This function handles the sequence type of arguments
#'
#' @param by the by argument passed to et(), used to specify the
#' increment for a sequence of observation times.
#'
#' @param length.out the length.out argument passed to et(), used to specify the number
#' of points in a sequence of observation times.
#'
#' @param xIsRxEt a logical indicating whether the x argument is an
#' rxEt object, which affects how the from/to values for the
#' sequence are resolved.
#'
#' @param envRef a reference to the internal environment of the rxEt
#' object being constructed, used to access and modify the current
#' state of the event table as new chunks are added.
#'
#' @param x the x argument passed to et(), which may be used to
#' resolve the from/to values for the sequence if xIsRxEt is FALSE
#'
#' @param ... the ... arguments passed to et(), which may contain
#' named or unnamed arguments used to resolve the from/to values for
#' the sequence, such as from/to or the first two unnamed numeric
#' arguments.
#'
#' @param envir the environment in which to evaluate any expressions needed to
#' resolve the from/to values for the sequence.
#'
#' @param time the time argument passed to et(), which is used to
#' check for conflicts with the sequence arguments.
#'
#' @param et the current state of the event table being constructed,
#' which may be modified by adding a new chunk of observation times
#' if the sequence arguments are successfully resolved.
#'
#' @param xMissing a logical indicating whether the x argument was
#' missing, which affects how the from/to values for the sequence
#' are resolved.
#'
#' @param timeMissing a logical indicating whether the time argument
#' was missing, which is used to check for conflicts with the
#' sequence arguments.
#'
#' @return a list with components done (a logical indicating whether
#' the sequence was successfully handled and the main et() function
#' should return immediately) and et (the possibly modified event
#' table after handling the sequence arguments)
#'
#' @noRd
#'
#' @author Matthew L. Fidler
#'
.etHandleSeq <- function(by, length.out, xIsRxEt, envRef, x, ..., envir,
time, et, xMissing, timeMissing) {
if (!is.null(by) && !is.null(length.out))
stop("cannot specify both 'by' and 'length.out'", call. = FALSE)
if (!is.null(by) || !is.null(length.out)) {
if (xIsRxEt && length(envRef$ids) > 0L) {
.seqTargetIds <- envRef$ids
} else {
.seqTargetIds <- NULL
}
.fromVal <- NULL
.toVal <- NULL
.seqDots <- list(...)
if (!xMissing && !xIsRxEt) {
.xVal <- x
} else {
.xVal <- NULL
}
.dotsNum <- Filter(function(.v) {
is.numeric(.v) || is.integer(.v)
}, .seqDots)
# Also check named from/to in ...
if (!is.null(.seqDots[["from"]])) {
.fromVal <- .seqDots[["from"]]
} else if (!is.null(.xVal) && (is.numeric(.xVal) || is.integer(.xVal))) {
.fromVal <- .xVal
} else if (xIsRxEt && length(.dotsNum) >= 1L) {
.fromVal <- .dotsNum[[1L]]
}
if (!is.null(.seqDots[["to"]])) {
.toVal <- .seqDots[["to"]]
} else if (!xMissing && !xIsRxEt && length(.dotsNum) >= 1L) {
.toVal <- .dotsNum[[1L]]
} else if (xIsRxEt && length(.dotsNum) >= 2L) {
.toVal <- .dotsNum[[2L]]
}
if (!is.null(.fromVal) &&
(is.numeric(.fromVal) || is.integer(.fromVal))) {
.from <- as.numeric(.fromVal)
if (length(.from) != 1L) {
stop("'from' must be scalar", call. = FALSE)
}
if (!is.null(.toVal)) {
.to <- as.numeric(.toVal)
if (length(.to) != 1L) {
stop("'to' must be scalar", call. = FALSE)
}
if (!is.null(by)) {
.resolvedTime <- seq(from = .from, to = .to, by = by)
} else {
.resolvedTime <- seq(from = .from, to = .to, length.out = length.out)
}
} else if (!is.null(by)) {
.resolvedTime <- seq(from = .from, by = by)
} else {
.resolvedTime <- seq(from = .from, length.out = length.out)
}
} else if (!is.null(time)) {
stop("'by'/'length.out' requires both a 'from' and 'to' value", call. = FALSE)
} else {
.resolvedTime <- numeric(0)
}
.df <- .etObsChunk(.resolvedTime) # nolint
.etAddChunk(envRef, .df, .seqTargetIds) # nolint
envRef$nobs <- envRef$nobs + length(.resolvedTime) * max(1L, length(.seqTargetIds))
return(list(done = TRUE, et = et))
}
list(done = FALSE)
}
#' Get the range sequence with et(1, 20) to seq(1, 20)
#'
#'
#' @param xVal x value
#'
#' @param dots the dots arguments
#'
#' @param envRef the environmental reference for the rxEt
#'
#' @param et event table that may be modified
#'
#' @return Either NULL or a list with `done` and `et` components
#'
#' @noRd
#' @author Matthew L. Fidler
.etHandlePositionalRange <- function(xVal, dots, envRef, et) {
if (length(dots) == 1 &&
!is.null(xVal) &&
length(xVal) == 1 &&
(is.numeric(xVal) || is.integer(xVal)) &&
(is.numeric(dots[[1]]) || is.integer(dots[[1]]))) {
#et(1, 20) add obs seq(1, 20)
.resolvedTime <- seq(from = as.numeric(xVal), to = as.numeric(dots[[1]]))
.df <- .etObsChunk(.resolvedTime) # nolint
.etAddChunk(envRef, .df, NULL) # nolint
envRef$nobs <- envRef$nobs + length(.resolvedTime)
return(list(done = TRUE, et = et))
}
NULL
}
#' Handle the positional data.frame arguments
#'
#' This includes modifying deSolve event data frames to their proper
#' value
#'
#' @param xVal the xVal is the data frame
#'
#' @param envRef environment reference
#'
#' @param et event table
#'
#' @return list of done and et events
#'
#' @noRd
#'
#' @author Matthew L. Fidler
#'
.etHandlePositionalDataFrame <- function(xVal, envRef, et) {
.df <- as.data.frame(xVal)
# as.data.frame() may drop it; re-tag first so the rename below tracks it
.extra <- .etExtraColsAttr(xVal) # nolint
if (length(.extra) > 0L) attr(.df, "rxEtExtraCols") <- .extra
.df <- .etImportNormalizeNames(.df)
# Convert deSolve-style (var/value/method) to canonical rxEt format
if (!is.null(.df$var) && !is.null(.df$value) && is.null(.df$amt) && is.null(.df$evid)) {
.df$cmt <- .df$var
.df$var <- NULL
.df$amt <- .df$value
.df$value <- NULL
if (!is.null(.df$method)) {
.df$evid <- ifelse(.df$method == "rep", 5L,
ifelse(.df$method == "mult", 6L, 1L))
.df$method <- NULL
} else {
.df$evid <- 1L
}
}
if (is.null(.df$evid)) {
if (!is.null(.df$amt)) {
.df$evid <- ifelse(!is.na(.df$amt) & as.numeric(.df$amt) != 0, 1L, 0L)
} else {
.df$evid <- 0L
}
}
.df$evid <- as.integer(.df$evid)
.hadId <- !is.null(.df$id)
if (is.null(.df$id)) {
.df$id <- 1L
}
.df$id <- as.integer(.df$id)
.obsIdx <- .df$evid == 0L
if (any(.obsIdx)) {
if (!is.null(.df$rate)) {
.df$rate[.obsIdx] <- NA_real_
}
if (!is.null(.df$amt)) {
.df$amt[.obsIdx] <- NA_real_
}
}
envRef$ids <- sort(unique(.df$id))
envRef$nobs <- envRef$nobs + sum(.obsIdx)
envRef$ndose <- envRef$ndose + sum(!.obsIdx)
if (length(envRef$ids) > 1L || .hadId) {
envRef$show["id"] <- TRUE
}
if (sum(!.obsIdx) > 0L) {
envRef$show["amt"] <- TRUE
}
if (!is.null(.df$rate) &&
any(.df$rate[!.obsIdx] != 0, na.rm = TRUE)) {
envRef$show["rate"] <- TRUE
}
if (!is.null(.df$ii) && any(.df$ii != 0, na.rm = TRUE)) {
envRef$show["ii"] <- TRUE
envRef$show["addl"] <- TRUE
}
envRef$chunks <- .addRowsToChunks(envRef$chunks, .df) # nolint
.etImportExtraCols(envRef, .df, names(.df)) # nolint
list(done = TRUE, et = et)
}
#' Handle the position arguments (ie ...)
#'
#'
#' @param x the x argument passed to et(), which may be used to
#' resolve the from/to values for a sequence of observation times if
#' xIsRxEt is FALSE
#'
#' @param ... the ... arguments passed to et(), to be resolved
#'
#' @param time the time argument passed to et()
#'
#' @param xIsRxEt a logical indicating whether the x argument is an
#' rxEt object
#'
#' @param envir the environment in which to evaluate any expressions
#' needed to
#'
#' @param envRef the reference to the internal environment of the rxEt
#' object being constructed
#'
#' @param et the current state of the event table being constructed,
#' which may be modified by adding a new chunk of observation times
#' if the sequence arguments are successfully resolved.
#'
#' @param xMissing Is the x argument missing?
#'
#' @param timeMissing Is the time argument missing?
#'
#' @return list with components done (a logical indicating whether the
#' position arguments were successfully handled and the main et()
#' function should return immediately), posCmt (the resolved cmt
#' value from the position arguments, if any), listObs (a list of
#' observation times from the position arguments, if any), time (the
#' resolved time value from the position arguments, if any), and et
#' (the possibly modified event table after handling the position
#' arguments)
#'
#' @noRd
#'
#' @author Matthew L. Fidler
.etHandlePositional <- function(x, ..., time, xIsRxEt, envir, envRef, et,
xMissing, timeMissing) {
.posCmt <- NULL
.listObs <- NULL
if (is.null(time) && !xMissing && !xIsRxEt) {
.xVal <- x
.dots <- list(...)
if (length(.dots) >= 2L) {
# possibly sequence of event tables or waiting times
if (any(vapply(.dots, is.rxEt, logical(1))) || # nolint
any(vapply(.dots, is.numeric, logical(1)))) {
# defer to etSeq handled in HandlePiping
return(list(done = FALSE, posCmt = NULL, listObs = NULL, time = NULL))
}
stop("unused positional arguments", call. = FALSE)
}
if (length(.dots) == 1L && !is.null(names(.dots)) && any(names(.dots) != "")) {
# Has named dots, let standard handler take it
} else {
.res <- .etHandlePositionalRange(.xVal, .dots, envRef, et)
if (!is.null(.res)) return(.res)
if (is.data.frame(.xVal)) return(.etHandlePositionalDataFrame(.xVal, envRef, et))
if (is.list(.xVal)) {
.listObs <- .xVal
} else if (!is.null(.xVal)) {
# single positional arg becomes time
time <- .xVal
# Second positional arg in ... treated as compartment (old API compat)
if (length(.dots) == 1L && is.character(.dots[[1]])) {
.posCmt <- .dots[[1]]
}
}
}
}
list(done = FALSE, posCmt = .posCmt, listObs = .listObs, time = time)
}
#' This function handles any units sent to the et() function.
#'
#'
#' @param envRef this is the reference to the internal environment of
#' the rxEt object being constructed
#'
#' @param amountUnits the amountUnits argument passed to et()
#'
#' @param timeUnits the timeUnits argument passed to et()
#'
#' @param dotArgs The .. arguments passed to et(), which may contain
#' named or unnamed arguments
#'
#' @param amountUnitsMissing a logical indicating whether the
#' amountUnits argument was missing
#'
#' @param timeUnitsMissing a logical indicating whether the timeUnits
#' argument was missing
#'
#' @return nothing, called for side effects
#' @noRd
#' @author Matthew L. Fidler
.etHandleUnits <- function(envRef, amountUnits, timeUnits, dotArgs,
amountUnitsMissing, timeUnitsMissing) {
if (!is.null(amountUnits)) envRef$units["dosing"] <- amountUnits
if (!is.null(timeUnits)) envRef$units["time"] <- timeUnits
# Handle dot-style and underscore aliases from ...
if (!is.null(dotArgs[["amount.units"]]) &&
is.null(amountUnits))
envRef$units["dosing"] <- dotArgs[["amount.units"]]
if (!is.null(dotArgs[["time.units"]]) &&
is.null(timeUnits))
envRef$units["time"] <- dotArgs[["time.units"]]
if (!is.null(dotArgs[["time_units"]]) &&
is.null(timeUnits) &&
is.null(dotArgs[["time.units"]]))
envRef$units["time"] <- dotArgs[["time_units"]]
if (!is.null(dotArgs[["amount_units"]]) &&
is.null(amountUnits) &&
is.null(dotArgs[["amount.units"]]))
envRef$units["dosing"] <- dotArgs[["amount_units"]]
}
#' `et(id=)` handling
#'
#' @param id The id argument
#'
#' @param envRef The `et()` environment
#'
#' @param xIsRxEt Is the object a rxode2 et object?
#'
#' @param envir evaluation environment
#'
#' @return id value for the event table object
#'
#' @noRd
#'
#' @author Matthew L. Fidler
#'
.etHandleId <- function(id, envRef, xIsRxEt, envir, addingEvents = FALSE) {
.resolvedId <- NULL
.addedIds <- integer(0)
.removedIds <- integer(0)
.existingIds <- integer(0)
.doResize <- FALSE
if (!is.null(id)) {
.idInput <- if (is.factor(id)) as.character(id) else id
.idVal <- suppressWarnings(as.integer(.idInput))
if (anyNA(.idVal)) {
stop("'id' must contain integer-like values", call. = FALSE)
}
.posIds <- .idVal[.idVal > 0L]
.negIds <- abs(.idVal[.idVal < 0L])
.existingIds <- envRef$ids
if (length(.posIds) > 0L &&
!xIsRxEt &&
identical(sort(as.integer(envRef$ids)), 1L) &&
envRef$nobs == 0L &&
envRef$ndose == 0L &&
length(.etGroups(envRef)) == 0L &&
length(envRef$chunks) == 0L) {
.addedIds <- setdiff(.posIds, .existingIds)
.removedIds <- setdiff(.existingIds, .posIds)
envRef$ids <- sort(unique(.posIds))
} else if (xIsRxEt && envRef$canResize && length(.idVal) == 0L) {
.removedIds <- .existingIds
.addedIds <- integer(0)
envRef$ids <- integer(0)
.doResize <- length(.removedIds) > 0L
} else if (length(.posIds) > 0L && xIsRxEt && envRef$canResize &&
(!addingEvents || (envRef$nobs == 0L && envRef$ndose == 0L &&
length(envRef$chunks) == 0L && length(.etGroups(envRef)) == 0L))) {
# canResize mode: positive ids define the exact target set, replacing existing
.removedIds <- setdiff(.existingIds, .posIds)
.addedIds <- setdiff(.posIds, .existingIds)
envRef$ids <- sort(unique(.posIds))
.doResize <- length(.addedIds) > 0L || length(.removedIds) > 0L
} else {
.addedIds <- setdiff(.posIds, .existingIds)
.removedIds <- intersect(.negIds, .existingIds)
if (length(.posIds) > 0L) {
envRef$ids <- sort(unique(c(envRef$ids, .posIds)))
}
if (length(.negIds) > 0L) {
envRef$ids <- setdiff(envRef$ids, .negIds)
}
.doResize <- xIsRxEt && (length(.addedIds) > 0L || length(.removedIds) > 0L)
}
envRef$show["id"] <- TRUE
.resolvedId <- .posIds
}
.targetIds <- .resolvedId
if (is.null(.targetIds) && xIsRxEt && length(envRef$ids) > 0L) {
.targetIds <- envRef$ids
}
list(resolvedId = .resolvedId, targetIds = .targetIds, doResize = .doResize,
addedIds = .addedIds, removedIds = .removedIds, existingIds = .existingIds)
}
#' Handle the EVID expression
#'
#' @param evidExpr The evid expression generated from `substitute(evid)`
#'
#' @param evidSym The evid symbol generated from `as.character(evidExpr)`
#'
#' @param envir environment where the evaluation occurs
#'
#' @param evidMissing Is the `evid` argument to `et()` missing
#'
#' @return evid value or NULL
#' @noRd
#' @author Matthew L. Fidler
.etHandleEvid <- function(evidExpr, evidSym, envir, evidMissing) {
.evidVal <- NULL
if (!evidMissing) {
.evidVal <- switch(evidSym,
obs = 0L,
`0` = 0L,
dose = 1L,
`1` = 1L,
other = 2L,
`2` = 2L,
reset = 3L,
`3` = 3L,
doseReset = 4L,
resetDose = 4L,
`4` = 4L,
as.integer(tryCatch(eval(evidExpr, envir = envir),
error = function(e) as.integer(evidSym)))
)
}
.evidVal
}
#' Handle cmt in et(cmt=...)
#'
#' @param cmtExpr Compartment expression (from `substitute(cmt)`)
#'
#' @param cmtSym Compartment symbol (from `as.character(cmtExpr)`)
#'
#' @param posCmt When et(1, "cmt") this is the position of the cmt
#' argument
#'
#' @param envir environment where evaluations are made
#'
#' @param cmtMissing logical value that tells if the cmt argument of
#' `et()` is missing
#'
#' @return The compartment value
#'
#' @noRd
#'
#' @author Matthew L. Fidler
.etHandleCmt <- function(cmtExpr, cmtSym, posCmt, envir, cmtMissing) {
.cmtVal <- posCmt
if (!cmtMissing) {
.cmtTry <- tryCatch(eval(cmtExpr, envir = envir), error = function(e) cmtSym)
.cmtVal <- if (is.character(.cmtTry) || is.numeric(.cmtTry)) .cmtTry else cmtSym
}
.cmtVal
}
#' Handle unit conversion for time and dosing valuess
#'
#' @param val the value to convert, which may be a numeric or a units
#' object
#'
#' @param unitType a character indicating the type of unit to convert,
#' either "time" or "dosing"
#'
#' @param envRef The environment for the event table
#'
#' @return the numeric value after converting units if necessary, or
#' the original numeric value if no conversion is needed
#'
#' @noRd
#'
#' @author Matthew L. Fidler
.etConvertUnits <- function(val, unitType, envRef) {
if (inherits(val, "units") && requireNamespace("units", quietly = TRUE)) {
.u <- envRef$units[unitType]
if (!is.na(.u) && nchar(.u) > 0) {
return(as.numeric(units::set_units(val, .u, mode = "standard")))
}
return(as.numeric(val))
}
as.numeric(val)
}
#' Handle the dose value, including unit conversion if needed
#'
#' @param expr the expression for the dose value
#'
#' @param missing a logical indicating whether the dose value is missing
#'
#' @param envRef the reference to the internal environment of the rxEt
#' object being constructed, used to access unit information for
#' conversion
#'
#' @param envir the environment in which to evaluate the dose expression
#'
#' @param unitType a character indicating the type of unit to convert
#' to, either "time" or "rate"
#'
#' @return the numeric dose value after evaluating the expression and
#' converting units if necessary
#'
#' @noRd
#' @author Matthew L. Fidler
.etHandleDoseValue <- function(expr, missing, envRef, envir, unitType = "time") {
if (missing) return(0.0)
.val <- eval(expr, envir = envir)
if (unitType == "rate") {
if (inherits(.val, "units") && requireNamespace("units", quietly = TRUE)) {
.du <- envRef$units["dosing"]
.tu <- envRef$units["time"]
if (!is.na(.du) && nchar(.du) > 0 && !is.na(.tu) && nchar(.tu) > 0) {
return(as.numeric(units::set_units(.val, paste0(.du, "/", .tu), mode = "standard")))
}
}
return(as.numeric(.val))
}
.etConvertUnits(.val, unitType, envRef)
}
#' Handle dose and related arguments
#'
#' @param amt Amount argument
#'
#' @param amtExpr Amount expression
#'
#' @param dotArgs the ... args (list)
#'
#' @param envRef the rxEt environment
#'
#' @param envir the evaluation environment
#'
#' @param time the time argument
#'
#' @param timeExpr the time expression
#'
#' @param iiExpr the ii expression
#'
#' @param addlExpr the addl expression
#'
#' @param ssExpr the ss expression
#'
#' @param rateExpr the rate expression
#'
#' @param durExpr the dur expression
#'
#' @param untilExpr the until expression
#'
#' @param evidVal the evid value
#'
#' @param cmtVal the cmt value
#'
#' @param resolvedId the resolved id value. When missing it defaults
#' to the ids present in the id environment
#'
#' @param targetIds The target ids
#'
#' @param addSampling the add sampling argument
#'
#' @param et the current state of the event table being constructed,
#' which may be modified by adding a new chunk of observation times
#' if the sequence arguments are successfully resolved.
#'
#' @param rateSym rate symbol (ie character)
#'
#' @param amtMissing is the amt argument missing
#'
#' @param timeMissing is the time argument missing
#'
#' @param iiMissing is the ii argument missing
#'
#' @param addlMissing is the addl argument missing
#'
#' @param ssMissing is the ss argument missing
#'
#' @param rateMissing is the rate argument missing
#'
#' @param durMissing is the duration argument missing?
#'
#' @param untilMissing is the until argument missing?
#'
#' @param addSamplingMissing is the addSampling argument missing?
#'
#' @return A list with components done (a logical indicating whether
#' the dose handling was successful and the main et() function
#' should return immediately) and et (the possibly modified event
#' table after handling the dose arguments)
#'
#' @noRd
#'
#' @author Matthew L. Fidler
#'
.etHandleDose <- function(amt, amtExpr, dotArgs, envRef, envir, time,
timeExpr, iiExpr, addlExpr, ssExpr, rateExpr,
durExpr, untilExpr, evidVal, cmtVal, resolvedId,
targetIds, addSampling, et, rateSym, amtMissing,
timeMissing, iiMissing, addlMissing, ssMissing,
rateMissing, durMissing, untilMissing,
addSamplingMissing) {
if (!is.null(amt) || !is.null(dotArgs[["dose"]])) {
if (!is.null(amt)) {
.amtVal <- amt
} else {
.amtVal <- dotArgs[["dose"]]
}
.amtVal <- .etConvertUnits(.amtVal, "dosing", envRef)
if (!is.null(time)) {
.timeVal <- time
} else {
.timeVal <- 0
}
.iiVal <- .etHandleDoseValue(iiExpr, iiMissing, envRef, envir, "time")
.addlVal <- if (!addlMissing) as.integer(eval(addlExpr, envir = envir)) else 0L
.ssVal <- if (!ssMissing) as.integer(eval(ssExpr, envir = envir)) else 0L
if (!rateMissing) {
if (rateSym == "model") {
.rateVal <- -1.0 # model -> -1, matching NONMEM conventions
} else if (rateSym == "dur") {
.rateVal <- -2.0 # dur -> -2, matching NONMEM conventions
} else {
.rateVal <- .etHandleDoseValue(rateExpr, FALSE, envRef, envir, "rate")
}
} else {
.rateVal <- 0.0
}
if (!durMissing) {
.durVal <- as.numeric(eval(durExpr, envir = envir))
} else {
.durVal <- 0.0
}
if (!untilMissing) {
.untilVal <- .etHandleDoseValue(untilExpr, FALSE, envRef, envir, "time")
} else {
.untilVal <- NULL
}
.df <- .etDoseChunk(time = .timeVal, # nolint
amt = .amtVal,
evid = ifelse((!is.null(evidVal)), evidVal, 1L),
cmt = ifelse((!is.null(cmtVal)), cmtVal, "(default)"),
ii = .iiVal, addl = .addlVal, ss = .ssVal,
rate = .rateVal, dur = .durVal,
until = .untilVal)
if (!durMissing && rateMissing && any(.durVal > 0, na.rm = TRUE)) {
.df$rate <- rep_len(0.0, nrow(.df))
.df$dur <- rep_len(.durVal, nrow(.df))
}
.pairDoseIds <- !is.null(resolvedId) &&
nrow(.df) > 1L &&
nrow(.df) == length(resolvedId)
if (.pairDoseIds) {
.df$id <- as.integer(resolvedId)
envRef$chunks <- .addRowsToChunks(envRef$chunks, .df) # nolint
} else {
.etAddChunk(envRef, .df, targetIds) # nolint
}
.pairIdsN <- if (.pairDoseIds) 1L else max(1L, length(targetIds))
envRef$ndose <- envRef$ndose + max(1L, nrow(.df)) * .pairIdsN
envRef$show["amt"] <- TRUE
if (!is.null(.df$ii) && any(.df$ii > 0, na.rm = TRUE)) {
envRef$show["ii"] <- TRUE
}
if (!is.null(.df$addl) && any(.df$addl > 0L, na.rm = TRUE)) {
envRef$show["addl"] <- TRUE
}
if (!is.null(.ssVal) && .ssVal > 0L) {
envRef$show["ss"] <- TRUE
}
if (!is.null(.df$rate) && any(.df$rate != 0, na.rm = TRUE)) {
envRef$show["rate"] <- TRUE
}
if (!is.null(.df$dur) && any(.df$dur != 0, na.rm = TRUE)) {
envRef$show["dur"] <- TRUE
}
if (!is.null(cmtVal) && cmtVal != "(default)") {
envRef$show["cmt"] <- TRUE
}
if (!addSamplingMissing && isTRUE(addSampling)) {
.obsChunk <- .etObsChunk(.timeVal) # nolint
.etAddChunk(envRef, .obsChunk, targetIds) # nolint
envRef$nobs <- envRef$nobs + length(.obsChunk$time) * max(1L, length(targetIds))
}
return(list(done = TRUE, et = et))
}
list(done = FALSE)
}
#' This handles infusions where amount isn't specified
#'
#' @param amt the amount argument passed to et(), which is expected to
#' be NULL for this handler to do anything
#'
#' @param amtExpr the expression for the amount argument, generated
#' from `substitute(amt)`
#'
#' @param rateExpr the expression for the rate argument, generated
#' from `substitute(rate)`
#'
#' @param ssExpr the expression for the ss argument, generated from
#' `substitute(ss)`
#'
#' @param envRef the reference to the internal environment of the rxEt
#' object being constructed, used to access unit information for
#' conversion
#'
#' @param envir the environment in which to evaluate any expressions
#' needed to handle the infusion dose
#'
#' @param time the time argument passed to `et()`, which may be used as
#' the time for the infusion dose
#'
#' @param timeExpr the expression for the time argument, generated
#' from `substitute(time)`
#'
#' @param iiExpr the expression for the ii argument, generated from
#' `substitute(ii)`
#'
#' @param durExpr the expression for the dur argument, generated from
#' `substitute(dur)`
#'
#' @param evidVal the evid value to use for the infusion dose, which
#' may be NULL
#'
#' @param cmtVal the cmt value to use for the infusion dose, which may
#' be NULL
#'
#' @param targetIds the target ids for the infusion dose, which may be
#' NULL to indicate
#'
#' @param et the current state of the event table being constructed, which may
#' be modified by adding a new chunk for the infusion dose if the
#' handling is successful
#'
#' @param rateSym the rate symbol (ie character) for the infusion dose
#'
#' @param amtMissing is the amt argument missing?
#'
#' @param rateMissing is the rate argument missing?
#'
#' @param ssMissing is the ss argument missing?
#'
#' @param timeMissing is the time argument missing?
#'
#' @param iiMissing is the ii argument missing?
#'
#' @param durMissing is the dur argument missing?
#'
#' @return A list with components done
#'
#' @noRd
#' @author Matthew L. Fidler
.etHandleInfusionNoAmt <- function(amt, amtExpr, rateExpr, ssExpr, envRef, envir,
time, timeExpr, iiExpr, durExpr, evidVal,
cmtVal, targetIds, et, rateSym,
amtMissing, rateMissing, ssMissing,
timeMissing, iiMissing, durMissing) {
if (is.null(amt) && (!rateMissing || !ssMissing)) {
.timeVal <- if (!is.null(time)) time else 0.0
.iiVal <- if (!iiMissing) as.numeric(eval(iiExpr, envir = envir)) else 0.0
.ssVal <- if (!ssMissing) as.integer(eval(ssExpr, envir = envir)) else 0L
if (!rateMissing) {
.rateVal <- switch(rateSym,
model = -1.0,
dur = -2.0,
as.numeric(eval(rateExpr, envir = envir))
)
} else {
.rateVal <- 0.0
}
if (!durMissing) {
.durVal <- as.numeric(eval(durExpr, envir = envir))
} else {
.durVal <- 0.0
}
if (!is.null(evidVal)) {
.evid2 <- evidVal
} else {
.evid2 <- 1L
}
if (!is.null(cmtVal)) {
.cmtVal <- cmtVal
} else {
.cmtVal <- "(default)"
}
.df <- .etDoseChunk( # nolint
time = .timeVal, amt = 0.0,
evid = .evid2,
cmt = .cmtVal,
ii = .iiVal, addl = 0L, ss = .ssVal,
rate = .rateVal, dur = .durVal
)
.etAddChunk(envRef, .df, targetIds) # nolint
envRef$ndose <- envRef$ndose + max(1L, nrow(.df)) * max(1L, length(targetIds))
envRef$show["amt"] <- TRUE
if (!is.null(.ssVal) && .ssVal > 0L) envRef$show["ss"] <- TRUE
if (!is.null(.df$rate) && any(.df$rate != 0, na.rm = TRUE)) envRef$show["rate"] <- TRUE
return(list(done = TRUE, et = et))
}
list(done = FALSE)
}
#' Handle observation times specified in the position arguments or time
#'
#'
#' @param time the time argument passed to et(), which may be used as
#' the observation time if not NULL
#'
#' @param timeExpr the expression for the time argument, generated
#' from `substitute(time)`, which may be evaluated to get the
#' observation time if time is NULL
#'
#' @param envir the environment in which to evaluate any expressions
#'
#' @param envRef the reference to the internal environment of the rxEt
#' object
#'
#' @param evidVal the evid value to use for the observation events,
#' which may be NULL
#'
#' @param cmtVal the cmt value to use for the observation events,
#' which may be NULL
#'
#' @param targetIds the target ids for the observation events, which may be NULL to
#' indicate all ids
#'
#' @param et the current state of the event table being constructed, which may
#' be modified by adding a new chunk for the observation events
#'
#' @param timeMissing is the time argument missing?
#'
#' @return A list with components done
#'
#' @noRd
#'
#' @author Matthew L. Fidler
.etHandleObs <- function(time, timeExpr, envir, envRef, evidVal, cmtVal,
targetIds, et, timeMissing) {
if (!is.null(time) || !timeMissing) {
if (!is.null(time)) {
.timeVal <- time
} else {
.timeVal <- eval(timeExpr, envir = envir)
}
if (!is.list(.timeVal) &&
inherits(.timeVal, "units") &&
requireNamespace("units", quietly = TRUE)) {
.tu2 <- envRef$units["time"]
if (!is.na(.tu2) && nchar(.tu2) > 0) {
.timeVal <- as.numeric(units::set_units(.timeVal, .tu2, mode = "standard"))
} else {
.timeVal <- as.numeric(.timeVal)
}
}
if (!is.null(evidVal)) {
.evid2 <- evidVal
} else {
.evid2 <- 0L
}
.df <- .etObsChunk(.timeVal, cmt = cmtVal) # nolint
if (.evid2 != 0L) {
.df$evid <- as.integer(.evid2)
}
.etAddChunk(envRef, .df, targetIds) # nolint
envRef$nobs <- envRef$nobs + length(.df$time) * max(1L, length(targetIds))
if (!is.null(cmtVal)) {
envRef$show["cmt"] <- TRUE
}
return(list(done = TRUE, et = et))
}
list(done = FALSE)
}
#' Handle piping types of calls
#'
#'
#' @param xIsRxEt is the x argument an rxEt object, implying piping of some sort
#'
#' @param x the x argument passed to et()
#'
#' @param time the time argument passed to et()
#'
#' @param timeExpr the expression for the time argument, generated from `substitute(time)`
#'
#' @param amt the amt argument passed to et()
#'
#' @param amtExpr the expression for the amt argument, generated from `substitute(amt)`
#'
#' @param dotArgs the ... arguments passed to et(), which may contain
#' named or unnamed arguments
#'
#' @param cmtVal the cmt value to use for any events created from the
#' piping arguments, which may be NULL
#'
#' @param targetIds the target ids for any events created from the
#' piping arguments, which may be NULL to indicate all ids
#'
#' @param evidVal the evid value to use for any events created from the piping
#'
#' @param envRef the reference to the internal environment of the rxEt object
#'
#' @param et the current state of the event table
#'
#' @param timeMissing is the time argument missing?
#'
#' @param amtMissing is the amt argument missing?
#'
#' @param envir the environment in which to evaluate any expressions needed to handle
#' the piping arguments
#'
#' @return A list with components done and et, where done is a logical
#' indicating whether the piping arguments were successfully handled
#' and the main et()
#'
#' @noRd
#'
#' @author Matthew L. Fidler
.etHandlePiping <- function(xIsRxEt, x, time, timeExpr, amt, amtExpr, # nolint
dotArgs, cmtVal, targetIds, evidVal,
envRef, et, timeMissing, amtMissing, envir) {
if (xIsRxEt &&
is.null(time) &&
is.null(amt) && timeMissing && amtMissing) {
if (length(dotArgs) >= 1) {
.firstDot <- dotArgs[[1]]
if (is.rxEt(.firstDot) || # nolint
any(vapply(dotArgs, is.rxEt, logical(1)))) {
# Sequence of event tables
.ret <- do.call(etSeq, c(list(x), dotArgs)) # nolint
return(list(done = TRUE, et = .ret))
}
if (length(dotArgs) > 2) {
stop("unused positional arguments", call. = FALSE)
}
if (is.list(.firstDot) && !is.data.frame(.firstDot)) {
.df <- .etObsChunk(.firstDot, cmt = cmtVal) # nolint
.etAddChunk(envRef, .df, targetIds) # nolint
envRef$nobs <- envRef$nobs + length(.df$time) * max(1L, length(targetIds))
if (!is.null(cmtVal)) {
envRef$show["cmt"] <- TRUE
}
return(list(done = TRUE, et = et))
} else if (is.numeric(.firstDot) || is.integer(.firstDot)) {
if (length(dotArgs) >= 2L &&
length(.firstDot) == 1L &&
(is.numeric(dotArgs[[2]]) || is.integer(dotArgs[[2]])) &&
length(dotArgs[[2]]) == 1L) {
# et(0, 10) add obs at times 0, 1, ..., 10
.timeVec <- seq(from = as.numeric(.firstDot), to = as.numeric(dotArgs[[2]]))
} else if (inherits(.firstDot, "units") &&
requireNamespace("units", quietly = TRUE)) {
.tu2 <- envRef$units["time"]
if (!is.na(.tu2) && nchar(.tu2) > 0) {
.timeVec <- as.numeric(units::set_units(.firstDot, .tu2, mode = "standard"))
} else {
.timeVec <- as.numeric(.firstDot)
}
} else {
.timeVec <- as.numeric(.firstDot)
}
.df <- .etObsChunk(.timeVec, cmt = cmtVal) # nolint
if (!is.null(evidVal) && evidVal != 0L) {
.df$evid <- as.integer(evidVal)
}
.etAddChunk(envRef, .df, targetIds) # nolint
envRef$nobs <- envRef$nobs + length(.timeVec) * max(1L, length(targetIds))
return(list(done = TRUE, et = et))
}
}
}
list(done = FALSE)
}
#' Handle etSeq() calls
#'
#'
#' @param item the item argument passed to etSeq(), which is expected
#' to be an rxEt object
#'
#' @param units the units argument passed to etSeq(), which may be NULL
#'
#' @param show the show argument passed to etSeq(), which may be NULL
#'
#' @param ids the ids argument passed to etSeq(), which may be NULL
#'
#' @param timeDelta the timeDelta argument passed to etSeq(), which is
#' expected to be a numeric value
#'
#' @param samples the samples argument passed to etSeq(), which is
#' expected to be a character value of either "use" or "dose"
#'
#' @param chunks the chunks argument passed to etSeq(), which is
#' expected to be a list of data frames
#'
#' @param nobs the nobs argument passed to etSeq(), which is expected
#' to be an integer value
#'
#' @param ndose the ndose argument passed to etSeq(), which is expected to be an
#' integer value
#'
#' @param explicitIi the explicitIi argument passed to etSeq(), which
#' is expected to be a logical value
#'
#' @param ii the ii argument passed to etSeq(), which is expected to be a numeric value
#'
#' @return a list with components units, show, ids, chunks, nobs, ndose, timeDelta,
#' lastIi, and lastDose, which represent the updated state of the event
#'
#' @noRd
#'
#' @author Matthew L. Fidler
.etSeqHandleRxEt <- function(item, units, show, ids, timeDelta, samples, chunks, groups,
nobs, ndose, explicitIi, ii) {
env <- .rxEtEnv(item) # nolint
if (is.null(units)) {
units <- env$units
show <- env$show
} else {
show <- show | env$show
}
.itemGroups <- .etGetGroups(env) # nolint
.keepGrouped <- length(chunks) == 0L &&
length(.itemGroups) == 1L &&
(length(groups) == 0L ||
(length(groups) == 1L && .etGroupIdsEqual(groups[[1]]$ids, .itemGroups[[1]]$ids))) # nolint
if (!.keepGrouped && length(groups) > 0L) {
for (.g in groups) {
chunks <- .addRowsToChunks(chunks, .etMaterializeGroup(.g)) # nolint
}
groups <- list()
}
ids <- sort(unique(c(ids, env$ids)))
if (.keepGrouped) {
.summaryDf <- .etShiftChunk(.itemGroups[[1]]$data, timeDelta) # nolint
if (samples == "use") {
.groupDf <- .summaryDf
nobs <- nobs + env$nobs
} else {
.groupDf <- .summaryDf[.summaryDf$evid != 0L, , drop = FALSE]
}
if (nrow(.groupDf) > 0L) {
if (length(groups) == 0L) {
groups <- list(list(ids = as.integer(.itemGroups[[1]]$ids), data = .groupDf))
} else {
groups[[1]]$data <- as.data.frame(
data.table::rbindlist(list(groups[[1]]$data, .groupDf), fill = TRUE)
)
}
}
mat <- .summaryDf
} else {
mat <- .etShiftChunk(.etMaterialize(item), timeDelta) # nolint
if (samples == "use") {
chunks <- .addRowsToChunks(chunks, mat) # nolint
nobs <- nobs + env$nobs
} else {
doseOnly <- mat[mat$evid != 0L, , drop = FALSE]
chunks <- .addRowsToChunks(chunks, doseOnly) # nolint
}
}
lastIi <- 0.0
lastDose <- 0.0
doseRows <- mat[mat$evid != 0L, , drop = FALSE]
if (nrow(doseRows) > 0L) {
lastDoseRow <- doseRows[nrow(doseRows), ]
if (is.null(lastDoseRow$addl) || is.na(lastDoseRow$addl)) {
addlVal <- 0L
} else {
addlVal <- as.integer(lastDoseRow$addl)
}
if (addlVal > 0L) {
lastIi <- lastDoseRow$ii
}
lastDose <- lastDoseRow$time + addlVal * lastIi
}
maxTime <- max(mat$time, na.rm = TRUE)
ndose <- ndose + env$ndose
# Advance past last dose period; also respect max obs time (for samples="use")
if (!(explicitIi && identical(ii, 0))) {
if (lastIi > 0) {
effectiveIi <- lastIi
} else {
effectiveIi <- ii
}
timeDelta <- max(maxTime, lastDose + effectiveIi)
}
list(units = units, show = show, ids = ids, chunks = chunks, groups = groups,
nobs = nobs, ndose = ndose, timeDelta = timeDelta,
lastIi = lastIi, lastDose = lastDose)
}
#' Handle wait
#'
#'
#' @param item the item argument passed to etSeq(), which is expected
#' to be a numeric value representing the wait time
#'
#' @param waitType the waitType argument passed to etSeq(), which is
#' expected to be a character value of either "+ii" or "smart"
#'
#' @param lastDose the lastDose value from the previous item in the
#' etSeq() sequence
#'
#' @param lastIi the lastIi value from the previous item in the
#' etSeq() sequence
#'
#' @param ii the ii argument passed to etSeq(), which is expected to
#' be a numeric value representing the inter-dose interval
#'
#' @param timeDelta the current timeDelta value in the etSeq() sequence, which may be
#' updated by this function to reflect the wait time
#'
#' @return the updated timeDelta value after applying the wait time
#' according to the specified waitType
#' @noRd
#'
#' @author Matthew L. Fidler
.etSeqHandleWait <- function(item, waitType, lastDose, lastIi, ii, timeDelta) {
wait <- as.numeric(item)
effectiveIi <- if (lastIi > 0) lastIi else ii
if (waitType == "+ii") {
timeDelta <- lastDose + effectiveIi + wait
} else { # smart
if (wait < effectiveIi) {
timeDelta <- lastDose + effectiveIi
} else {
timeDelta <- lastDose + wait
}
}
timeDelta
}
Try the rxode2 package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.