Add cps_check_codes() warning and document 2022+ No Response discontinuity

.gitignore

@@ -25,3 +25,5 @@ claude.md
 /Meta/
 docs
 /doc/
+cpsvote.Rcheck/
+cpsvote_0.2.0.tar.gz

DESCRIPTION

@@ -41,7 +41,11 @@ Suggests:
     ggplot2,
     usmap,
     ggthemes,
-    tweenr
+    tweenr,
+    kableExtra,
+    ggrepel,
+    googlesheets4,
+    readxl
 VignetteBuilder: knitr
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.3

NAMESPACE

@@ -1,6 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 export("%>%")
+export(cps_check_codes)
 export(cps_data_dir)
 export(cps_docs_dir)
 export(cps_download_data)

NEWS.md

@@ -1,5 +1,6 @@
 # cpsvote 0.2
 
+- Add `cps_check_codes()`, which warns when a response documented in the codebook (e.g. the `-9` "No Response" code for `PES1`/`VRS_VOTE`) is entirely absent from a given year's data. `cps_recode_vote()` now calls this automatically. This catches a real discontinuity: the Census Bureau's public-use file stops including any `-9` respondents starting in 2022, without documenting the change (see `vignette("voting")` for details, h/t Michael Hanmer)
 - Include new 2020, 2022, and 2024 CPS VRS data
 - Note: 2024 microdata downloaded from Census Bureau (not NBER); VEP reweighting data from University of Florida Election Lab
 - Update maintainer and copyright info

R/cps_check_codes.R

@@ -0,0 +1,71 @@
+#' check that expected response codes actually appear in the data
+#'
+#' @description The Census Bureau occasionally changes how it codes
+#' nonresponse between survey years without documenting the change. For
+#' example, the `-9` ("No Response") code for `PES1`/`VRS_VOTE` appears in
+#' every CPS VRS release from 1994-2020, but is entirely absent starting in
+#' 2022 (the codebook still lists it, but no respondent is actually coded
+#' that way -- see `vignette("voting")` for details). Because
+#' [cps_label()] and [cps_recode_vote()] do not error when an expected
+#' response is simply absent, this kind of change can silently shift what
+#' population is excluded from `cps_turnout` and `hurachen_turnout` without
+#' any warning. This function compares the responses documented in `factors`
+#' for a given year against what is actually observed in `data`, and warns
+#' when a documented response is completely unobserved for a year where it
+#' should exist.
+#' @param data labelled CPS data (i.e. the output of [cps_label()]),
+#' containing `vote_col` and a `YEAR` column
+#' @param vote_col which column to check
+#' @param check_labels which labels (as they appear in `factors$value`,
+#' case-insensitive) to check for. Defaults to the three categories the
+#' Census treats as nonvoters: "Don't Know", "Refused", and "No Response"
+#' @param factors A data frame containing the label codes to be applied,
+#' as in [cps_label()]
+#' @param names_col Which column of `factors` contains the column names of
+#' `data`
+#' @return `data`, invisibly. This function is called for its side effect of
+#' issuing warnings.
+#' @examples cps_check_codes(cps_label(cps_2024_10k))
+#'
+#' @export
+cps_check_codes <- function(data,
+                            vote_col = "VRS_VOTE",
+                            check_labels = c("DON'T KNOW", "REFUSED", "NO RESPONSE"),
+                            factors = cpsvote::cps_factors,
+                            names_col = "new_name") {
+
+  if (!(vote_col %in% colnames(data)) || !("YEAR" %in% colnames(data))) {
+    return(invisible(data))
+  }
+
+  # numeric (pre-`cps_label()`) data isn't labelled yet, so there's nothing
+  # to compare against `factors$value`
+  if (is.numeric(data[[vote_col]])) {
+    return(invisible(data))
+  }
+
+  check_labels <- toupper(check_labels)
+
+  for (yr in sort(unique(data$YEAR))) {
+    documented <- toupper(factors$value[factors[[names_col]] == vote_col & factors$year == yr])
+    expected <- intersect(check_labels, documented)
+    if (length(expected) == 0) next
+
+    observed <- toupper(as.character(data[[vote_col]][data$YEAR == yr]))
+    missing <- expected[!(expected %in% observed)]
+
+    if (length(missing) > 0) {
+      warning(
+        "cps_check_codes: for YEAR = ", yr, ", column '", vote_col, "', the codebook ",
+        "documents the response(s) ", paste(sQuote(missing), collapse = ", "),
+        " but none of them appear in the data. This usually means the Census Bureau ",
+        "changed its coding of nonresponse for this year (see vignette(\"voting\") for ",
+        "the 2022+ `-9`/No Response discontinuity), and turnout estimates from ",
+        "`cps_recode_vote()` / `cps_reweight_turnout()` may be biased as a result.",
+        call. = FALSE
+      )
+    }
+  }
+
+  invisible(data)
+}

R/refactor.R

