R/et.R

Defines functions .rxCbindStudyIndividual .cbindThetaOmega .setEvCur .etRep .etSeq .etUpdate .et_ set_units.rxRateDur pillar_shaft.rxRateDur type_sum.rxRateDur `[<-.rxRateDur` `[[.rxRateDur` .colorFmt.rxRateDur .fmt as.character.rxRateDur c.rxRateDur `[.rxRateDur` rxRateDur pillar_shaft.rxEvid type_sum.rxEvid `[<-.rxEvid` `units<-.rxEvid` `[[.rxEvid` as.character.rxEvid .colorFmt.rxEvid `[.rxEvid` c.rxEvid rxEvid etExpand is.rxEt as_tibble.rxEt as.data.table.rxEt as.data.frame.rxEt as.et.default as.et rep.rxEt etRep c.rxEt seq.rxEt rbind.rxEt etRbind etSeq eventTable add.sampling add.dosing set_units.rxEt drop_units.rxEt rxEtDispatchSolve.default rxEtDispatchSolve `$.rxEt` et.default et.rxParams et.rxSolve et.rxode2 .clearPipe .pipeNStud .pipeNSub .pipeDfSub .pipeDfObs .pipeSigma .pipeOmega .pipeThetaMat .pipeKeep .pipeParams .pipeEvents .pipeInits .pipeRx .isNa1 et .etAddCls .isRxEt .DollarNames.rxEt

Documented in add.dosing add.sampling as.character.rxEvid as.character.rxRateDur as.et as.et.default .clearPipe c.rxEvid c.rxRateDur et et.default etExpand etRbind etRep et.rxode2 et.rxParams et.rxSolve etSeq eventTable is.rxEt .pipeDfObs .pipeDfSub .pipeEvents .pipeInits .pipeKeep .pipeNStud .pipeNSub .pipeOmega .pipeParams .pipeRx .pipeSigma .pipeThetaMat rbind.rxEt rep.rxEt rxEtDispatchSolve rxEtDispatchSolve.default rxEvid rxRateDur seq.rxEt

#' @importFrom utils .DollarNames
#' @export
.DollarNames.rxEt <- function(x, pattern) {
  grep(pattern, .Call(`_rxode2et_etDollarNames`, x), value = TRUE)
}

.isRxEt <- function(obj) {
  .Call(`_rxode2et_rxIsEt2`, obj)
}


.etAddCls <- function(x) {
  if (.isRxEt(x)) {
    .x <- x
    .cls <- class(x)
    class(.x) <- "data.frame"
    if (!is.null(.x[["evid"]])) {
      class(.x[["evid"]]) <- "rxEvid"
      .tmp <- .x[["rate"]]
      .cls2 <- class(.tmp)
      if (!inherits(.cls2, "rxRateDur")) {
        class(.tmp) <- c("rxRateDur", .cls2)
      }
      .x[["rate"]] <- .tmp
      .tmp <- .x[["dur"]]
      .cls2 <- class(.tmp)
      if (!inherits(.cls2, "rxRateDur")) {
        class(.tmp) <- c("rxRateDur", .cls2)
      }
      .x[["dur"]] <- .tmp
      class(.x) <- .cls
      return(.x)
    } else {
      return(x)
    }
  } else {
    return(x)
  }
}
#' Event Table Function
#'
#' @param ... Times or event tables.  They can also be one of the named arguments below.
#'
#' @param time Time is the time of the dose or the sampling times.
#'     This can also be unspecified and is determined by the object
#'     type (list or numeric/integer).
#'
#' @param amt Amount of the dose. If specified, this assumes a dosing
#'     record, instead of a sampling record.
#'
#' @param evid Event ID; This can be:
#'
#' | Numeric Value | Description |
#' |---------------|-------------|
#' | 0             | An observation. This can also be specified as `evid=obs` |
#' | 1             | A dose observation.  This can also be specified as `evid=dose` |
#' | 2             | A non-dose event. This can also be specified as `evid=other` |
#' | 3             | A reset event.  This can also be specified as `evid=reset`. |
#' | 4             |Dose and reset event.  This can also be specified as `evid=doseReset` or `evid=resetDose` |
#'
#' Note a reset event resets all the compartment values to zero and turns off all infusions.
#'
#' @param cmt Compartment name or number.  If a number, this is an
#'   integer starting at 1.  Negative compartments turn off a
#'   compartment. If the compartment is a name, the compartment name
#'   is changed to the correct state/compartment number before
#'   running the simulation.  For a compartment named "-cmt" the
#'   compartment is turned off.
#'
#'     Can also specify `cmt` as `dosing.to`,
#'     `dose.to`, `doseTo`, `dosingTo`, and
#'     `state`.
#'
#' @param ii When specifying a dose, this is the inter-dose interval
#'     for `ss`, `addl` and `until` options (described below).
#'
#' @param addl The number of additional doses at a inter-dose
#'     interval after one dose.
#'
#' @param ss Steady state flag;  It can be one of:
#'
#' | Value | Description |
#' |------------|-------------|
#' | 0 | This dose is not a steady state dose
#' | 1 | This dose is a steady state dose with the between/inter-dose interval of `ii` |
#' | 2 | Superposition steady state |
#'
#' When `ss=2` the steady state dose that uses the super-position
#' principle to allow more complex steady states, like 10 mg in the
#' morning and 20 mg at night, or dosing at 8 am 12 pm and 8 pm
#' instead of every 12 hours.  Since it uses the super positioning
#' principle, it only makes sense when you know the kinetics are
#' linear.
#'
#' All other values of `SS` are currently invalid.
#'
#' @param rate When positive, this is the rate of infusion.  Otherwise:
#'
#' | Value | Description |
#' |-------|--------------------------------|
#' | 0     |  No infusion is on this record |
#' | -1    | Modeled rate (in rxode2:`rate(cmt) =`); Can be `et(rate=model)`. |
#' |-2     | Modeled duration (in rxode2: `dur(cmt) =`); Can be`et(dur=model)` or `et(rate=dur)`. |
#'
#' When a modeled bioavailability is applied to positive rates
#' (`rate` > 0), the duration of infusion is changed. This is
#' because the data specify the rate and amount, the only think that
#' modeled bioavailability can affect is duration.
#'
#' If instead you want the modeled bioavailability to increase the
#' rate of infusion instead of the duration of infusion, specify the
#' `dur` instead or model the duration with `rate=2`.
#'
#' @param dur Duration of infusion.  When `amt` and `dur`
#'     are specified the rate is calculated from the two data items.
#'     When `dur` is specified instead of `rate`, the
#'     bioavailability changes will increase rate instead of
#'     duration.
#'
#' @param until This is the time until the dosing should end.  It can
#'     be an easier way to figure out how many additional doses are
#'     needed over your sampling period.
#'
#' @param id A integer vector of IDs to add or remove from the event
#'     table.  If the event table is identical for each ID, then you
#'     may expand it to include all the IDs in this vector.  All the
#'     negative IDs in this vector will be removed.
#'
#' @param amountUnits The units for the dosing records (`amt`)
#'
#' @param timeUnits The units for the time records (`time`)
#'
#' @param addSampling This is a boolean indicating if a sampling time
#'     should be added at the same time as a dosing time.  By default
#'     this is `FALSE`.
#'
#' @param x This is the first argument supplied to the event table.
#'     This is named to allow `et` to be used in a pipe-line
#'     with arbitrary objects.
#'
#' @inheritParams base::eval
#' @inheritParams base::seq
#' @return A new event table
#'
#' @template etExamples
#' @useDynLib rxode2et, .registration=TRUE
#' @importFrom Rcpp evalCpp
#' @importFrom stats simulate end setNames start
#' @importFrom utils assignInMyNamespace
#' @importFrom methods is
#' @importFrom rxode2random rxnorm
#' @importFrom rxode2parse rxode2parse
#' @export
et <- function(x, ..., envir = parent.frame()) {
  UseMethod("et")
}

