#' map_bgs
#'
#' Map the average block group mnrisks results with leaflet
#' @param data The dataframe or sf object containing the modeling results for mapping.
#' @param result_col Column name containing the modeling concentration/risk results.
#' @param geoid_col Block group GEOID colulmn name for mapping results.
#' @param colors Color palette to use for block group fill, ex. "viridis", "inferno", "Blues", "Greens"
#' @param reverse_colors Flip the color palette order
#' @param signif_digits Number of significant figures to show in map labels.
#' @keywords Map average blockgroup mnrisks leaflet
#' @export
#' @examples
#' # For all block groups
#' map_bgs(data = mnrisk_results,
#' result_col = "avg_cancer_risk",
#' colors = "Blues")
#
map_bgs <- function(data = NULL,
result_col = "avg_risk",
geoid_col = "geoid",
colors = "viridis",
reverse_colors = T,
signif_digits = 3) {
if (is.null(data) | !"data.frame" %in% class(data)) stop("Incorrect data passed to function. Set `data` argument to the 'data.frame' or 'sf' object containing the modeling results.")
if (!result_col %in% names(data)) stop(paste("The result_col [", result_col, "] was not found in the data."))
if (!geoid_col %in% names(data)) stop(paste("The geoid_col [", geoid_col, "] was not found in the data."))
max_result <- max(data[, result_col], na.rm = T)
names(data)[grep(result_col, names(data))] <- "avg_result"
names(data) <- tolower(names(data))
pal <- colorNumeric(palette = colors, domain = data$avg_result, reverse = reverse_colors)
#pal <- leaflet::colorNumeric("viridis", quantile(data$avg_result, c(seq(0,0.9,0.1),0.95,0.97,1)), reverse = T)
if (!'sf' %in% class(data)) {
bgs <- get_bg_shapes()
names(bgs) <- tolower(names(bgs))
bgs <- dplyr::left_join(bgs, data, by = c("geoid" = tolower(geoid_col)))
} else {
bgs <- data
}
bgs$label <- paste0("<h2>",
result_col,
"</h2><h1 style='text-align: center; color: grey;'>",
signif(bgs$avg_result, signif_digits), "</h1>")
leaflet(bgs %>% subset(!is.na(avg_result))) %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addPolygons(fillColor = ~pal(avg_result),
color = ~pal(avg_result),
fillOpacity = ~0.45*avg_result/max_result + 0.35, # Scale the opacity up to 0.8 for highest risks
weight = 1,
stroke = T,
smoothFactor = 0.5,
opacity = ~0.4*avg_result/max_result + 0.3, # Scale the border opacity up to 0.7 for highest risks
label = ~lapply(label, htmltools::HTML),
popup = ~lapply(label, htmltools::HTML)) %>%
addLegend("bottomright",
pal = pal,
values = ~avg_result,
title = result_col,
opacity = 0.7)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.