How to Recolor An Already Existing Polygon

[jrisi256]

Hi! Thanks for creating this wonderful library! I do have an issue though.

Currently I have shapefiles for all counties for all 50 states. And I am coloring them based on some outcome variable chosen by the user (e.g. unemployment, poverty rate, etc.)

Using leafletProxy() I can update the color however this necessitates a redrawing of the polygons even though it is the same polygons being drawn over and over again! I just want to change the color.

Normally, this wouldn't be an issue, but because it is a relatively large collection of shapefiles it can take a bit before the map updates.

I was wondering if there was any plans in the work to edit an already existing set of polygons or something along those lines? If not, what would you recommend I do? (I've already reduced the shapefiles down in size as much as possible). Would this be an issue for leaflet.extras perhaps?

#170

The above issue seems similar to mine, and it seems like at some point there was work to be done on it? But it's a few years old, and I can't tell if there has been any work on it since then.

Thanks again!

[cenuno]

@jrisi256 are you open to incorporating the shiny package with your leaflet map? If so, check out https://github.com/cenuno/shiny/tree/master/Interactive_UI/Dynamic_Legend: a small shiny app that does what you're doing but for the neighborhoods in the City of Chicago.

In global.R, I call addPolygons() for each variable of interest and assign each instance a group value. These groups are placed in addLayersControl() as base-groups, allowing the user to switch the colors based on the variable of interest.

In server.R, I use shiny::observeEvent() and leafletProxy() to update the legend to the user-selected variable.

[jrisi256]

I am looking at your code now, and my only concern is the map I am creating is much larger than the one you are creating.

For reference, I am using the shape files as detailed below, and I have about 13 outcome variables (and I am going to want to add more). And each time I add another set of Polygons based on the county shape files, I calculate it adds 3.65 Mb to the total size of the map. For my 13 outcomes, that comes out to over 50 Mb, and I anticipate that this would cause Leaflet/Shiny to slow down quite a bit.

So I'm curious if there is a more 'elegant' solution versus having to copy/paste a bunch of code and wasting a lot of computational resources rendering basically the same polygons over and over again.

library(sf)
library(sp)
library(albersusa)
library(tigris)

#Read in shape file for counties
usa_counties_sp = counties(cb=TRUE, resolution="20m")

#Shift Alaska and Hawaii closer to the United States (as well as shrinking them)
usa_counties_sp_shift = points_elided(usa_counties_sp)
usa_counties_sf = st_as_sf(usa_counties_sp_shift)

#Do some cleaning of the shape files like getting rid of U.S. territories
data("fips_codes")
usa_counties = usa_counties_sf %>%
  filter(!(STATEFP %in% c("78", "66", "69", "60", "72"))) %>%
  inner_join(fips_codes, by=c("STATEFP" = "state_code", "COUNTYFP" = "county_code")) %>%
  rename(county_name=NAME, state_code=STATEFP, county_code=COUNTYFP) %>%
  select(state_code, county_code, state_name, county_name)

[timelyportfolio]

@jrisi256, this is possible but not through the currently provided R interface. I am waiting on response on #496 (reference) to make sure I am not missing another implementation. I will post an example if this will not be added to the API in the development version.

[jrisi256]

@timelyportfolio Thank you so much! I eagerly await your example.
@cenuno Thank you as well. I tried your idea, and it allowed for very fast transition between the polygons. However, it took a very, very long time to load the map. So sort of one step forward, one step backward type situation.

[cenuno]

@jrisi256: for speed, you might want to consider exporting your final spatial polygon data frame (or your entire leaflet map for that matter) as an .rds file in a separate R script, and then import that file into your global.R.

Kyle Walker does this with his neighborhood diversity Shiny app. You can see his GitHub repo here.

[jrisi256]

@cenuno Thank you! I'll have to check that out if this current line of inquiry doesn't work.
@timelyportfolio Any update? I found a function in leaflet.extras "setMapWidgetStyle()" which may work for my purposes however I have been unable to get it to work.

[jrisi256]

@timelyportfolio Hello! Not to be a bother, but do you think my best bet is to build the map ahead of time as cenuno suggested?

[jplecavalier]

I don't want to rush anybody, but I'm just curious if #598 is scheduled to be merge soon? I have to work with massive shapefiles of thousands of complex polygons and I will have to consider another R solution than leaflet if this issue is not addressed soon. Thanks for your wonderful work! 😄

[PetraOleum]

Yeah, this would be so very useful

[timelyportfolio]

@PetraOleum @jplecavalier @jrisi256 I'm not sure why @edwindj #598 has not been accepted or discussed. In my mind his changes should work perfectly. I had considered this solved. Here is how to use it without the pull request. We'll need to add the JavaScript methods with tags$script and then insert the R functions in your session. Once we have the code available to both R and JavaScript, the lines at the end demonstrate where the style changes setShapeStyle(layerId = ~NAME_1, fillColor=input$color, color = input$color). I am happy to discuss further if my quick answer is not sufficient.

All at Once - Ugly and Intimidating

library(shiny)
library(leaflet)

# add in methods from https://github.com/rstudio/leaflet/pull/598
setCircleMarkerRadius <- function(map, layerId, radius, data=getMapData(map)){
  options <- list(layerId = layerId, radius = radius)
  # evaluate all options
  options <- evalFormula(options, data = data)
  # make them the same length (by building a data.frame)
  options <- do.call(data.frame, c(options, list(stringsAsFactors=FALSE)))
  leaflet::invokeMethod(map, data, "setRadius", options$layerId, options$radius)
}

setCircleMarkerStyle <- function(map, layerId
                                 , radius = NULL
                                 , stroke = NULL
                                 , color = NULL
                                 , weight = NULL
                                 , opacity = NULL
                                 , fill = NULL
                                 , fillColor = NULL
                                 , fillOpacity = NULL
                                 , dashArray = NULL
                                 , options = NULL
                                 , data = getMapData(map)
){
  if (!is.null(radius)){
    setCircleMarkerRadius(map, layerId = layerId, radius = radius, data = data)
  }

  options <- c(list(layerId = layerId),
               options,
               filterNULL(list(stroke = stroke, color = color,
                               weight = weight, opacity = opacity,
                               fill = fill, fillColor = fillColor,
                               fillOpacity = fillOpacity, dashArray = dashArray
               )))

  if (length(options) < 2) { # no style options set
    return()
  }
  # evaluate all options
  options <- evalFormula(options, data = data)

  # make them the same length (by building a data.frame)
  options <- do.call(data.frame, c(options, list(stringsAsFactors=FALSE)))
  layerId <- options[[1]]
  style <- options[-1] # drop layer column

  #print(list(style=style))
  leaflet::invokeMethod(map, data, "setStyle", "marker", layerId, style);
}

setShapeStyle <- function( map, data = getMapData(map), layerId,
                           stroke = NULL, color = NULL,
                           weight = NULL, opacity = NULL,
                           fill = NULL, fillColor = NULL,
                           fillOpacity = NULL, dashArray = NULL,
                           smoothFactor = NULL, noClip = NULL,
                           options = NULL
){
  options <- c(list(layerId = layerId),
               options,
               filterNULL(list(stroke = stroke, color = color,
                               weight = weight, opacity = opacity,
                               fill = fill, fillColor = fillColor,
                               fillOpacity = fillOpacity, dashArray = dashArray,
                               smoothFactor = smoothFactor, noClip = noClip
               )))
  # evaluate all options
  options <- evalFormula(options, data = data)
  # make them the same length (by building a data.frame)
  options <- do.call(data.frame, c(options, list(stringsAsFactors=FALSE)))

  layerId <- options[[1]]
  style <- options[-1] # drop layer column

  #print(list(style=style))
  leaflet::invokeMethod(map, data, "setStyle", "shape", layerId, style);
}


coor <- sp::coordinates(gadmCHE)

ui <- fluidPage(
  tags$head(
    # add in methods from https://github.com/rstudio/leaflet/pull/598
    tags$script(HTML(
'
window.LeafletWidget.methods.setStyle = function(category, layerId, style){
  var map = this;
  if (!layerId){
    return;
  } else if (!(typeof(layerId) === "object" && layerId.length)){ // in case a single layerid is given
    layerId = [layerId];
  }

  //convert columnstore to row store
  style = HTMLWidgets.dataframeToD3(style);
  //console.log(style);

  layerId.forEach(function(d,i){
    var layer = map.layerManager.getLayer(category, d);
    if (layer){ // or should this raise an error?
      layer.setStyle(style[i]);
    }
  });
};

window.LeafletWidget.methods.setRadius = function(layerId, radius){
  var map = this;
  if (!layerId){
    return;
  } else if (!(typeof(layerId) === "object" && layerId.length)){ // in case a single layerid is given
    layerId = [layerId];
    radius = [radius];
  }

  layerId.forEach(function(d,i){
    var layer = map.layerManager.getLayer("marker", d);
    if (layer){ // or should this raise an error?
      layer.setRadius(radius[i]);
    }
  });
};
'
    ))
  ),
  leafletOutput("map"),
  radioButtons("color", "Color", choices = c("blue", "red",  "green")),
  sliderInput("radius", "Radius", min = 1, max = 30, value=5, animate = TRUE)
)

server <- function(input, output, session){
  output$map <- renderLeaflet({
    leaflet(data=gadmCHE) %>%
      addPolygons(layerId = ~NAME_1, weight = 1) %>%
      addCircleMarkers(layerId = gadmCHE$NAME_1, data = coor, weight = 1)
  })

  observe({
    leafletProxy("map", data = gadmCHE) %>%
      setCircleMarkerRadius(gadmCHE$NAME_1, input$radius)
  })

  observe({
    leafletProxy("map", data = gadmCHE) %>%
      setShapeStyle(layerId = ~NAME_1, fillColor=input$color, color = input$color) %>%
      setCircleMarkerStyle(layerId = ~NAME_1, fillColor = input$color, color = input$color)
  })

}

shinyApp(ui, server)

Cleaner and Maybe Less Scary

The code looks like a lot since we have to manually add the JavaScript and R functions. I'll do a slightly different example below where we use sf and separate the JS/R additions to hopefully make the code less scary.

Add the R + JS from pull 598

### R functions
# add in methods from https://github.com/rstudio/leaflet/pull/598
setCircleMarkerRadius <- function(map, layerId, radius, data=getMapData(map)){
  options <- list(layerId = layerId, radius = radius)
  # evaluate all options
  options <- evalFormula(options, data = data)
  # make them the same length (by building a data.frame)
  options <- do.call(data.frame, c(options, list(stringsAsFactors=FALSE)))
  leaflet::invokeMethod(map, data, "setRadius", options$layerId, options$radius)
}

setCircleMarkerStyle <- function(map, layerId
                                 , radius = NULL
                                 , stroke = NULL
                                 , color = NULL
                                 , weight = NULL
                                 , opacity = NULL
                                 , fill = NULL
                                 , fillColor = NULL
                                 , fillOpacity = NULL
                                 , dashArray = NULL
                                 , options = NULL
                                 , data = getMapData(map)
){
  if (!is.null(radius)){
    setCircleMarkerRadius(map, layerId = layerId, radius = radius, data = data)
  }

  options <- c(list(layerId = layerId),
               options,
               filterNULL(list(stroke = stroke, color = color,
                               weight = weight, opacity = opacity,
                               fill = fill, fillColor = fillColor,
                               fillOpacity = fillOpacity, dashArray = dashArray
               )))

  if (length(options) < 2) { # no style options set
    return()
  }
  # evaluate all options
  options <- evalFormula(options, data = data)

  # make them the same length (by building a data.frame)
  options <- do.call(data.frame, c(options, list(stringsAsFactors=FALSE)))
  layerId <- options[[1]]
  style <- options[-1] # drop layer column

  #print(list(style=style))
  leaflet::invokeMethod(map, data, "setStyle", "marker", layerId, style);
}

setShapeStyle <- function( map, data = getMapData(map), layerId,
                           stroke = NULL, color = NULL,
                           weight = NULL, opacity = NULL,
                           fill = NULL, fillColor = NULL,
                           fillOpacity = NULL, dashArray = NULL,
                           smoothFactor = NULL, noClip = NULL,
                           options = NULL
){
  options <- c(list(layerId = layerId),
               options,
               filterNULL(list(stroke = stroke, color = color,
                               weight = weight, opacity = opacity,
                               fill = fill, fillColor = fillColor,
                               fillOpacity = fillOpacity, dashArray = dashArray,
                               smoothFactor = smoothFactor, noClip = noClip
               )))
  # evaluate all options
  options <- evalFormula(options, data = data)
  # make them the same length (by building a data.frame)
  options <- do.call(data.frame, c(options, list(stringsAsFactors=FALSE)))

  layerId <- options[[1]]
  style <- options[-1] # drop layer column

  #print(list(style=style))
  leaflet::invokeMethod(map, data, "setStyle", "shape", layerId, style);
}

### JS methods
leafletjs <-  tags$head(
    # add in methods from https://github.com/rstudio/leaflet/pull/598
    tags$script(HTML(
'
window.LeafletWidget.methods.setStyle = function(category, layerId, style){
  var map = this;
  if (!layerId){
    return;
  } else if (!(typeof(layerId) === "object" && layerId.length)){ // in case a single layerid is given
    layerId = [layerId];
  }

  //convert columnstore to row store
  style = HTMLWidgets.dataframeToD3(style);
  //console.log(style);

  layerId.forEach(function(d,i){
    var layer = map.layerManager.getLayer(category, d);
    if (layer){ // or should this raise an error?
      layer.setStyle(style[i]);
    }
  });
};

window.LeafletWidget.methods.setRadius = function(layerId, radius){
  var map = this;
  if (!layerId){
    return;
  } else if (!(typeof(layerId) === "object" && layerId.length)){ // in case a single layerid is given
    layerId = [layerId];
    radius = [radius];
  }

  layerId.forEach(function(d,i){
    var layer = map.layerManager.getLayer("marker", d);
    if (layer){ // or should this raise an error?
      layer.setRadius(radius[i]);
    }
  });
};
'
    ))
  )

Shiny app

Then I think the code becomes much less intimidating (run above first).

library(sf)
library(scales) # to color our shapes
library(shiny)
library(leaflet)

gadsf <- sf::st_as_sf(gadmCHE)
# add some random data to gadsf that we will color
#  this could be done on the fly if data supported it
gadsf$random1 <- scales::col_quantile(domain = c(0,100),palette="Set1")(runif(nrow(gadsf),0,100))
gadsf$random2 <- scales::col_factor(domain = NULL,palette="Accent")(LETTERS[runif(nrow(gadsf),1,4)])


ui <- fluidPage(
  leafletjs,
  leafletOutput("map"),
  # set our options to our random data variable names
  radioButtons("color", "Color", choices = c("random1", "random2"))
)

server <- function(input, output, session){
  output$map <- renderLeaflet({
    leaflet(data = gadsf) %>%
      addPolygons(layerId = ~NAME_1, weight = 1)
  })

  observe({
    leafletProxy("map", data = gadsf) %>%
      setShapeStyle(layerId = ~NAME_1, fillColor = gadsf[[input$color]], color = gadsf[[input$color]])
  })

}

shinyApp(ui, server)

[PetraOleum]

You're a lifesaver (or at least a data-and-timesaver). Thanks a bunch!

Hopefully the changes will be merged in a future version

[martinzuba]

This is awesome. I will try to use it to update labels too.

This is how I did it:

Javascript:

window.LeafletWidget.methods.setLabel = function(category, layerId, label){
  var map = this;
  if (!layerId){
    return;
  } else if (!(typeof(layerId) === "object" && layerId.length)){ // in case a single layerid is given
    layerId = [layerId];
  }

  //convert columnstore to row store
  //label = HTMLWidgets.dataframeToD3(label);
  //console.log(label);

  layerId.forEach(function(d,i){
    var layer = map.layerManager.getLayer(category, d);
    if (layer){ // or should this raise an error?
      // layer.setStyle(style[i]);
      layer.unbindTooltip();
      layer.bindTooltip(label[i])
    }
  });
};

R function:

setShapeLabel <- function( map, data = getMapData(map), layerId,
                           label = NULL,
                           options = NULL
){
  options <- c(list(layerId = layerId),
               options,
               filterNULL(list(label = label
               )))
  # evaluate all options
  options <- evalFormula(options, data = data)
  # make them the same length (by building a data.frame)
  options <- do.call(data.frame, c(options, list(stringsAsFactors=FALSE)))
  
  layerId <- options[[1]]
  style <- options[-1] # drop layer column
  
  #print(list(style=style))
  leaflet::invokeMethod(map, data, "setLabel", "shape", layerId, label);
}