R/get_prmNlme.R

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

#' Access NLME model parameter estimates
#'
#' @description Access model parameter estimates from an xpdb object generated by
#' xposeNlme.
#'
#' @param xpdb An \code{xpose} data base object from which the model output
#' file data will be extracted. Only objects generated by \code{xposeNlme} are supported.
#' @param .problem The problem to be used.
#' @param .subprob The subproblem to be used.
#' @param .method The estimation method to be used.
#' @param digits Integer specifying the number of significant digits to be displayed.
#' @param show_all Logical specifying whether the 0 off-diagonal omega elements
#' should be removed from the output or not.
#' @param level Numeric specifying confidence level to compute confidence intervals,
#' which are calculated based on Student’s t distribution.
#'
#' @return A tibble for single problem/subproblem.
#' @seealso \code{\link{xposeNlme}}
#' @importFrom magrittr %>%
#' @importFrom rlang :=
#' @examples
#' # Store the parameter table
#' prm <- get_prmNlme(xpdb_ex_Nlme)
#'
#' # Set the desired number of significant digits to display results
#'
#' # Note: To have results displayed in the number of significant digits
#' #  specified in the digits argument, one needs to make sure that
#' #  the value of pillar.sigfig option (default value is 3) is greater
#' #  than or equal to this specified value.
#'
#' options(pillar.sigfig = 6)
#' get_prmNlme(xpdb_ex_Nlme, digits = 4)
#'
#' @export
get_prmNlme <- function(xpdb,
                        .problem = 1,
                        .subprob = 0,
                        .method = NULL,
                        digits = 6,
                        show_all = FALSE,
                        level = 0.95) {
  stopifnot(xpose::is.xpdb(xpdb))
  prmNlme <- xpdb$files %>%
    dplyr::filter(name == "prmTable" &
                    problem == get(".problem") &
                    subprob == get(".subprob"))

  if (!is.null(.method)) {
    prmNlme <-
      dplyr::filter(prmNlme, problem == get(".method"))
  }

  if (nrow(prmNlme) == 0) {
    stop("Data frame with given properties is not found in the database.")
  } else if (nrow(prmNlme) > 1) {
    warning("More than one data frame is found with given condition;
            using the last one.")
    prmNlme <- prmNlme[nrow(prmNlme),]
  }

  prmtibble <- prmNlme$data[[1]]

  if (!show_all) {
    prmtibble <- dplyr::filter(prmtibble,
                               (type != "ome") |
                                 (diagonal == TRUE) |
                                 (value != 0))
  }

  if (length(level) > 0) {
    overallDF <-
      get_overallNlme(xpdb,
                      .problem  = .problem,
                      .subprob  = .subprob,
                      .method   = .method)
    if (nrow(overallDF) == 0) {
      stop("cannot find overall data frame bound for the current problem.")
    }
    degOfFreedom <- overallDF$nObs - overallDF$nParm
    if (degOfFreedom < 1) {
      depOfFreedom <- 1
    }

    CI <- 0.5 * (1 + c(-1, 1) * level)
    CINames <- c()
    for (interval in CI) {
      tValue <- stats::qt(interval, degOfFreedom)
      CIName <- paste0(signif(interval * 100, 5), "% CI")
      CINames <- c(CINames, CIName)
      prmtibble <-
        dplyr::mutate(prmtibble,!!CIName := signif(value + tValue * se, digits))
    }
  }

  prmtibble <-
    dplyr::mutate(prmtibble,
                  dplyr::across(c(value, se, rse), ~ signif(.x, digits)))

  drops <-
    c("type",
      "name",
      "label",
      "value",
      "se",
      "rse",
      "fixed",
      "diagonal",
      "m",
      "n",
      CINames)
  prmtibble[, names(prmtibble) %in% drops, drop = FALSE]
}