Merge pull request #21 from alarm-redist/dilution_asymmetry

Implement dilution asymmetry from Gordon and Yntiso 2024

NAMESPACE

@@ -26,6 +26,7 @@ export(list_fn)
 export(part_bias)
 export(part_decl)
 export(part_decl_simple)
+export(part_dil_asym)
 export(part_dseats)
 export(part_dvs)
 export(part_egap)

R/partisan.R

@@ -31,10 +31,10 @@ part_bias <- function(plans, shp, dvote, rvote, v = 0.5) {
   dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
   rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
 
-  if (any(is.na(dvote))) {
+  if (anyNA(dvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
   }
-  if (any(is.na(rvote))) {
+  if (anyNA(rvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
   }
   if (length(rvote) != nrow(plans)) {
@@ -80,10 +80,10 @@ part_dseats <- function(plans, shp, dvote, rvote) {
   dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
   rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
 
-  if (any(is.na(dvote))) {
+  if (anyNA(dvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
   }
-  if (any(is.na(rvote))) {
+  if (anyNA(rvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
   }
   if (length(rvote) != nrow(plans)) {
@@ -130,10 +130,10 @@ part_dvs <- function(plans, shp, dvote, rvote) {
   dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
   rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
 
-  if (any(is.na(dvote))) {
+  if (anyNA(dvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
   }
-  if (any(is.na(rvote))) {
+  if (anyNA(rvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
   }
   if (length(rvote) != nrow(plans)) {
@@ -182,10 +182,10 @@ part_egap <- function(plans, shp, dvote, rvote) {
   dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
   rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
 
-  if (any(is.na(dvote))) {
+  if (anyNA(dvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
   }
-  if (any(is.na(rvote))) {
+  if (anyNA(rvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
   }
   if (length(rvote) != nrow(plans)) {
@@ -235,10 +235,10 @@ part_egap_ep <- function(plans, shp, dvote, rvote) {
   dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
   rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
 
-  if (any(is.na(dvote))) {
+  if (anyNA(dvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
   }
-  if (any(is.na(rvote))) {
+  if (anyNA(rvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
   }
   if (length(rvote) != nrow(plans)) {
@@ -289,10 +289,10 @@ part_tau_gap <- function(plans, shp, dvote, rvote, tau = 1) {
   dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
   rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
 
-  if (any(is.na(dvote))) {
+  if (anyNA(dvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
   }
-  if (any(is.na(rvote))) {
+  if (anyNA(rvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
   }
   if (length(rvote) != nrow(plans)) {
@@ -311,6 +311,63 @@ part_tau_gap <- function(plans, shp, dvote, rvote, tau = 1) {
   rep(taugap(tau = tau, dvs = dvs, dseat_vec = dseat_vec, nd = nd), each = nd)
 }
 
+#' Calculate Dilution Asymmetry
+#'
+#' @templateVar plans TRUE
+#' @templateVar shp TRUE
+#' @templateVar dvote TRUE
+#' @templateVar rvote TRUE
+#' @template template_nosf
+#'
+#' @returns A numeric vector. Can be shaped into a district-by-plan matrix.
+#' @export
+#' @concept partisan
+#'
+#' @references
+#' Sanford C. Gordon and Sidak Yntiso. 2024.
+#' Base Rate Neglect and the Diagnosis of Partisan Gerrymanders.
+#' Election Law Journal: Rules, Politics, and Policy. \doi{10.1089/elj.2023.0005}.
+#'
+#' @examples
+#' data(nh)
+#' data(nh_m)
+#' # For a single plan:
+#' part_dil_asym(plans = nh$r_2020, shp = nh, rvote = nrv, dvote = ndv)
+#'
+#' # Or many plans:
+#' part_dil_asym(plans = nh_m[, 3:5], shp = nh, rvote = nrv, dvote = ndv)
+#'
+part_dil_asym <- function(plans, shp, dvote, rvote) {
+
+  plans <- process_plans(plans)
+  dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
+  rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
+
+  if (anyNA(dvote)) {
+    cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
+  }
+  if (anyNA(rvote)) {
+    cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
+  }
+  if (length(rvote) != nrow(plans)) {
+    cli::cli_abort('{.arg rvote} length and {.arg plans} rows are not equal.')
+  }
+  if (length(dvote) != nrow(plans)) {
+    cli::cli_abort('{.arg dvote} length and {.arg plans} rows are not equal.')
+  }
+
+  nd <- length(unique(plans[, 1]))
+  rcounts <- agg_p2d(vote = rvote, dm = plans, nd = nd)
+  dcounts <- agg_p2d(vote = dvote, dm = plans, nd = nd)
+  half <- floor((rcounts + dcounts) / 2) + 1
+
+  waste_dem <- matrix(ifelse(rcounts > dcounts, dcounts, dcounts - half), nrow = nd)
+  waste_rep <- matrix(ifelse(dcounts > rcounts, rcounts, rcounts - half), nrow = nd)
+
+  dil <- colSums(waste_dem)/sum(dvote) - colSums(waste_rep)/sum(rvote)
+  rep(dil, each = nd)
+}
+
 #' Calculate Mean Median Score
 #'
 #' @templateVar plans TRUE
@@ -344,10 +401,10 @@ part_mean_median <- function(plans, shp, dvote, rvote) {
   dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
   rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
 
-  if (any(is.na(dvote))) {
+  if (anyNA(dvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
   }
-  if (any(is.na(rvote))) {
+  if (anyNA(rvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
   }
   if (length(rvote) != nrow(plans)) {
@@ -398,10 +455,10 @@ part_decl <- function(plans, shp, dvote, rvote, normalize = TRUE, adjust = TRUE)
   dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
   rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
 
-  if (any(is.na(dvote))) {
+  if (anyNA(dvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
   }
-  if (any(is.na(rvote))) {
+  if (anyNA(rvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
   }
   if (length(rvote) != nrow(plans)) {
@@ -462,10 +519,10 @@ part_decl_simple <- function(plans, shp, dvote, rvote) {
   dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
   rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
 
-  if (any(is.na(dvote))) {
+  if (anyNA(dvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
   }
-  if (any(is.na(rvote))) {
+  if (anyNA(rvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
   }
   if (length(rvote) != nrow(plans)) {
@@ -520,10 +577,10 @@ part_resp <- function(plans, shp, dvote, rvote, v = 0.5, bandwidth = 0.01) {
   dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
   rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
 
-  if (any(is.na(dvote))) {
+  if (anyNA(dvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
   }
-  if (any(is.na(rvote))) {
+  if (anyNA(rvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
   }
   if (length(rvote) != nrow(plans)) {
@@ -573,10 +630,10 @@ part_lop_wins <- function(plans, shp, dvote, rvote) {
   dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
   rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
 
-  if (any(is.na(dvote))) {
+  if (anyNA(dvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
   }
-  if (any(is.na(rvote))) {
+  if (anyNA(rvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
   }
   if (length(rvote) != nrow(plans)) {
@@ -627,10 +684,10 @@ part_rmd <- function(plans, shp, dvote, rvote) {
   dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
   rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
 
-  if (any(is.na(dvote))) {
+  if (anyNA(dvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
   }
-  if (any(is.na(rvote))) {
+  if (anyNA(rvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
   }
   if (length(rvote) != nrow(plans)) {
@@ -680,10 +737,10 @@ part_sscd <- function(plans, shp, dvote, rvote) {
   dvote <- rlang::eval_tidy(rlang::enquo(dvote), shp)
   rvote <- rlang::eval_tidy(rlang::enquo(rvote), shp)
 
-  if (any(is.na(dvote))) {
+  if (anyNA(dvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg dvote}.')
   }
-  if (any(is.na(rvote))) {
+  if (anyNA(rvote)) {
     cli::cli_abort('{.val NA} in argument to {.arg rvote}.')
   }
   if (length(rvote) != nrow(plans)) {

R/process.R

@@ -8,7 +8,7 @@ process_plans <- function(plans) {
   if (!is.matrix(plans)) {
     plans <- as.matrix(plans)
   }
-  if (any(is.na(plans))) {
+  if (anyNA(plans)) {
     cli::cli_abort('{.val NA} in argument to {.arg plans}.')
   }
   plans

R/splits.R

@@ -155,7 +155,7 @@ splits_count <- function(plans, shp, admin) {
   if (is.null(admin)) {
     cli::cli_abort('{.arg admin} not found in {.arg shp}.')
   }
-  if (any(is.na(admin))) {
+  if (anyNA(admin)) {
     cli::cli_abort(c('{.arg admin} may not contain {.val NA}.',
                      i = 'Consider using {.fn splits_sub_count} instead.'))
   }
@@ -213,7 +213,7 @@ splits_sub_count <- function(plans, shp, sub_admin) {
   }
   nc <- vctrs::vec_unique_count(sub_admin)
 
-  if (any(is.na(sub_admin))) {
+  if (anyNA(sub_admin)) {
     admin_splits_count(plans, sub_admin, nd, nc)[-max(sub_admin), ] |>
       `rownames<-`(value = stats::na.omit(row_names))
   } else {

src/partisan.cpp

@@ -98,7 +98,6 @@ NumericVector effgap(NumericMatrix dcounts, NumericMatrix rcounts, int totvote){
   return eg;
 }
 
-
 // [[Rcpp::export(rng = false)]]
 NumericVector taugap(double tau, NumericMatrix dvs, IntegerVector dseat_vec, int nd){
   NumericMatrix ai_mat = NumericMatrix(dvs.nrow(), dvs.ncol());

tests/testthat/test-partisan.R

@@ -133,3 +133,13 @@ test_that("part_tau_gap works", {
   e <- c(-0.98850905428411, -0.98850905428411, 0.0284448215286677, 0.0284448215286677)
   expect_equal(a, e, tolerance = 1e-4)
 })
+
+test_that("part_dil_asym works", {
+  a <- part_dil_asym(nh$r_2020, shp = nh, dvote = pre_20_dem_bid, rvote = pre_20_rep_tru)
+  e <- c(0.0889622939876797, 0.0889622939876797)
+  expect_equal(a, e, tolerance = 1e-4)
+
+  a <- part_dil_asym(nh_m[, 1:2], shp = nh, dvote = pre_20_dem_bid, rvote = pre_20_rep_tru)
+  e <- c(-0.930254640596044, -0.930254640596044, 0.0889622939876797, 0.0889622939876797)
+  expect_equal(a, e, tolerance = 1e-4)
+})

vignettes/party.Rmd

@@ -248,6 +248,16 @@ part_tau_gap(plans = nh$r_2020, shp = nh, dvote = ndv, rvote = nrv)
 
 The default is `tau = 1`.
 
+### Dilution Asymmetry
+
+The Dilution Asymmetry is the difference in rate of wasted votes by party. Wasted votes are as in the efficiency gap. A negative score indicates a pro-Democratic bias, whereas a positive score inidcates a pro-Republican bias.
+
+Formally, this can be written as:
+
+$$\textrm{Dilution Asymmetry} = \frac{W_D}{\textrm{votes}_D} - \frac{W_R}{\textrm{votes}_R}$$
+
+with $W_R$ as the wasted votes by Republicans and $W_D$ as the wasted votes by Democrats and $\textrm{votes}_D$ and$\textrm{votes}_R$ are the total votes for Democrats and Republicans, respectively.
+
 ### Smoothed Seat Count Deviation
 
 The Smoothed Seat Count Deviation offers an interpolation between seats when describing the number of seats won by a party. This can be added to the Democratic seats to describe the smoothed seat count.