使用Leaflet/R创建时间滑块

Question

我目前在使用R语言，并使用leaflet包来可视化地理空间数据，我想通过时间轴进行分析并显示我的地图。在R中，有一个美学函数，可以使用“frame”选项添加滑块，是否有类似的函数可以在leaflet / ggmap中实现或者至少可以根据不同年份对地图进行分面？我尝试使用ggmap和ggplotly进行练习，但结果并不如预期。任何示例/文档或提示都将非常有帮助。我已经将现有的代码适应到我的数据库中，但是我没有任何方法为每年执行核密度估计。

ui <- bootstrapPage(
  tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
  leafletOutput("map", width = "100%", height = "100%"),
  absolutePanel(top = 10, right = 10,

    sliderInput("range", "Magnitudes", min(FINAL$UWY), max(FINAL$UWY),
      value = range(FINAL$UWY), step = 1,
      animate =
                    animationOptions(interval = 500, loop = TRUE)

    ),        

    #sliderInput("animation", "Looping Animation:",
    #              min = min(FINAL$UWY), max = max(FINAL$UWY),
    #              value = range(FINAL$UWY), step = 1,
    #              animate =
    #                animationOptions(interval = 300, loop = TRUE)

    #),
    selectInput("colors", "Color Scheme",
      rownames(subset(brewer.pal.info, category %in% c("seq", "div")))
    ),
    checkboxInput("legend", "Show legend", TRUE)
  )
)

server <- function(input, output, session) {

  # Reactive expression for the data subsetted to what the user selected
  filteredData <- reactive({
    FINAL[FINAL$UWY >= input$range[1] & FINAL$UWY <= input$range[2],]
  })

  # This reactive expression represents the palette function,
  # which changes as the user makes selections in UI.
  colorpal <- reactive({
    colorNumeric(input$colors, FINAL$UWY)
  })

  output$map <- renderLeaflet({
    # Use leaflet() here, and only include aspects of the map that
    # won't need to change dynamically (at least, not unless the
    # entire map is being torn down and recreated).
    leaflet(FINAL) %>% addTiles() %>%
      fitBounds(~min(longitude), ~min(latitude), ~max(longitude), ~max(latitude))
  })

  # Incremental changes to the map (in this case, replacing the
  # circles when a new color is chosen) should be performed in
  # an observer. Each independent set of things that can change
  # should be managed in its own observer.
  observe({
    pal <- colorpal()

    leafletProxy("map", data = filteredData()) %>%
      clearShapes() %>%
      addCircles(radius = ~amount_claims/10, weight = 1, color = "#777777",
        fillColor = ~pal(amount_claims), fillOpacity = 0.7, popup = ~paste(Country.EN)
      )
  })

  # Use a separate observer to recreate the legend as needed.
  observe({
    proxy <- leafletProxy("map", data = FINAL)

    # Remove any existing legend, and only if the legend is
    # enabled, create a new one.
    proxy %>% clearControls()
    if (input$legend) {
      pal <- colorpal()
      proxy %>% addLegend(position = "bottomright",
        pal = pal, values = ~amount_claims
      )
    }
  })
}

shinyApp(ui, server)

- Yough Ghoug

---

你目前尝试了什么？ - Stedy

@Stedy：我已经添加了代码。 - Yough Ghoug

Answer 1

这里是使用Shiny包的基本解决方案：

    library(shiny)
    library(dplyr)
    library(leaflet)

    # Fake data
    df <- data.frame(lng = c(-5, -5, -5, -5, -15, -15, -10),
                     lat = c(8, 8, 8, 8, 33, 33, 20),
                     year = c(2018, 2018, 2018, 2017, 2017, 2017, 2016),
                     stringsAsFactors = FALSE)

    ui <- bootstrapPage(
      tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
      leafletOutput("map", width = "100%", height = "100%"),
      absolutePanel(top = 10, right = 10,
                    style="z-index:500;", # legend over my map (map z = 400)
                    tags$h3("map"), 
                    sliderInput("periode", "Chronology",
                                min(df$year),
                                max(df$year),
                                value = range(df$year),
                                step = 1,
                                sep = ""
                    )
    )
    )

    server <- function(input, output, session) {

      # reactive filtering data from UI

      reactive_data_chrono <- reactive({
        df %>%
          filter(year >= input$periode[1] & year <= input$periode[2])
      })


      # static backround map
      output$map <- renderLeaflet({
        leaflet(df) %>%
          addTiles() %>%
          fitBounds(~min(lng), ~min(lat), ~max(lng), ~max(lat))
      })  

      # reactive circles map
      observe({
        leafletProxy("map", data = reactive_data_chrono()) %>%
          clearShapes() %>%
          addMarkers(lng=~lng,
                     lat=~lat,
                     layerId = ~id) # Assigning df id to layerid
      })
    }

    shinyApp(ui, server)

- Wilcar