Dynamically render choropleth map with sliderInput in R shiny - r

I have shapefile which I am reading into R using readOGR to convert it to SpatialPolygonDataframe. The attribute table looks as shown in the figure below.
Each row is a zone (postal code area) and there are values for each hour of the day eg: h_0, h_1, ...h_23 measured for each zone. In my shiny app I want to show a map which changes as the user select a particular hour using sliderInput widget. The shiny app looks like below:
The code that produces the above result is here:
library(shiny)
library(leaflet)
library(reshape2)
library(maps)
library(mapproj)
library(rgdal)
library(RColorBrewer)
library(sp)
library(rgeos)
ui <- fluidPage(
titlePanel("Title"),
sidebarLayout(
sidebarPanel(
tabsetPanel(id= "tabs",
tabPanel("Map", id = "Map",
br(),
p("Choose options below to interact with the Map"),
sliderInput("hour", "Select the hours", min = 0 , max = 23,
value = 7, step = 1, dragRange= TRUE)
)
)
),
mainPanel(
tabsetPanel(type= "tabs",
tabPanel("Map", leafletOutput(outputId = "map"))
)
)
)
)
server <- function(input, output) {
layer <- reactive( {
shp = readOGR("shp",layer = "attractiveness_day3")
shp_p <- spTransform(shp, CRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0"))
})
output$map <- renderLeaflet({
bins<- c(0, 2000, 4000, 8000, 16000, Inf)
pal <- colorBin("YlOrRd", domain = layer()$h_7, bins = bins)
leaflet(layer()) %>%
setView(13.4, 52.5, 9) %>%
addTiles()%>%
addPolygons(
fillColor = ~pal(h_7),
weight = 0.0,
opacity = 1,
color = "white",
dashArray = "3",
fillOpacity = 0.7
) %>%
addLegend(pal = pal, values = ~h_7, opacity = 0.7, title = NULL, position = "bottomright")
})
#until here it works but onwards not.
observe(leafletProxy("map", layer())%>%
clearShapes()%>%
addPolygons(
fillColor = ~pal(h_7), # is it possible here to pass column name dynamically
weight = 0.0,
opacity = 1,
color = "white",
dashArray = "3",
fillOpacity = 0.7
) %>%
addLegend(pal = pal, values = ~h_7, opacity = 0.7, title = NULL, position = "bottomright")
)
}
shinyApp(ui, server)
So currently the choropleth map is populated with values of column h_7 selected statically. But I don't know how and whether I can dynamically pass the column name based on sliderInput selection ( For eg. If sliderInput value is 8 the corresponding column is h_8). And then render the map based on the selected column passed from reactive funnction to the observe and leafletProxy functions.
sample data : sample data

It is possible to pass the column names as a string. In leafletProxy you can link to your column values with dataset[[column_name]]. With a single square bracket you are not only selecting the values, but also the corresponding polygons.
For your app to work you need to call layer() outside the leafletProxy function. In addition, use clearControls() to remove duplicate legends.
Finally, I am not sure why you put your shapefile in a reactive expression. It wil also work if you just add it as a variable in your server.
observeEvent({input$hour},{
hour_column <- paste0('h_',input$hour)
data = layer()[hour_column]
pal <- colorBin("YlOrRd", domain = as.numeric(data[[hour_column]]), bins = bins)
leafletProxy("map", data=data)%>%
clearShapes()%>%
addPolygons(
fillColor = pal(as.numeric(data[[hour_column]])),
weight = 0.0,
opacity = 1,
color = "white",
dashArray = "3",
fillOpacity = 0.7
) %>% clearControls() %>%
addLegend(pal = pal, values =as.numeric(data[[hour_column]]), opacity = 0.7, title = NULL, position = "bottomright")
})

Related

Updating spatial polygon dataframe with shiny

My shapefile has columns mean, median and sd and i want to draw a choropleth map in R Shiny. I have a sidebar that controls if tiles of map should display mean, median or sd. But I am not able to do it in Shiny. I tried using the reactive funtions but I keep getting the error below
Error: Polygon data not found; please provide addPolygons with data and/or lng/lat arguments
My code is below
library(shiny)
library(leaflet)
library(rgdal)
library(RColorBrewer)
val <- readOGR('exampleshapefile.shp')
mybins <- c(24,270,470,555,770,2000,Inf)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
radioButtons("stat", "Stat Type:",
c("Mean" = "mean",
"Median" = "q0_50",
"Standard Deviation" = "sd"
)
)
),
mainPanel("mainpanel",
leafletOutput("distSAM")
)
)
)
server <- function(input, output) {
###################### dist-wise
data <- eventReactive(input$stat,{
val#data$input$stat
})
pal <- reactive({
colorBin(palette="RdYlGn", domain = data(), na.color = "transparent", bins=mybins, reverse = TRUE)
})
labels <- reactive({
sprintf(
"<strong>%s<br/>%s</strong>%.1f",
val#data[["NAME_2"]], "SAM: ", data()
) %>% lapply(htmltools::HTML)
})
output$distSAM <- renderLeaflet({
df <- data()
pal <- pal()
lab <- labels()
leaflet() %>% addTiles() %>%
addPolygons(data = df,
fillColor = ~pal(mean),
weight = 2,
opacity = 1,
color = "white",
dashArray = "3",
fillOpacity = 0.7,
highlight = highlightOptions(
weight = 5,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE),
label = lab,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")) %>%
addLegend(pal = pal, values = ~df$mean,
title = "SAM </br> Prevalence",
position = "bottomleft")
}
)
}
shinyApp(ui, server)
val#data$input$stat is not a valid data selection. Instead you can use:
selected_stat <- val[[input$stat]]

Selecting/deselecting multiple polygons in leaflet to update plotly chart using R Shiny

I'm building an R Shiny app. I want reactive plots (plotly) that highlight one or more counties when they are clicked on the map (leaflet). When a highlighted county is clicked again, I want it to be removed.
Ideally I'd also like the reverse, where clicking on a bar in the plot also highlights it and the respective county on the map, but that is a lower priority.
I have tried to adapt code from multiple related posts (especially Changing styles when selecting and deselecting multiple polygons with Leaflet/Shiny and R leaflet highlight options), but can't figure it out.
Problems to solve:
Proxy adds new polygons but does not remove when clicked a second time
I want the proxy to have a green outline so that the original choropleth is still visible, but instead it fills it in all white.
I want to apply the same type of proxy update to the plotly bar chart, but I'm waiting to do that until I figure it out with the leaflet.
Here is a simple reprex using a dummy dataset and percent variable like what I will be using.
#MAP REPREX
library(sf)
library(shiny)
library(tidyverse)
library(leaflet)
library(leaflet.extras)
library(tidycensus)
library(plotly)
library(htmltools)
# GET DATA
NC_counties <- tigris::counties("North Carolina", cb=TRUE, year=2018)%>% st_as_sf()%>% st_transform(crs=4326)
NC_counties <- NC_counties %>% mutate(
pct_water = AWATER/(ALAND+AWATER)*100)
# UI
ui <- fluidPage(
tabsetPanel(id="page1",
tabPanel("Data Tracker",
fluidRow(column(6, leafletOutput("my_map", height = 300)),
column(6, plotlyOutput("comp_bars", height=300))),
tabPanel("About the data")))
)
# SERVER
server <- function(input,output, session){
# CHOROPLETH MAP OF NC COUNTIES
output$my_map = renderLeaflet({
data <- NC_counties
var <- NC_counties$pct_water
bins <- c(0,1,5,10,50,100)
pal <- colorBin(palette = c("#dde4e6","#547980"),
domain = var,
bins = bins,
na.color="#cfcfcf")
labels <- sprintf("%s County", data$NAME)%>% lapply(htmltools::HTML)
leaflet(data,
options=leafletOptions(minZoom=6, maxZoom=6, zoomControl=FALSE))%>%
setView(-80, 34.7, 6) %>%
setMapWidgetStyle(list(background= "white"))%>%
addPolygons(
fillColor = ~pal(var),
fillOpacity = 1,
color = "white",
weight = 1,
layerId=~GEOID,
label = labels,
labelOptions = labelOptions(style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "12px",
direction = "auto")) %>%
addLegend(pal = pal,
values = ~var,
opacity = 1,
title = "Percent water",
position = "bottomleft")
})
# I WANT A PROXY MAP THAT UPDATES TO HIGHLIGHT ONE OR MORE COUNTIES (THAT GET REMOVED ON THE SECOND CLICK)
clicklist <- reactiveValues(ids=vector())
observe({
click <- input$my_map_shape_click
clicklist$ids <- c(clicklist$ids, click$id)
selected <- NC_counties[as.character(NC_counties$GEOID) %in% clicklist$ids, ]
proxy <- leafletProxy("my_map")
proxy %>%
addPolygons(data = selected,
layerId = ~GEOID,
color = "#9DE0AD",
weight = 3,
opacity = 1,
label = labels,
labelOptions = labelOptions(style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "12px",
direction = "auto"))
})
# TOTAL CLAIMS BY COUNTY LINE CHART
output$comp_bars <- renderPlotly({
NC_counties$NAME <- factor(NC_counties$NAME, levels = unique(NC_counties$NAME)[order(NC_counties$pct_water)])
ylabs <- list(
title = NULL,
showticklabels = FALSE
)
fig <- plot_ly(
x=NC_counties$pct_water,
y=NC_counties$NAME,
name = "Percent water",
type = "bar",
orientation = 'h',
marker = list(color = "#cfcfcf"))
fig <- fig %>% layout(yaxis=ylabs)
fig
})
# UPDATE BAR CHART WITH SELECTED POLYGONS
observeEvent(input$my_map_shape_click, {
click <- input$my_map_shape_click
clicklist$ids <- c(clicklist$ids, click$id)
selected <- NC_counties[GEOID %in% clicklist$ids, ]
})
}
# SHINY APP
shinyApp(ui, server)
#MAP REPREX
library(sf)
library(shiny)
library(tidyverse)
library(leaflet)
library(leaflet.extras)
library(tidycensus)
library(plotly)
library(htmltools)
# GET DATA
NC_counties <- tigris::counties("North Carolina", cb=TRUE, year=2018)%>% st_as_sf()%>% st_transform(crs=4326)
NC_counties <- NC_counties %>% mutate(
pct_water = AWATER/(ALAND+AWATER)*100)
# UI
ui <- fluidPage(
tabsetPanel(id="page1",
tabPanel("Data Tracker",
fluidRow(column(6, leafletOutput("my_map", height = 300)),
column(6, plotlyOutput("comp_bars", height=300))),
tabPanel("About the data")))
)
# SERVER
server <- function(input,output, session){
# CHOROPLETH MAP OF NC COUNTIES
output$my_map = renderLeaflet({
data <- NC_counties
var <- NC_counties$pct_water
bins <- c(0,1,5,10,50,100)
pal <- colorBin(palette = c("#dde4e6","#547980"),
domain = var,
bins = bins,
na.color="#cfcfcf")
labels <- sprintf("%s County", data$NAME)%>% lapply(htmltools::HTML)
leaflet(data,
options=leafletOptions(minZoom=6, maxZoom=6, zoomControl=FALSE))%>%
setView(-80, 34.7, 6) %>%
setMapWidgetStyle(list(background= "white"))%>%
addPolygons(
fillColor = ~pal(var),
fillOpacity = 1,
color = "white",
weight = 1,
layerId=~GEOID,
label = labels,
labelOptions = labelOptions(style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "12px",
direction = "auto")) %>%
addLegend(pal = pal,
values = ~var,
opacity = 1,
title = "Percent water",
position = "bottomleft")
})
# I WANT A PROXY MAP THAT UPDATES TO HIGHLIGHT ONE OR MORE COUNTIES (THAT GET REMOVED ON THE SECOND CLICK)
clicklist <- reactiveValues(ids=vector())
observeEvent(input$my_map_shape_click, {
click <- input$my_map_shape_click
proxy <- leafletProxy("my_map")
# gather previous and new clicks in single vector
clicklist$ids <- c(clicklist$ids, click$id)
# subset data
selected <- NC_counties[as.character(NC_counties$GEOID) %in% clicklist$ids, ]
#if the current click ID exists in the clicked polygon (if it has been clicked twice)
if(click$id %in% selected$GEOID){
#define vector that subsets NAME that matches first click ID
duplicates <- selected$GEOID[selected$GEOID == click$id]
# remove the current click$id AND its name match from the selected shapefile
clicklist$ids <- clicklist$ids[!clicklist$ids %in% click$id]
clicklist$ids <- clicklist$ids[!clicklist$ids %in% duplicates]
#remove that highlighted polygon from the map
proxy %>% removeShape(layerId = click$id)
} else {
# map highlighted polygons
proxy %>%
addPolygons(data = selected,
layerId = ~GEOID,
color = "#9DE0AD",
fillOpacity=0,
weight = 3,
opacity = 1,
highlight = highlightOptions(weight = 0,
color = NA,
bringToFront = T),
label = labels,
labelOptions = labelOptions(style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "12px",
direction = "auto"))
}
})
# TOTAL CLAIMS BY COUNTY LINE CHART
output$comp_bars <- renderPlotly({
NC_counties$NAME <- factor(NC_counties$NAME, levels = unique(NC_counties$NAME)[order(NC_counties$pct_water)])
ylabs <- list(
title = NULL,
showticklabels = FALSE
)
fig <- plot_ly(
x=NC_counties$pct_water,
y=NC_counties$NAME,
name = "Percent water",
type = "bar",
orientation = 'h',
marker = list(color = "#cfcfcf"))
fig <- fig %>% layout(yaxis=ylabs)
fig
})
# UPDATE BAR CHART WITH SELECTED POLYGONS
# to do with plotlyProxy() after map gets resolved
}
# SHINY APP
shinyApp(ui, server)

Click polygon and will updateselectinput() - (using leaflet R)

Currently i've managed to align the data with the shape file and plot each region to the map. The polygon is added layer to segregate each region giving more information to whats going on in that region.
what i'm trying to do is that, user should be able to click on the polygon and this should update the inputselect option.
i tried to use Observe() with updateselectinput() but i dont think its working
library(leaflet)
library(leaflet.extras)
library(rgdal)
library(shiny)
library(shinydashboard)
sgmap55 <-readOGR("https://raw.githubusercontent.com/aeiyuni/regioncount/master/55_MP14_PLNG_AREA_WEB_PL.kml")
wfmap <- read.csv("https://raw.githubusercontent.com/aeiyuni/regioncount/master/wfmap.csv")
## to check if all the data matches
bins <-c(1,50,100,150,200,250,300,350,400,450,500)
pal <- colorBin("YlGnBu", domain = wfmap$count, bins = bins, na.color = "#808080")
labels <- sprintf(
"<strong>%s</strong><br/>%g respondents </sup>",
wfmap$planarea, wfmap$count
) %>% lapply(htmltools::HTML)
##_----------------------------
ui<- fluidPage(
sidebarPanel(
selectInput("region", "Planning Area:",
choices = wfmap$planarea)
),
mainPanel(
leafletOutput("sgmap2", height= "1000px"))
)
server <- function(input, output, session){
output$sgmap2 <- renderLeaflet({
leaflet() %>%
addTiles() %>%
addSearchOSM()%>%
addResetMapButton()%>%
clearMarkers()%>%
addProviderTiles("OpenStreetMap") %>%
setView(103.8198,1.3521,12) %>%
addPolygons(data = sgmap55,
weight = 1,
color = "white",
smoothFactor = 0.5,
fillOpacity = 0.8,
fillColor = pal(wfmap$count),
highlight = highlightOptions(
weight = 5,
color = "#666666",
fillOpacity = 0.7,
bringToFront = TRUE),
label = labels,
labelOptions = labelOptions(
style = list("font-weight" = "normal",
padding = "3px 8px"),
textsize = "15px",
direction = "auto"),
group = "By region")%>%
addLegend(pal = pal,
values = wfmap$count,
opacity = 0.7,
position = "topright")
})
###<<<< observe() code here
}
shinyApp(ui, server)
When i added Observe(), it stop working.
##trial code starts here----
observe({
event <- input$insgmap2_shape_click
updateSelectInput(session, inputId = "region", selected = event$Name
)
})
## trial code end here------
Here you go. As per my comment, you need to specify the layerId as the ~Name. This will then be returned in the id field of the click event.
You also had an error in your observe() event. You weren't referencing the correct map name. I've fixed this for you (see my comment in the observe() function)
I've also included a print(event) statement so you can see the data that gets returned when you click on the layer
library(leaflet)
library(leaflet.extras)
library(rgdal)
library(shiny)
library(shinydashboard)
sgmap55 <- readOGR("https://raw.githubusercontent.com/aeiyuni/regioncount/master/55_MP14_PLNG_AREA_WEB_PL.kml")
wfmap <- read.csv("https://raw.githubusercontent.com/aeiyuni/regioncount/master/wfmap.csv")
bins <-c(1,50,100,150,200,250,300,350,400,450,500)
pal <- colorBin("YlGnBu", domain = wfmap$count, bins = bins, na.color = "#808080")
labels <- sprintf(
"<strong>%s</strong><br/>%g respondents </sup>",
wfmap$planarea, wfmap$count
) %>% lapply(htmltools::HTML)
ui<- fluidPage(
sidebarPanel(
selectInput("region", "Planning Area:",
choices = wfmap$planarea)
),
mainPanel(
leafletOutput("sgmap2", height= "1000px"))
)
server <- function(input, output, session){
output$sgmap2 <- renderLeaflet({
leaflet() %>%
addTiles() %>%
addSearchOSM()%>%
addResetMapButton()%>%
clearMarkers()%>%
addProviderTiles("OpenStreetMap") %>%
setView(103.8198,1.3521,12) %>%
addPolygons(data = sgmap55,
weight = 1,
color = "white",
smoothFactor = 0.5,
fillOpacity = 0.8,
fillColor = pal(wfmap$count),
highlight = highlightOptions(
weight = 5,
color = "#666666",
fillOpacity = 0.7,
bringToFront = TRUE),
label = labels,
labelOptions = labelOptions(
style = list("font-weight" = "normal",
padding = "3px 8px"),
textsize = "15px",
direction = "auto"),
group = "By region",
layerId = ~Name
) %>%
addLegend(pal = pal,
values = wfmap$count,
opacity = 0.7,
position = "topright")
})
observe({
## the sgmap2 needs to match the name of the map you're outputting above
event <- input$sgmap2_shape_click
print( event )
updateSelectInput(session, inputId = "region", selected = event$id
)
})
}
shinyApp(ui, server)

Leaflet Shiny Integration slow

I am trying to build an interactive Choropleth in Shiny using leaflet. However, the load time and recreate time is really slow. Any way to speed it up.
Here is a link to the entire app folder along with the data:
https://www.dropbox.com/home/Leaflet_Shiny_app
global.R
library(shinydashboard)
library(tidyverse)
library(ggvis)
library(leaflet)
library(WDI)
library(sp)
ui.R
header <- dashboardHeader(
title = "Greenhouse gas (GHG) emissions"
)
## Sidebar content
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Interactive Choropleth", tabName = "choropleth")
)
)
## Body content
body <- dashboardBody(
# First tab content
tabItem("choropleth",
fluidRow(
column(width = 9,
box(width = NULL, solidHeader = TRUE,
title = "Greenhouse gas emissions (kt of CO2 equivalent)",
leafletOutput("choropleth_ghg", height = 500)
)
),
column(width = 3,
box(width = NULL, status = "warning",
selectInput("year", "Year",
choices = seq(1970, 2012, 1),
selected = 2012)
)
)
)
)
)
dashboardPage(
header,
sidebar,
body
)
server.R
# Read the dataset for choropleth
# From http://data.okfn.org/data/core/geo-countries#data
countries <- geojsonio::geojson_read("json/countries.geojson", what = "sp")
# Download the requested data by using the World Bank's API,
# parse the resulting JSON file, and format it in long country-year format.
load("who_ghg.RData")
function(input, output, session) {
# Interactive Choropleth map.........................................................
# Reactive expression for the data subsetted to what the user selected
countries_plus_ghg <- reactive({
# Filter the data to select for the year user selected
who_ghg_subset <- filter(who_ghg, year == input$year)
# Merge a Spatial object having a data.frame for Choropleth map
sp::merge(countries, who_ghg_subset,
by.x = "ISO_A3", by.y = "iso3c")
})
# Create the map
output$choropleth_ghg <- renderLeaflet({
leaflet(countries) %>%
setView(0, 20, zoom = 1) %>%
addTiles()
})
# Observer to change the color of countries, labels and legends
# based on the year user selects in the UI
observe({
dat <- countries_plus_ghg()
# Define numeric vector bins to add some color
bins <- ggplot2:::breaks(c(min(dat$EN.ATM.GHGT.KT.CE, na.rm = TRUE)
,max(dat$EN.ATM.GHGT.KT.CE, na.rm = TRUE)),
"width",n = 5)
# Call colorBin to generate a palette function that maps the RColorBrewer
#"YlOrRd" colors to our bins.
pal <- colorBin("YlOrRd",
domain = dat$EN.ATM.GHGT.KT.CE,
bins = bins)
# Generate the labels with some HTML
labels <- sprintf(
"<strong>%s</strong><br/>%g",
dat$country, dat$EN.ATM.GHGT.KT.CE
) %>% lapply(htmltools::HTML)
leafletProxy("choropleth_ghg", data = dat) %>%
addPolygons(
fillColor = ~pal(EN.ATM.GHGT.KT.CE),
weight = 1,
opacity = 1,
color = "white",
fillOpacity = 0.7,
highlight = highlightOptions(
weight = 2,
color = "#666",
dashArray = "",
fillOpacity = 0.7,
bringToFront = TRUE),
label = labels,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "3px 8px"),
textsize = "15px",
direction = "auto")) %>%
clearControls() %>%
addLegend(pal = pal, values = ~EN.ATM.GHGT.KT.CE, opacity = 0.7, title = NULL,
position = "bottomleft")
})
}
Simplifying geometries using rmapshaper::ms_simplify helped make it a lot faster.
This is what I did-
# Topologically-aware geometry simplification using rmapshaper package,
# keep = proportion of points to retain
countries_simple <- rmapshaper::ms_simplify(countries, keep = 0.05, keep_shapes = TRUE)
I used countries_simple instead of countries in the code then.

