leafgl
leafgl copied to clipboard
r-spatial
Weird behavior where polygons will change colour when they haven't been clicked in r shiny
I am trying to make a shiny app where the user uses a slider input to create n leaflet maps. Then on these maps clickable polygons are displayed, when the user clicks on the polygon the polygon changes colour.
I had this working with leaflet and addPolygons but because I need 19000+ polygons on (up to) 99 maps, I've been trying to use leafgl and addGlPolygons.
At first the maps seem to work ok, but then they start to display weird behavior where polygons will change colour when they haven't been clicked.
When they are initially plotted they are blue, but when the app errors they are removed.
Then I also get this weird sad face with cross eyes in the top-left corner of the leaflet.
library(shiny)
library(leaflet)
library(sp)
library(leafgl)
library(dplyr)
## create five 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)))
Sr3 <- Polygon(cbind(c(3, 4, 4, 3, 3), c(1, 1, 2, 2, 1)))
Sr4 <- Polygon(cbind(c(4, 5, 5, 4, 4), c(1, 1, 2, 2, 1)))
Sr5 <- Polygon(cbind(c(5, 6, 6, 5, 5), c(1, 1, 2, 2, 1)))
Srs1 <- Polygons(list(Sr1), "s1")
Srs2 <- Polygons(list(Sr2), "s2")
Srs3 <- Polygons(list(Sr3), "s3")
Srs4 <- Polygons(list(Sr4), "s4")
Srs5 <- Polygons(list(Sr5), "s5")
SpP <- SpatialPolygons(list(Srs1, Srs2, Srs3, Srs4, Srs5), 1:5)
ui <- fluidPage(
sliderInput("nomaps", "Number of maps:",
min = 1, max = 5, value = 1
),
uiOutput("plots")
)
change_color <- function(map, id_to_remove, data, colour, new_group){
leafletProxy(map) %>%
removeGlPolygons(id_to_remove) %>% # remove previous occurrence
addGlPolygons(
data = data,
label = data$display,
layerId = data$ID,
group = new_group, # change group
color = colour)
}
server <- function(input,output,session){
## Polygon data
rv <- reactiveValues(
df = SpatialPolygonsDataFrame(SpP, data = data.frame(
ID = c("1", "2", "3", "4", "5"),
display = c("1", "1","1", "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
lapply(1:input$nomaps, function(i) {
output[[paste("plot", i, sep = "_")]] <- renderLeaflet({
leaflet(options = leafletOptions(zoomControl = FALSE, minZoom = 6.2, maxZoom = 6.2, dragging = FALSE))%>%
addGlPolygons(
data = data,
label = data$display,
layerId = data$ID,
group = "unclicked_poly",
color = cbind(0, 0.2, 1),
fillOpacity = 1)
})
})
})
# Create plot tag list
output$plots <- renderUI({
plot_output_list <- lapply(1:input$nomaps, function(i) {
plotname <- paste("plot", i, sep = "_")
leafglOutput(plotname)
})
do.call(tagList, plot_output_list)
})
observe ({
lapply(1:input$nomaps, function(i) {
observeEvent(input[[paste0("plot_", i,"_glify_click",sep="")]], {
selected.id <- input[[paste0("plot_", i,"_glify_click",sep="")]]
data <- rv$df[rv$df$ID==selected.id$id,]
change_color(map = paste0("plot_", i, sep=""),
id_to_remove = selected.id$id,
data = data,
colour = "yellow",
new_group = "clicked1_poly")
})
})
})
}
shinyApp(ui, server)
Hi @BrookeGibbons interesting use-case... I think you're hitting a browser imposed limit of how many webgl contexts are allowed to be drawn. IIRC for chrome this number is 16. You should see a warning in the browser console: "WARNING: Too many active WebGL contexts. Oldest context will be lost." @robertleeplummerjr is ther anything that Leaflet.glify can do to avoid hitting this limit? E.g. draw everything that is added to a map to the same webgl canvas? Is something like that even possible?
