R/get_method.R

In Certara.Xpose.NLME: Enhances 'xpose' Diagnostics for Pharmacometric Models from 'Certara.RsNLME' and Phoenix NLME

get_method <- function(nlme7engineLines, params = NULL) {
  if (!is.null(params) && isS4(params) &&
      !is.null(tryCatch(params@method, error = function(e) NULL))) {
    return(.method_from_params(params))
  }

  flags <- .parse_engine_log_metadata(nlme7engineLines)
  idengine <- flags[["IDENGINE"]]
  if (is.null(idengine)) return("na")

  xfocehess <- flags[["IFLAGFOCEHESS"]]
  .method_label(idengine, if (is.null(xfocehess)) NA_integer_ else xfocehess)
}

# Method-code -> label mapping shared by the `params`-driven path
# (`.method_from_params()`) and the log-driven path (`get_method()`), so the
# two can never disagree on the same underlying flags. For method == 5
# (`IDENGINE`), `xfocehess`/`IFLAGFOCEHESS` discriminates FOCE-ELS (1, or
# absent -- older logs/params predate the flag) from LAPLACIAN (0).
.method_label <- function(idengine, xfocehess = NA_integer_) {
  if (is.na(idengine)) return("na")
  if (idengine == 5L) {
    if (!is.na(xfocehess) && xfocehess == 0L) return("LAPLACIAN")
    return("FOCE-ELS")
  }
  switch(as.character(idengine),
         "1" = "QRPEM",
         "2" = "IT2S-EM",
         "3" = "FOCE-LB",
         "4" = "FO",
         "6" = "NAIVE-POOLED",
         "na")
}

# Authoritative method label derived from the resolved engine params.
.method_from_params <- function(params) {
  m <- tryCatch(as.integer(params@method), error = function(e) NA_integer_)
  xfh <- tryCatch(as.integer(params@xfocehess), error = function(e) NA_integer_)
  .method_label(m, xfh)
}

# Human-readable ODE solver label for a numeric solver code. Codes 1-7
# match `params@odeToUse`; the log-only extras (0 = no solver invoked,
# 8 = Higham variant, 11-17 = C++ engine builds of 1-7) are only ever seen
# via `nlme7engine.log`'s `iodelevelused` line, never via `params`.
#
# Code 3/13 is DVERK (`writeinitialsol.f90`: "3=DVERK non-stiff"), not
# Runge-Kutta -- DVERK is a Runge-Kutta-Verner variant but the engine's own
# label is DVERK, so that is what's surfaced here. The "...Jacobian" suffix
# on the LSODE/LSODA codes mirrors `print(params)`'s "LSODE with numerical
# Jacobian" wording (see `Certara.RsNLME::engine_params.r`).
.ode_solver_label <- function(code) {
  if (is.null(code) || is.na(code)) return(NA_character_)
  switch(as.character(code),
         "0"  = "None",
         "1"  = "LSODE-numeric Jacobian",
         "2"  = "LSODE-analytic Jacobian",
         "3"  = "DVERK",
         "4"  = "LSODA-numeric Jacobian",
         "5"  = "LSODA-analytic Jacobian",
         "6"  = "Matrix-Exponent",
         "7"  = "DOPRI5",
         "8"  = "Higham-Matrix-Exponent",
         "11" = "LSODE-numeric Jacobian (C++)",
         "12" = "LSODE-analytic Jacobian (C++)",
         "13" = "DVERK (C++)",
         "14" = "LSODA-numeric Jacobian (C++)",
         "15" = "LSODA-analytic Jacobian (C++)",
         "16" = "Matrix-Exponent (C++)",
         "17" = "DOPRI5 (C++)",
         NA_character_)
}

# Human-readable finite-difference scheme label for `params@xstderr` / the
# engine log's `IFLAGSTDERR`/`iflagstderr` flag. This is the finite-
# difference scheme used while computing the objective gradient/Hessian for
# standard errors -- distinct from the SE *algorithm* (Hessian/Sandwich/
# Fisher/Auto), which is surfaced separately by `stderr_algorithm`
# (`.resolve_stderr_algorithm()` in `R/parse_engine_metadata.R`). Wording
# matches `print(params)`'s "Central Difference"/"Forward Difference".
.stderr_method_label <- function(code) {
  if (is.null(code) || is.na(code)) return(NA_character_)
  switch(as.character(code),
         "0" = "None",
         "1" = "Central Difference",
         "2" = "Forward Difference",
         NA_character_)
}

# Standard-error *algorithm* (Hessian/Sandwich/Fisher Score/Auto-Detect/
# None) implied by the resolved engine params, mirroring the `stdErr`
# derivation in `print.NlmeEngineExtraParams()`
# (`Certara.RsNLME::engine_params.r`): the `@sand`/`@fisher`/`@autodetect`
# flag strings take precedence over `@xstderr`, since RsNLME sets exactly
# one of them (or none, for Hessian) alongside `@xstderr`. Used only as the
# fallback tier of `.resolve_stderr_algorithm()` -- the log's own Auto-
# Detect prose / `iflagwhichstderr` flag are the actual outcome and take
# priority whenever present.
.stderr_algorithm_from_params <- function(params) {
  sand <- tryCatch(params@sand, error = function(e) "")
  fisher <- tryCatch(params@fisher, error = function(e) "")
  autodetect <- tryCatch(params@autodetect, error = function(e) "")
  xstderr <- tryCatch(as.integer(params@xstderr), error = function(e) NA_integer_)

  if (is.character(sand) && nzchar(trimws(sand))) return("Sandwich")
  if (is.character(fisher) && nzchar(trimws(fisher))) return("Fisher Score")
  if (is.character(autodetect) && nzchar(trimws(autodetect))) return("Auto-Detect")
  if (!is.na(xstderr) && xstderr == 0L) return("None")
  if (!is.na(xstderr)) return("Hessian")
  NA_character_
}