R/iterPrintControl.R

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

#' Iteration-print configuration parameters (documentation stub)
#'
#' Shared `@param` docs for iteration-print formatting, used by both the
#' scalar `*Control()` arguments and [iterPrintControl()] via `@inheritParams`.
#'
#' @param print Either a scalar print-frequency (`0` = suppress, `1`
#'   (default) = every evaluation, `N` = every Nth), OR a pre-built
#'   [iterPrintControl()] object. Equivalent to
#'   `iterPrintControl(every = print, ncol = printNcol, useColor = useColor)`.
#' @param printNcol Integer (or `NULL`) parameter columns per row before
#'   wrapping. `NULL` (default) uses `floor((getOption("width") - 23) / 12)`.
#' @param every Integer. Print one iteration row every `every` parameter
#'   evaluations; `0` suppresses output. Defaults to `1L`.
#' @param ncol Integer or `NULL`. Parameter columns per row before wrapping.
#'   `NULL` (default) uses `floor((getOption("width") - 23) / 12)`.
#' @param headerEvery Integer or `NULL`. Re-emit the column header every
#'   `headerEvery` parameter-print events; `0` prints it once at fit start.
#'   `NULL` (default) uses `10L`.
#' @param useColor Logical (or `NULL`) emit ANSI bold/color escapes in the
#'   iteration print. `NULL` (default) defers to [crayon::has_color()].
#' @param simple Logical. When `TRUE`, print a single row per iteration,
#'   suppressing the unscaled (`U`) / back-transformed (`X`) rows. Defaults
#'   to `FALSE`.
#' @return Nothing; this is a documentation-only helper.
#' @keywords internal
#' @name iterPrintParams
NULL

#' Control iteration-time print formatting
#'
#' Bundles the options controlling the iteration progress output emitted by
#' `nlmixr2` estimators. Pass as the `print` argument to any `*Control()`
#' function; the scalar form (`print = N`) still works and is wrapped into
#' an `iterPrintControl()` internally.
#'
#' @inheritParams iterPrintParams
#' @return A list with the validated, defaulted iteration-print
#'   options.  Has class `"iterPrintControl"` so the outer `*Control()`
#'   functions can distinguish a pre-built object from a scalar
#'   `print = N`.
#' @author Bill Denney, Matthew L. Fidler
#' @export
#' @examples
#' iterPrintControl()
#' iterPrintControl(every = 5, headerEvery = 0)
iterPrintControl <- function(every = 1L,
                             ncol = NULL,
                             headerEvery = NULL,
                             useColor = NULL,
                             simple = FALSE) {
  if (is.null(ncol))        ncol        <- floor((getOption("width") - 23) / 12)
  if (is.null(headerEvery)) headerEvery <- 10L
  if (is.null(useColor))    useColor    <- crayon::has_color()
  checkmate::assertIntegerish(every,       len = 1, lower = 0, any.missing = FALSE)
  checkmate::assertIntegerish(ncol,        len = 1, lower = 1, any.missing = FALSE)
  checkmate::assertIntegerish(headerEvery, len = 1, lower = 0, any.missing = FALSE)
  checkmate::assertLogical(useColor,       len = 1, any.missing = FALSE)
  checkmate::assertLogical(simple,         len = 1, any.missing = FALSE)
  .ret <- list(
    every       = as.integer(every),
    ncol        = as.integer(ncol),
    headerEvery = as.integer(headerEvery),
    useColor    = as.logical(useColor),
    simple      = as.logical(simple)
  )
  class(.ret) <- c("iterPrintControl", "list")
  .ret
}

