R/print_methods.R

In FPScausal: Functional Propensity Score for Causal Inference

#' Print method for fps_weighting objects
#'
#' @param x An object of class \code{"fps_weighting"}.
#' @param ... Ignored.
#' @return Invisibly returns \code{x}.
#' @export
print.fps_weighting <- function(x, ...) {
  n  <- length(x$weights)
  L  <- x$fpca_treatment$L
  pv <- round(sum(x$fpca_treatment$varprop) * 100, 1)

  cat("Functional Propensity Score Weighting\n")
  cat("--------------------------------------\n")
  cat(sprintf("Observations       : %d\n", n))
  cat(sprintf("Treatment FPCs (L) : %d  (%.1f%% variance explained)\n", L, pv))
  cat(sprintf("Convergence code   : %d  (%s)\n",
              x$convergence,
              if (x$convergence == 0) "converged" else "may not have converged"))
  cat(sprintf("Weights            : min = %.4f  max = %.4f  mean = %.4f\n",
              min(x$weights), max(x$weights), mean(x$weights)))
  if (!is.null(x$fpca_covariates)) {
    nfc <- length(x$fpca_covariates)
    Ks  <- vapply(x$fpca_covariates, function(fpc) fpc$L, integer(1))
    cat(sprintf("Functional covariates : %d (FPCs retained: %s)\n",
                nfc, paste(Ks, collapse = ", ")))
  }
  invisible(x)
}

#' Summary method for fps_weighting objects
#'
#' @param object An object of class \code{"fps_weighting"}.
#' @param ... Ignored.
#' @return Invisibly returns \code{object}.
#' @export
summary.fps_weighting <- function(object, ...) {
  print(object)

  w          <- object$weights
  A          <- object$fpca_treatment$scr
  conf       <- object$conf_matrix
  n_conf     <- ncol(conf)
  L          <- ncol(A)

  cat("\nCovariate balance (absolute Pearson correlations):\n")
  cat("  Unweighted vs Weighted\n")

  for (l in seq_len(L)) {
    for (j in seq_len(n_conf)) {
      r_uw <- abs(stats::cor(A[, l], conf[, j]))
      r_w  <- abs(wCorr::weightedCorr(A[, l], conf[, j],
                                       method  = "Pearson",
                                       weights = w))
      cat(sprintf("  FPC%d ~ Conf%d :  unweighted = %.3f  weighted = %.3f\n",
                  l, j, r_uw, r_w))
    }
  }
  invisible(object)
}

#' Print method for fps_effect_estimation objects
#'
#' @param x An object of class \code{"fps_effect_estimation"}.
#' @param ... Ignored.
#' @return Invisibly returns \code{x}.
#' @export
print.fps_effect_estimation <- function(x, ...) {
  cat("Functional Propensity Score Effect Estimation\n")
  cat("----------------------------------------------\n")
  cat(sprintf("Outcome type     : %s\n", x$outcome_type))
  L  <- x$fpca_treatment$L
  pv <- round(sum(x$fpca_treatment$varprop) * 100, 1)
  cat(sprintf("Treatment FPCs   : %d  (%.1f%% variance explained)\n", L, pv))

  if (x$outcome_type == "functional" && !is.null(x$fpca_outcome)) {
    Ly  <- x$fpca_outcome$L
    pvy <- round(sum(x$fpca_outcome$varprop) * 100, 1)
    cat(sprintf("Outcome FPCs     : %d  (%.1f%% variance explained)\n", Ly, pvy))
  }

  cat(sprintf("Bootstrap CIs    : %s\n",
              if (!is.null(x$ci_lower)) paste0("yes (alpha = ", x$alpha, ")") else "no"))

  if (x$outcome_type != "functional") {
    cat(sprintf("Beta range       : [%.4f, %.4f]\n",
                min(x$beta), max(x$beta)))
  } else {
    cat(sprintf("Beta surface range: [%.4f, %.4f]\n",
                min(x$beta), max(x$beta)))
  }
  invisible(x)
}

#' Summary method for fps_effect_estimation objects
#'
#' @param object An object of class \code{"fps_effect_estimation"}.
#' @param ... Ignored.
#' @return Invisibly returns \code{object}.
#' @export
summary.fps_effect_estimation <- function(object, ...) {
  print(object)

  if (!is.null(object$true_beta)) {
    metrics <- .compute_error_metrics(object$beta, object$true_beta)
    cat("\nError vs true beta:\n")
    cat(sprintf("  ISE  = %.6f\n", metrics["ISE"]))
    cat(sprintf("  ISB  = %.6f\n", metrics["ISB"]))

    metrics_u <- .compute_error_metrics(object$beta_unweighted, object$true_beta)
    cat("\nError vs true beta (unweighted):\n")
    cat(sprintf("  ISE  = %.6f\n", metrics_u["ISE"]))
    cat(sprintf("  ISB  = %.6f\n", metrics_u["ISB"]))
  }
  invisible(object)
}