Changing styles when selecting and deselecting multiple polygons with Leaflet/Shiny
The answer lies in layerIds. I wasn't understanding how these were applied to my polygons and removing shapes--understanding this is key. This might not be the most elegant solution, but it gets the job done!
In the below code, the initial map rendering of Rwanda has a layerId of rwa@data$NAME_1, which are the region names. You can see this in action with the label also being set as rwa@data$NAME_1. So in the below image, the leftmost polygon is labeled as Iburengerazuba, its attribute in the NAME_1 column. This layerId sets the click$id for any click events you have on this initial map rendering. So, just as this polygon is labeled Iburengerazuba, its click$id will also be set as Iburengerazuba. As stated in the Leaflet Shiny documentation, if you've got more than one polygon, this needs to be a vectorized argument. If you only need to select and deselect ONE polygon (so only one region at a time, in this example), you could use a layerId string, as I mentioned in my question (such as layerId = "selected").
Next up is the observeEvent for your shape click. Thanks to the help of user @John Paul, I figured out how to save all click events (click ids specifically in this case) made on the map. I saved those in a reactive vector, then subset my shapefile by those click ids. The code is pretty thoroughly commented, so hopefully anyone else looking for this same solution can figure out exactly what's going on.
The final bit of code (housed in the if...else conditional statement) is probably the most confusing. Let's look at the else portion of the code first. (Note: Your initial map click is going to trigger this event because there's no way for the if conditions to have been met upon first click.) If any white polygon is clicked, the addPolygons() call is triggered, adding the clicked polygon onto the map with different styling (in this case, it's red). This is plotting an entirely different polygon on top of the leafletProxy object!
The key to removing the red clicked polygons is giving these polygons a different layerId than the initial map rendering. Note that in the above image, the white polygon that was labeled Iburengerazuba is now labeled as 3. This is because the layerId in the second addPolygons call is set as CC_1 INSTEAD OF NAME_1. So, bottom layer white map has a NAME_1 layerID and therefore NAME_1 click ids, whereas any red clicked polygon plotted on top of that has a CC_1 layerId and therefore CC_1 click ids.
The if statements states that if your click$id already exists in the clickedPolys polygon, that this shape is removed. This is kind of confusing, so again, it might help to go through each line of code and play around with it to truly understand.
Again using the above example, clicking the leftmost polygon adds the layerId Iburengerazuba to the clickedIds$ids vector. This click event triggers a second map drawing, plotting the clicked polygon on top of itself in a different style and with a layerId of 3 (from the CC_1 column). We want to say that if any red polygon is clicked twice (if(click$id %in% clickedPolys@data$CC_1)), it counts as a deselection, and that polygon should be removed from the map. So if you click on the red leftmost polygon with a layerId of 3, the clickedIds$ids vector will be comprised of Iburengerazuba and 3. Iburengerazuba in the NAME_1 column of the clickedPolys polygon corresponds to 3 in the CC_1 column, triggering the if statement. The call removeShape(layerId = click$id) means to remove the shape that corresponds to that click$id. So in this case, the clickedPolys polygon with a CC_1 layerId of 3.
Keep in mind that every click id, both NAME_1 and CC_1 are being recorded in your clickedIds$ids vector. This vector is subsetting your Rwanda shapefile to map all clicked polygons, so as you're clicking polygons, the clickedPolys polygon is dynamically updating (use print calls to check every bit of code if this isn't making sense to you!). Removing any double-clicked shape isn't enough to plot everything correctly--you need to remove deselected layerIds, both NAME_1 and CC_1, from the clickedIds$ids vector. I matched each deselected CC_1 layerId to its corresponding NAME_1 value and removed both of those attributes from the clickedIds$ids vector so that they are removed from the clickedPolys polygon.
Voila! Now you can select and deselect any polygons you want!
library(raster)
library(shiny)
library(leaflet)
#load shapefile
rwa <- getData("GADM", country = "RWA", level = 1)
shinyApp(
ui = fluidPage(
leafletOutput("map")
),
server <- function(input, output, session){
#create empty vector to hold all click ids
clickedIds <- reactiveValues(ids = vector())
#initial map output
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
addPolygons(data = rwa,
fillColor = "white",
fillOpacity = 1,
color = "black",
stroke = T,
weight = 1,
layerId = rwa@data$NAME_1,
group = "regions",
label = rwa@data$NAME_1)
}) #END RENDER LEAFLET
observeEvent(input$map_shape_click, {
#create object for clicked polygon
click <- input$map_shape_click
#define leaflet proxy for second regional level map
proxy <- leafletProxy("map")
#append all click ids in empty vector
clickedIds$ids <- c(clickedIds$ids, click$id)
#shapefile with all clicked polygons - original shapefile subsetted by all admin names from the click list
clickedPolys <- rwa[rwa@data$NAME_1 %in% clickedIds$ids, ]
#if the current click ID [from CC_1] exists in the clicked polygon (if it has been clicked twice)
if(click$id %in% clickedPolys@data$CC_1){
#define vector that subsets NAME that matches CC_1 click ID
nameMatch <- clickedPolys@data$NAME_1[clickedPolys@data$CC_1 == click$id]
#remove the current click$id AND its name match from the clickedPolys shapefile
clickedIds$ids <- clickedIds$ids[!clickedIds$ids %in% click$id]
clickedIds$ids <- clickedIds$ids[!clickedIds$ids %in% nameMatch]
#remove that highlighted polygon from the map
proxy %>% removeShape(layerId = click$id)
} else {
#map highlighted polygons
proxy %>% addPolygons(data = clickedPolys,
fillColor = "red",
fillOpacity = 1,
weight = 1,
color = "black",
stroke = T,
label = clickedPolys@data$CC_1,
layerId = clickedPolys@data$CC_1)
} #END CONDITIONAL
}) #END OBSERVE EVENT
}) #END SHINYAPP
Is there a way to change styles twice (for double click and triple click) when selecting and deselecting polygons in leaflet/shiny?
This is a possible solution using groups. I tried to make eveything simple and commented, but ask me if there is something unclear.
library(shiny)
library(leaflet)
## create two square polygons
Sr1 <- Polygon(cbind(c(1, 2, 2, 1, 1), c(1, 1, 2, 2, 1)))
Sr2 <- Polygon(cbind(c(2, 3, 3, 2, 2), c(1, 1, 2, 2, 1)))
Srs1 <- Polygons(list(Sr1), "s1")
Srs2 <- Polygons(list(Sr2), "s2")
SpP <- SpatialPolygons(list(Srs1, Srs2), 1:2)
ui <- fluidPage(
leafletOutput("map")
)
change_color <- function(map, id_to_remove, data, colour, new_group){
leafletProxy(map) %>%
removeShape(id_to_remove) %>% # remove previous occurrence
addPolygons(
data = data,
label = data$display,
layerId = data$ID,
group = new_group, # change group
fillColor = colour)
}
server <- function(input,output,session){
## Polygon data
rv <- reactiveValues(
df = SpatialPolygonsDataFrame(SpP, data = data.frame(
ID = c("1", "2"),
display = c("1", "1")
), match.ID = FALSE)
)
# initialization
output$map <- renderLeaflet({
leaflet(options = leafletOptions( zoomControl = FALSE, minZoom = 6.2, maxZoom = 6.2, dragging = FALSE))
})
observe({
data <- rv$df
leafletProxy("map") %>%
addPolygons(
data = data,
label = data$display,
layerId = data$ID,
group = "unclicked_poly")
})
#first click
observeEvent(input$map_shape_click, {
# execute only if the polygon has never been clicked
req(input$map_shape_click$group == "unclicked_poly")
# filter data
data <- rv$df[rv$df$ID==input$map_shape_click$id,]
change_color(map = "map",
id_to_remove = input$map_shape_click$id,
data = data,
colour = "yellow",
new_group = "clicked1_poly")
})
#second click
observeEvent(input$map_shape_click, {
# execute only if the polygon has been clicked once
req(input$map_shape_click$group == "clicked1_poly")
data <- rv$df[rv$df$ID==input$map_shape_click$id,]
change_color(map = "map",
id_to_remove = input$map_shape_click$id,
data = data,
colour = "orange",
new_group = "clicked2_poly")
})
#third click
observeEvent(input$map_shape_click, {
req(input$map_shape_click$group == "clicked2_poly")
# filter data
data <- rv$df[rv$df$ID==input$map_shape_click$id,]
change_color(map = "map",
id_to_remove = input$map_shape_click$id,
data = data,
colour = "red",
new_group = "clicked3_poly")
})
#fourth click : back to normal ?
observeEvent(input$map_shape_click, {
req(input$map_shape_click$group == "clicked3_poly")
data <- rv$df[rv$df$ID==input$map_shape_click$id,]
# back to normal
leafletProxy("map") %>%
removeShape(input$map_shape_click$id) %>% # remove previous occurrence
addPolygons(
data = data,
label = as.character(data$display),
layerId = data$ID,
group = "unclicked_poly") # back to initialize group
})
}
shinyApp(ui, server)
Select and Deselect Polylines in Shiny/Leaflet
I found the solution by my own..my data and my incomprehension were the problem. It only works, when all used columns are type character...so i had to do a type conversion with as.character()
Select multiple items using map_click in leaflet, linked to selectizeInput() in shiny app (R)
Please see the following workaround:
I'm adding all polygons on rendering the map and hiding the red overlay. Furthermore each of the red polygons is assigned to it's own group. On click the according group and therefore the polygon is shown/hidden.
library(shiny)
library(leaflet)
library(sf)
library(dplyr)
#load shapefile
nc <- st_read(system.file("shape/nc.shp", package="sf")) %>%
st_transform(4326)
shinyApp(
ui = fluidPage(
"Update selectize input by clicking on the map",
leafletOutput("map"),
"I would like the selectize input to update to show all the locations selected,",
"but also when items are removed here, they are removed on the map too, so linked to the map.",
selectizeInput(inputId = "selected_locations",
label = "selected",
choices = nc$NAME,
selected = NULL,
multiple = TRUE)
),
server <- function(input, output, session){
#create empty vector to hold all click ids
selected_ids <- reactiveValues(ids = vector())
#initial map output
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
addPolygons(data = nc,
fillColor = "white",
fillOpacity = 0.5,
color = "black",
stroke = TRUE,
weight = 1,
layerId = ~NAME,
group = "regions",
label = ~NAME) %>%
addPolygons(data = nc,
fillColor = "red",
fillOpacity = 0.5,
weight = 1,
color = "black",
stroke = TRUE,
layerId = ~CNTY_ID,
group = ~NAME) %>%
hideGroup(group = nc$NAME) # nc$CNTY_ID
}) #END RENDER LEAFLET
#define leaflet proxy for second regional level map
proxy <- leafletProxy("map")
#create empty vector to hold all click ids
selected <- reactiveValues(groups = vector())
observeEvent(input$map_shape_click, {
if(input$map_shape_click$group == "regions"){
selected$groups <- c(selected$groups, input$map_shape_click$id)
proxy %>% showGroup(group = input$map_shape_click$id)
} else {
selected$groups <- setdiff(selected$groups, input$map_shape_click$group)
proxy %>% hideGroup(group = input$map_shape_click$group)
}
updateSelectizeInput(session,
inputId = "selected_locations",
label = "",
choices = nc$NAME,
selected = selected$groups)
})
observeEvent(input$selected_locations, {
removed_via_selectInput <- setdiff(selected$groups, input$selected_locations)
added_via_selectInput <- setdiff(input$selected_locations, selected$groups)
if(length(removed_via_selectInput) > 0){
selected$groups <- input$selected_locations
proxy %>% hideGroup(group = removed_via_selectInput)
}
if(length(added_via_selectInput) > 0){
selected$groups <- input$selected_locations
proxy %>% showGroup(group = added_via_selectInput)
}
}, ignoreNULL = FALSE)
})
Edit: regarding your initial approach adapting this answer you would need to pass the layerId as character to make things work again:
proxy %>% removeShape(layerId = as.character(click$id))
proxy %>% addPolygons(data = clicked_polys,
fillColor = "red",
fillOpacity = 0.5,
weight = 1,
color = "black",
stroke = TRUE,
layerId = as.character(clicked_polys$CNTY_ID))
I filed an issue regarding this.
However, I'd still prefer the above show/hide approach as I guess it's more performant than adding and removing polygons.
Changing Leaflet map according to input without redrawing (multiple polygons)
I guess this is in line with what you are trying to achieve. I prefer have separate global, ui and server files. My sample project file is:
"","Country","Client","Channel","Status"
"1","Croatia","Client 1","Agent network","Launched"
"2","Germany","Client 2","Debit cards","Launched"
"3","Italy","Client 3","M-banking","Planning"
"4","France","Client 4","M-banking","Launched"
"5","Slovenia","Client 5","Agent network","Launched"
"6","Austria","Client 6","Agent network","Launched"
"7","Hungary","Client 7","Agent network","Pilot"
global.R
library(shiny)
library(shinythemes)
library(leaflet)
library(rgdal)
# Set working directory
# Read csv, which was created specifically for this app
projects <- read.csv("sample data10.csv", header = TRUE)
# Read a shapefile
countries <- readOGR(".","ne_50m_admin_0_countries")
# Merge data
projects.df <- merge(countries, projects, by.x = "name", by.y = "Country")
ui.R
library(shiny)
library(shinythemes)
library(leaflet)
library(rgdal)
shinyUI(fluidPage(theme = shinytheme("united"),
titlePanel("Map sample"),
sidebarLayout(
sidebarPanel(
selectInput("countryInput", "Country",
choices = c("Choose country", "Croatia",
"Germany",
"Italy",
"France",
"Slovenia",
"Austria",
"Hungary"),
selected = "Choose country"),
selectInput("clientInput", " Client",
choices = c("Choose Client", "Client 1",
"Client 2",
"Client 3",
"Client 4",
"Client 5",
"Client 6"),
selected = "Choose Client"),
selectInput("channeInput", "Channel",
choices = c("Choose Channel", "Agent network",
"M-banking", "Debit cards"),
selected = "Choose Channel"),
selectInput("statusInput", "Status",
choices = c("Choose status", "Launched",
"Pilot", "Planning"),
selected = "Choose status")
),
mainPanel(leafletOutput(outputId = 'map', height = 800)
)
)
))
server.R
shinyServer(function(input, output) {
output$map <- renderLeaflet({
leaflet(projects.df) %>%
addProviderTiles(providers$Stamen.Watercolor) %>%
setView(11.0670977,0.912484, zoom = 4) #%>%
})
# observers
# selected country
selectedCountry <- reactive({
projects.df[projects.df$name == input$countryInput, ]
})
observe({
state_popup <- paste0("<strong>Country: </strong>",
selectedCountry()$name,
"<br><strong> Client: </strong>",
selectedCountry()$Client,
"<br><strong> Channel: </strong>",
selectedCountry()$Channel,
"<br><strong>Status: </strong>",
selectedCountry()$Status)
leafletProxy("map", data = selectedCountry()) %>%
clearShapes() %>%
addPolygons(fillColor = "red",
popup = state_popup,
color = "#BDBDC3",
fillOpacity = 1,
weight = 1)
})
# selected clients
selectedClient <- reactive({
tmp <- projects.df[!is.na(projects.df$Client), ]
tmp[tmp$Client == input$clientInput, ]
})
observe({
state_popup <- paste0("<strong>Country: </strong>",
selectedClient()$name,
"<br><strong> Client: </strong>",
selectedClient()$Client,
"<br><strong> Channel: </strong>",
selectedClient()$Channel,
"<br><strong>Status: </strong>",
selectedClient()$Status)
leafletProxy("map", data = selectedClient()) %>%
clearShapes() %>%
addPolygons(fillColor = "yellow",
popup = state_popup,
color = "#BDBDC3",
fillOpacity = 1,
weight = 1)
})
# selected channel
selectedChannel <- reactive({
tmp <- projects.df[!is.na(projects.df$Channel), ]
tmp[tmp$Channel == input$channeInput, ]
})
observe({
state_popup <- paste0("<strong>Country: </strong>",
selectedChannel()$name,
"<br><strong> Client: </strong>",
selectedChannel()$Client,
"<br><strong> Channel: </strong>",
selectedChannel()$Channel,
"<br><strong>Status: </strong>",
selectedChannel()$Status)
leafletProxy("map", data = selectedChannel()) %>%
clearShapes() %>%
addPolygons(fillColor = "green",
popup = state_popup,
color = "#BDBDC3",
fillOpacity = 1,
weight = 1)
})
# selected status
selectedStatus <- reactive({
tmp <- projects.df[!is.na(projects.df$Status), ]
tmp[tmp$Status == input$statusInput, ]
})
observe({
state_popup <- paste0("<strong>Country: </strong>",
selectedStatus()$name,
"<br><strong> Client: </strong>",
selectedStatus()$Client,
"<br><strong> Channel: </strong>",
selectedStatus()$Channel,
"<br><strong>Status: </strong>",
selectedStatus()$Status)
leafletProxy("map", data = selectedStatus()) %>%
clearShapes() %>%
addPolygons(fillColor = "blue",
popup = state_popup,
color = "#BDBDC3",
fillOpacity = 1,
weight = 1)
})
})
Let me know...
Issue with selecting multiple filter options in R Shiny with Leaflet
A few things you should consider for next time.
Use dput() on your dataframe to give us a quick way to use your data and run your code in a fresh r session before posting to check if it actually runs. You have a comma after "Topic 2" which throws out an error.
pickerInput("topicInput","Topic", choices=c("Select topic...", "Topic 1", "Topic 2", )...
If you run your code you should get something like
Warning in mapdata$Country == input$countryInput : longer object
length is not a multiple of shorter object length
To fix that problem just try following
server <- function(input, output) {
output$map <- renderLeaflet({
#Set basemap
leaflet(mapdata) %>%
addProviderTiles(providers$Wikimedia) %>%
setView(lat = 54.093409, lng = -2.89479, zoom = 6)
})
#Select country
selectedCountry <- reactive({
mapdata[mapdata$Country %in% input$countryInput, ] # here you want to change to %in% as == does a element wise checking for equality
})
observe({
state_popup <- paste0("<strong>Country: </strong>",
selectedCountry()$Country,
"<br><strong> Topic: </strong>",
selectedCountry()$Topic)
leafletProxy("map", data = selectedCountry()) %>%
clearMarkerClusters() %>%
clearMarkers() %>%
addMarkers(~long, ~lat, clusterOptions = markerClusterOptions())
})
#Select topic
selectedTopic <- reactive({
tmp <- mapdata[!is.na(mapdata$Topic), ]
tmp[tmp$Topic == input$topicInput, ]
})
observe({
state_popup <- paste0("<strong>Country: </strong>",
selectedTopic()$Country,
"<br><strong> Topic: </strong>",
selectedTopic()$Topic)
leafletProxy("map", data = selectedTopic()) %>%
clearMarkers() %>%
clearMarkerClusters() %>%
addMarkers(~long, ~lat, clusterOptions = markerClusterOptions())
})
}
shinyApp(ui, server)
You can also check Why do I get “warning longer object length is not a multiple of shorter object length”?
Hope that helps.
Related Topics
Order Categorical Data in a Stacked Bar Plot with Ggplot2
Create Link to the Other Part of the Shiny App
R Crashing While Displaying Ggplot After Update (Process Memory Read Out of Range)
Using R - Delete Rows When a Value Repeated Less Than 3 Times
Data.Table - Left Outer Join on Multiple Tables
Problems with Dplyr and Posixlt Data
A Vector to an Upper Triangle Matrix by Row in R
How to Pass Aes Parameters of Ggplot to Function
How to Load a Matlab Struct into a R Data Frame
Ggplot2 Add a Legend for Several Stat_Functions
Subtract Pairs of Columns Based on Matching Column
Package 'Pbkrtest' Is Not Available (For R Version 3.2.2)
Text Color Based on Contrast Against Background
How to Combine Multiple .CSV Files in R
Error: Maximal Number of Dlls Reached
Difference Between Backticks and Quotes in Aes Function in Ggplot
Ggplot2: Horizontal Position of Stat_Summary with Geom_Boxplot