Selecting fillColor based on user input

I have a function in R that I'm using for creating a map of demographic information.
draw_demographics <- function(map, input, data) {
pal <- colorQuantile("YlGnBu", domain = NULL, n = 7)
#browser()
map %>%
clearShapes() %>%
addPolygons(data = data,
fillColor = ~pal(input$population),
fillOpacity = 0.4,
color = "#BDBDC3",
weight = 1)
}
It's a pure function that takes the map data from Leaflet, the input from the user, and the data from a shapefile to create the map layers. The columns of the shapefile include information like population density, total population, and so on, and I'd like to fill the polygons based on the column name. But where I'm a bit lost is figuring out how to pass selectInput() properly to Leaflet.
Here's a very basic example:
library(shiny)
library(leaflet)
ui <- bootstrapPage(
fluidRow(
column(12, leafletOutput("map"))
),
fluidRow(
column(12, uiOutput("select_population"))
)
)
server <- function(input, output, session) {
output$select_population <- renderUI({
choices <- list("None" = "None",
"All population" = "totalPop",
"Population density" = "totalDens",
"Black population" = "totalAfAm",
"Asian population" = "totalAsian",
"Latino population" = "totalHispanic",
"Native population" = "totalIndian")
selectInput(inputId = "population", label = "Demographics",
choices = choices, selected = "totalDens")
})
output$map <- renderLeaflet({
map <- leaflet() %>%
addProviderTiles(provider = "CartoDB.Positron",
providerTileOptions(detectRetina = FALSE,
reuseTiles = TRUE,
minZoom = 4,
maxZoom = 8)) %>%
setView(lat = 43.25, lng = -94.30, zoom = 6)
map %>% draw_demographics(input, counties[["1890"]])
})
}
## Helper functions
# draw_demographics draws the choropleth
draw_demographics <- function(map, input, data) {
pal <- colorQuantile("YlGnBu", domain = NULL, n = 7)
#browser()
map %>%
clearShapes() %>%
addPolygons(data = data,
fillColor = ~pal(input$population),
fillOpacity = 0.4,
color = "#BDBDC3",
weight = 1)
}
shinyApp(ui, server)
Where I'm a bit lost is how to pass the vector values from the column totalDens from the user's input of totalDens from the dropdown (or, pass whichever column of data they choose to map) to Leaflet. In other words, if a user selects totalPop instead, how can I tell Leaflet to reapply the color palette to this new set of data and re-render the polygons? I attempted using a reactive to get the results of input$population, but to no avail.
Any suggestions, or ways I could troubleshoot? Thanks!
With the data you posted on the github I redid it. The central problem seems to be the generation of the color palette. This is pretty fragile as it assumes that you have selected a good values for the cuts.
It needs a function that tries out various methods, see the code for details The really challenging case (that I found) was the Asian population for 1890, that was very skewed but definitely had values, and the median method always mapped everything to one color.
The following changes were made:
Added some code to download and save the counties data
Read in the data you provided
Added a field to select the year
added a req(input$population) to stop the typical shiny initialization NULL errors.
Created a getpal that tries out a different values starting on equally space quantiles.
If the number of quantiles reduces to 2, then it falls back to colorBin as colorQuantile colors everything the same in that case - probably a bug.
If there is no population data it does not draw the county shapes as that takes a lot of time, and there are a lot of those cases.
Here is the code:
library(shiny)
library(leaflet)
library(sf)
ui <- bootstrapPage(
fluidRow(
column(12, leafletOutput("map"))
),
fluidRow(
column(12, uiOutput("select_year")),
column(12, uiOutput("select_population"))
)
)
choices <- list("None" = "None",
"All population" = "totalPop",
"Population density" = "totalDens",
"Black population" = "totalAfAm",
"Asian population" = "totalAsian",
"Latino population" = "totalHispanic",
"Native population" = "totalIndian")
fn <- Sys.glob("shp/*.shp")
counties <- lapply(fn, read_sf)
names(counties) <- c("1810", "1820","1830","1840","1850","1860","1870","1880","1890","1900",
"1910","1920","1930","1940","1950","1960","1970","1980","1990","2000","2010")
server <- function(input, output, session) {
output$select_population <- renderUI({
selectInput(inputId = "population", label = "Demographics",
choices = choices, selected = "totalDens")
})
output$select_year <- renderUI({
selectInput(inputId = "year", label = "Year",
choices = names(counties))
})
output$map <- renderLeaflet({
req(input$population)
req(input$year)
map <- leaflet() %>%
addProviderTiles(provider = "CartoDB.Positron",
providerTileOptions(detectRetina = FALSE,
reuseTiles = TRUE,
minZoom = 4,
maxZoom = 8)) %>%
setView(lat = 43.25, lng = -94.30, zoom = 6)
map %>% draw_demographics(input, counties[[input$year]])
})
}
# try out various ways to get an acceptable color palette function
getpal <- function(cpop,nmax){
if (length(cpop)>1){
# try out value from nmax down to 1
for (n in nmax:1){
qpct <- 0:n/n
cpopcuts <- quantile(cpop,qpct)
# here we test to see if all the cuts are unique
if (length(unique(cpopcuts))==length(cpopcuts)){
if (n==1){
# The data is very very skewed.
# using quantiles will make everything one color in this case (bug?)
# so fall back to colorBin method
return(colorBin("YlGnBu",cpop, bins=nmax))
}
return(colorQuantile("YlGnBu", cpop, probs=qpct))
}
}
}
# if all values and methods fail make everything white
pal <- function(x) { return("white") }
}
draw_demographics <- function(map, input, data) {
cpop <- data[[input$population]]
if (length(cpop)==0) return(map) # no pop data so just return (much faster)
pal <- getpal(cpop,7)
map %>%
clearShapes() %>%
addPolygons(data = data,
fillColor = ~pal(cpop),
fillOpacity = 0.4,
color = "#BDBDC3",
weight = 1)
}
shinyApp(ui, server)
Here is the output:
The challenging case of Asian population distribution in 1890 - very highly skewed data with the population concentrated in three counties. This means that the getpal function will be forced to give up on colorQuantile and fall back on colorBin in order to show anything:

Resources