Merge pull request #125 from mdblocker/drop_bad_geos

Update to census_helper_v2

DESCRIPTION

@@ -33,6 +33,7 @@ Depends:
 Imports:
     cli,
     dplyr,
+    tidyr,
     furrr,
     future,
     piggyback (>= 0.1.4),

R/census_helper_v2.R

@@ -42,6 +42,9 @@
 #' @param retry The number of retries at the census website if network interruption occurs.
 #' @param use.counties A logical, defaulting to FALSE. Should census data be filtered by counties 
 #' available in \var{census.data}?
+#' @param skip_bad_geos Logical. Option to have the function skip any geolocations that are not present 
+#' in the census data, returning a partial data set. Default is set to \code{FALSE}, which case it will 
+#' break and provide error message with a list of offending geolocations.
 #' @return Output will be an object of class \code{data.frame}. It will 
 #'  consist of the original user-input data with additional columns of 
 #'  Census data.
@@ -65,8 +68,10 @@ census_helper_new <- function(
     year = "2020",
     census.data = NULL,
     retry = 3,
-    use.counties = FALSE
+    use.counties = FALSE,
+    skip_bad_geos = FALSE
 ) {
+
   if (geo == "precinct") {
     stop("Error: census_helper_new function does not currently support precinct-level data.")
   }
@@ -198,11 +203,15 @@ census_helper_new <- function(
     #Check if geolocation missing from census object
     if(any(is.na(voters.census$r_whi))){
       miss_ind <- which(is.na(voters.census$r_whi))
-      stop("The following locations in the voter.file are not available in the census data ",
+      message("The following locations in the voter.file are not available in the census data.",
            paste0("(listed as ", paste0(c("state",geo.merge), collapse="-"),"):\n"),
            paste(do.call(paste, c(unique(voters.census[miss_ind, c("state",geo.merge)]),
                                   sep="-")),
                  collapse = ", "))
+      if(skip_bad_geos == TRUE){
+        message("NOTE: Skipping unavailable geolocations. Returning partial data set.")
+      voters.census <- tidyr::drop_na(voters.census, r_whi)}
+      else(stop("Stopping predictions. Please revise census data and/or verify the correct year is being supplied. To skip these rows use 'skip_bad_geos = TRUE'"))
     }
 
     # }

R/predict_race.R

@@ -75,6 +75,9 @@
 #' it should be coded as 1 for Democrat, 2 for Republican, and 0 for Other.
 #' @param retry The number of retries at the census website if network interruption occurs.
 #' @param impute.missing Logical, defaults to TRUE. Should missing be imputed?
+#' @param skip_bad_geos Logical. Option to have the function skip any geolocations that are not present 
+#' in the census data, returning a partial data set. Default is set to \code{FALSE}, in which case it
+#' will break and provide error message with a list of offending geolocations.
 #' @param use.counties A logical, defaulting to FALSE. Should census data be filtered by counties 
 #' available in \var{census.data}?
 #' @param model Character string, either "BISG" (default) or "fBISG" (for error-correction, 
@@ -150,6 +153,7 @@ predict_race <- function(
     party = NULL,
     retry = 3,
     impute.missing = TRUE,
+    skip_bad_geos = FALSE,
     use.counties = FALSE,
     model = "BISG",
     race.init = NULL,
@@ -220,6 +224,7 @@ predict_race <- function(
                               census.data = census.data,
                               retry = retry,
                               impute.missing = impute.missing,
+                              skip_bad_geos = skip_bad_geos,
                               census.surname = census.surname,
                               use.counties = use.counties)
   } else {
@@ -237,6 +242,7 @@ predict_race <- function(
       if(ctrl$verbose){
         message("Using `predict_race` to obtain initial race prediction priors with BISG model")
       }
+
       race.init <-  predict_race(voter.file = voter.file,
                                  names.to.use = names.to.use,
                                  year = year,
@@ -248,10 +254,12 @@ predict_race <- function(
                                  census.data = census.data,
                                  retry = retry,
                                  impute.missing = TRUE,
+                                 skip_bad_geos = skip_bad_geos,
                                  census.surname = census.surname,
                                  use.counties = use.counties,
                                  model = "BISG",
                                  control = list(verbose=FALSE))
+
       race.init <- max.col(
         race.init[, paste0("pred.", c("whi", "bla", "his", "asi", "oth"))],
         ties.method = "random"

R/race_prediction_funs.R

@@ -26,6 +26,7 @@
 #' @param party See documentation in \code{race_predict}.
 #' @param retry See documentation in \code{race_predict}.
 #' @param impute.missing See documentation in \code{race_predict}.
+#' @param skip_bad_geos See documentation in \code{race_predict}.
 #' @param names.to.use See documentation in \code{race_predict}.
 #' @param race.init See documentation in \code{race_predict}.
 #' @param name.dictionaries See documentation in \code{race_predict}.
@@ -268,6 +269,7 @@ NULL
 #' New race prediction function, implementing classical BISG with augmented
 #' surname dictionary, as well as first and middle name information.
 #' @rdname modfuns
+
 predict_race_new <- function(
     voter.file,
     names.to.use,
@@ -281,6 +283,7 @@ predict_race_new <- function(
     census.data = NULL,
     retry = 0,
     impute.missing = TRUE,
+    skip_bad_geos = FALSE,
     census.surname = FALSE,
     use.counties = FALSE
 ) {
@@ -379,7 +382,8 @@ predict_race_new <- function(
       year = year,
       census.data = census.data, 
       retry = retry,
-      use.counties = use.counties
+      use.counties = use.counties,
+      skip_bad_geos = skip_bad_geos
     )
   }
 
@@ -433,6 +437,7 @@ predict_race_new <- function(
 #' surname dictionary, as well as first and middle name information.
 #' @importFrom dplyr pull
 #' @rdname modfuns
+
 predict_race_me <- function(
     voter.file,
     names.to.use,

tests/testthat/test-predict_race_2010.R

@@ -125,7 +125,7 @@ test_that("Fails on territories", {
   )
 }) 
 
-test_that("Fails on missing geolocation", {
+test_that("Fails on missing geolocation if skip_bad_geos default is used", {
   skip_on_cran()
   set.seed(42)
   data(voters)
@@ -138,10 +138,27 @@ test_that("Fails on missing geolocation", {
     census.data = census, 
     use.counties = TRUE)
   ),
-  "The following locations in the voter\\.file are not available"
+  "Stopping predictions. Please revise"
   )
 })
 
+test_that("Skip_bad_geos option successfully returns working geolocations", {
+  skip_on_cran()
+  set.seed(42)
+  data(voters)
+  census <- readRDS(test_path("data/census_test_nj_block_2010.rds"))
+  test_drop <- suppressMessages(predict_race(
+    voter.file = voters[voters$state == "NJ", ], 
+    year = 2010,
+    census.geo = "block", 
+    census.key = NULL, 
+    census.data = census,
+    skip_bad_geos = TRUE,
+    use.counties = TRUE)
+  )
+  expect_equal(nrow(test_drop), 6)
+})
+
 test_that("Handles zero-pop. geolocations", {
   skip_on_cran()
   set.seed(42)

tests/testthat/test-predict_race_2020.R

@@ -120,7 +120,7 @@ test_that("Fails on territories", {
   )
 }) 
 
-test_that("Fails on missing geolocation", {
+test_that("Fails on missing geolocation if skip_bad_geos default is used", {
   skip_on_cran()
   set.seed(42)
   data(voters)
@@ -132,10 +132,26 @@ test_that("Fails on missing geolocation", {
     census.data = census, 
     use.counties = TRUE)
   ),
-  "The following locations in the voter\\.file are not available"
+  "Stopping predictions. Please revise"
   )
 })
 
+test_that("Skip_bad_geos option successfully returns working geolocations", {
+  skip_on_cran()
+  set.seed(42)
+  data(voters)
+  census <- readRDS(test_path("data/census_test_nj_block_2020.rds"))
+  test_drop <- suppressMessages(predict_race(
+    voter.file = voters[voters$state == "NJ", ], 
+    census.geo = "block", 
+    census.key = NULL, 
+    census.data = census,
+    skip_bad_geos = TRUE,
+    use.counties = TRUE)
+  )
+  expect_equal(nrow(test_drop), 1)
+  })
+
 test_that("Handles zero-pop. geolocations", {
   skip_on_cran()
   set.seed(42)