tests/testthat/test-ei_summary.R

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

# tests/testthat/test-ei_summary.R
# Tests for ei_summary(), to_lphom(), to_eipack(), and [.ei_summary.
#
# All tests use synthetic data passed via the `data` argument, so no files
# are downloaded during testing.

# ----------------------------------------------------------------------------
# Helper: synthetic microdata using real race codes
# ----------------------------------------------------------------------------

make_test_data <- function(n = 300, seed = 42) {
  set.seed(seed)
  data.frame(
    COUNTY   = "Lee",
    PRECINCT = sample(paste0("P", 1:5), n, replace = TRUE),
    # PRE: all voters eligible (no NA)
    PRE      = sample(c("R", "D", "O", "A"), n, replace = TRUE,
                      prob = c(0.50, 0.40, 0.05, 0.05)),
    # USS: ~20% of voters not eligible (NA)
    USS      = sample(c("R", "D", "O", "A", NA), n, replace = TRUE,
                      prob = c(0.40, 0.33, 0.04, 0.04, 0.19)),
    # HOS3: multi-member race with combinations; all eligible
    HOS3     = sample(c("Bau", "Duf", "BauDuf", "BerDuf", "A"), n,
                      replace = TRUE, prob = c(0.25, 0.25, 0.25, 0.20, 0.05)),
    # D21: referendum, ~30% not eligible
    D21      = sample(c("Y", "N", "A", NA), n, replace = TRUE,
                      prob = c(0.42, 0.35, 0.05, 0.18)),
    stringsAsFactors = FALSE
  )
}


# ----------------------------------------------------------------------------
# Single-race ei_summary
# ----------------------------------------------------------------------------

test_that("ei_summary() with one race returns correct structure", {
  obj <- ei_summary("PRE", data = make_test_data())
  expect_s3_class(obj, "ei_summary")
  expect_null(obj$joint_precinct)
  expect_null(obj$joint_total)
  expect_type(obj$margins, "list")
  expect_named(obj$margins, "PRE")
  expect_s3_class(obj$margins$PRE, "data.frame")
  expect_true(all(c("precinct_id", "county_id", "n_voters") %in%
                    names(obj$margins$PRE)))
})

test_that("ei_summary() single race: vote columns match opt_levels", {
  obj      <- ei_summary("PRE", data = make_test_data())
  opt_cols <- setdiff(names(obj$margins$PRE),
                      c("precinct_id", "county_id", "n_voters"))
  expect_equal(sort(opt_cols), sort(obj$meta$opt_levels$PRE))
})

test_that("ei_summary() single race: n_voters equals row sum of options", {
  obj      <- ei_summary("PRE", data = make_test_data())
  opt_cols <- setdiff(names(obj$margins$PRE),
                      c("precinct_id", "county_id", "n_voters"))
  row_sums <- rowSums(obj$margins$PRE[, opt_cols, drop = FALSE])
  expect_equal(obj$margins$PRE$n_voters, row_sums)
})

test_that("ei_summary() single race: A and I placed last in opt_levels", {
  obj  <- ei_summary("PRE", data = make_test_data())
  opts <- obj$meta$opt_levels$PRE
  # All elements after the last non-special element should be A or I
  special <- intersect(opts, c("A", "I"))
  if (length(special) > 0L) {
    tail_opts <- tail(opts, length(special))
    expect_equal(sort(tail_opts), sort(special))
  }
})


# ----------------------------------------------------------------------------
# Two-race ei_summary
# ----------------------------------------------------------------------------

test_that("ei_summary() two races returns 3-D joint array", {
  obj <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  expect_false(is.null(obj$joint_precinct))
  expect_equal(length(dim(obj$joint_precinct)), 3L)
  # dim: [opts_PRE, opts_HOS3, precincts] -- precinct is the LAST dimension
  expect_equal(dim(obj$joint_precinct)[1L], length(obj$meta$opt_levels$PRE))
  expect_equal(dim(obj$joint_precinct)[2L], length(obj$meta$opt_levels$HOS3))
  expect_equal(dim(obj$joint_precinct)[3L], obj$meta$n_precincts)
  expect_equal(names(dimnames(obj$joint_precinct))[3L], "precinct")
})