.pipelineRx <- NULL
.pipelineInits <- NULL
.pipelineEvents <- NULL
.pipelineParams <- NULL
.pipelineICov <- NULL
.pipelineKeep <- NULL
.pipelineThetaMat <- NULL
.pipelineOmega <- NULL
.pipelineIov <- NULL
.pipelineSigma <- NULL
.pipelineDfObs <- NULL
.pipelineDfSub <- NULL
.pipelineNSub <- NULL

.isNa1 <- function(x) {
  if (inherits(x, "logical") ||
        inherits(x, "numeric") ||
        inherits(x, "integer")) {
    if (length(x) == 1) {
      return(is.na(x))
    }
  }
  FALSE
}

.pipelineNStud <- NULL

#' Assign in the rxode2 pipeline
#'
#'
#' @param obj  Object to assign.  If NA return the value.
#' @return The pipeline object (invisibly)
#' @author Matthew L. Fidler
#' @export
#' @keywords internal
.pipeRx <- function(obj) {
  if (.isNa1(obj)) return(invisible(.pipelineRx))
  assignInMyNamespace(".pipelineRx", obj)
  return(invisible(obj))
}

#' @rdname dot-pipeRx
#' @export
.pipeInits <- function(obj) {
  if (.isNa1(obj)) return(invisible(.pipelineInits))
  assignInMyNamespace(".pipelineInits", obj)
  return(invisible(obj))
}

#' @rdname dot-pipeRx
#' @export
.pipeEvents <- function(obj) {
  if (.isNa1(obj)) return(invisible(.pipelineEvents))
  assignInMyNamespace(".pipelineEvents", obj)
  return(invisible(obj))
}

#' @rdname dot-pipeRx
#' @export
.pipeParams <- function(obj) {
  if (.isNa1(obj)) return(invisible(.pipelineParams))
  assignInMyNamespace(".pipelineParams", obj)
  return(invisible(obj))
}

#' @rdname dot-pipeRx
#' @export
.pipeKeep <- function(obj) {
  if (.isNa1(obj)) return(invisible(.pipelineKeep))
  assignInMyNamespace(".pipelineKeep", obj)
  return(invisible(obj))
}

#' @rdname dot-pipeRx
#' @export
.pipeThetaMat <- function(obj) {
  if (.isNa1(obj)) return(invisible(.pipelineThetaMat))
  assignInMyNamespace(".pipelineThetaMat", obj)
  return(invisible(obj))
}

#' @rdname dot-pipeRx
#' @export
.pipeOmega <- function(obj) {
  if (.isNa1(obj)) return(invisible(.pipelineOmega))
  assignInMyNamespace(".pipelineOmega", obj)
  return(invisible(obj))
}

#' @rdname dot-pipeRx
#' @export
.pipeSigma <- function(obj) {
  if (.isNa1(obj)) return(invisible(.pipelineSigma))
  assignInMyNamespace(".pipelineSigma", obj)
  return(invisible(obj))
}

#' @rdname dot-pipeRx
#' @export
.pipeDfObs <- function(obj) {
  if (.isNa1(obj)) return(invisible(.pipelineDfObs))
  assignInMyNamespace(".pipelineDfObs", obj)
  return(invisible(obj))
}

#' @rdname dot-pipeRx
#' @export
.pipeDfSub <- function(obj) {
  if (.isNa1(obj)) return(invisible(.pipelineDfSub))
  assignInMyNamespace(".pipelineDfSub", obj)
  return(invisible(obj))
}

#' @rdname dot-pipeRx
#' @export
.pipeNSub <- function(obj) {
  if (.isNa1(obj)) return(invisible(.pipelineNSub))
  assignInMyNamespace(".pipelineNSub", obj)
  return(invisible(obj))
}


#' @rdname dot-pipeRx
#' @export
.pipeNStud <- function(obj) {
  if (.isNa1(obj)) return(invisible(.pipelineNStud))
  assignInMyNamespace(".pipelineNStud", obj)
  return(invisible(obj))
}

#' Clear/Set pipeline
#'
#' @param rx rxode2 object
#' @keywords internal
#' @return None, clears rxode2 pipeline
#' @export
.clearPipe <- function(rx = NULL, inits = NULL,
                       events = NULL, params = NULL,
                       iCov = NULL, keep = NULL,
                       thetaMat = NULL, omega = NULL,
                       sigma = NULL, dfObs = NULL,
                       dfSub = NULL, nSub = NULL,
                       nStud = NULL) {
  assignInMyNamespace(".pipelineRx", rx)
  assignInMyNamespace(".pipelineInits", inits)
  assignInMyNamespace(".pipelineEvents", events)
  assignInMyNamespace(".pipelineParams", params)
  assignInMyNamespace(".pipelineICov", iCov)
  assignInMyNamespace(".pipelineKeep", keep)
  assignInMyNamespace(".pipelineThetaMat", thetaMat)
  assignInMyNamespace(".pipelineOmega", omega)
  assignInMyNamespace(".pipelineSigma", sigma)
  assignInMyNamespace(".pipelineDfObs", dfObs)
  assignInMyNamespace(".pipelineDfSub", dfSub)
  assignInMyNamespace(".pipelineNSub", nSub)
  assignInMyNamespace(".pipelineNStud", nStud)
}

#' @rdname et
#' @export
et.rxode2 <- function(x, ..., envir = parent.frame()) {
  .clearPipe()
  assignInMyNamespace(".pipelineRx", x)
  do.call(et, c(list(...), list(envir = envir)), envir = envir)
}

#' @rdname et
#' @export
et.function <- et.rxode2

#' @rdname et
#' @export
et.rxUi <- et.rxode2

#' @rdname et
#' @export
et.rxSolve <- function(x, ..., envir = parent.frame()) {
  ## Need to extract:
  ## 1. rxode2 model
  assignInMyNamespace(".pipelineRx", x$.args.object)
  ## 2. rxode2 parameters
  assignInMyNamespace(".pipelineParams", x$.args.par0)
  assignInMyNamespace(".pipelineICov", x$.args$iCov)
  assignInMyNamespace(".pipelineKeep", x$.args$keep)
  ## 3. rxode2 inits
  assignInMyNamespace(".pipelineInits", x$.args.inits)
  ## 4. rxode2 thetaMat
  assignInMyNamespace(".pipelineThetaMat", x$.args$thetaMat)
  ## 5. rxode2 omega
  assignInMyNamespace(".pipelineOmega", x$.args$omega)
  ## 6. rxode2 sigma
  assignInMyNamespace(".pipelineSigma", x$.args$sigma)
  ## 7. rxode2 dfObs
  assignInMyNamespace(".pipelineDfObs", x$env$.args$dfObs)
  ## 8. rxode2 dfSub
  assignInMyNamespace(".pipelineDfSub", x$env$.args$dfSub)
  do.call(et, c(list(...), list(envir = envir)), envir = envir)
}

