Selecting fillColor based on user input

Question

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!

hmm you really need to wrap it in a function or cant u just add the code to the `renderLeaflet()`. If you need the function you should look into shiny modules. Then you want to check this: https://stackoverflow.com/questions/43976128/create-a-reactive-function-outside-the-shiny-app/43976516#43976516 — Tonio Liebrand, May 23 '17 at 20:24
So, I've tried two things to modify my `draw_demographics()` function: 1. used `req()` to try and work around the `NULL` initialization. This is included right at the start of the function. 2. added a reactive statement `a <- reactive(input$population)` that gets passed to the `fillColor` argument in Leaflet. But, I'm running into an error: `Warning in is.na(x) : is.na() applied to non-(list or vector) of type 'closure' Warning: Error in [: object of type 'closure' is not subsettable` — Jason Heppler, May 24 '17 at 20:10
Quick follow-up: I followed the suggestion [here](https://stackoverflow.com/questions/40623749/what-is-object-of-type-closure-is-not-subsettable-error-in-shiny) for troubleshooting the above error, but am left with a new error `Warning: Error in *: non-numeric argument to binary operator`. — Jason Heppler, May 24 '17 at 21:15
So where are you storing the population values anyway? I see in the github they are in a seperate csv file, are they present in the above code at all? — Mike Wise, May 24 '17 at 21:29
Right, sorry for the confusion there. There are two sets of data: the CSV data is for creating a bubble map of population growth and unrelated to this particular part of the app (they're handled by a different function, and is working fine). But in the `shp/` folder are the shapefiles that contain the demographic information and polygons that I'm also trying to visualize. — Jason Heppler, May 24 '17 at 21:36

Mike Wise · Accepted Answer · 2017-05-29T12:11:42.983

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:

Thanks! This is helpful. I have one wrinkle, though: I'm using shapefile data from NHGIS, and have done some data manipulation to create a new set of shapefiles. The whole app is here (https://github.com/hepplerj/midwest-map-population). Right now, `counties` is a list of those shapefiles (see inside `helpers.R`). So, I'm already using something like `counties[[input$population]]` to access the appropriate shapefile by year... — Jason Heppler, May 24 '17 at 17:50
Your update above did it, thanks so much for digging into this! I just have a few other small bugs to track down. Answer accepted. — Jason Heppler, May 25 '17 at 13:42

score 1 · Answer 2 · answered May 04 '23 at 13:14

1

TLDR;
fillColor = ~pal(data[[input$column]])
not fillColor = ~pal(input$column)

answered May 04 '23 at 13:14

A. West

571
5
12

Thank you, I did get that to work although the $ sign in input$column had me confused for a sec. My code is fillColor = ~color_palette(data[[predicted_value_col]]), where predicted_value_col contains the correct column name and data is the dataframe. – Dan Crosby Jul 23 '23 at 02:32

Selecting fillColor based on user input

2 Answers2