legend with animated leaflet

Question

I have an animated map, with points colour-coded by group (where groups are provided by user input). Not all groups are present at all time stamps. I would like the legend to remain static - i.e., show all groups selected by the user, while the points move around / disappear (if that group/time doesn't exist).

I can't figure out how to make the legend work correctly (currently, the colours are not coordinated between the legend and the map - for example, the first point shown on the map is "b", but its colour-coded as "a", due to the discrepancy in group values between my two datasets (points(), which stores data relevant to the date stamp shown in the animation slider, and df(), which stores the data on the groups selected by the user...

A toy example is below.

library(plyr)
library(dplyr)
library(tidyr)
library(ggplot2)
library(shiny)
library(leaflet)

set.seed(0)         
data <- data.frame(Lon = -119.5, Lat = 49.3, Group = letters[1:10]) %>%
        crossing(Date = seq(as.Date("2020-01-01"), as.Date("2020-01-10"), 1)) %>%
        mutate(Lon = rnorm(n(), Lon, 0.1),
                Lat = rnorm(n(), Lat, 0.1))
data <- data[sample(1:nrow(data), 40),]

ui <- fluidPage(
        sidebarLayout(sidebarPanel(selectInput(inputId = "Var", label = "select", 
                        choices = letters[1:6], multiple = TRUE, selected = c("a", "b", "c"))),
            mainPanel(sliderInput("animationSlider", "Date:", 
                 min = min(data$Date), max = max(data$Date), value = min(data$Date), step = 1,
                 animate = animationOptions(interval = 600, loop = FALSE)),
                        leafletOutput("MapAnimate", width="1100px", height="650px")))) 
                                                
                
server <- function(input, output, session) {
    df <- reactive({
            data %>%
                filter(Group %in% input$Var)
                                })

     points <- reactive({
          req(input$animationSlider)
          df() %>%
            filter(Date == input$animationSlider)
   })
    
     output$MapAnimate <- renderLeaflet({
        df.in <- df()
        pal <- colorFactor("RdYlBu", df.in$Group)

         leaflet(data) %>%
            setView(lng = -119.5, lat = 49.3, zoom = 9) %>%
            addProviderTiles("Esri.WorldImagery", layerId = "basetile") %>%
         addLegend(title = "ID", position = "topleft", pal = pal, values = ~df.in$Group)     
                                 }) 
                                 
 observe({
     df.in <- points()
 
     pal <- colorFactor("RdYlBu", df.in$Group)
 
     leafletProxy("MapAnimate", data = points()) %>%
         clearShapes() %>%
         addCircles(lng = ~Lon, lat = ~Lat, fillOpacity = 1, color = ~pal(df.in$Group), popup = ~Group) 
 })
}

shinyApp(ui = ui, server = server)

Answer 1

Once you fix the colors for each Group value, you should be able to achieve your desired output. Try this

library(plyr)
library(dplyr)
library(tidyr)
library(ggplot2)
library(shiny)
library(leaflet)

set.seed(0)         
data <- data.frame(Lon = -119.5, Lat = 49.3, Group = letters[1:10]) %>%
  crossing(Date = seq(as.Date("2020-01-01"), as.Date("2020-01-10"), 1)) %>%
  mutate(Lon = rnorm(n(), Lon, 0.1),
         Lat = rnorm(n(), Lat, 0.1))
data <- data[sample(1:nrow(data), 40),]

ui <- fluidPage(
  sidebarLayout(sidebarPanel(selectInput(inputId = "Var", label = "select", 
                                         choices = letters[1:6], multiple = TRUE, selected = c("a", "b", "c"))),
                mainPanel(sliderInput("animationSlider", "Date:", 
                                      min = min(data$Date), max = max(data$Date), value = min(data$Date), step = 1,
                                      animate = animationOptions(interval = 600, loop = FALSE)),
                          leafletOutput("MapAnimate", width="1100px", height="650px")))) 


server <- function(input, output, session) {
  df <- reactive({
    data %>%
      filter(Group %in% input$Var)
  })
  
  points <- reactive({
    req(input$animationSlider)
    df() %>%
      filter(Date == input$animationSlider)
  })
  
  mycolorlist <- c("red", "blue", "black", "purple", "green", "orange", "yellow", "steelblue", "cyan", "maroon", "darkblue", "darkgreen", "brown")
  n <- length(unique(data$Group))
  mycolors <- reactive({
    colorFactor("RdYlBu", levels=unique(data$Group))
    #colorFactor(mycolorlist[1:n], levels=unique(data$Group))  ## manually define your own colors
  })
  
  output$MapAnimate <- renderLeaflet({
    df.in <- df()
    pal <- mycolors() # colorFactor("RdYlBu", df.in$Group)
    
    leaflet(data) %>%
      setView(lng = -119.5, lat = 49.3, zoom = 9) %>%
      addProviderTiles("Esri.WorldImagery", layerId = "basetile") %>%
      addLegend(title = "ID", position = "topleft", pal = pal, values = ~df.in$Group)     
  }) 
  
  observe({
    df.in <- points()
    
    pal <- mycolors() # colorFactor("RdYlBu", df.in$Group)
    
    leafletProxy("MapAnimate", data = points()) %>%
      clearShapes() %>%
      addCircles(lng = ~Lon, lat = ~Lat, fillOpacity = 1, color = ~pal(df.in$Group), popup = ~Group)
  })
}

shinyApp(ui = ui, server = server)