#' @rdname et
#' @export
et.rxParams <- function(x, ..., envir = parent.frame()) {
  ## Need to extract:
  ## 1. rxode2 model
  ## 2. rxode2 parameters
  if (!is.null(x$params)) assignInMyNamespace(".pipelineParams", x$params)
  if (!is.null(x$iCov)) assignInMyNamespace(".pipelineICov", x$iCov)
  if (!is.null(x$keep)) assignInMyNamespace(".pipelineKeep", x$keep)
  ## 3. rxode2 inits
  if (!is.null(x$inits)) assignInMyNamespace(".pipelineInits", x$inits)
  ## 4. rxode2 thetaMat
  if (!is.null(x$thetaMat)) assignInMyNamespace(".pipelineThetaMat", x$thetaMat)
  ## 5. rxode2 omega
  if (!is.null(x$omega)) assignInMyNamespace(".pipelineOmega", x$omega)
  ## 6. rxode2 sigma
  if (!is.null(x$sigma)) assignInMyNamespace(".pipelineSigma", x$sigma)
  ## 7. rxode2 dfObs
  if (!is.null(x$dfObs)) assignInMyNamespace(".pipelineDfObs", x$dfObs)
  ## 8. rxode2 dfSub
  if (!is.null(x$dfSub)) assignInMyNamespace(".pipelineDfSub", x$dfSub)
  if (!is.null(x$nSub)) assignInMyNamespace(".pipelineNSub", x$nSub)
  if (!is.null(x$nStud)) assignInMyNamespace(".pipelineNStud", x$nStud)

  do.call(et, c(list(...), list(envir = envir)), envir = envir)
}

