R/methods.R

In MultiFrailty: Shared Frailty Regression Models with Inverse Gaussian, Generalized Lindley, and Gamma Frailty Distributions

#' S3 Methods for MultiFrailty Fit Objects
#'
#' Provides standard \code{print}, \code{summary}, \code{coef}, \code{vcov},
#' \code{logLik}, \code{AIC}, \code{BIC}, and \code{confint} S3 methods for objects
#' of class \code{"multifrailty_fit"}.
#'
#' @param x An object of class \code{"multifrailty_fit"}.
#' @param object An object of class \code{"multifrailty_fit"}.
#' @param parm Optional parameter vector or names.
#' @param level Confidence level for interval. Default 0.95.
#' @param ... Additional arguments.
#'
#' @return Formatted console output or numeric objects depending on method.
#'
#' @references
#' Pandey, A., Hanagal, D. D., & Tyagi, S. (2022). Shared Frailty Models Based on Cancer Data. International Journal of Statistics and Reliability Engineering, 9(3), 461-474.
#'
#' Pandey, A., & Tyagi, S. (2021). Comparison of Multiplicative Frailty Models Under Weibull Baseline Distribution. Lobachevskii Journal of Mathematics, 42(13), 3184-3195.
#'
#' @export
print.multifrailty_fit <- function(x, ...) {
  cat("\n=========================================================\n")
  cat(" MultiFrailty Regression Model Fit (MLE)\n")
  cat("=========================================================\n")
  cat("Baseline Hazard :", x$baseline, "\n")
  cat("Frailty Family  :", x$frailty, "\n")
  cat("Sample Size (n) :", x$n, "\n")
  cat("Log-Likelihood  :", format(x$logLik, digits = 5), "\n")
  cat("AIC / BIC       :", format(x$AIC, digits = 5), "/", format(x$BIC, digits = 5), "\n")
  cat("Frailty Var (SE):", format(x$frailty_var, digits = 4), "(", format(x$frailty_var_se, digits = 4), ")\n")
  cat("Optimizer       :", ifelse(x$converged, "Converged", "Failed to Converge"), "\n")
  cat("---------------------------------------------------------\n")
  cat("Parameter Estimates (Natural Scale):\n")
  df_print <- x$coefficients
  num_cols <- intersect(c("Estimate", "StdErr", "z_stat", "p_value"), colnames(df_print))
  df_print[num_cols] <- lapply(df_print[num_cols], function(v) round(v, 4))
  print(df_print)
  cat("=========================================================\n\n")
  invisible(x)
}

#' @rdname print.multifrailty_fit
#' @export
summary.multifrailty_fit <- function(object, ...) {
  res <- list(
    fit = object,
    coefficients = object$coefficients,
    logLik = object$logLik,
    AIC = object$AIC,
    BIC = object$BIC,
    AICc = object$AICc,
    HQIC = object$HQIC,
    frailty_var = object$frailty_var,
    frailty_var_se = object$frailty_var_se,
    converged = object$converged
  )
  class(res) <- "summary.multifrailty_fit"
  res
}

#' @rdname print.multifrailty_fit
#' @export
print.summary.multifrailty_fit <- function(x, ...) {
  print(x$fit)
  invisible(x)
}

#' @rdname print.multifrailty_fit
#' @export
coef.multifrailty_fit <- function(object, ...) {
  stats::setNames(object$coefficients$Estimate, rownames(object$coefficients))
}

#' @rdname print.multifrailty_fit
#' @export
vcov.multifrailty_fit <- function(object, ...) {
  object$vcov
}

#' @rdname print.multifrailty_fit
#' @export
logLik.multifrailty_fit <- function(object, ...) {
  val <- object$logLik
  attr(val, "df") <- object$n_par_base + object$n_par_frailty + object$n_cov
  attr(val, "nobs") <- object$n
  class(val) <- "logLik"
  val
}

#' @rdname print.multifrailty_fit
#' @export
AIC.multifrailty_fit <- function(object, ...) {
  object$AIC
}

#' @rdname print.multifrailty_fit
#' @export
BIC.multifrailty_fit <- function(object, ...) {
  object$BIC
}

#' @rdname print.multifrailty_fit
#' @export
confint.multifrailty_fit <- function(object, parm, level = 0.95, ...) {
  cf <- object$coefficients
  z_crit <- stats::qnorm((1 + level) / 2)
  res_mat <- cbind(cf$Estimate - z_crit * cf$StdErr, cf$Estimate + z_crit * cf$StdErr)
  rownames(res_mat) <- rownames(cf)
  pct <- paste0(format(100 * c((1 - level) / 2, (1 + level) / 2), trim = TRUE, digits = 3), "%")
  colnames(res_mat) <- pct

  if (!missing(parm)) {
    res_mat <- res_mat[parm, , drop = FALSE]
  }
  res_mat
}