R/summary.mrt_effect_size.R

In MRTAnalysis: Assessing Proximal, Distal, and Mediated Causal Excursion Effects for Micro-Randomized Trials

#' Summary for standardized proximal effect size
#'
#' Summarizes the time-varying standardized proximal effect size estimates
#' produced by [calculate_mrt_effect_size()] for continuous proximal outcomes.
#'
#' @param object An object of class \code{"mrt_effect_size"}.
#' @param ... Currently ignored.
#'
#' @return A list of class \code{"summary.mrt_effect_size"} with components:
#' \itemize{
#'   \item \code{call} — the original call
#'   \item \code{n_id} — number of participants (if available)
#'   \item \code{n_time} — number of decision points
#'   \item \code{smooth}, \code{loess_span}, \code{loess_degree} — smoothing settings
#'   \item \code{do_bootstrap}, \code{boot_replications}, \code{confidence_alpha} — bootstrap settings
#'   \item \code{effect_summary} — data frame of summary statistics for \code{estimate}
#'   \item \code{ci_summary} — optional data frame of CI-width statistics
#' }
#'
#' @export
#' @method summary mrt_effect_size
summary.mrt_effect_size <- function(object, ...) {
  stopifnot(inherits(object, "mrt_effect_size"))

  est <- object$estimate
  time <- object$time

  finite_idx <- which(is.finite(est))
  if (length(finite_idx) > 0) {
    min_idx <- finite_idx[which.min(est[finite_idx])]
    max_idx <- finite_idx[which.max(est[finite_idx])]
    min_est <- est[min_idx]
    max_est <- est[max_idx]
    time_min <- time[min_idx]
    time_max <- time[max_idx]
  } else {
    min_est <- max_est <- time_min <- time_max <- NA_real_
  }

  effect_summary <- data.frame(
    Mean = mean(est, na.rm = TRUE),
    Median = stats::median(est, na.rm = TRUE),
    Min = min_est,
    Time_at_Min = time_min,
    Max = max_est,
    Time_at_Max = time_max,
    check.names = FALSE
  )

  ci_summary <- NULL
  if (all(c("lower", "upper") %in% names(object))) {
    ci_width <- object$upper - object$lower
    if (any(is.finite(ci_width))) {
      ci_summary <- data.frame(
        `Mean CI Width` = mean(ci_width, na.rm = TRUE),
        `Median CI Width` = stats::median(ci_width, na.rm = TRUE),
        `Pct CI Excludes 0` = 100 * mean(object$lower > 0 | object$upper < 0, na.rm = TRUE),
        check.names = FALSE
      )
    }
  }

  out <- list(
    call = attr(object, "call"),
    n_id = attr(object, "n_id"),
    n_time = length(time),
    smooth = attr(object, "smooth"),
    loess_span = attr(object, "loess_span"),
    loess_degree = attr(object, "loess_degree"),
    do_bootstrap = attr(object, "do_bootstrap"),
    boot_replications = attr(object, "boot_replications"),
    confidence_alpha = attr(object, "confidence_alpha"),
    effect_summary = effect_summary,
    ci_summary = ci_summary
  )

  class(out) <- "summary.mrt_effect_size"
  out
}

#' @export
#' @method print summary.mrt_effect_size
print.summary.mrt_effect_size <- function(x, ...) {
  cat("\nCall:\n")
  print(x$call)

  if (!is.null(x$n_id) && is.finite(x$n_id)) {
    cat(sprintf("\nParticipants: %d\n", x$n_id))
  }
  cat(sprintf("Decision points: %d\n", x$n_time))

  if (isTRUE(x$smooth)) {
    cat(sprintf(
      "Smoothing: LOESS (span = %g, degree = %g)\n",
      x$loess_span, x$loess_degree
    ))
  } else {
    cat("Smoothing: none\n")
  }

  if (isTRUE(x$do_bootstrap)) {
    cat(sprintf(
      "Bootstrap: %d replications; alpha = %g\n",
      x$boot_replications, x$confidence_alpha
    ))
  } else {
    cat("Bootstrap: not used\n")
  }

  cat("\nStandardized effect summary:\n")
  print(x$effect_summary)

  if (!is.null(x$ci_summary)) {
    cat("\nBootstrap CI summary:\n")
    print(x$ci_summary)
  }

  invisible(x)
}

#' Plot standardized proximal effect size
#'
#' Plot the standardized effect estimate over time, with optional bootstrap
#' confidence bounds if available.
#'
#' @importFrom graphics plot lines
#' @param x An object of class \code{"mrt_effect_size"}.
#' @param show_ci Logical; if \code{TRUE} and CIs are available, plot the
#'   lower and upper confidence bounds.
#' @param col Color for the estimate line.
#' @param lwd Line width for the estimate line.
#' @param ci_col Color for CI lines.
#' @param ci_lty Line type for CI lines.
#' @param ... Additional arguments passed to [plot()].
#'
#' @export
#' @method plot mrt_effect_size
plot.mrt_effect_size <- function(
    x,
    show_ci = TRUE,
    col = "black",
    lwd = 1.5,
    ci_col = "red",
    ci_lty = 2,
    ...) {
  stopifnot(inherits(x, "mrt_effect_size"))

  plot(
    x$time, x$estimate, type = "l",
    xlab = "time (decision point)",
    ylab = "standardized effect",
    col = col,
    lwd = lwd,
    ...
  )

  if (isTRUE(show_ci) && all(c("lower", "upper") %in% names(x))) {
    if (any(is.finite(x$lower))) {
      lines(x$time, x$lower, col = ci_col, lty = ci_lty, lwd = 1)
    }
    if (any(is.finite(x$upper))) {
      lines(x$time, x$upper, col = ci_col, lty = ci_lty, lwd = 1)
    }
  }

  invisible(x)
}