#' @rdname et
#' @export
et.default <- function(x, ..., time, amt, evid, cmt, ii, addl,
                       ss, rate, dur, until, id,
                       amountUnits, timeUnits, addSampling,
                       envir = parent.frame(),
                       by = NULL, length.out = NULL) {
  .lst <- as.list(match.call()[-1])

  .isPipe <- as.character(substitute(x))
  if (length(.isPipe) == 1) {
    .isPipe <- (.isPipe == ".")
  } else {
    .isPipe <- FALSE
  }
  if (!missing(x)) {
    names(.lst)[1] <- ""
  }
  if (!missing(by)) {
    force(by)
    checkmate::assertNumeric(by, finite = TRUE, max.len = 1, any.missing = FALSE, min.len = 0)
    if (!missing(length.out)) {
      stop("cannot supply both 'by' and 'length.out'", call. = FALSE)
    }
    .lst <- .lst[names(.lst) != "by"]
    .lst <- .lst[names(.lst) != "envir"]
    if (.isPipe) {
      if (length(.lst) == 3) {
        .from <- eval(.lst[[2]], envir = envir)
        .to <- eval(.lst[[3]], envir = envir)
        .lst <- .lst[-3]
        checkmate::assertNumeric(.from, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "from")
        checkmate::assertNumeric(.to, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "to")
        .lst[[2]] <- seq(from = .from, to = .to, by = by)
        return(do.call(et.default, .lst, envir = envir))
      } else {
        .from <- eval(.lst[[2]], envir = envir)
        checkmate::assertNumeric(.from, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "from")
        .lst[[2]] <- seq(from = .from, by = by)
        return(do.call(et.default, .lst, envir = envir))
      }
    } else {
      if (length(.lst) == 2) {
        .from <- eval(.lst[[1]], envir = envir)
        .to <- eval(.lst[[2]], envir = envir)
        .lst <- .lst[-2]
        checkmate::assertNumeric(.from, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "from")
        checkmate::assertNumeric(.to, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "to")
        .lst[[1]] <- seq(from = .from, to = .to, by = by)
        return(do.call(et.default, .lst, envir = envir))
      } else {
        .from <- eval(.lst[[1]], envir = envir)
        checkmate::assertNumeric(.from, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "from")
        .lst[[1]] <- seq(from = .from, by = by)
        return(do.call(et.default, .lst, envir = envir))
      }
    }
  }
  if (!missing(length.out)) {
    checkmate::assertCount(length.out)
    .lst <- .lst[names(.lst) != "length.out"]
    .lst <- .lst[names(.lst) != "envir"]
    if (.isPipe) {
      if (length(.lst) == 3) {
        .from <- eval(.lst[[2]], envir = envir)
        .to <- eval(.lst[[3]], envir = envir)
        .lst <- .lst[-3]
        checkmate::assertNumeric(.from, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "from")
        checkmate::assertNumeric(.to, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "to")
        .lst[[2]] <- seq(from = .from, to = .to, length.out = length.out)
        return(do.call(et.default, .lst, envir = envir))
      } else {
        .from <- eval(.lst[[2]], envir = envir)
        checkmate::assertNumeric(.from, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "from")
        .lst[[2]] <- seq(from = .from, length.out = length.out)
        return(do.call(et.default, .lst, envir = envir))
      }
    } else {
      if (length(.lst) == 2) {
        .from <- eval(.lst[[1]], envir = envir)
        .to <- eval(.lst[[2]], envir = envir)
        checkmate::assertNumeric(.from, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "from")
        checkmate::assertNumeric(.to, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "to")
        .lst <- eval(.lst[-2], envir = envir)
        .lst[[1]] <- seq(from = .from, to = .to, length.out = length.out)
        return(do.call(et.default, .lst, envir = envir))
      } else {
        .from <- eval(.lst[[1]], envir = envir)
        checkmate::assertNumeric(.from, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "from")
        .lst[[1]] <- seq(from = .from, length.out = length.out)
        return(do.call(et.default, .lst, envir = envir))
      }
    }
  }
  if (!.isPipe) {
    if (all(names(.lst) == "") && length(.lst) == 2) {
      if ((is(.lst[[1]], "numeric") || is(.lst[[1]], "integer")) &&
        (is(.lst[[2]], "numeric") || is(.lst[[2]], "integer"))) {
        .from <- eval(.lst[[1]], envir = envir)
        .to <- eval(.lst[[2]], envir = envir)
        .lst <- .lst[-2]
        checkmate::assertNumeric(.from, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "from")
        checkmate::assertNumeric(.to, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "to")
        .lst[[1]] <- seq(from = .from, to = .to)
        return(do.call(et.default, .lst, envir = envir))
      }
    }
    .len <- sum(names(.lst) == "")
    if (.len == 2 && is(.lst[[2]], "character")) {
    } else if (.len > 1) {
      stop("improper arguments to 'et'", call. = FALSE)
    }
  } else {
    if (all(names(.lst)[-1] == "") && length(.lst) == 3) {
      if ((is(.lst[[2]], "numeric") || is(.lst[[2]], "integer")) &&
        (is(.lst[[3]], "numeric") || is(.lst[[3]], "integer"))) {
        .from <- eval(.lst[[2]], envir = envir)
        .to <- eval(.lst[[3]], envir = envir)
        checkmate::assertNumeric(.from, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "from")
        checkmate::assertNumeric(.to, finite = TRUE, max.len = 1, any.missing = FALSE, .var.name = "to")
        .lst <- .lst[-3]
        .lst[[2]] <- seq(from = .from, to = .to)
        return(do.call(et.default, .lst, envir = envir))
      }
    }
    .len <- sum(names(.lst)[-1] == "")
    if (.len == 2 && is(.lst[[3]], "character")) {
    } else if (.len > 1) {
      if (sum(names(.lst)[-1] == "") > 1) {
        stop("improper arguments to 'et'", call. = FALSE)
      }
    }
  }
  if (!missing(amt)) {
    if (length(amt) > 1) {
      if (missing(time)) {
        time <- 0
      } else if (length(time) != length(amt)) {
        if (length(time) != 1) {
          stop("when supplying vectors of 'time', 'amt' they need to be the same size", call. = FALSE)
        }
      }
      .df <- data.frame(time = time, amt = amt)
      ##
      if (!missing(id)) {
        force(id)
        .df$id <- id
      }
      if (missing(cmt)) {
        .df$cmt <- "(default)"
      } else {
        .df$cmt <- cmt
      }
      .df$amt <- amt
      if (missing(rate)) {
        .df$rate <- 0.0
      } else {
        .df$rate <- rate
      }
      if (missing(ii)) {
        .df$ii <- 0.0
      } else {
        .df$ii <- ii
      }
      if (missing(addl)) {
        .df$addl <- 0L
      } else {
        .df$addl <- addl
      }
      if (missing(evid)) {
        .df$evid <- 1L
      } else {
        .df$evid <- evid
      }
      if (missing(ss)) {
        .df$ss <- 0L
      } else {
        .df$ss <- ss
      }
      if (missing(dur)) {
        .df$dur <- 0.0
      } else {
        .df$dur <- dur
      }
      .et <- et()
      .et$import.EventTable(.df)
      if (.isPipe) {
        .tmp <- eval(.lst[[1]], envir = envir)
        if (nrow(.et) == 0) {
          return(.tmp)
        } else if (nrow(.tmp) == 0) {
          return(.et)
        } else {
          return(etRbind(.tmp, .et))
        }
      } else {
        return(.et)
      }
    }
  }
  if (!missing(time)) {
    if (inherits(time, "list")) {
      checkmate::assertList(time,
        any.missing = FALSE,
        unique = FALSE,
        names = "unnamed"
      )
    } else {
      checkmate::assertNumeric(time,
        finite = TRUE,
        any.missing = FALSE,
        unique = TRUE,
        names = "unnamed"
      )
    }
    .lst$time <- time
  }
  if (!missing(amt)) {
    checkmate::assertNumeric(amt,
      finite = TRUE,
      any.missing = FALSE,
      max.len = 1,
      names = "unnamed"
    )
    .lst$amt <- amt
  }
  if (!missing(evid)) {
    .evid <- as.character(substitute(evid))
    if (length(.evid) != 1) {
      if (all(.evid == .evid[1])) {
        .evid <- .evid[1]
      } else {
        .evid0 <- suppressWarnings(try(as.numeric(evid), silent = TRUE))
        if (inherits(.evid, "try-error")) {
          stop(sprintf(
            gettext("only a single evid 'evid' can be specified ('%s')"),
            paste(.evid, collapse = "', '")
          ), call. = FALSE)
        } else {
          .evid <- .evid0
        }
      }
    }
    if (.evid == "obs" || .evid == "0") {
      .tmp <- try(eval(evid, envir = envir), silent = TRUE)
      if (inherits(.tmp, "try-error")) {
        .lst$evid <- 0L
      } else {
        .lst$evid <- as.integer(.tmp)
      }
    } else if (.evid == "dose" || .evid == "1") {
      .tmp <- try(eval(evid, envir = envir), silent = TRUE)
      if (inherits(.tmp, "try-error")) {
        .lst$evid <- 1L
      } else {
        .lst$evid <- as.integer(.tmp)
      }
    } else if (.evid == "other" || .evid == "2") {
      .tmp <- try(eval(evid, envir = envir), silent = TRUE)
      if (inherits(.tmp, "try-error")) {
        .lst$evid <- 2L
      } else {
        .lst$evid <- as.integer(.tmp)
      }
    } else if (.evid == "reset" || .evid == "3") {
      .tmp <- try(eval(evid, envir = envir), silent = TRUE)
      if (inherits(.tmp, "try-error")) {
        .lst$evid <- 3L
      } else {
        .lst$evid <- as.integer(.tmp)
      }
    } else if (.evid == "doseReset" || .evid == "resetDose" || .evid == "4") {
      .tmp <- try(eval(evid, envir = envir), silent = TRUE)
      if (inherits(.tmp, "try-error")) {
        .lst$evid <- 4L
      } else {
        .lst$evid <- as.integer(.tmp)
      }
    } else {
      .lst$evid <- as.integer(evid)
    }
  }
  if (!missing(cmt)) {
    .cmt <- as.character(substitute(cmt))
    .cmt2 <- try(force(cmt), silent=TRUE)
    if (inherits(.cmt2, "character") ||
          inherits(.cmt2, "numeric")) {
      .cmt <- .cmt2
    }
    if (length(.cmt) != 1) {
      if (.cmt[1] == "$") {
        force(cmt)
        .cmt <- cmt
      } else if (all(.cmt == .cmt[1])) {
        .cmt <- .cmt[1]
      } else {
        .cmt0 <- suppressWarnings(try(as.numeric(cmt), silent = TRUE))
        if (inherits(.cmt, "try-error")) {
          stop(sprintf(
            gettext("only a single compartment 'cmt' can be specified ('%s')"),
            paste(.cmt, collapse = "', '")
          ), call. = FALSE)
        } else {
          .cmt <- .cmt0
        }
      }
    }
    .cmt1 <- try(suppressWarnings(as.integer(cmt)), silent = TRUE)
    if (inherits(.cmt1, "try-error")) {
      .lst$cmt <- .cmt
    } else {
      if (is.na(.cmt1)) {
        .lst$cmt <- .cmt
      } else {
        .lst$cmt <- .cmt1
      }
    }
  }
  if (!missing(rate)) {
    .rate <- as.character(substitute(rate))
    if (length(.rate) != 1) {
      if (all(.rate == .rate[1])) {
        .rate <- .rate[1]
      } else {
        .rate0 <- suppressWarnings(try(as.numeric(rate), silent = TRUE))
        if (inherits(.rate, "try-error")) {
          stop(sprintf(
            gettext("only a single rate 'rate' can be specified ('%s')"),
            paste(.rate, collapse = "', '")
          ), call. = FALSE)
        } else {
          .rate <- .rate0
        }
      }
    }
    .lst$rate <- rate
  }
  if (!missing(dur)) {
    .dur <- as.character(substitute(dur))
    if (length(.dur) != 1) {
      if (all(.dur == .dur[1])) {
        .dur <- .dur[1]
      } else {
        .dur0 <- suppressWarnings(try(as.numeric(dur), silent = TRUE))
        if (inherits(.dur, "try-error")) {
          stop(sprintf(
            gettext("only a single duration 'dur' can be specified ('%s')"),
            paste(.dur, collapse = "', '")
          ), call. = FALSE)
        } else {
          .dur <- .dur0
        }
      }
    }
    .lst$dur <- dur
  }
  .unitNames <- names(.lst)
  .unitNames <- .unitNames[regexpr("^(amount|time)", .unitNames) != -1]
  .unitNames <- .unitNames[.unitNames != "time"]
  for (.u in .unitNames) {
    if (inherits(.lst[[.u]], "name")) {
      .tmp <- .lst[[.u]]
      .tmp <- deparse(substitute(.tmp))
      .lst[[.u]] <- .tmp
    }
  }
  .lst <- lapply(.lst, function(x) {
    eval(x, envir)
  })
  if (any(names(.lst) == "evid")) {
    if (all(.lst$evid == 0)) {
      .lst <- .lst[names(.lst) != "evid"]
    }
  }
  .Call(`_rxode2et_et_`, .lst, list())
}

