R/parse_engine_metadata.R

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

# `nlme7engine.log` is the engine's own record of what
# actually ran, so it is the only source consulted here.

# Extract the last complete "Other flags and run conditions/tolerances:" ...
# "Initial parameter values:" header block from `nlme7engine.log`. The
# engine opens the log in append mode, so a rerun in the same directory can
# leave more than one such block; only the final one reflects the run that
# produced the `dmp.txt`/`residuals`/`posthoc` this `xp` is built from.
# Returns `character(0)` (never an error) when no complete section exists.
# The caller only falls back to a whole-log scan when both markers are absent,
# which preserves compatibility with older logs without these sections while
# preventing a trailing partial section from overriding a preceding run.
.last_engineLogBlock <- function(nlme7engineLines) {
  bounds <- .last_engineLogBlockBounds(nlme7engineLines)
  if (is.na(bounds$start)) return(character(0))
  nlme7engineLines[bounds$start:bounds$end]
}

# 1-based start/end indices of the last complete header block, or
# `NA_integer_` for both when no complete section exists. Shared by
# `.last_engineLogBlock()` and AutoSE prose scanning (which resumes after
# `end`).
.last_engineLogBlockBounds <- function(nlme7engineLines) {
  empty <- list(start = NA_integer_, end = NA_integer_)
  if (!length(nlme7engineLines)) return(empty)

  startIdx <- grep("Other flags and run conditions/tolerances:",
                   nlme7engineLines, fixed = TRUE)
  endIdx <- grep("Initial parameter values:",
                 nlme7engineLines, fixed = TRUE)
  if (!length(startIdx) || !length(endIdx)) return(empty)

  sectionEnd <- vapply(seq_along(startIdx), function(i) {
    nextStart <- if (i == length(startIdx)) {
      length(nlme7engineLines) + 1L
    } else {
      startIdx[i + 1L]
    }
    candidateEnd <- endIdx[
      endIdx > startIdx[i] & endIdx < nextStart
    ]
    if (length(candidateEnd)) candidateEnd[1L] else NA_integer_
  }, integer(1))
  complete <- which(!is.na(sectionEnd))
  if (!length(complete)) return(empty)

  lastComplete <- complete[length(complete)]
  list(start = startIdx[lastComplete], end = sectionEnd[lastComplete])
}

# Extract an integer flag value from `<value>  <FLAGNAME>` lines, e.g.
# "         5  IDENGINE" or "           1  iflagstderr". `flagNames` are
# tried in order so a caller can prefer the fixed-width header spelling
# (e.g. "IFLAGSTDERR") and fall back to the free-format lowercase spelling
# used later in the same block (e.g. "iflagstderr") when the two disagree
# only in casing/position. When a flag name appears more than once (whole-
# log fallback for logs without section markers, or an appended rerun), the
# *last* match wins so a stale earlier run never overrides the current one.
# Returns `NA_integer_` when nothing matches or the captured token isn't
# numeric -- never an error.
.extract_engineLogInt <- function(lines, flagNames) {
  for (flagName in flagNames) {
    pattern <- paste0(
      "^\\s*(-?[0-9]*\\.?[0-9]+(?:[EeDd][+-]?[0-9]+)?)\\s+",
      flagName, "\\b"
    )
    hit <- grep(pattern, lines, perl = TRUE, value = TRUE)
    if (!length(hit)) next
    captured <- regmatches(hit[length(hit)],
                           regexec(pattern, hit[length(hit)], perl = TRUE))[[1]]
    if (length(captured) < 2) next
    val <- suppressWarnings(as.numeric(captured[2]))
    if (!is.na(val)) return(as.integer(round(val)))
  }
  NA_integer_
}

# Parse execution flags from `nlme7engine.log`. Returns a plain named
# `list()` containing only the flags that were actually found -- missing or
# unparsable flags are simply absent (never `NA`), so callers can drive
# presence checks with `flags[["x"]]` / `is.null()` without an extra
# `na.omit()` step.
#
# Recognised flags: `IDENGINE` (estimation method), `IFLAGFOCEHESS` (FOCE
# Hessian variant; also discriminates FOCE-ELS from LAPLACIAN when
# `IDENGINE == 5`), `NORDERAGQ` (adaptive Gaussian quadrature order),
# `IFLAGSTDERR` (finite-difference standard-error scheme), `iodelevelused`
# (ODE solver actually used), `IFLAGWHICHSTDERR` (standard-error
# *algorithm* -- Hessian/Sandwich/Fisher/Auto-detect; only used by
# `.resolve_stderr_algorithm()`, never mapped onto the `stderr_method`
# finite-difference row), and `IFLAGANAGRAD`/`IFLAGPOPAD` (inner-/outer-loop
# automatic differentiation, only ever written by the engine for
# `IDENGINE == 5`).
.parse_engine_log_metadata <- function(nlme7engineLines) {
  block <- .last_engineLogBlock(nlme7engineLines)
  hasSectionMarkers <- any(
    grepl("Other flags and run conditions/tolerances:|Initial parameter values:",
          nlme7engineLines, fixed = FALSE)
  )
  if (!length(block) && !hasSectionMarkers) block <- nlme7engineLines

  out <- list()
  add <- function(name, flagNames) {
    val <- .extract_engineLogInt(block, flagNames)
    if (!is.na(val)) out[[name]] <<- val
  }

  add("IDENGINE", "IDENGINE")
  add("IFLAGFOCEHESS", "IFLAGFOCEHESS")
  add("NORDERAGQ", "NORDERAGQ")
  add("IFLAGSTDERR", c("IFLAGSTDERR", "iflagstderr"))
  add("iodelevelused", "iodelevelused")
  add("IFLAGWHICHSTDERR", "iflagwhichstderr")
  add("IFLAGANAGRAD", "iflaganagrad")
  add("IFLAGPOPAD", "iflagpopad")

  out
}

