R/update_etaShrinkageNlme.R

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

#' @title Update ETA shrinkage with subject-level filtering
#'
#' @description Recomputes overall ETA shrinkage from stored subject-by-ETA
#'   data, applying threshold-based filtering to remove subjects whose
#'   individual shrinkage is too close to 1 (variance form). Returns an
#'   updated \code{xpdb} with the \code{etashk} summary row replaced.
#'
#' @param xpdb An \code{xpose_data} object created by
#'   \code{\link{xposeNlme}} or \code{\link{xposeNlmeModel}}.
#' @param threshold Global default threshold applied to all ETAs
#'   (default \code{1e-6}). A subject/ETA row is removed when its
#'   variance-form shrinkage \eqn{\ge (1 - \text{threshold})^2}.
#' @param eta_threshold Optional named numeric vector overriding
#'   \code{threshold} for specific ETAs, e.g.
#'   \code{c(nV = 1e-6, nCl = 0.05)}.
#' @param eta_name Optional character vector selecting a subset of ETAs
#'   to recompute. ETAs not listed keep their current summary values.
#' @param .problem Problem number (default \code{1}).
#'
#' @return A new \code{xpdb} with the \code{etashk} value in
#'   \code{xpdb$summary} updated.
#'
#' @export
update_etaShrinkageNlme <- function(xpdb,
                                    threshold = 1e-6,
                                    eta_threshold = NULL,
                                    eta_name = NULL,
                                    .problem = 1) {
  stopifnot(inherits(xpdb, "xpose_data"))

  eta_subject <- get_etaSubjectNlme(xpdb, .problem = .problem)
  omega_diag <- .get_omegaDiagNlme(xpdb, .problem = .problem)

  result <- .compute_etaShrinkageNlme(
    eta_subject = eta_subject,
    omega_diag = omega_diag,
    threshold = threshold,
    eta_threshold = eta_threshold,
    eta_name = eta_name
  )

  current_etashk <- xpdb$summary$value[
    xpdb$summary$problem == .problem & xpdb$summary$label == "etashk"
  ]
  if (length(current_etashk) == 0) current_etashk <- NA_character_

  new_etashk <- .format_etaShrinkage_summary(result, current_etashk)

  idx <- which(xpdb$summary$problem == .problem &
                 xpdb$summary$label == "etashk")
  if (length(idx) > 0) {
    xpdb$summary$value[idx] <- new_etashk
  }

  xpdb
}