#' Derive every iteration-print transform vector from a ui object
#'
#' Pure inspection helper: walks `ui$muRefCurEval` against `ui$iniDf` and
#' emits the transform vectors needed by an estimator's iteration printer
#' or C-side setup (per-printed-param `xPar`/`probitIdx`/bounds, and
#' ntheta-indexed `log`/`logit`/`probit` theta vectors with matching
#' bounds). Names in `printNames` not present in `ui$muRefCurEval` (e.g.
#' saem's `V(eta.*)` or residual-error names) get `xPar = 0`/`probitIdx = 0`.
#'
#' @param ui rxode2 ui object.
#' @param printNames Character vector of parameter names in the same
#'   order as the printed parameter vector.  When `NULL` (default)
#'   uses all thetas (fixed + unfixed) in `ntheta` order.
#' @return Named list of integer / numeric vectors, see source.
#' @noRd
.iterPrintXParFromUi <- function(ui, printNames = NULL) {
  iniThetas <- ui$iniDf[!is.na(ui$iniDf$ntheta), c("ntheta", "name")]
  iniThetas <- iniThetas[order(iniThetas$ntheta), ]
  if (is.null(printNames)) printNames <- iniThetas$name
  printNames <- as.character(printNames)
  muRef <- ui$muRefCurEval
  xPar <- integer(length(printNames))
  probitIdx <- integer(length(printNames))
  logitThetaLow <- numeric(0)
  logitThetaHi <- numeric(0)
  probitThetaLow <- numeric(0)
  probitThetaHi <- numeric(0)
  empty <- function() list(
    xPar             = xPar,
    probitIdx        = probitIdx,
    logitThetaLow    = logitThetaLow,
    logitThetaHi     = logitThetaHi,
    probitThetaLow   = probitThetaLow,
    probitThetaHi    = probitThetaHi,
    logNthetas       = integer(0),
    logitNthetas     = integer(0),
    logitNthetasLow  = numeric(0),
    logitNthetasHi   = numeric(0),
    probitNthetas    = integer(0),
    probitNthetasLow = numeric(0),
    probitNthetasHi  = numeric(0)
  )
  if (is.null(muRef) || nrow(muRef) == 0L) return(empty())
  if (!is.null(ui$boundedTransforms)) {
    for (.tr in ui$boundedTransforms) {
      .w <- which(muRef$parameter == .tr$internalName)
      if (length(.w) > 0L) {
        muRef$low[.w] <- .tr$lower
        muRef$hi[.w] <- .tr$upper
      }
    }
  }
  # Per-printed-name xPar / probitIdx / bounds, in printNames order.
  for (i in seq_along(printNames)) {
    nm <- printNames[i]
    idx <- which(muRef$parameter == nm)
    if (length(idx) == 0L) next
    idx <- idx[1L]
    ce <- muRef$curEval[idx]
    if (isTRUE(ce == "exp")) {
      xPar[i] <- 1L
    } else if (isTRUE(ce == "expit")) {
      logitThetaLow <- c(logitThetaLow, muRef$low[idx])
      logitThetaHi  <- c(logitThetaHi,  muRef$hi[idx])
      xPar[i] <- -as.integer(length(logitThetaLow))
    } else if (isTRUE(ce == "probitInv")) {
      probitThetaLow <- c(probitThetaLow, muRef$low[idx])
      probitThetaHi  <- c(probitThetaHi,  muRef$hi[idx])
      probitIdx[i] <- as.integer(length(probitThetaLow))
    }
  }
  # ntheta-indexed views over the unfixed-theta order.  These are
  # always emitted regardless of `printNames` because
  # .postEstimationBoundedTransform consumes them on the env under
  # logThetasF/logitThetasF/probitThetasF names.
  tr <- merge(iniThetas, muRef, by.x = "name", by.y = "parameter")
  tr <- tr[order(tr$ntheta), ]
  list(
    xPar             = xPar,
    probitIdx        = probitIdx,
    logitThetaLow    = logitThetaLow,
    logitThetaHi     = logitThetaHi,
    probitThetaLow   = probitThetaLow,
    probitThetaHi    = probitThetaHi,
    logNthetas       = as.integer(tr[which(tr$curEval == "exp"),       "ntheta"]),
    logitNthetas     = as.integer(tr[which(tr$curEval == "expit"),     "ntheta"]),
    logitNthetasLow  = as.double( tr[which(tr$curEval == "expit"),     "low"]),
    logitNthetasHi   = as.double( tr[which(tr$curEval == "expit"),     "hi"]),
    probitNthetas    = as.integer(tr[which(tr$curEval == "probitInv"), "ntheta"]),
    probitNthetasLow = as.double( tr[which(tr$curEval == "probitInv"), "low"]),
    probitNthetasHi  = as.double( tr[which(tr$curEval == "probitInv"), "hi"])
  )
}

#' Wrap scalar or list arguments into an iterPrintControl object
#'
#' Absorbs the scalar `print`/`printNcol`/`useColor` arguments into a single
#' [iterPrintControl()] object, or passes through an already pre-built one.
#'
#' @param print Either an integer print-frequency or an
#'   `iterPrintControl` object.
#' @param printNcol,useColor Scalar `*Control()` arguments forwarded
#'   to [iterPrintControl()] only when `print` is a scalar.
#' @param iterPrintControl Optional pre-built [iterPrintControl()] object.
#'   Wins over `print` and the other scalars when supplied.
#' @return An `iterPrintControl` list.
#' @keywords internal
#' @export
.absorbIterPrintControl <- function(print = 1L,
                                    printNcol = NULL,
                                    useColor = NULL,
                                    iterPrintControl = NULL) {
  if (!is.null(iterPrintControl)) {
    if (!inherits(iterPrintControl, "iterPrintControl")) {
      stop("`iterPrintControl` must be the result of iterPrintControl()",
           call. = FALSE)
    }
    return(iterPrintControl)
  }
  if (inherits(print, "iterPrintControl")) {
    .conflicts <- character(0)
    if (!is.null(printNcol)) .conflicts <- c(.conflicts, "printNcol")
    if (!is.null(useColor))  .conflicts <- c(.conflicts, "useColor")
    if (length(.conflicts)) {
      warning("ignoring `", paste(.conflicts, collapse = "`, `"),
              "` because `print` was passed as an iterPrintControl object",
              call. = FALSE)
    }
    return(print)
  }
  iterPrintControl(every = print, ncol = printNcol, useColor = useColor)
}