updates from utils/update.r scripts, adding CI paramteres to ei_iter,…

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: eiCompare
 Type: Package
 Title: Compares Different Ecological Inference Methods
-Version: 3.0.3
+Version: 3.0.4
 Authors@R: 
     c(person(given = "Loren",
              family = "Collingwood",
@@ -43,11 +43,11 @@ License: GPL-3
 Depends: R (>= 3.5.0), eiPack, ei, wru (>= 1.0.0)
 Imports: bayestestR, coda, data.table, doSNOW,
         dplyr, foreach, ggplot2, graphics, magrittr, mcmcse, methods,
-        overlapping, purrr, rlang, sf, stringr, tidyr,tidyselect
+        overlapping, purrr, rlang, sf, stringr, tidyr, tidyselect, viridis
 NeedsCompilation: no
 Suggests: knitr, plyr, rmarkdown, reshape2, RColorBrewer,
         RJSONIO, testthat, tigris
-RoxygenNote: 7.2.1
+RoxygenNote: 7.3.2
 Encoding: UTF-8
 VignetteBuilder: knitr
 Packaged: 2020-09-08 07:00:35 UTC; lorencollingwood

NAMESPACE

@@ -40,7 +40,9 @@ export(predict_race_multi_barreled)
 export(race_cand_cors)
 export(race_check_2_3)
 export(resolve_missing_vals)
+export(rpv_coef_plot)
 export(rpv_density)
+export(rpv_toDF)
 export(stdize_votes)
 export(stdize_votes_all)
 export(strip_special_characters)

NEWS.md

@@ -1,3 +1,13 @@
+# eiCompare 3.0.4
+
+## Package changes
+
+* incorporated rpv_coef_plot() and rpv_toDF() functions from eiExpand package
+* edited ei_iter() to have flexible CI parameters (default is 0.95) using bayestestR for calculation and updated column naming, and to use reproducible parallel processing (.inorder=TRUE)
+* edited ei_rxc() with repdocuible parallel processing and changed column naming to fit ei_iter()
+* Fixed summary.eiCompare() print behavior
+* Added viridis to imports for color visualiztion and updated RoxygenNote to 7.3.2
+
 # eiCompare 3.0.3
 
 ## Package changes

R/data.R

@@ -339,3 +339,11 @@
 #' @usage data(gwinnett_ei)
 "gwinnett_ei"
 
+#' Example RPV analysis results in Washington State
+#'
+"example_rpvDF"
+
+#' Example election and demographic data from South Carolina 2020 General Elections
+#' 
+"south_carolina"
+

R/ei_iter.R

@@ -38,6 +38,8 @@
 #' @param n_cores The number of cores to use in parallel computation. Defaulted to NULL, in which case parallel::detectCores() - 1 is used
 #' @param verbose A boolean indicating whether to print out status messages.
 #' @param plot_path A string to specify plot save location. If NULL, plot is not saved
+#' @param CI  Numeric. Confidence interval level (default = 0.95). Specifies the
+#'   interval width for calculation with bayestestR package.
 #' @param ... Additional arguments passed directly to ei::ei()
 #'
 #' @return If eiCompare_class = TRUE, an object of class eiCompare is returned.
@@ -76,6 +78,7 @@ ei_iter <- function(
                     n_cores = NULL,
                     verbose = FALSE,
                     plot_path = NULL,
+                    CI = .95,
                     ...) {
 
   # Preparation for parallel processing if user specifies parallelization
@@ -156,7 +159,7 @@ ei_iter <- function(
   # Loop through each 2x2 ei
   ei_results <- foreach::foreach(
     i = seq_len(n_iters),
-    .inorder = FALSE,
+    .inorder = TRUE,
     .packages = c("ei", "stats", "utils", "mvtnorm"),
     .options.snow = opts
   ) %myinfix% {
@@ -200,11 +203,6 @@ ei_iter <- function(
               )
           })
           break
-          # This was meant to enable parameterization of the ei importance sample
-          # size, but its inclusion changes results dramatically.
-          # utils::capture.output({
-          #  ei_out <- suppressMessages(ei_sim(ei_out, samples))
-          # })
         },
         error = function(cond) {
           if (ii == n_erhos) {
@@ -393,7 +391,7 @@ ei_iter <- function(
       # Both CIs
       suppressMessages({
         suppressWarnings({
-          cis <- bayestestR::ci(aggs, ci = 0.95, method = "HDI")
+          cis <- bayestestR::ci(aggs, ci = CI, method = "HDI")
         })
       })
       ci_lowers <- append(ci_lowers, cis$CI_low)
@@ -436,9 +434,9 @@ ei_iter <- function(
     estimates <- data.frame(cbind(means, sds, ci_lowers, ci_uppers))
     estimates <- cbind(cands, races, estimates)
     colnames(estimates) <- c(
-      "cand", "race", "mean", "sd", "ci_95_lower", "ci_95_upper"
+      "cand", "race", "mean", "sd",
+      "ci_lower", "ci_upper"
     )
-
     output <- list(
       "type" = "iter",
       "estimates" = estimates,

R/ei_rxc.R

@@ -162,12 +162,12 @@ ei_rxc <- function(
 
     md_mcmc <- foreach::foreach(
       chain = seq_len(n_chains),
-      .inorder = FALSE,
+      .inorder = TRUE,
       .packages = c("ei"),
       .options.snow = opts
-    ) %myinfix% {
-      # Bayes model estimation
-      suppressWarnings(
+      ) %myinfix%  {
+        # Bayes model estimation
+        suppressWarnings(
         md_out <- ei.MD.bayes(
           formula = formula,
           sample = samples,
@@ -263,14 +263,14 @@ ei_rxc <- function(
 
     # Get point estimates and standard errors
     estimate <- mcmcse::mcse.mat(chains_pr)
-
+    
     # Get standard deviation of each distribution
     sds <- apply(chains_pr, 2, stats::sd)
 
     # The upper and lower CI estimates also have standard errors. Here these
     # errors are conservatively used to extend the 95% confidence bound further
 
-    # Set bounds according to
+    # Set bounds according to   
     if (eiCompare_class) {
       # eiCompare class object reports fixed CIs
       ci_lower <- 0.025
@@ -284,27 +284,27 @@ ei_rxc <- function(
         message(paste("Setting CI upper bound equal to", ci_upper))
       }
     }
-
+    
     # Lower CI estimate
     lower <- mcmcse::mcse.q.mat(chains_pr, q = ci_lower)
     lower_est <- lower[, 1]
     lower_se <- lower[, 2]
     lower <- lower_est - lower_se
-
+    
     # Upper CI estimate
     upper <- mcmcse::mcse.q.mat(chains_pr, q = ci_upper)
     upper_est <- upper[, 1]
     upper_se <- upper[, 2]
     upper <- upper_est + upper_se
-
+    
     # Get race and cand cols for the final table
     cand_col <- rep(cand_cols, each = length(race_cols))
     race_col <- rep(race_cols, times = length(cand_cols))
-
+    
     # Put names on chains_pr
     names <- paste(cand_col, race_col, sep = "_")
     colnames(chains_pr) <- names
-
+    
     # Create, name an output table
     results_table <- data.frame(cbind(estimate[, 1], sds, lower, upper))
     results_table <- cbind(cand_col, race_col, results_table)
@@ -320,14 +320,14 @@ ei_rxc <- function(
       )
     } else {
       colnames(results_table) <- c(
-        "cand", "race", "mean", "sd", "ci_95_lower", "ci_95_upper"
+        "cand", "race", "mean", "sd", "ci_lower", "ci_upper"
       )
     }
 
     if (!eiCompare_class) {
       # Match expected output
       results_table <- get_md_bayes_gen_output(results_table)
-
+      
       # Return results and chains if requested
       if (ret_mcmc) {
         return(list(table = results_table, chains = chains_pr))

R/rpv_coef_plot.R

@@ -0,0 +1,161 @@
+#' @export
+#' @import ggplot2
+#' @importFrom rlang .data
+#'
+#' @author Rachel Carroll <rachelcarroll4@gmail.com>
+#' @author Stephen El-Khatib <stevekhatib@gmail.com>
+#' @author Loren Collingwood <lcollingwood@unm.edu>
+#'
+#' @title Racially Polarized Voting Analysis (RPV) Coefficient Plot
+#' @description Creates a coefficient plot showing of RPV results estimate ranges
+#' of all contests by voter race
+#' @param rpvDF A data.frame containing RPV results
+#' @param title The plot title
+#' @param caption The plot caption
+#' @param ylab Label along y axis
+#' @param colors Character vector of colors, one for each racial group. The order
+#' of colors will be respective to the order of racial groups.
+#' @param race_order Character vector of racial groups from the \code{voter_race} column of
+#' \code{rpvDF} in the order they should appear in the plot. If not specified,
+#' the race groups will appear in alphabetical order.
+#'
+#' @return Coefficient plot of RPV analysis as a ggplot2 object
+#'
+#' @examples
+#'library(eiCompare)
+#'data(example_rpvDF)
+#'
+#'dem_rpv_results <- example_rpvDF %>% dplyr::filter(Party == "Democratic")
+#'rpv_coef_plot(dem_rpv_results)
+#'
+rpv_coef_plot <- function(
+    rpvDF = NULL,
+    title = "Racially Polarized Voting Analysis Estimates",
+    caption = "Data: eiCompare RPV estimates",
+    ylab = NULL,
+    colors = NULL,
+    race_order = NULL
+  ) {
+
+  # -----------------------------    QC CHECKS    -----------------------------
+
+  colnames(rpvDF) <- stringr::str_to_lower(colnames(rpvDF))
+
+  ##### new code (copied from eiExpand lines 40-58)
+  # make sure rpvDF argument is defined
+  if(is.null(rpvDF)){stop("you must include rpvDF argument")}
+
+  # make sure necessary columns are included
+  dif <- setdiff(c("party", "voter_race", "estimate", "lower_bound", "upper_bound"),
+          colnames(rpvDF))
+
+  if( length(dif) > 0 ) {
+    stop(paste("rpvDF is missing the following fields:",
+               paste(dif, collapse = ", ")))
+  }
+
+  # make sure only one party is in rpvDF
+  if( length(unique(rpvDF$party)) > 1 ){
+    stop("rpvDF should only contain one unique values in column Party")}
+  ##### end QC checks
+
+  # ----------------------   Prep Data and Plot Inputs   ----------------------
+
+  ##### Voter Race Order #####
+  ##### old code (from Updates_7_1_2024.R)
+  # rpvDF$voter_race <- factor(rpvDF$voter_race, levels = race_order)
+  ##### new code (copied from eiExpand lines 64-69)
+  # proper case for plot
+  rpvDF$voter_race <- stringr::str_to_title(rpvDF$voter_race)
+  #get factor order if not specified
+  if( is.null(race_order) ) { race_order <- sort(unique(rpvDF$voter_race)) }
+  #set factor
+  rpvDF$voter_race <- factor(rpvDF$voter_race,
+                             levels = race_order)
+
+  ##### Colors #####
+  len_race <- length(unique(rpvDF$voter_race))
+  ##### old code (from Updates_7_1_2024.R)
+  # if (is.null(colors)) {
+  #   if (len_race == 2) {
+  #     race_colors <- c(viridis::viridis(10)[4], viridis::viridis(10)[7])
+  #     names(race_colors) <- race_order
+  #     ggplot_color_obj <- scale_color_manual(values = race_colors)
+  #   }
+  #   else {
+  #     ggplot_color_obj <- viridis::scale_color_viridis(drop = FALSE,
+  #                                                      discrete = TRUE, option = "turbo", alpha = 0.8)
+  #   }
+  # }
+  ##### new code (copied from eiExpand lines 71-85)
+  if( is.null(colors) ){
+    if( len_race == 2 ){
+      race_colors <- c(viridis::viridis(10)[4], viridis::viridis(10)[7])
+      names(race_colors) <- race_order
+
+      ggplot_color_obj <- scale_color_manual(values = race_colors)
+
+    } else {
+      ggplot_color_obj <- viridis::scale_color_viridis(drop = FALSE,
+                                                       discrete = TRUE,
+                                                       option = "turbo",
+                                                       alpha = .8)
+    }
+  } # END  if( is.null(colors) )
+
+  ##### ylab #####
+  if( is.null(ylab) ){
+    prty <- unique(rpvDF$party) %>% stringr::str_to_title()
+    ylab <- paste("Percent Voting for", prty,  "Candidate")
+  }
+
+  ##### mean percent vote for label #####
+  mean <- rpvDF %>%
+    dplyr::group_by(.data$voter_race) %>%
+    dplyr::summarize(avg = mean(.data$estimate))
+
+  rpvDF <- dplyr::left_join(rpvDF, mean, by = "voter_race")
+  rpvDF$panelLab <- paste0(rpvDF$voter_race, "\n(mean: ", round(rpvDF$avg,1), "%)")
+
+  # --------------------------      Build Plot       --------------------------
+
+  coef_plot <- ggplot(rpvDF,
+                      aes(x = 0, y = 0:100)) +
+    scale_y_continuous(breaks = seq(0,100, by = 10),
+                       limits = c(0, 100),
+                       labels = sprintf("%0.1f%%", seq(0,100, by = 10)),
+                       expand = c(0, 0)) +
+    geom_hline(yintercept = 50, colour = "#000000", size = 0.75) +  # Line at 0
+    geom_pointrange(aes(y = .data$estimate,
+                        ymin = .data$lower_bound,
+                        ymax = .data$upper_bound,
+                        color = .data$voter_race),
+                    position = position_jitter(width = 0.1),
+                    size = 2,
+                    fatten = 1.5,
+                    show.legend = F) +  # Ranges for each coefficient
+    ggplot_color_obj +
+    facet_grid(~panelLab) +
+        labs(y = ylab,
+         title = title,
+         caption = caption) +  # Labels
+    theme_minimal() +
+    theme(legend.title = element_blank(),
+          axis.title.x = element_blank(),
+          axis.ticks.x = element_blank(),
+          axis.text.x  = element_blank(),
+          panel.border = element_rect(fill = NA, colour = "grey"),
+          panel.grid.major.x = element_blank(),
+          panel.grid.minor.x = element_blank(),
+          panel.grid.minor.y = element_blank(),
+          axis.text.y = element_text(size = 20, face = "bold", family = "serif"),
+          axis.title.y = element_text(size = 24, face = "bold", family = "serif"),
+          strip.text.x = element_text(size = 15, face = "bold", family = "serif"),
+          #strip.text.x = element_blank(),
+          title = element_text(size = 30, hjust = .5, face = "bold", family = "serif"),
+          plot.caption = element_text(size = 12, face = "italic", family = "serif")
+          )
+
+# --------------------------        Return         --------------------------
+  return(coef_plot)
+}