I have a Shiny app with a leaflet showing ~9,000 points on a grid (each point representing a 100 m x 100 m square). The app is animated, so that each point changes colour over time. The first version of the app used addPolygons() with the setShapeStyle() function from here to allow the polygons to change colour over time, while accounting for area that each point accounts for. The polygon app was great but super slow, so I changed to addCircleMarkers instead, coupled with setCircleMarkerStyle() from the same GitHub page. This is way faster and works well, BUT I have 2 problems - 1) at low zooms, my points overlap, and 2) at high zooms, my points are separated by space.
Can anyway help me apply the same animation solutions offered by the change of style as here, but applied to addCircles() so that I can use a set radius, or a similar solution? Ideas for making the points square, so that I don't end up with empty spaces at high zooms are also welcome.
libraries and fake data:
library(plyr)
library(dplyr)
library(tidyr)
library(lubridate)
library(shiny)
library(leaflet)
library(viridisLite)
nodes <- structure(list(node = 1:9, Lon = c(-60.1760758677342, -60.1768617891598,
-60.1664512653477, -60.1672369749724, -60.1680228296767, -60.1688085769102,
-60.1695943435806, -60.170380129055, -60.1711659327049), Lat = c(43.316878317912,
43.317580709354, 43.309714197049,43.310416744826, 43.311119197611,
43.311821734546, 43.312524176034, 43.3132266121, 43.31392913277
)), row.names = c(NA, -9L), class = "data.frame")
data <- nodes %>%
crossing(Date = seq(as_date("2020-01-01"), as_date("2020-03-15"), "1 day")) %>%
mutate(Density = abs(rnorm(675, 10, 10)),
Exceed = ifelse(Density > 20, 1, 0),
Layer = paste(node, "Tile", sep = "_"))
FirstDay <- data %>%
filter(Date == min(Date))
Helper functions (based on the Github page referenced):
leafletjs <- tags$head(
tags$script(HTML('
window.LeafletWidget.methods.setStyle = function(category, layerId, style){
var map = this;
if (!layerId){
return;
} else if (!(typeof(layerId) === "object" && layerId.length)){
layerId = [layerId];
}
style = HTMLWidgets.dataframeToD3(style);
layerId.forEach(function(d,i){
var layer = map.layerManager.getLayer(category, d);
if (layer){
layer.setStyle(style[i]);
}
});
};
')))
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)
){
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);
}
UI and server
ui <- fluidPage(
leafletjs,
sidebarLayout(
sidebarPanel(sliderInput("dateSel", "Date",
min = min(data$Date), max = max(data$Date),
value = min(data$Date), step = 1, timeFormat = "%d %b %y",
animate = animationOptions(interval = 100, loop = FALSE))),
mainPanel(leafletOutput("MapAnimate"))))
server <- function(input, output, session) {
filteredData <- reactive({
data %>% filter(Date == input$dateSel)
})
output$MapAnimate <- renderLeaflet({
range <- range(data$Density)
palette <- colorNumeric(palette = viridis(100), domain = range)
leaflet(FirstDay) %>%
addTiles() %>%
addCircleMarkers(lng = ~Lon, lat = ~Lat, layerId = ~Layer,
fillColor = "lightgray", fill = TRUE,
color = "white", stroke = TRUE,
fillOpacity = 1, opacity = 1, weight = 2) %>%
leaflet::addLegend(pal = palette, values = range, opacity = 0.9, position = "topleft")
})
observe({
df.in <- filteredData()
range <- range(data$Density)
palette <- colorNumeric(palette = viridis(100), domain = range)
leafletProxy("MapAnimate", data = df.in) %>%
setCircleMarkerStyle(layerId = ~Layer,
fillColor = ~palette(Density),
color = ~ifelse(Exceed == 1, "red", "white"))
})
}
shinyApp(ui = ui, server = server)