带有动画传单的图例

Question

我有一个动画地图，其中的点按组进行颜色编码（其中组由用户输入提供）。并非所有组都在所有时间戳上都存在。我希望图例保持静态 - 即显示用户选择的所有组，而点移动/消失（如果该组/时间不存在）。

我不知道如何使图例正确工作（目前，图例和地图之间的颜色不协调 - 例如，地图上显示的第一个点是“b”，但其颜色编码为“a”，由于我的两个数据集之间的

group

值存在差异（

points()

，它存储与动画滑块中显示的日期戳相关的数据，以及

df()

，它存储由用户...

下面是一个玩具示例。

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

一旦修复了每个

Group

值的颜色，您应该能够实现所需的输出。 试试这个

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)