#' @export
`$.rxEt` <- function(obj, arg, exact = FALSE) {
  return(.Call(`_rxode2et_etUpdate`, obj, arg, NULL, exact))
}
#' Dispatch solve to 'rxode2' solve
#'
#'
#' @param x rxode2 solve dispatch object
#' @param ...  other arguments
#' @return if 'rxode2'  is loaded, a solved object, otherwise an error
#' @author Matthew L. Fidler
#' @export
rxEtDispatchSolve <- function(x, ...) {
  UseMethod("rxEtDispatchSolve")
}

#' @rdname rxEtDispatchSolve
#' @export
rxEtDispatchSolve.default <- function(x, ...) {
  stop("need 'rxode2' loaded for piping to a simulation")
}

#' @export
simulate.rxEt <- # nolint
  function(object, nsim = 1, seed = NULL, ...) {
    .name <- as.character(substitute(object))
    if (is.null(.pipelineRx) || .name != ".") {
      if (!missing(nsim)) warning("'nsim' is ignored when simulating event tables", call. = FALSE)
      if (!is.null(seed)) set.seed(seed)
      return(.Call(`_rxode2et_et_`, list(simulate = TRUE), object))
    } else {
      .ret <- list(object, ..., seed = seed, nsim = nsim)
      class(.ret) <- "rxode2et"
      return(rxEtDispatchSolve(.ret))
    }
  }

drop_units.rxEt <- function(x) {
  if (requireNamespace("units", quietly = TRUE)) {
    stop("requires package 'units'", call. = FALSE)
  }
  .Call(`_rxode2et_et_`, list(amountUnits = NA_character_, timeUnits = NA_character_), x)
}

set_units.rxEt <- function(x, value, ..., mode = .setUnitsMode()) {
  if (is.null(mode)) {
    stop("requires package 'units'", call. = FALSE)
  }
  if (missing(value)) {
    value <- .unitless()
  } else if (mode == "symbols") {
    value <- substitute(value)
    if (is.numeric(value) && !identical(value, 1) && !identical(value, 1L)) {
      stop("the only valid number defining a unit is '1', signifying a unitless unit", call. = FALSE)
    }
  }
  if (identical(value, .unitless())) {
    warning("clearing both amount and time units\nfor more precise control use 'et(amountUnits=\"\")' or 'et(timeUnits=\"\")'",
      call. = FALSE
    )
    return(suppressWarnings({
      .Call(`_rxode2et_et_`, list(amountUnits = "", timeUnits = ""), x)
    }))
  } else {
    if (!inherits(value, "character")) value <- deparse(value)
    .tUnit <- units::set_units(1, "sec", mode = "standard")
    .isTime <- try(units::set_units(units::set_units(1, value, mode = "standard"), "sec"), silent = TRUE)
    if (inherits(.isTime, "try-error")) {
      ## Amount
      return(.Call(`_rxode2et_et_`, list(amountUnits = value), x))
    } else {
      ##
      return(.Call(`_rxode2et_et_`, list(timeUnits = value), x))
    }
  }
}

#' Add dosing to eventTable
#'
#' This adds a dosing event to the event table.  This is provided for
#' piping syntax through magrittr.  It can also be accessed by `eventTable$add.dosing(...)`
#'
#' @param eventTable eventTable object; When accessed from object it would be `eventTable$`
#' @param dose numeric scalar, dose amount in `amount.units`;
#' @param nbr.doses integer, number of doses;
#' @param dosing.interval required numeric scalar, time between doses
#'     in `time.units`, defaults to 24 of
#'     `time.units="hours"`;
#' @param dosing.to integer, compartment the dose goes into (first
#'     compartment by default);
#' @param rate for infusions, the rate of infusion (default is
#'     `NULL`, for bolus dosing;
#' @param amount.units optional string indicating the dosing units.
#'     Defaults to `NA` to indicate as per the original
#'     `EventTable` definition.
#' @param start.time required dosing start time;
#' @param do.sampling logical, should observation sampling records be
#'     added at the dosing times? Defaults to `FALSE`.
#' @param time.units optional string indicating the time units.
#'     Defaults to `"hours"` to indicate as per the original
#'     `EventTable` definition.
#' @param ... Other parameters passed to [et()].
#' @return eventTable with updated dosing (note the event table will
#'     be updated anyway)
#' @author Matthew L. Fidler
#' @template etExamples
#' @export
# nolint start
add.dosing <- function(eventTable, dose, nbr.doses = 1L,
                       dosing.interval = 24, dosing.to = 1L,
                       rate = NULL, amount.units = NA_character_,
                       start.time = 0.0, do.sampling = FALSE,
                       time.units = NA_character_, ...) {
  checkmate::assertDouble(dose, any.missing = FALSE, finite = TRUE, max.len = 1)
  checkmate::assertDouble(dosing.interval, lower = 0, any.missing = FALSE, finite = TRUE, max.len = 1)
  checkmate::assertDouble(start.time, any.missing = FALSE, finite = TRUE, max.len = 1)
  .lst <- list(
    dose = dose,
    nbr.doses = nbr.doses,
    start.time = start.time,
    do.sampling = do.sampling,
    ...
  )
  if (!is.na(amount.units)) .lst$amount.units <- amount.units
  if (!is.na(time.units)) .lst$time.units <- time.units
  if (dosing.to != 1) .lst$dosing.to <- dosing.to
  if (!is.null(rate)) .lst$rate <- rate
  if (nbr.doses > 1) {
    .lst$dosing.interval <- dosing.interval
  } else {
    .lst$dosing.interval <- 0.0
  }
  checkmate::assertIntegerish(nbr.doses, lower = 1L, any.missing = FALSE, max.len = 1)
  .Call(`_rxode2et_et_`, .lst, eventTable)
}

#' Add sampling to eventTable
#'
#' This adds a dosing event to the event table.  This is provided for
#' piping syntax through magrittr.  It can also be accessed by
#' `eventTable$add.sampling()`
#'
#' @param eventTable An eventTable object. When accessed from object it would be `eventTable$`
#' @param time a vector of time values (in `time.units`).
#' @param time.units an optional string specifying the time
#'     units. Defaults to the units specified when the
#'     `EventTable` was initialized.
#' @return eventTable with updated sampling.  (Note the event table
#'     will be updated even if you don't reassign the eventTable)
#' @template etExamples
#' @export
add.sampling <- function(eventTable, time, time.units = NA) {
  .lst <- list(time = time)
  if (!is.na(time.units)) .lst$time.units <- time.units
  return(.Call(`_rxode2et_et_`, .lst, eventTable))
}


