Map Interface

# key setups
.libPaths('R:/Project/UWED/Master Team Folder/Code/site_libs/')
library(pacman)

pacman::p_load(
    sf, leaflet, leaflet.minicharts, leaflet.extras,
    tools, stringi, magrittr, htmltools, 
    DT, shiny, shinyjs, shinydashboard, sqldf, kableExtra, raster, rmapshaper, htmlwidgets,
    magrittr, tictoc, tidyverse, leafpop
)

#remotes::install_github("r-spatial/leafpop")

# db connection
source("R:/Project/UWED/code/dbconnect.R")
U <- uwed <- connectdb(dbname = "uwed", host = "doyenne.csde.washington.edu", user = "uwed_user", password = Sys.getenv("uwed_user_pgpassword"))

The map below show racial demographics by precinct in Washington in 2020. Hovering over the precinct shows the county and precinct name. Click on a precinct to see chart showing the total population broken down by race, as well as the registered voter population and the voting population, broken down by imputed race. The full dataset, containing years 2007-2023, is available for download in the Datasets tab, under Section 2.1.

# get PostGIS data
# all years
# v_sf <- st_read(dsn = U, layer = "precinct_census_cvap_agg_votes_piechart")

# 2020 only
v_sf <- v_sf_2020 <- st_read(dsn = U, layer = "v_precinct_census_cvap_agg_votes_piechart_2020")
v_sf_2020<- rmapshaper::ms_simplify(v_sf, keep_shapes = TRUE)

registrants <- read_csv('R:/Project/UWED/Master Team Folder/Data/Outputs/Registrant_Population_by_Precinct_Race_Year.csv')
voters <- read_csv('R:/Project/UWED/Master Team Folder/Data/Outputs/Voter_Population_by_Election_Precinct_Race_Year.csv')

# a function to create a pie chart
make_pl <- function(i, overwrite = FALSE, verbose = FALSE){
    message(i)
    x <- v_plots[i,]
    # year-create image dirs
    myyear <- x$electionyear
    # id, etc.
    xid <- x$fmoid
    # county, precinct
    mycounty <- x$county
    ctycode <- x$countycode
    myprecinct <- x$precinctname
    mytitle <- str_c(myyear, mycounty, str_to_title(myprecinct), sep = ", " )

    vot_sub <- voters %>% 
        filter(countycode == ctycode,
               precinctname == myprecinct,
               Year == 2020) %>%
        mutate(Type = 'Voted Population') %>%
        filter(row_number() == n())
    
    reg_sub <- registrants %>% 
        filter(countycode == ctycode,
               precinctname == myprecinct,
               Year == 2020) %>%
        mutate(Type = 'Registered Population')
    
    all <- bind_rows(vot_sub, reg_sub) %>%
        pivot_longer(cols = c('Total_Population', "Black_Pop", "White_Pop", "Hispanic_Pop", "Asian_Pop", "OtherRace_Pop")) %>%
        rename(Race = name,
               Population = value) %>%
        filter(Race != "Total_Population") %>%
        mutate(
            Race = str_remove_all(string = Race, pattern = "_Pop") %>%
                factor(levels = c("White", "Black", "Asian", "Hispanic", "OtherRace"), 
                       labels = c("White", "Black", "Asian", "Hispanic", "Other"))
        )
    
    
      
    g1 <- ggplot(data = all, aes(x = Race, y = Population)) +
         geom_col(aes(), show.legend = F) +
         theme_minimal() +
         geom_text(aes(label=ceiling(Population)), vjust = -1, color = "gray20") +
         ggtitle(paste0("Voting Population by Imputed Race in ", mycounty, " County, \n", str_to_title(myprecinct), " Precinct, ", myyear)) +
         theme(axis.text.x = element_text(angle = 45, hjust=1)) +
         ylim(c(0, max(all$Population)+ 0.05*max(all$Population))) +
        facet_wrap(~Type)

    
    # long format
    xl <- x %>% 
        select(matches("race")) %>% 
        gather() %>% 
        filter(key != "race_total") %>% 
        mutate(
            key = str_remove_all(string = key, pattern = "race_") %>% 
                factor(levels = c("white", "black", "aian", "asian", "nhpi", "hispanic", "other"), 
                       labels = c("White", "Black", "AIAN", "Asian", "NHPI", "Hispanic", "Other"))
            ) %>%
        rename(Race = key,
               Population = value)
    
    colors <- RColorBrewer::brewer.pal(7, "Dark2")
  
    g2 <- ggplot(data = xl, aes(x = Race, y = Population)) +
         geom_col(aes(fill = colors), show.legend = F) +
         theme_minimal() +
         geom_text(aes(label=ceiling(Population)), vjust = -1, color = "gray20") +
         ggtitle(paste0("Population by Race in ", mycounty, " County, \n", str_to_title(myprecinct), " Precinct, ", myyear)) +
         theme(axis.text.x = element_text(angle = 45, hjust=1)) +
         ylim(c(0, max(xl$Population)+ 0.05*max(xl$Population))) +
         labs(caption = "*AIAN: American Indian/Alaska Native\nNHPI: Native Hawaiin/Pacific Islander ")
    
    if(nrow(all != 0)){
        g_final <- cowplot::plot_grid(g2, g1, rows = 2, cols = 1)
    } else{
        g_final <- g2
    }

 return(g_final)
}


v_plots <- st_drop_geometry(v_sf_2020) 

registrants <- registrants %>%
    mutate(PRECNAME = tolower(PRECNAME)) %>%
    rename(precinctname = PRECNAME,
           countycode = COUNTYCODE)

voters <- voters %>%
    mutate(PRECNAME = tolower(PRECNAME)) %>%
    rename(precinctname = PRECNAME,
           countycode = COUNTYCODE)


pls <- lapply(c(1:nrow(v_plots)), make_pl)
# list of files for popup images
# L <- list.files(path = "R:/Project/UWED/html/images/2020/", pattern = ".*png", full.names = TRUE)

# labels for hover
labels <- v_sf_2020 %>%
    mutate(labs = paste0("County: ", county, "<br  />Precinct: ", str_to_title(precinctname)))%>%
    pull(labs) %>% 
    lapply(htmltools::HTML)

v_sf_simple <- ms_simplify(v_sf_2020, keep_shapes = TRUE)

m <- leaflet(data = v_sf_simple, width = "100%") %>%
    addProviderTiles(providers$CartoDB.Positron) %>%
    addPolygons(weight = 2, label = ~labels, group = "v_sf_simple", color = 'gray',
                fillColor = 'gray', opacity = 0.5,
                highlight = highlightOptions(
                      weight = 3,
                      fillOpacity = 0.6,
                      color = "gray",
                      opacity = 1.0,
                      bringToFront = TRUE,
                      sendToBack = TRUE) ) %>% 
    leafpop::addPopupGraphs(graph = pls, group = "v_sf_simple", height = 450, width = 300)

#leafpop::addPopupImages(image = L, group = "v_sf_2020")

m