test_that("ei_summary() two races: joint_total collapses precincts", {
  obj <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  expect_equal(length(dim(obj$joint_total)), 2L)
  # precinct is the LAST dimension of joint_precinct (dim 3); joint_total
  # keeps only the first two (option) dimensions.
  expect_equal(dim(obj$joint_total),
               dim(obj$joint_precinct)[1:2])
})

test_that("margins are consistent with joint_precinct (row sums)", {
  obj <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  # Dims: [opts_PRE (1), opts_HOS3 (2), precinct (3)]

  # PRE margin = sum over HOS3 dimension, kept as [precinct x opt_PRE]
  pre_from_joint <- apply(obj$joint_precinct, c(3L, 1L), sum)
  pre_margin     <- obj$margins$PRE
  opt_cols       <- setdiff(names(pre_margin),
                            c("precinct_id", "county_id", "n_voters"))
  for (opt in opt_cols) {
    expect_equal(
      sum(pre_margin[[opt]]),
      sum(pre_from_joint[, opt]),
      label = sprintf("PRE option '%s': margin vs joint", opt)
    )
  }

  # HOS3 margin = sum over PRE dimension, kept as [precinct x opt_HOS3]
  hos_from_joint <- apply(obj$joint_precinct, c(3L, 2L), sum)
  hos_margin     <- obj$margins$HOS3
  opt_cols       <- setdiff(names(hos_margin),
                            c("precinct_id", "county_id", "n_voters"))
  for (opt in opt_cols) {
    expect_equal(
      sum(hos_margin[[opt]]),
      sum(hos_from_joint[, opt]),
      label = sprintf("HOS3 option '%s': margin vs joint", opt)
    )
  }
})

test_that("joint_total equals apply(joint_precinct, 1:2, sum)", {
  obj      <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  # Sum over the LAST dimension (precinct, dim 3), keep dims 1:2 (options)
  expected <- apply(obj$joint_precinct, c(1L, 2L), sum)
  expect_equal(obj$joint_total, expected)
})

test_that("n_voters in meta equals sum of any margin's n_voters", {
  obj      <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  n_from_pre <- sum(obj$margins$PRE$n_voters)
  n_from_hos <- sum(obj$margins$HOS3$n_voters)
  expect_equal(obj$meta$n_voters, n_from_pre)
  expect_equal(obj$meta$n_voters, n_from_hos)
})

test_that("intersection universe is smaller when a race has NAs", {
  d    <- make_test_data()
  pres <- ei_summary("PRE",          data = d)
  both <- ei_summary(c("PRE", "USS"), data = d)
  # Adding USS (which has NAs) must reduce or maintain the voter count
  expect_lte(both$meta$n_voters, pres$meta$n_voters)
})


# ----------------------------------------------------------------------------
# Three-race ei_summary
# ----------------------------------------------------------------------------

test_that("ei_summary() three races returns 4-D joint array", {
  obj <- ei_summary(c("PRE", "USS", "HOS3"), data = make_test_data())
  expect_equal(length(dim(obj$joint_precinct)), 4L)
})


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

test_that("[.ei_summary extracts a 2-race subset correctly", {
  obj3 <- ei_summary(c("PRE", "USS", "HOS3"), data = make_test_data())
  obj2 <- obj3[c("PRE", "USS")]
  expect_equal(obj2$meta$elections, c("PRE", "USS"))
  expect_equal(length(dim(obj2$joint_precinct)), 3L)
  expect_named(obj2$margins, c("PRE", "USS"))
})

test_that("[.ei_summary extracting one race returns NULL joints", {
  obj3 <- ei_summary(c("PRE", "USS", "HOS3"), data = make_test_data())
  obj1 <- obj3["PRE"]
  expect_null(obj1$joint_precinct)
  expect_null(obj1$joint_total)
})

test_that("[.ei_summary errors on unknown race code", {
  obj <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  expect_error(obj["ZZZNOPE"], regexp = "not present")
})

test_that("[.ei_summary returns identical object when all races requested", {
  obj  <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  same <- obj[c("PRE", "HOS3")]
  expect_identical(obj, same)
})


# ----------------------------------------------------------------------------
# Format converters
# ----------------------------------------------------------------------------