#' Create an event table object
#'
#' Initializes an object of class \sQuote{EventTable} with methods for
#' adding and querying dosing and observation records
#'
#' @param amount.units string denoting the amount dosing units, e.g.,
#'      \dQuote{mg}, \dQuote{ug}. Default to `NA` to denote
#'      unspecified units.  It could also be a solved rxode2 object.  In
#'      that case, eventTable(obj) returns the eventTable that was used
#'      to solve the rxode2 object.
#'
#' @param time.units string denoting the time units, e.g.,
#'      \dQuote{hours}, \dQuote{days}. Default to `"hours"`.
#'
#'  An `eventTable` is an object that consists of a data.frame
#'  storing ordered time-stamped events of an (unspecified) PK/PD
#'  dynamic system, units (strings) for dosing and time records, plus a
#'  list of functions to add and extract event records.
#'
#'  Currently, events can be of two types: dosing events that represent
#'  inputs to the system and sampling time events that represent
#'  observations of the system with \sQuote{amount.units} and
#'  \sQuote{time.units}, respectively.
#'
#'
#' @return A modified data.frame with the following accessible functions:
#'
#' * `get.EventTable()` returns the current event table
#'
#' * [add.dosing()]  adds dosing records to the event table.
#'
#' * `get.dosing()` returns a data.frame of dosing records.
#'
#' * `clear.dosing()` clears or deletes all dosing from event table
#'
#' *  `[add.sampling()] adds sampling time observation records to the
#'        event table.
#'
#' * `get.sampling()`returns a data.frame of sampled observation records.
#'
#' * `clear.sampling()` removes all sampling from event table.
#'
#' * `get.obs.rec()` returns a logical vector indicating whether each
#'    event record represents an observation or not.
#'
#' * `get.nobs()` returns the number of observation (not dosing) records.
#'
#' * `get.units()` returns a two-element character vector with the
#'        dosing and time units, respectively
#'
#' * `copy()` makes a copy of the current event table. To create
#'        a copy of an event table object use `qd2 <- qd$copy()`
#'
#' * `expand()` Expands the event table for multi-subject solving.
#'    This is done by `qd$expand(400)` for a 400 subject data expansion
#'
#' @author Matthew Fidler, Melissa Hallow and Wenping Wang
#'
#' @seealso [et()]
#'
#' @examples
#' # create dosing and observation (sampling) events
#' # QD 50mg dosing, 5 days followed by 25mg 5 days
#' #
#' qd <- eventTable(amount.units = "mg", time.units = "days")
#' #
#' qd$add.dosing(dose = 50, nbr.doses = 5, dosing.interval = 1, do.sampling = FALSE)
#' #
#' # sample the system's drug amounts hourly the first day, then every 12 hours
#' # for the next 4 days
#' qd$add.sampling(seq(from = 0, to = 1, by = 1 / 24))
#' qd$add.sampling(seq(from = 1, to = 5, by = 12 / 24))
#' #
#' # print(qd$get.dosing())     # table of dosing records
#' print(qd$get.nobs()) # number of observation (not dosing) records
#' #
#' # BID dosing, 5 days
#' bid <- eventTable("mg", "days") # only dosing
#' bid$add.dosing(
#'   dose = 10000, nbr.doses = 2 * 5,
#'   dosing.interval = 12, do.sampling = FALSE
#' )
#' #
#' # Use the copy() method to create a copy (clone) of an existing
#' # event table (simple assignments just create a new reference to
#' # the same event table object (closure)).
#' #
#' bid.ext <- bid$copy() # three-day extension for a 2nd cohort
#' bid.ext$add.dosing(
#'   dose = 5000, nbr.doses = 2 * 3,
#'   start.time = 120, dosing.interval = 12, do.sampling = FALSE
#' )
#'
#' # You can also use the Piping operator to create a table
#'
#' qd2 <- eventTable(amount.units = "mg", time.units = "days") %>%
#'   add.dosing(dose = 50, nbr.doses = 5, dosing.interval = 1, do.sampling = FALSE) %>%
#'   add.sampling(seq(from = 0, to = 1, by = 1 / 24)) %>%
#'   add.sampling(seq(from = 1, to = 5, by = 12 / 24))
#' # print(qd2$get.dosing())     # table of dosing records
#' print(qd2$get.nobs()) # number of observation (not dosing) records
#'
#' # Note that piping with %>% will update the original table.
#'
#' qd3 <- qd2 %>% add.sampling(seq(from = 5, to = 10, by = 6 / 24))
#' print(qd2$get.nobs())
#' print(qd3$get.nobs())
#' @keywords models data
#' @concept ordinary differential equations
#' @concept Nonlinear regression
#' @concept Pharmacokinetics (PK)
#' @concept Pharmacodynamics (PD)
#' @export
eventTable <- function(amount.units = NA, time.units = NA) {
  .lst <- list()
  if (!missing(amount.units)) {
    checkmate::assertCharacter(amount.units, max.len = 1)
    .lst$amount.units <- amount.units
  }
  if (!missing(time.units)) {
    checkmate::assertCharacter(time.units, max.len = 1)
    .lst$time.units <- time.units
  }
  .Call(`_rxode2et_et_`, .lst, list())
}
# nolint end

#' Sequence of event tables
#'
#' This combines a sequence of event tables.
#'
#' @param ... The event tables and optionally time between event
#'     tables, called waiting times in this help document.
#'
#' @param samples How to handle samples when repeating an event
#'     table.  The options are:
#'
#' * `"clear"` Clear sampling records before combining the datasets
#' * `"use"` Use the sampling records when combining the datasets
#'
#' @param waitII This determines how waiting times between events are
#'     handled. The options are:
#'
#' * `"smart"` This "smart" handling of waiting times is the
#'   default option.  In this case, if the waiting time is above the
#'   last observed inter-dose interval in the first combined event
#'   table, then the actual time between doses is given by the wait
#'   time.  If it is smaller than the last observed inter-dose
#'   interval, the time between event tables is given by the inter-dose
#'   interval + the waiting time between event tables.
#'
#' * `"+ii"` In this case, the wait time is added to the
#'    inter-dose interval no matter the length of the wait time or
#'    inter-dose interval
#'
#' @param ii If there was no inter-dose intervals found in the event
#'     table, assume that the interdose interval is given by this
#'     `ii` value.  By default this is `24`.
#'
#' @return An event table
#'
#' @details
#'
#' This `seq`uences all the event tables in added in the
#' argument list `...`.  By default when combining the event
#' tables the offset is at least by the last inter-dose interval in
#' the prior event table (or `ii`).  If you separate any of the
#' event tables by a number, the event tables will be separated at
#' least the wait time defined by that number or the last inter-dose
#' interval.
#'
#' @template etExamples
#'
#' @export
etSeq <- function(..., samples = c("clear", "use"), waitII = c("smart", "+ii"), ii = 24) {
  ## etSeq_(List ets, bool clearSampling=clearSampling);
  .sampleIx <- c(clear = 0L, use = 1L)
  .waitIx <- c(smart = 0L, `+ii` = 1L)
  .collectWarnings(.Call(
    `_rxode2et_etSeq_`, list(...), setNames(.sampleIx[match.arg(samples)], NULL),
    setNames(.waitIx[match.arg(waitII)], NULL), as.double(ii), FALSE, 0L,
    0L, TRUE, character(0), logical(0), FALSE
  ))
}
#' Combining event tables
#'
#' @inheritParams etSeq
#' @param id This is how rbind will handle IDs.  There are two different types of options:
#'
#' * `merge` with `id="merge"`, the IDs are merged together,
#' overlapping IDs would be merged into a single event table.
#'
#' * `unique` with `id="unique"`, the IDs will be renumbered
#' so that the IDs in all the event tables are not overlapping.
#'
#' @param
#' deparse.level The `deparse.level` of a traditional
#'     `rbind` is ignored.
#'
#' @author Matthew L Fidler
#'
#' @return An event table
#'
#' @template etExamples
#'
#' @export
etRbind <- function(..., samples = c("use", "clear"), waitII = c("smart", "+ii"),
                    id = c("merge", "unique")) {
  .sampleIx <- c(clear = 0L, use = 1L)
  .waitIx <- c(smart = 0L, `+ii` = 1L)
  .idIx <- c(merge = 0L, unique = 1L)
  .collectWarnings(.Call(
    `_rxode2et_etSeq_`, list(...), setNames(.sampleIx[match.arg(samples)], NULL),
    setNames(.waitIx[match.arg(waitII)], NULL), as.double(0), TRUE,
    setNames(.idIx[match.arg(id)], NULL),
    0L, TRUE, character(0), logical(0), FALSE
  ))
}