@@ -148,20 +148,26 @@ cps_refactor <- function(data, move_levels = TRUE) {
 #' where multiple categories map to "No", and one which follows the guidelines 
 #' from Hur & Achen (2013) of setting these categories to `NA`. See the Vignette 
 #' for more information on this process.
+#' @details Before recoding, this function calls [cps_check_codes()], which
+#' warns if any of `items` is documented in the codebook for a given year but
+#' never actually observed in the data -- as happens with the `-9` ("No
+#' Response") code starting in 2022. See `vignette("voting")` for details.
 #' @param data the input data set
 #' @param vote_col which column contains the voting variable
-#' @param items which items should be "No" in the CPS coding and `NA` in the 
+#' @param items which items should be "No" in the CPS coding and `NA` in the
 #' Hur & Achen coding
-#' 
+#'
 #' @return `data` with two columns attached, `cps_turnout` and `hurachen_turnout`,
 #' voting variables recoded according to the process above
 #' @importFrom rlang .data
 #' @examples cps_recode_vote(cps_refactor(cps_label(cps_2016_10k)))
-#' 
+#'
 #' @export
-cps_recode_vote <- function(data, 
+cps_recode_vote <- function(data,
                             vote_col = "VRS_VOTE",
                             items = c("DON'T KNOW", "REFUSED", "NO RESPONSE")) {
+  cps_check_codes(data, vote_col = vote_col, check_labels = items)
+
   if (is.numeric(data[[vote_col]])) {
     output <- dplyr::mutate(data,
                             cps_turnout = dplyr::case_when(

sandbox/make_massachusetts_gif.R

@@ -0,0 +1,25 @@
+# Animated ternary plot of Massachusetts's vote mode share over time
+# (1996-2024), all years. A single dot labeled "MA", with a trail showing
+# its path through the ternary space over time.
+
+library(here)
+library(dplyr)
+source(here("sandbox", "ternary_gif_lib.R"))
+
+vote_mode <- readRDS(here("sandbox", "vote_mode_data.rds")) %>%
+  filter(STATE == "MA")
+
+years_seq <- seq(1996, 2024, 2)
+
+make_vote_mode_gif(
+  vote_mode = vote_mode,
+  years_seq = years_seq,
+  output_gif = here("sandbox", "massachusetts_vote_mode.gif"),
+  title = "The Move Away From Election Day Voting in Massachusetts",
+  subtitle = "Share of votes cast by mode, 1996-2024",
+  highlight_states = c("MA"),
+  highlight_color = "red",
+  trail = TRUE
+)
+
+cat("Wrote", here("sandbox", "massachusetts_vote_mode.gif"), "\n")

sandbox/make_midterm_gif.R

@@ -0,0 +1,19 @@
+# Animated ternary plot of vote mode share by state, midterm election years
+# only (1998-2022). One dot per state per year.
+
+library(here)
+source(here("sandbox", "ternary_gif_lib.R"))
+
+vote_mode <- readRDS(here("sandbox", "vote_mode_data.rds"))
+
+years_seq <- seq(1998, 2022, 4)
+
+make_vote_mode_gif(
+  vote_mode = vote_mode,
+  years_seq = years_seq,
+  output_gif = here("sandbox", "midterm_vote_mode.gif"),
+  title = "The Move Away From Election Day Voting in America",
+  subtitle = "Midterm elections: share of votes cast by mode, 1998-2022"
+)
+
+cat("Wrote", here("sandbox", "midterm_vote_mode.gif"), "\n")

sandbox/make_presidential_gif.R

@@ -0,0 +1,19 @@
+# Animated ternary plot of vote mode share by state, presidential election
+# years only (1996-2024). One dot per state per year.
+
+library(here)
+source(here("sandbox", "ternary_gif_lib.R"))
+
+vote_mode <- readRDS(here("sandbox", "vote_mode_data.rds"))
+
+years_seq <- seq(1996, 2024, 4)
+
+make_vote_mode_gif(
+  vote_mode = vote_mode,
+  years_seq = years_seq,
+  output_gif = here("sandbox", "presidential_vote_mode.gif"),
+  title = "The Move Away From Election Day Voting in America",
+  subtitle = "Presidential elections: share of votes cast by mode, 1996-2024"
+)
+
+cat("Wrote", here("sandbox", "presidential_vote_mode.gif"), "\n")

sandbox/prep_vote_mode_data.R

@@ -0,0 +1,32 @@
+# Purpose: Build the weighted YEAR x STATE vote-mode share table used by the
+# three ternary-plot GIF scripts (presidential years, midterm years, MA-only).
+# This is the same data-prep pipeline as sandbox/animate_snowglobe.R, factored
+# out so it only needs to run once.
+
+library(dplyr)
+library(tidyr)
+library(srvyr)
+library(here)
+
+devtools::load_all(here(), quiet = TRUE)
+
+options(cpsvote.datadir = here("cps_data"))
+
+cps <- cps_load_basic(years = seq(1996, 2024, 2))
+
+cps_weighted <- cps %>%
+  filter(YEAR > 1995) %>%
+  srvyr::as_survey_design(weights = turnout_weight)
+
+vote_mode <- cps_weighted %>%
+  select(YEAR, STATE, VRS_VOTEMETHOD_CON) %>%
+  filter(if_all(everything(), ~ !is.na(.x))) %>%
+  group_by(YEAR, STATE, VRS_VOTEMETHOD_CON) %>%
+  summarize(survey_mean(na.rm = TRUE)) %>%
+  select(-ends_with('_se')) %>%
+  pivot_wider(id_cols = c("YEAR", "STATE"), names_from = "VRS_VOTEMETHOD_CON", values_from = "coef",
+              values_fill = 0)
+
+saveRDS(vote_mode, here("sandbox", "vote_mode_data.rds"))
+
+cat("Saved", nrow(vote_mode), "rows across years:", paste(sort(unique(vote_mode$YEAR)), collapse = ", "), "\n")