test_that("to_eipack() converts margins to a wide data.frame", {
  obj  <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  wide <- to_eipack(obj)
  expect_s3_class(wide$margins, "data.frame")
  expect_equal(wide$meta$format, "eipack")
  # Column names should include RACE_OPTION prefixes
  expect_true(any(grepl("^PRE_",  names(wide$margins))))
  expect_true(any(grepl("^HOS3_", names(wide$margins))))
})

test_that("to_lphom() converts wide margins back to a list", {
  obj  <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  wide <- to_eipack(obj)
  back <- to_lphom(wide)
  expect_type(back$margins, "list")
  expect_equal(back$meta$format, "lphom")
  expect_named(back$margins, c("PRE", "HOS3"))
})

test_that("to_lphom(to_eipack(obj)) preserves vote totals", {
  obj      <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  round_trip <- to_lphom(to_eipack(obj))

  for (e in c("PRE", "HOS3")) {
    orig_total <- sum(obj$margins[[e]]$n_voters)
    rt_total   <- sum(round_trip$margins[[e]]$n_voters)
    expect_equal(rt_total, orig_total,
                 label = sprintf("%s n_voters after round-trip", e))
  }
})

test_that("to_eipack() is idempotent", {
  obj   <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  wide1 <- to_eipack(obj)
  wide2 <- to_eipack(wide1)
  expect_identical(wide1$margins, wide2$margins)
})

test_that("to_lphom() is idempotent", {
  obj  <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  obj2 <- to_lphom(obj)
  expect_identical(obj$margins, obj2$margins)
})


# ----------------------------------------------------------------------------
# Error handling
# ----------------------------------------------------------------------------

test_that("ei_summary() errors on unknown race code", {
  expect_error(
    ei_summary("ZZZNOPE", data = make_test_data()),
    regexp = "not found in catalog"
  )
})

test_that("ei_summary() errors on missing columns in data", {
  d <- make_test_data()[, c("COUNTY", "PRECINCT", "PRE")]
  expect_error(
    ei_summary(c("PRE", "HOS3"), data = d),
    regexp = "Missing columns"
  )
})

test_that("ei_summary() errors when intersection universe is empty", {
  d <- make_test_data()
  # Make all USS values NA so intersection with PRE is empty
  d$USS <- NA_character_
  expect_error(
    ei_summary(c("PRE", "USS"), data = d),
    regexp = "No voters are eligible"
  )
})

test_that("dim(joint_precinct) is unnamed", {
  obj <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  expect_null(names(dim(obj$joint_precinct)))
})

test_that("precinct is the last dimension and is named", {
  obj <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  k   <- length(dim(obj$joint_precinct))
  expect_equal(names(dimnames(obj$joint_precinct))[k], "precinct")
  expect_equal(dim(obj$joint_precinct)[k], obj$meta$n_precincts)
})

test_that("joint_precinct[, , p] gives the contingency table for precinct p", {
  obj <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  p   <- obj$meta$precinct_info$precinct_id[1L]
  tab <- obj$joint_precinct[, , p]
  expect_equal(dim(tab), dim(obj$joint_precinct)[1:2])
  expect_equal(sum(tab), sum(obj$margins$PRE$n_voters[
    obj$margins$PRE$precinct_id == p
  ]))
})

test_that("to_eipack() does not leak old margins_list names", {
  obj  <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  wide <- to_eipack(obj)
  # Regression test: modifyList() previously merged old list-names
  # (PRE, HOS3) with the new data.frame's column names.
  expect_false("PRE"  %in% names(wide$margins))
  expect_false("HOS3" %in% names(wide$margins))
  expect_equal(nrow(wide$margins), obj$meta$n_precincts)
})

test_that("to_lphom() does not leak old wide column names", {
  obj  <- ei_summary(c("PRE", "HOS3"), data = make_test_data())
  back <- to_lphom(to_eipack(obj))
  expect_named(back$margins, c("PRE", "HOS3"))
})

test_that("subset_elections() drops opt_levels of removed races", {
  obj3 <- ei_summary(c("PRE", "USS", "HOS3"), data = make_test_data())
  obj2 <- obj3[c("PRE", "USS")]
  # Regression test: modifyList() previously kept HOS3's levels around
  # even after HOS3 was removed from the subset.
  expect_false("HOS3" %in% names(obj2$meta$opt_levels))
  expect_named(obj2$meta$opt_levels, c("PRE", "USS"))
})