остановить листовки карта вспыхивает в анимированные блестящие - PullRequest
Новая
       27

остановить листовки карта вспыхивает в анимированные блестящие

0 голосов
/ 19 марта 2019

Я создал приложение, которое отображает координаты на карте, которые можно анимировать с помощью функции анимации 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)

1 Ответ

1 голос
/ 19 марта 2019

Найден ответ, который заключается в добавлении баллов с помощью наблюдения: 

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)
...