Shiny开发Leaflet动画地图静态图例实现及颜色匹配问题

开发R生态下带时间滑块的Leaflet动画地图，点位按用户勾选的分组做颜色编码。受数据覆盖限制，并非每个时间戳下都有全部分组的点位，核心需求是图例全程固定展示用户选中的所有分组，不随当前时间戳的点位动态变化——某分组在当前时间没有数据时，对应点位自动消失，但图例始终保留全部分组的颜色映射关系。
目前存在的故障：点位颜色和图例映射不匹配，比如本该属于b分组的点，被渲染成了a分组对应的颜色。

两处独立的颜色映射逻辑不一致：

• 渲染静态图例时，用全量选中分组的数据集df()生成颜色因子
• 渲染动态点位时，又基于当前时间戳的点位集points()重新生成一次颜色因子
  由于当前时间戳下经常缺少部分分组数据，新生成的颜色因子会把现有点位按出现顺序重新映射颜色，直接打乱了和图例的对应关系。

• 基于用户选中的全部分组列表，一次性生成固定的颜色因子调色板，后续不管是渲染图例还是动态点位，都调用同一个调色板，绝对不基于当前时间的点位集重算调色板
• 生成调色板时通过domain参数锁定全部分组的映射范围，避免因缺失数据导致的颜色偏移
• 图例基于固定调色板生成，全程锁定全部分组的展示，不随时间点变化
• 动态更新点位时，直接复用同一个固定调色板给点位上色，没有对应分组数据时自然不会画出点，完全不影响图例展示

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 = "选择分组", 
                  choices = letters[1:6], multiple = TRUE, selected = c("a", "b", "c"))
    ),
    mainPanel(
      sliderInput("animationSlider", "日期:", 
                  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)
  })

  # 固定调色板：始终基于用户选中的全部分组生成映射关系，不随时间戳变化
  pal <- reactive({
    req(df())
    colorFactor("RdYlBu", domain = df()$Group)
  })

  # 渲染静态底图+固定图例
  output$MapAnimate <- renderLeaflet({
    leaflet(data) %>%
      setView(lng = -119.5, lat = 49.3, zoom = 9) %>%
      addProviderTiles("Esri.WorldImagery", layerId = "basetile") %>%
      addLegend(title = "分组", position = "topleft", 
                pal = pal(), values = df()$Group)     
  }) 
                                 
  # 动态更新时间轴对应的点位
  observe({
    leafletProxy("MapAnimate", data = points()) %>%
      clearShapes() %>%
      addCircles(lng = ~Lon, lat = ~Lat, fillOpacity = 1, 
                 color = ~pal()(Group), popup = ~Group) 
  })
}

shinyApp(ui = ui, server = server)

内容的提问来源于stack exchange，提问作者user2602640