#' @rdname etRbind
#' @export
rbind.rxEt <- function(..., deparse.level = 1) {
  if (!missing(deparse.level)) warning("'deparse.level' not used with rxode2 event tables", call. = FALSE)
  do.call(etRbind, list(...))
}

#' @rdname etSeq
#' @export
seq.rxEt <- function(...) {
  do.call(etSeq, list(...))
}

#' @export
c.rxEt <- function(...) {
  do.call(etSeq, list(...))
}

#' Repeat an rxode2 event table
#'
#' @param x An rxode2 event table
#' @param times Number of times to repeat the event table
#' @param length.out Invalid with rxode2 event tables, will throw an
#'     error if used.
#' @param each Invalid with rxode2 event tables, will throw an error
#'     if used.
#' @param n The number of times to repeat the event table.  Overrides
#'     `times`.
#' @param wait Waiting time between each repeated event table.  By
#'     default there is no waiting, or wait=0
#' @inheritParams et
#' @inheritParams etSeq
#' @template etExamples
#' @return An event table
#' @export
etRep <- function(x, times = 1, length.out = NA, each = NA, n = NULL, wait = 0, id = integer(0),
                  samples = c("clear", "use"),
                  waitII = c("smart", "+ii"), ii = 24) {
  if (!is.null(n)) {
    times <- n
  }
  .sampleIx <- c(clear = 0L, use = 1L)
  .waitIx <- c(smart = 0L, `+ii` = 1L)
  if (!is.na(length.out)) stop("'length.out' makes no sense with event tables", call. = FALSE)
  if (!is.na(each)) stop("'each' makes no sense with event tables", call. = FALSE)
  .collectWarnings(.Call(
    `_rxode2et_etRep_`, x, as.integer(times),
    wait, as.integer(id), setNames(.sampleIx[match.arg(samples)], NULL),
    setNames(.waitIx[match.arg(waitII)], NULL), as.double(ii)
  ))
}

#' @rdname etRep
#' @export
rep.rxEt <- function(x, ...) {
  do.call(etRep, list(x = x, ...))
}
#' Coerce object to data.frame
#'
#' @param x Object to coerce to et.
#' @param ... Other parameters
#' @return An event table
#' @export
as.et <- function(x, ...) {
  UseMethod("as.et")
}
#' @rdname as.et
#' @export
as.et.default <- function(x, ...) {
  .e <- et()
  .e$import.EventTable(as.data.frame(x))
  return(.e)
}

#' @export
as.data.frame.rxEt <- function(x, row.names = NULL, optional = FALSE, ...) {
  if (.isRxEt(x)) {
    .x <- x
    .tmp <- .x[, .x$show, drop = FALSE]
    class(.tmp) <- c("rxEt2", "data.frame")
    return(as.data.frame(.tmp, row.names = NULL, optional = FALSE, ...))
  } else {
    return(as.data.frame(x, row.names = NULL, optional = FALSE, ...))
  }
}

.datatable.aware <- TRUE
#' Convert an event table to a data.table
#'
#' @inheritParams data.table::as.data.table
#'
#' @return data.table of event table
#'
#' @noRd
as.data.table.rxEt <- function(x, keep.rownames = FALSE, ...) {
  rxReq("data.table")
  return(data.table::as.data.table(as.data.frame.rxEt(x, ...), keep.rownames = keep.rownames, ...))
}

#' Convert to tbl
#'
#' @param x rxode2 event table
#'
#' @param ... Other arguments to `as_tibble`
#'
#' @return tibble of event table
#'
#' @noRd
as_tibble.rxEt <- function(x, ...) {
  rxReq("tibble")
  if (.isRxEt(x)) {
    .x <- x
    .show <- .x$show
    class(.x) <- "data.frame"
    .tmp <- .x[, .show, drop = FALSE]
    return(tibble::as_tibble(.tmp, ...))
  } else {
    return(tibble::as_tibble(x, ...))
  }
}

#' Check to see if this is an rxEt object.
#'
#' @param x object to check to see if it is rxEt
#'
#' If this is an rxEt object that has expired strip all rxEt
#' information.
#'
#' @return Boolean indicating if this is a rxode2 event table
#'
#' @author Matthew L.Fidler
#'
#' @export
#' @keywords internal
is.rxEt <- function(x) {
  .Call(`_rxode2et_rxIsEt2`, x)
}
#' Expand additional doses
#'
#' @param et Event table to expand additional doses for.
#' @return New event table with `addl` doses expanded
#' @author Matthew Fidler
#' @examples
#' ev <- et(amt = 3, ii = 24, until = 240)
#' print(ev)
#' etExpand(ev) # expands event table, but doesn't modify it
#'
#' print(ev)
#'
#' ev$expand() ## Expands the current event table and saves it in ev
#' @export
etExpand <- function(et) {
  .Call(`_rxode2et_et_`, list(expand = TRUE), et)
}

#' EVID formatting for tibble and other places.
#'
#' This is to make an EVID more readable by non
#' pharmacometricians. It displays what each means and allows it to
#' be displayed in a tibble.
#'
#' @param x Item to be converted to a rxode2 EVID specification.
#'
#' @param ... Other parameters
#'
#' @return rxEvid specification
#'
#' @examples
#'
#' rxEvid(1:7)
#' @export
rxEvid <- function(x) {
  return(structure(x, class = "rxEvid"))
}

#' @rdname rxEvid
#' @export
as.rxEvid <- rxEvid

#' @rdname rxEvid
#' @export
c.rxEvid <- function(x, ...) {
  return(as.rxEvid(NextMethod()))
}

