R/print.feasible.R

In CICI: Causal Inference with Continuous (Multiple Time Point) Interventions

print.feasible <- function(x, digits = 3,
                           strategies = "all",
                           times = "all",
                           ...) {
  if (!inherits(x, "feasible")) stop("x must be a <feasible> object.")
  
  s_all <- attr(x, "summary")
  k_strat_total <- length(x$feasible)
  
  if (is.null(s_all) || !is.data.frame(s_all) || nrow(s_all) == 0L) {
    cat(sprintf("<feasible> object with %d strateg%s\n",
                k_strat_total, ifelse(k_strat_total == 1, "y", "ies")))
    cat("No summary available.\n")
    return(invisible(x))
  }
  
  s <- s_all
  
  if (!identical(strategies, "all")) {
    strategies <- sort(unique(as.integer(strategies)))
    s <- s[s$Strategy %in% strategies, , drop = FALSE]
  }
  
  if (!identical(times, "all")) {
    times <- sort(unique(as.integer(times)))
    s <- s[s$time %in% times, , drop = FALSE]
  }
  
  if (nrow(s) == 0L) {
    cat(sprintf("<feasible> object with %d strateg%s\n",
                k_strat_total, ifelse(k_strat_total == 1, "y", "ies")))
    cat("No summary available for the requested strategies/time points.\n")
    return(invisible(x))
  }
  
  infeas_col <- NULL
  if ("%infeasible" %in% names(s)) {
    infeas_col <- "%infeasible"
  } else if ("Low" %in% names(s)) {
    infeas_col <- "Low"
  } else {
    stop("Summary must contain a '%infeasible' or 'Low' column.")
  }
  
  k_strat_sel <- length(unique(s$Strategy))
  t_pts_sel   <- length(unique(s$time))
  t_pts_total <- length(unique(s_all$time))
  
  cat(sprintf("<feasible> object with %d strateg%s (showing %d) across %d time point%s (showing %d)\n",
              k_strat_total, ifelse(k_strat_total == 1, "y", "ies"),
              k_strat_sel,
              t_pts_total, ifelse(t_pts_total == 1, "", "s"),
              t_pts_sel))
  
  dat_map <- unique(s[, c("time", "Abar", "Strategy")])
  mapping_by_time <- split(dat_map[, c("Abar", "Strategy")], dat_map$time)
  .norm_map <- function(df) {
    df <- df[order(df$Abar, df$Strategy), , drop = FALSE]
    rownames(df) <- NULL
    df
  }
  base_map <- .norm_map(mapping_by_time[[1]])
  all_identical <- all(vapply(mapping_by_time, function(df) identical(.norm_map(df), base_map), logical(1)))
  
  strat_ids <- sort(unique(s$Strategy))
  time_ids  <- sort(unique(s$time))
  
  mean_fun <- function(z) mean(z, na.rm = TRUE)
  make_mat <- function(colname) {
    mat <- matrix(NA_real_,
                  nrow = length(strat_ids),
                  ncol = length(time_ids),
                  dimnames = list(
                    paste0("Strategy ", strat_ids),
                    paste0("t=", time_ids)
                  ))
    for (i in seq_along(strat_ids)) {
      k <- strat_ids[i]
      for (j in seq_along(time_ids)) {
        tt <- time_ids[j]
        idx <- s$Strategy == k & s$time == tt
        if (any(idx)) {
          mat[i, j] <- mean_fun(s[idx, colname])
        }
      }
    }
    mat
  }
  
  mat_infeas <- make_mat(infeas_col)      # assumed in [0, 1]
  mat_feas   <- make_mat("Feasible")
  
  cat("\nWhat the values represent (based on selected strategies/time points):\n")
  cat("  Abar        : target intervention value\n")
  cat("  Strategy    : index of the intervention rule\n")
  cat("  time        : time index\n")
  cat("  %infeasible : proportion of mass falling below the density threshold\n")
  cat("  Feasible    : mean feasible value after replacing low-density bins\n")
  if (all_identical) {
    cat("  (Each selected strategy uses the same Abar at every selected time point.)\n")
  }
  
  # generic table printer; suffix allows adding "%" for percentages
  print_num_matrix <- function(mat, digits, na_string = "NA", suffix = "") {
    fmt <- function(x) {
      if (is.na(x)) {
        na_string
      } else {
        paste0(
          format(round(x, digits = digits), digits = digits, trim = TRUE),
          suffix
        )
      }
    }
    mat_chr <- apply(mat, c(1, 2), fmt)
    
    col_widths <- pmax(
      nchar(colnames(mat_chr)),
      apply(mat_chr, 2, function(z) max(nchar(z), na.rm = TRUE))
    )
    
    header <- paste(vapply(seq_along(colnames(mat_chr)), function(j) {
      sprintf(sprintf("%%%ds", col_widths[j]), colnames(mat_chr)[j])
    }, character(1)), collapse = "  ")
    
    sep <- paste(vapply(seq_along(colnames(mat_chr)), function(j) {
      paste(rep("-", col_widths[j]), collapse = "")
    }, character(1)), collapse = "  ")
    
    cat("          ", header, "\n", sep = "")
    cat("          ", sep,    "\n", sep = "")
    
    for (i in seq_len(nrow(mat_chr))) {
      rowlab <- rownames(mat_chr)[i]
      vals <- paste(vapply(seq_along(colnames(mat_chr)), function(j) {
        sprintf(sprintf("%%%ds", col_widths[j]), mat_chr[i, j])
      }, character(1)), collapse = "  ")
      cat(sprintf("%-10s %s\n", rowlab, vals))
    }
  }
  
  ## Table 1: %infeasible as percentage with "%" sign
  mat_infeas_pct <- mat_infeas * 100
  cat("\nTable 1: %infeasible (percentage, 0-100) by strategy (rows) and time (columns)\n")
  print_num_matrix(mat_infeas_pct, digits = digits, suffix = "%")
  
  ## Table 2: Feasible in original scale
  cat("\nTable 2: Feasible (mean feasible value) by strategy (rows) and time (columns)\n")
  print_num_matrix(mat_feas, digits = digits, suffix = "")
  
  cat("\nAbar targets by time (selected):\n")
  cat(sprintf("  time: [%s]\n", paste(time_ids, collapse = ", ")))
  
  get_abar_vec <- function(k) {
    vapply(time_ids, function(tt) {
      vals <- unique(s$Abar[s$Strategy == k & s$time == tt])
      if (!length(vals)) return(NA_character_)
      if (length(vals) == 1) return(as.character(vals))
      paste(as.character(vals), collapse = "|")
    }, character(1))
  }
  
  for (k in strat_ids) {
    v <- get_abar_vec(k)
    v <- ifelse(is.na(v), "NA", v)
    cat(sprintf("  Strategy %d: [%s]\n",
                k,
                paste(v, collapse = ", ")))
  }
  
  invisible(x)
}