Question

我制作了一个在地图上显示坐标的应用程序，可以使用sliderInput动画功能对其进行动画处理。但是，每次地图在两个日期之间切换时，即使它是完全相同的基础地图，地图也会随着刷新而闪烁。有办法防止这种情况发生吗？

示例应用程序：

library(tidyverse)
library(leaflet)
library(sf)
library(analyticsSimprintR)
library(shiny)

mapUI <- function(id){
  ns <- NS(id)
  tagList(
    leafletOutput(ns("map")))
}
mapServer <- function(input, output, session, data, dateFetcher){
  output$map <- renderLeaflet({
    leaflet(options = leafletOptions(preferCanvas = TRUE)) %>%
      addProviderTiles(providers$Esri.WorldGrayCanvas, options = providerTileOptions(
        updateWhenZooming = TRUE,      # map won't update tiles until zoom is done
        updateWhenIdle = FALSE           # map won't load new tiles when panning
      )) %>%
      fitBounds(lng1 = min(data$lon),
                lat1 = min(data$lat),
                lng2 = max(data$lon),
                lat2 = max(data$lat))%>%
      addCircles(data = st_as_sf(data[data$date == dateFetcher(),],
                                 coords = c("lon", "lat"),
                                 crs = 4326,
                                 agr = "constant"),
                 weight = 0)
  })
}

localChooserUI <- function(id){
  ns <- NS(id)
  uiOutput(ns('chooser'))
}
dateSlider <- function(input, output, session, data){
  output$chooser <- renderUI({
    ns <- session$ns
    sliderInput(inputId = ns("chosen"),
                "Dates:",
                min = as.Date("2019-01-01","%Y-%m-%d"),
                max = as.Date("2019-04-01","%Y-%m-%d"),
                value=as.Date("2019-01-01"),
                timeFormat="%Y-%m-%d",
                animate = animationOptions(interval = 750, loop = TRUE))
  })

  return(reactive(input$chosen))

}

ui <- fluidPage(
  sidebarPanel('Filters',
               localChooserUI('mapDateSlider')),
  mainPanel(mapUI('newMap'))
)

server <- function(input,output){
  coords <- data.frame(lon = runif(10000, min = 0, max = 10), 
                       lat = runif(10000, min = 0, max = 10),
                       date = sample(seq(as.Date('2019/01/01'), 
                                         as.Date('2019/04/01'), 
                                         by="day"), 
                                     100000, , replace = TRUE))
  dateInput <- callModule(dateSlider, id = 'mapDateSlider', data = coords)
  callModule(mapServer, id = 'newMap', data = coords, dateFetcher = dateInput)

}


shinyApp(ui, server)

Answer 1

找到了答案，那就是使用观察来添加点：

library(tidyverse)
library(leaflet)
library(sf)
library(analyticsSimprintR)
library(shiny)

mapUI <- function(id){
  ns <- NS(id)
  tagList(
    leafletOutput(ns("map")))
}
mapServer <- function(input, output, session, data, dateFetcher){
  output$map <- renderLeaflet({
    leaflet(options = leafletOptions(preferCanvas = TRUE)) %>%
      addProviderTiles(providers$Esri.WorldGrayCanvas, options = providerTileOptions(
        updateWhenZooming = TRUE,      # map won't update tiles until zoom is done
        updateWhenIdle = FALSE           # map won't load new tiles when panning
      )) %>%
      fitBounds(lng1 = min(data$lon),
                lat1 = min(data$lat),
                lng2 = max(data$lon),
                lat2 = max(data$lat))
  })
  observe({
    leafletProxy(mapId = 'map') %>%
    clearMarkers() %>%
    clearShapes() %>%
      addCircles(data = st_as_sf(data[data$date == dateFetcher(),],
                                 coords = c("lon", "lat"),
                                 crs = 4326,
                                 agr = "constant"),
                 weight = 0)})
}

localChooserUI <- function(id){
  ns <- NS(id)
  uiOutput(ns('chooser'))
}
dateSlider <- function(input, output, session, data){
  output$chooser <- renderUI({
    ns <- session$ns
    sliderInput(inputId = ns("chosen"),
                "Dates:",
                min = as.Date("2019-01-01","%Y-%m-%d"),
                max = as.Date("2019-04-01","%Y-%m-%d"),
                value=as.Date("2019-01-01"),
                timeFormat="%Y-%m-%d",
                animate = animationOptions(interval = 750, loop = TRUE))
  })

  return(reactive(input$chosen))

}

ui <- fluidPage(
  sidebarPanel('Filters',
               localChooserUI('mapDateSlider')),
  mainPanel(mapUI('newMap'))
)

server <- function(input,output){
  coords <- data.frame(lon = runif(10000, min = 0, max = 10), 
                       lat = runif(10000, min = 0, max = 10),
                       date = sample(seq(as.Date('2019/01/01'), 
                                         as.Date('2019/04/01'), 
                                         by="day"), 
                                     100000, , replace = TRUE))
  dateInput <- callModule(dateSlider, id = 'mapDateSlider', data = coords)
  callModule(mapServer, id = 'newMap', data = coords, dateFetcher = dateInput)

}


shinyApp(ui, server)

阻止传单地图在动画效果中闪烁

1 个答案: