R/ei_methods.R

In eiballots: Ballot-Level Microdata and Summaries for Ecological Inference (Florida 2000)

# eiballots/R/ei_methods.R
# S3 methods for objects of class "ei_summary"

# ----------------------------------------------------------------------------
# print
# ----------------------------------------------------------------------------

#' Print an ei_summary object
#'
#' @param x An `"ei_summary"` object.
#' @param ... Ignored.
#' @return The input object `x`, returned invisibly. Called for its
#'   side effect of printing a structured summary to the console.
#' @export
print.ei_summary <- function(x, ...) {
  cat("Ecological Inference Summary  [eiballots]\n")
  cat(strrep("-", 44), "\n")
  cat(sprintf("%-14s: %s\n", "Races",
              paste(x$meta$elections, collapse = ", ")))
  cat(sprintf("%-14s: %s\n", "Counties",
              paste(x$meta$counties, collapse = ", ")))
  cat(sprintf("%-14s: %d\n", "Precincts", x$meta$n_precincts))
  cat(sprintf("%-14s: %s (intersection universe)\n", "Voters",
              format(x$meta$n_voters, big.mark = ",")))
  cat(sprintf("%-14s: %s\n", "Format", x$meta$format))

  cat("\nOptions per race:\n")
  for (e in x$meta$elections) {
    opts <- x$meta$opt_levels[[e]]
    cat(sprintf("  %-8s: %s\n", e, paste(opts, collapse = ", ")))
  }

  if (!is.null(x$joint_precinct)) {
    dims_str <- paste(
      c(paste0(vapply(x$meta$opt_levels, length, integer(1L)), " opts"),
        paste0(x$meta$n_precincts, " prec")),
      collapse = " \u00d7 "   # ×
    )
    cat(sprintf("\nJoint array  : [%s]\n", dims_str))
  }

  invisible(x)
}


# ----------------------------------------------------------------------------
# summary
# ----------------------------------------------------------------------------

#' Summarise an ei_summary object
#'
#' Prints aggregate vote totals and percentages for each race, and (when
#' there are exactly two races) the full joint contingency table.
#'
#' @param object An `"ei_summary"` object.
#' @param ... Ignored.
#' @return The input object `object`, returned invisibly. Called for its
#'   side effect of printing aggregate vote totals and the joint
#'   contingency table (when two races are present) to the console.
#' @export
summary.ei_summary <- function(object, ...) {

  # Work from list form
  src <- if (object$meta$format == "lphom") object else to_lphom(object)

  cat("=== Marginal totals by race ===\n")
  cat(sprintf("    Universe: %s voters, %d precincts\n\n",
              format(object$meta$n_voters, big.mark = ","),
              object$meta$n_precincts))

  for (e in object$meta$elections) {
    # Try to get office name from catalog; fall back gracefully
    office <- tryCatch(election_catalog[[e]]$office, error = function(err) "")
    header <- if (nchar(office) > 0L) sprintf("%s  [%s]", e, office) else e
    cat(sprintf("--- %s ---\n", header))

    m        <- src$margins[[e]]
    opt_cols <- setdiff(names(m), c("precinct_id", "county_id", "n_voters"))
    totals   <- colSums(m[, opt_cols, drop = FALSE])
    n_total  <- sum(totals)

    for (opt in names(totals)) {
      cat(sprintf("  %-14s %7s  (%5.1f%%)\n",
                  opt,
                  format(totals[opt], big.mark = ","),
                  100 * totals[opt] / n_total))
    }
    cat(sprintf("  %-14s %7s\n", "TOTAL", format(n_total, big.mark = ",")))
    cat("\n")
  }

  # Print joint table when exactly two races are present
  if (!is.null(object$joint_total) && length(object$meta$elections) == 2L) {
    cat(sprintf("--- Joint table: %s \u00d7 %s ---\n",
                object$meta$elections[1L], object$meta$elections[2L]))
    print(object$joint_total)
    cat("\n")
  }

  invisible(object)
}


# ----------------------------------------------------------------------------
# [ subsetting operator
# ----------------------------------------------------------------------------

#' Subset an ei_summary to fewer races
#'
#' Extracts a subset of races from an existing `"ei_summary"` object without
#' reloading or recomputing from raw data. Vote counts remain exactly as in
#' the original object because the universe is unchanged.
#'
#' The `[` operator is also available as a shorthand: `x[elections]` is
#' equivalent to `subset_elections(x, elections)`.
#'
#' @param x An `"ei_summary"` object.
#' @param elections Character vector of race codes to retain. Must be a
#'   subset of `x$meta$elections`.
#'
#' @return A new `"ei_summary"` object restricted to `elections`.
#'
#' @examples
#' \donttest{
#' obj3 <- ei_summary(c("PRE", "USS", "HOS3"))
#'
#' # Equivalent ways to extract a 2-race subset
#' obj2 <- subset_elections(obj3, c("PRE", "USS"))
#' obj2 <- obj3[c("PRE", "USS")]
#'
#' obj1 <- obj3["PRE"]   # single race: no joint array
#' }
#'
#' @export
subset_elections <- function(x, elections) {
  stopifnot(inherits(x, "ei_summary"))

  unknown <- setdiff(elections, x$meta$elections)
  if (length(unknown) > 0L)
    stop(
      sprintf("Race(s) not present in this ei_summary object: %s",
              paste(unknown, collapse = ", ")),
      call. = FALSE
    )

  # Nothing to subset
  if (length(elections) == length(x$meta$elections) &&
      all(sort(elections) == sort(x$meta$elections)))
    return(x)

  # Work from list form
  src <- if (x$meta$format == "lphom") x else to_lphom(x)

  new_margins <- src$margins[elections]

  if (length(elections) == 1L) {
    new_joint <- NULL
    new_total <- NULL

  } else {
    idx          <- match(elections, x$meta$elections)
    precinct_dim <- length(x$meta$elections) + 1L

    new_joint <- if (length(idx) == length(x$meta$elections)) {
      x$joint_precinct
    } else {
      apply(x$joint_precinct, c(idx, precinct_dim), sum)
    }

    other_dims <- seq_along(elections)
    new_total  <- apply(new_joint, other_dims, sum)
  }

  # Restore original format
  final_margins <- if (x$meta$format == "eipack") {
    .to_eipack_wide(new_margins)
  } else {
    new_margins
  }

  structure(
    list(
      margins        = final_margins,
      joint_precinct = new_joint,
      joint_total    = new_total,
      meta           = c(
        x$meta[setdiff(names(x$meta), c("elections", "opt_levels"))],
        list(elections = elections,
             opt_levels = x$meta$opt_levels[elections])
      )
    ),
    class = c("ei_summary", "list")
  )
}


#' `[` operator: thin syntactic-sugar wrapper around subset_elections().
#' Exported so that `obj[elections]` works, but intentionally undocumented
#' subset_elections() is the documented entry point.
#' @rdname subset_elections
#' @export
`[.ei_summary` <- function(x, elections) {
  subset_elections(x, elections)
}