# Last-occurrence scan for the engine's own Auto-Detect SE resolution prose
# (`stderr.f90::SelectApprTypeStdErr`), written well after the "Initial
# parameter values:" header block (during the covariance/stderr step).
# Restricts the search to lines *after* the last complete header block so
# an earlier AutoSE run's prose never contaminates a later AutoSE rerun
# that never reached (or rewrote) the stderr step. Returns `NA_character_`
# (never an error) when no such line exists -- e.g. non-Auto-Detect runs,
# or SE off entirely.
.stderr_algorithm_from_log <- function(nlme7engineLines) {
  if (!length(nlme7engineLines)) return(NA_character_)

  bounds <- .last_engineLogBlockBounds(nlme7engineLines)
  searchFrom <- if (!is.na(bounds$end)) bounds$end + 1L else 1L
  searchLines <- if (searchFrom <= length(nlme7engineLines)) {
    nlme7engineLines[searchFrom:length(nlme7engineLines)]
  } else {
    character(0)
  }

  proseMap <- c(
    "Auto-detect: Hessian is chosen" = "Hessian",
    "Auto-detect: Sandwich is chosen since both Score and Hessian succeeded" = "Sandwich",
    "Auto-detect: Fisher Score is selected" = "Fisher Score",
    # Both failed: the engine still falls back to sandwich internally
    # (`stderr.f90`: `iflagwhichstderr = 1` after this message).
    "Auto-detect: Both Score and Hessian failed" = "Sandwich"
  )

  bestIdx <- 0L
  bestVal <- NA_character_
  for (pat in names(proseMap)) {
    hitIdx <- grep(pat, searchLines, fixed = TRUE)
    if (length(hitIdx) && hitIdx[length(hitIdx)] > bestIdx) {
      bestIdx <- hitIdx[length(hitIdx)]
      bestVal <- proseMap[[pat]]
    }
  }
  bestVal
}

# Resolve the standard-error *algorithm* (Hessian/Sandwich/Fisher Score/
# Auto-Detect/None) actually applied, in "actual wins" order:
#
#   1. Log `IFLAGWHICHSTDERR` when it's an explicit non-Auto value (0/1/2).
#      Explicit runs must win over Auto-Detect prose from an *earlier*
#      append in the same log (the prose lives outside the header block,
#      so a last-occurrence prose scan alone would otherwise leak).
#   2. Log Auto-Detect prose (the resolved method the engine picked at
#      runtime -- only present when Auto-Detect was requested). Used when
#      the current block has `iflagwhichstderr == 3` or the flag is absent.
#   3. `params@sand`/`@fisher`/`@autodetect`/`@xstderr`
#      (`.stderr_algorithm_from_params()`) -- the *requested* setting, used
#      only when the log has nothing to say (e.g. no `nlme7engine.log`, or
#      an Auto-Detect run that never reached the stderr step).
#   4. Log `IFLAGSTDERR == 0` (SE explicitly off) -> `"None"`.
#
# Returns `NA_character_` when none of the above resolves (e.g. no log and
# no params).
.resolve_stderr_algorithm <- function(nlme7engineLines, flags, params) {
  whichSE <- flags[["IFLAGWHICHSTDERR"]]
  if (!is.null(whichSE) && whichSE %in% 0:2) {
    return(c("Hessian", "Sandwich", "Fisher Score")[whichSE + 1L])
  }

  fromLog <- .stderr_algorithm_from_log(nlme7engineLines)
  if (!is.na(fromLog)) return(fromLog)

  if (!is.null(params) && isS4(params)) {
    fromParams <- .stderr_algorithm_from_params(params)
    if (!is.na(fromParams)) return(fromParams)
  }

  fdCode <- flags[["IFLAGSTDERR"]]
  if (!is.null(fdCode) && fdCode == 0L) return("None")

  NA_character_
}