Search code examples
rshinyr-leaflet

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.

Do you have any suggestions or ways I could troubleshoot?

Solution

  • 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:

    enter image description here

    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:

    enter image description here