Using click events in leaflet to dynamically display grouped sums - r

Question

I'm working on a shiny app with basic functionality like this:
library(sf)
library(DT)
library(leaflet)
library(shiny)
library(tidyverse)
nc <- st_read(system.file("shape/nc.shp", package = "sf"), quiet = T) %>%
st_transform(4326) %>%
select(NAME, geometry, id = CNTY_ID) %>%
mutate(x = rnorm(n = nrow(.), mean = 100, sd = 20),
fill = sample(c("green", "red"), n(), replace = T),
fill_2 = if_else(fill == "green", "red", "green"))
# Function to change fill color on click event (taken from https://stackoverflow.com/a/69618323)
change_color <- function(map, id_to_remove, data, colour, new_group){
leafletProxy(map) %>%
removeShape(id_to_remove) %>% # remove previous occurrence
addPolygons(
data = data,
layerId = data$id,
group = new_group, # change group
fillColor = colour,
color = "black",
weight = 1,
fillOpacity = 1)
}
## UI
ui <- fluidPage(
leafletOutput("map"),
DT::dataTableOutput("table")
)
## Server
server <- function(input,output,session){
# Reactives
rv <- reactiveValues(
df = nc,
df.tab = as.data.frame(nc)
)
# Initial map
output$map <- renderLeaflet({
leaflet() %>%
setView(-79.99, 35.52, zoom = 7)
})
observe({
data <- rv$df
leafletProxy("map") %>%
addPolygons(
data = data,
weight = 1, color = "black", fillOpacity = 1, fillColor = ~fill,
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 = ~fill_2,
new_group = "clicked1_poly")
})
#second click: reverse first click
observeEvent(input$map_shape_click, {
req(input$map_shape_click$group == "clicked1_poly")
data <- rv$df[rv$df$id==input$map_shape_click$id,]
leafletProxy("map") %>%
removeShape(input$map_shape_click$id) %>% # remove previous occurrence
addPolygons(
data = data,
weight = 1, color = "black", fillOpacity = 1, fillColor = ~fill,
layerId = data$id,
group = "unclicked_poly") # back to initialize group
})
output$table <- DT::renderDataTable({
rv$df.tab %>%
group_by(fill) %>%
summarise(x = sum(x))
})
}
shinyApp(ui, server)
The idea here is that the user can change the fill color of the polygons with the click of a button. This works as is. However, I also want to dynamically display the fill-specific sum of x in the data tabe below the leaflet map. Currently, the table shows the grouped sums according to the initial data frame. However, when a user changes a polygon from green to red, the calculation should be done anew.
I have tried implementing this idea using a logic similar to the observeEvents() in output(map), but the problem here was that I could only ever access the last click, so previous clicks would not factor into the grouped sums calculation (group_by(fill) %>% summarise(x = sum(x))). Ideally, I would like to have information on whatever the current fill of all polygons is so that the data table reflects the user's input.

Answer 1

I ended up solving this problem in four steps:
Recording each click on a polygon using reactiveValues(Clicks=vector())
Converting vector into data frame, with click frequency determined by table()
Using modulo division on the number of clicks with the %% operator to ascertain current fill color on map (the number of fill options is much higher than two in my real world application)
Merging clicked and unclicked polygons to obtain current map status and using DT::dataTableProxy() to update table
App is now working as intended. Code:
library(sf)
library(DT)
library(leaflet)
library(shiny)
library(tidyverse)
nc <- st_read(system.file("shape/nc.shp", package = "sf"), quiet = T) %>%
st_transform(4326) %>%
select(NAME, geometry, id = CNTY_ID) %>%
mutate(x = rnorm(n = nrow(.), mean = 100, sd = 20),
fill = sample(c("green", "red"), n(), replace = T),
fill_2 = if_else(fill == "green", "red", "green"))
# Function to change fill color on click event (taken from https://stackoverflow.com/a/69618323)
change_color <- function(map, id_to_remove, data, colour, new_group){
leafletProxy(map) %>%
removeShape(id_to_remove) %>% # remove previous occurrence
addPolygons(
data = data,
layerId = data$id,
group = new_group, # change group
fillColor = colour,
color = "black",
weight = 1,
fillOpacity = 1)
}
## UI
ui <- fluidPage(
leafletOutput("map"),
DT::dataTableOutput("table")
)
## Server
server <- function(input,output,session){
# Reactives
rv <- reactiveValues(
df = nc,
df.tab = as.data.frame(nc)
)
# Initial map
output$map <- renderLeaflet({
leaflet() %>%
setView(-79.99, 35.52, zoom = 7)
})
observe({
data <- rv$df
leafletProxy("map") %>%
addPolygons(
data = data,
weight = 1, color = "black", fillOpacity = 1, fillColor = ~fill,
layerId = data$id, label = ~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 = ~fill_2,
new_group = "clicked1_poly")
})
#second click: reverse first click
observeEvent(input$map_shape_click, {
req(input$map_shape_click$group == "clicked1_poly")
data <- rv$df[rv$df$id==input$map_shape_click$id,]
leafletProxy("map") %>%
removeShape(input$map_shape_click$id) %>% # remove previous occurrence
addPolygons(
data = data,
weight = 1, color = "black", fillOpacity = 1, fillColor = ~fill,
layerId = data$id, label = ~id,
group = "unclicked_poly") # back to initialize group
})
output$table <- DT::renderDataTable({
rv$df.tab %>%
group_by(fill) %>%
summarise(x = sum(x)) -> sum
sum
})
proxy <- DT::dataTableProxy("table")
RV<-reactiveValues(Clicks=vector())
observeEvent(input$map_shape_click, {
#create object for clicked polygon
click <- input$map_shape_click
RV$Clicks<- c(RV$Clicks,click$id)
test <- as.data.frame(table(RV$Clicks)) %>%
mutate(current = Freq %% 2,
id = as.double(as.character(Var1)))
rv$df.tab %>%
full_join(test, by = "id") %>%
mutate(fill = case_when(current == 1 ~ fill_2,
TRUE ~ fill)) %>%
group_by(fill) %>%
summarise(x = sum(x)) -> sum
proxy %>% replaceData(sum)
})
}
shinyApp(ui, server)