R/build_array.R

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

# eiballots/R/build_array.R
# Internal functions for joint array construction.
# These are not exported; they are called by ei_summary().

# ----------------------------------------------------------------------------
# Main array builder
# ----------------------------------------------------------------------------

# Build the joint precinct array from microdata
#
# Filters to the intersection universe (voters non-NA in ALL requested
# races), derives option levels, and constructs the array
# [precinct x opt_1 x ... x opt_k].
#
# @param data data.frame with columns COUNTY, PRECINCT, and race columns.
# @param elections character vector of race codes.
# @return A list with:
#   - `joint_precinct`: integer array [precinct x opt_1 x ... x opt_k]
#   - `precinct_info`: data.frame with precinct_id, COUNTY, PRECINCT
#   - `opt_levels`: named list of option levels per race
#   - `n_universe`: number of voters in the intersection universe
.build_joint_array <- function(data, elections) {

  # Create precinct identifier
  data$precinct_id <- paste(data$COUNTY, data$PRECINCT, sep = "_")

  # --- Intersection universe: non-NA in ALL races ---
  is_complete <- complete.cases(data[, elections, drop = FALSE])
  universe    <- data[is_complete, , drop = FALSE]

  if (nrow(universe) == 0L)
    stop(
      paste0(
        "No voters are eligible in all selected races simultaneously.\n",
        "Check that the chosen races have overlapping universes."
      ),
      call. = FALSE
    )

  # --- Sorted unique precincts (determines array dimension 1) ---
  precincts <- sort(unique(universe$precinct_id))
  n_p       <- length(precincts)

  # --- Option levels per race ---
  # Convention: valid vote codes first (alphabetical), then A (blank), then I (invalid)
  opt_levels <- lapply(elections, function(e) {
    vals    <- as.character(unique(universe[[e]]))
    valid   <- sort(vals[!vals %in% c("A", "I")])
    special <- intersect(c("A", "I"), vals)
    c(valid, special)
  })
  names(opt_levels) <- elections

  # --- Convert to factors with fixed levels ---
  # Ensures table() produces consistent dimensions even for precincts
  # that are missing some options.
  for (e in elections) {
    universe[[e]] <- factor(universe[[e]], levels = opt_levels[[e]])
  }

  # --- Precinct info lookup (used when building margin data.frames) ---
  precinct_info <- universe[
    !duplicated(universe$precinct_id),
    c("precinct_id", "COUNTY", "PRECINCT"),
    drop = FALSE
  ]
  precinct_info <- precinct_info[order(precinct_info$precinct_id), , drop = FALSE]
  rownames(precinct_info) <- NULL

  # --- Build array: [opt_1 x ... x opt_k x precinct] ---
  # Precinct is the LAST dimension: joint_precinct[, ..., p] gives the
  # cross-tab for precinct p directly.
  n_opts       <- vapply(opt_levels, length, integer(1L))
  arr_dims     <- unname(c(n_opts, n_p))
  arr_dimnames <- c(opt_levels, list(precinct = precincts))

  splits <- split(universe[, elections, drop = FALSE], universe$precinct_id)

  flat_list <- lapply(precincts, function(p) as.integer(table(splits[[p]])))

  # Stack as COLUMNS: mat has dim (prod(n_opts), n_p), since precinct is
  # the last (slowest-varying) dimension of the target array.
  mat <- do.call(cbind, flat_list)

  joint_precinct <- array(mat, dim = arr_dims, dimnames = arr_dimnames)

  list(
    joint_precinct = joint_precinct,
    precinct_info  = precinct_info,
    opt_levels     = opt_levels,
    n_universe     = nrow(universe)
  )
}


# ----------------------------------------------------------------------------
# Margin derivation
# ----------------------------------------------------------------------------

# Derive per-race margin data.frames from the joint array
#
# For each race i, sums over all other race dimensions to obtain a
# [precinct x opt_i] matrix, then wraps it as a data.frame.
#
# @param joint_precinct array [opt_1 x ... x opt_k x precinct], k >= 2.
# @param elections character vector of length k.
# @param precinct_info data.frame with precinct_id and COUNTY columns.
# @return Named list of data.frames, one per race.
.derive_margins <- function(joint_precinct, elections, precinct_info) {
  precinct_dim <- length(elections) + 1L   # precinct is the LAST dimension
  lapply(seq_along(elections), function(i) {
    keep_dims <- c(precinct_dim, i)
    mar       <- apply(joint_precinct, keep_dims, sum)
    .array_to_margin_df(mar, precinct_info)
  })
}

# Convert a 2D [precinct x opt] array to a margin data.frame
#
# Adds `n_voters` (row total) and `county_id` columns and reorders columns
# to the canonical order: precinct_id, county_id, n_voters, <options>.
.array_to_margin_df <- function(arr, precinct_info) {
  df          <- as.data.frame.matrix(arr)
  opt_cols    <- names(df)
  df$n_voters <- rowSums(df[, opt_cols, drop = FALSE])
  df$precinct_id <- rownames(arr)

  # Attach county information
  df <- merge(
    df,
    precinct_info[, c("precinct_id", "COUNTY"), drop = FALSE],
    by    = "precinct_id",
    all.x = TRUE,
    sort  = FALSE
  )
  names(df)[names(df) == "COUNTY"] <- "county_id"

  # Canonical column order
  df[, c("precinct_id", "county_id", "n_voters", opt_cols), drop = FALSE]
}


# ----------------------------------------------------------------------------
# Wide (eipack) format conversion
# ----------------------------------------------------------------------------

# Convert a list of margin data.frames to a single wide data.frame
#
# Column names become `<RACE>_<OPTION>` (e.g. `PRE_R`, `PRE_D`).
# `n_voters` is taken from the first race (identical across all races
# because they share the same intersection universe).
.to_eipack_wide <- function(margins_list) {
  base <- margins_list[[1L]][, c("precinct_id", "county_id", "n_voters"),
                              drop = FALSE]
  for (e in names(margins_list)) {
    m        <- margins_list[[e]]
    opt_cols <- setdiff(names(m), c("precinct_id", "county_id", "n_voters"))
    renamed  <- m[, opt_cols, drop = FALSE]
    names(renamed) <- paste(e, opt_cols, sep = "_")
    base <- cbind(base, renamed)
  }
  rownames(base) <- NULL
  base
}