#' @rdname rxEvid
#' @export
`[.rxEvid` <- function(x, ...) {
  return(as.rxEvid(NextMethod()))
}
.colorFmt.rxEvid <- function(x, ...) {
  .x <- unclass(x)
  .x <-
    ifelse(.x == 0, paste0(crayon::blue$bold("0"), ":", crayon::white("Observation")),
      ifelse(.x == 1, paste0(crayon::blue$bold("1"), ":", crayon::yellow("Dose (Add)")),
        ifelse(.x == 2, paste0(crayon::blue$bold("2"), ":", crayon::yellow("Other")),
          ifelse(.x == 3, paste0(crayon::blue$bold("3"), ":", crayon::red("Reset")),
            ifelse(.x == 4, paste0(crayon::blue$bold("4"), ":", crayon::red("Reset"), "&", crayon::yellow("Dose")),
              ifelse(.x == 5, paste0(crayon::blue$bold("5"), ":", crayon::red("Replace")),
                ifelse(.x == 6, paste0(crayon::blue$bold("6"), ":", crayon::yellow("Multiply")),
                  ifelse(.x == 7, paste0(crayon::blue$bold("7"), ":", crayon::yellow("Transit")),
                  paste0(crayon::blue$red(.x), ":", crayon::red("Invalid")))
                )
              )
            )
          )
        )
      )
    )
  return(format(.x, justify = "left"))
}

#' @rdname rxEvid
#' @export
as.character.rxEvid <- function(x, ...) {
  .x <- unclass(x)
  .x <-
    ifelse(.x == 0, "0:Observation",
      ifelse(.x == 1, "1:Dose (Add)",
        ifelse(.x == 2, "2:Other",
          ifelse(.x == 3, "3:Reset",
            ifelse(.x == 4, "4:Reset&Dose",
              ifelse(.x == 5, "5:Replace",
                ifelse(.x == 6, "6:Multiply",
                  ifelse(.x == 7, "7:Transit",
                         paste0(.x, ":Invalid"))
                )
              )
            )
          )
        )
      )
    )
  return(.x)
}



#' @rdname rxEvid
#' @export
`[[.rxEvid` <- function(x, ...) {
  as.rxEvid(NextMethod())
}

`units<-.rxEvid` <- function(x, value) {
  stop("'evid' is unitless", call. = FALSE)
}


#' @export
`[<-.rxEvid` <- function(x, i, value) {
  as.rxEvid(NextMethod())
}

# registered in .onLoad()
type_sum.rxEvid <- function(x) {
  "evid"
}

# registered in .onLoad()
pillar_shaft.rxEvid <- function(x, ...) {
  .x <- .colorFmt.rxEvid(x)
  pillar::new_pillar_shaft_simple(.x)
}

#' @export
as.data.frame.rxEvid <- base::as.data.frame.difftime

#' Creates a rxRateDur object
#'
#' This is primarily to display information about rate
#'
#' @param x rxRateDur data
#' @param ... Other parameters
#'
#' @return rxRateDur object
#'
#' @export
rxRateDur <- function(x) {
  return(structure(x, class = "rxRateDur"))
}

#' @rdname rxRateDur
#' @export
`[.rxRateDur` <- function(x, ...) {
  return(as.rxRateDur(NextMethod()))
}

#' @rdname rxRateDur
#' @export
as.rxRateDur <- rxRateDur
#' @rdname rxEvid
#' @export
c.rxRateDur <- function(x, ...) {
  return(as.rxRateDur(NextMethod()))
}

#' @rdname rxRateDur
#' @export
as.character.rxRateDur <- function(x, ...) {
  .x <- unclass(x)
  .x <-
    ifelse(.x == -1, "-1:rate",
      ifelse(.x == -2, "-2:dur",
        ifelse(.x < 0, paste0(as.character(.x), ":Invalid"),
          sprintf(" %-8g", .x)
        )
      )
    )
  return(.x)
}

.fmt <- function(x, width = 9) {
  .g <- sprintf(paste0(" %-", width - 1, "g"), unclass(x))
  .f <- sprintf(paste0(" %-", width - 1, "f"), unclass(x))
  .ncg <- nchar(.g)
  .ncf <- nchar(.f)
  .ret <- ifelse(.ncg == width, .g,
    ifelse(.ncf == width, .f, .g)
  )
  return(.ret)
}


.colorFmt.rxRateDur <- function(x, ...) {
  .x <- unclass(x)
  .x <-
    ifelse(.x == -1, paste0(crayon::red("-1"), ":", crayon::yellow("rate")),
      ifelse(.x == -2, paste0(crayon::red("-2"), ":", crayon::yellow("dur")),
        ifelse(.x < 0, paste0(crayon::red(as.character(.x)), ":", crayon::red("Invalid")),
          .fmt(.x)
        )
      )
    )
  return(.x)
}

#' @rdname rxRateDur
#' @export
`[[.rxRateDur` <- function(x, ...) {
  as.rxRateDur(NextMethod())
}

#' @export
`[<-.rxRateDur` <- function(x, i, value) {
  as.rxRateDur(NextMethod())
}

# registered in .onLoad()
type_sum.rxRateDur <- function(x) {
  .unit <- attr(x, "units")
  if (!is.null(.unit)) {
    .tmp <- x
    class(.tmp) <- "units"
    return(pillar::type_sum(.tmp))
  } else {
    return("rate/dur")
  }
}

# registered in .onLoad()
pillar_shaft.rxRateDur <- function(x, ...) {
  .x <- .colorFmt.rxRateDur(x)
  pillar::new_pillar_shaft_simple(.x, align = "left", width = 10)
}

#' @export
as.data.frame.rxRateDur <- base::as.data.frame.difftime

set_units.rxRateDur <- function(x, value, ..., mode = .setUnitsMode()) {
  if (is.null(mode)) {
    stop("requires package 'units'", call. = FALSE)
  }
  if (inherits(x, "units")) {
    .ret <- x
    .ret0 <- unclass(x)
    .w1 <- which(.ret0 == -1)
    .w2 <- which(.ret0 == -2)
    .lst <- as.list(match.call())[-1]
    class(.ret0) <- "units"
    .lst[[1]] <- .ret0
    .ret <- do.call(units::set_units, .lst)
    if (length(.w1) > 0) .ret[.w1] <- -1
    if (length(.w2) > 0) .ret[.w2] <- -2
    class(.ret) <- c("rxRateDur", "units")
    return(.ret)
  } else {
    .lst <- as.list(match.call())[-1]
    .lst[[1]] <- unclass(x)
    .ret <- do.call(units::set_units, .lst)
    class(.ret) <- c("rxRateDur", "units")
    return(.ret)
  }
}



.et_ <- function(x1, x2) {
  .Call(`_rxode2et_et_`, x1, x2)
}

.etUpdate <- function(x1, x2, x3, x4) {
  .Call(`_rxode2et_etUpdate`, x1, x2, x3, x4)
}

.etSeq <- function(x1, x2, x3, x4, x5,
                   x6, x7, x8, x9, x10,
                   x11) {
  .Call(`_rxode2et_etSeq_`,
        x1, x2, x3, x4, x5,
        x6, x7, x8, x9, x10,
        x11)
}

.etRep <- function(x1, x2, x3, x4, x5,
                   x6, x7) {
  .Call(`_rxode2et_etRep_`,
        x1, x2, x3, x4, x5,
        x6, x7)
}

.setEvCur <- function(x1) {
  .Call(`_rxode2et_setEvCur`, x1)
}


.cbindThetaOmega <- function(x1, x2) {
  .Call(`_rxode2et_cbindThetaOmega`, x1, x2)
}

.rxCbindStudyIndividual <- function(x1, x2) {
  .Call(`_rxode2et_rxCbindStudyIndividual`, x1, x2)
}

Try the rxode2et package in your browser

Any scripts or data that you put into this service are public.

rxode2et documentation built on June 22, 2024, 12:17 p.m.