R/npde.R

In nlmixr2est: Nonlinear Mixed Effects Models in Population PK/PD, Estimation Routines

#' NPDE calculation for nlmixr2
#'
#' @param object nlmixr2 fit object
#' @param updateObject Boolean indicating if original object should be updated.  By default this is TRUE.
#' @param table `tableControl()` list of options
#' @inheritParams foceiControl
#' @inheritParams addCwres
#' @param ... Other ignored parameters.
#'
#'
#' @return New nlmixr2 fit object
#' @author Matthew L. Fidler
#' @examples
#'
#' \donttest{
#'
#' one.cmt <- function() {
#'   ini({
#'     ## You may label each parameter with a comment
#'     tka <- 0.45 # Log Ka
#'     tcl <- log(c(0, 2.7, 100)) # Log Cl
#'     ## This works with interactive models
#'     ## You may also label the preceding line with label("label text")
#'     tv <- 3.45; label("log V")
#'     ## the label("Label name") works with all models
#'     eta.ka ~ 0.6
#'     eta.cl ~ 0.3
#'     eta.v ~ 0.1
#'     add.sd <- 0.7
#'   })
#'   model({
#'     ka <- exp(tka + eta.ka)
#'     cl <- exp(tcl + eta.cl)
#'     v <- exp(tv + eta.v)
#'     linCmt() ~ add(add.sd)
#'   })
#' }
#'
#' f <- nlmixr2(one.cmt, theo_sd, "saem")
#'
#' # even though you may have forgotten to add the NPDE, you can add it to the data.frame:
#'
#' f <- addNpde(f)
#'
#' }
#' @export
addNpde <- function(object, updateObject = TRUE, table = tableControl(), ..., envir = parent.frame(1)) {
  nlmixr2global$finalUiCompressed <- FALSE
  on.exit(nlmixr2global$finalUiCompressed <- TRUE)
  assertNlmixrFitData(object)
  if (any(names(object) == "NPDE")) {
    warning("already contains NPDE", call. = FALSE)
    return(object)
  }
  checkmate::assertLogical(updateObject, len = 1, any.missing = FALSE)
  nlmixrWithTiming(
    "NPDE",
    {
      .objName <- as.character(substitute(object))
      if (missing(table)) {
        table <- object$table
      }
      .malert("Add NPDE")
      if (missing(table)) {
        table <- object$table
      }
      table$npde <- TRUE
      .fitEnv <- object$env
      .npde <- .calcNpde(object, dv = object$DV, table = table)
      .fit <- nlmixrClone(object)
      .new <- nlmixrCbind(.fit, .npde[[2]])
      if (updateObject) {
        nlmixrUpdateObject(.new, .objName, envir, .fitEnv)
      }
      .msuccess("done")
      .new
    },
    object$env
  )
}