Динамическая тепловая карта Shiny R с ggplot. Проблемы с масштабом и скоростью

Question

Я пытаюсь использовать некоторую общедоступную информацию для составления тепловой карты Канады для некоторой статистики труда. Использование пространственных файлов из переписи и данных из Статистического управления Канады (это большие zip-файлы, в которые нет необходимости копаться). Ниже приведен рабочий пример, который иллюстрирует обе проблемы, с которыми я сталкиваюсь, с небольшим относительным изменением между регионами (хотя между периодами может быть большое абсолютное изменение, а также медленное время прорисовки. Чтобы это работало, вам нужно скачать ZIP-архив. файл из ссылки на перепись и разархивируйте файлы в папку данных.

library(shiny)
library(maptools)
library(ggplot2)
require(reshape2)
library(tidyr)
library(maptools)
library(ggplot2)
library(RColorBrewer)


ui <- fluidPage(

  titlePanel("heatmap"),

   # Sidebar with a slider input for year of interest
   sidebarLayout(
      sidebarPanel(
        sliderInput("year",h3("Select year or push play button"),
                    min = 2000, max = 2002, step = 1, value = 2000,
                    animate = TRUE)
      ),

      # Output of the map
      mainPanel(
        plotOutput("unemployment")
      )
   )
)

server <- function(input, output) {
  #to get the spacial data: from file in link above
  provinces<-maptools::readShapeSpatial("data/gpr_000a11a_e.shp")

  data.p<- ggplot2::fortify(provinces, region = "PRUID")
  data.p<-data.p[which(data.p$id<60),]

  #dataframe with same structure as statscan csv after processing
   unem <- runif(10,min=0,max=100)
   unem1 <- unem+runif(1,-10,10)
   unem2 <- unem1+runif(1,-10,10)
   unemployment <- c(unem,unem1,unem2)
   #dataframe with same structure as statscan csv after processing
   X <- data.frame("id" = c(10,11,12,13,24,35,46,47,48,59,
   10,11,12,13,24,35,46,47,48,59,
   10,11,12,13,24,35,46,47,48,59),
              "Unemployment" = unemployment,
              "year" = c(rep(2000,10),rep(2001,10),rep(2002,10))
              )


  plot.data<- reactive({
a<- X[which(X$year == input$year),]
    return(merge(data.p,a,by = "id"))
  })

  output$unemployment <- renderPlot({
    ggplot(plot.data(), 
           aes(x = long, y = lat, 
               group = group , fill =Unemployment)) +
      geom_polygon() +
      coord_equal()
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

Любая помощь по любому из вопросов будет принята с благодарностью

Answer 1

Для этого типа анимации гораздо быстрее использовать буклет вместо ggplot, так как буклет позволяет вам перерисовывать только полигоны, а не всю карту.

Я использую два других трюка для ускорения анимации:

1. Присоединяюсь к данным вне реактива. В реактиве это просто подмножество. Обратите внимание, что соединение может быть выполнено вне приложения и считано как предварительно обработанный файл .rds.

2. Я упрощаю полигоны с помощью пакета rmapshaper, чтобы сократить время рисования листовки. Опять же, это можно сделать вне приложения, чтобы сократить время загрузки при запуске.

Анимация может быть даже более плавной, если вместо полигонов использовать круги (то есть центроид каждой провинции). Размер круга может варьироваться в зависимости от уровня безработицы.

Обратите внимание, что для этого подхода вам нужны пакеты leaflet, sf, dplyr и rmapshaper.

library(shiny)
library(dplyr)
library(leaflet)
library(sf)
library(rmapshaper)

ui <- fluidPage(

  titlePanel("heatmap"),

  # Sidebar with a slider input for year of interest
  sidebarLayout(
    sidebarPanel(
      sliderInput("year",h3("Select year or push play button"),
                  min = 2000, max = 2002, step = 1, value = 2000,
                  animate = TRUE)
    ),

    # Output of the map
    mainPanel(
      leafletOutput("unemployment")
    )
  )
)

server <- function(input, output) {
  #to get the spacial data: from file in link above
  data.p <- sf::st_read("input/gpr_000a11a_e.shp") %>% 
    st_transform(4326) %>%
    rmapshaper::ms_simplify()
  data.p$PRUID <- as.character(data.p$PRUID) %>% as.numeric
  data.p <- data.p[which(data.p$PRUID < 60),]

  lng.center <- -99
  lat.center <- 60
  zoom.def <- 3

  #dataframe with same structure as statscan csv after processing
  unem <- runif(10,min=0,max=100)
  unem1 <- unem+runif(1,-10,10)
  unem2 <- unem1+runif(1,-10,10)
  unemployment <- c(unem,unem1,unem2)
  #dataframe with same structure as statscan csv after processing
  X <- data.frame("id" = c(10,11,12,13,24,35,46,47,48,59,
                           10,11,12,13,24,35,46,47,48,59,
                           10,11,12,13,24,35,46,47,48,59),
                  "Unemployment" = unemployment,
                  "year" = c(rep(2000,10),rep(2001,10),rep(2002,10))
  )

  data <- left_join(data.p, X, by = c("PRUID"= "id"))

  output$unemployment <- renderLeaflet({
    leaflet(data = data.p) %>%
      addProviderTiles("OpenStreetMap.Mapnik", options = providerTileOptions(opacity = 1), group = "Open Street Map") %>%
      setView(lng = lng.center, lat = lat.center, zoom = zoom.def) %>%
      addPolygons(group = 'base', 
                  fillColor = 'transparent', 
                  color = 'black',
                  weight = 1.5)  %>%
      addLegend(pal = pal(), values = X$Unemployment, opacity = 0.7, title = NULL,
                position = "topright")
  })

  get_data <- reactive({
    data[which(data$year == input$year),]
  })

  pal <- reactive({
    colorNumeric("viridis", domain = X$Unemployment)
  })

  observe({
    data <- get_data()
    leafletProxy('unemployment', data = data) %>%
      clearGroup('polygons') %>%
      addPolygons(group = 'polygons', 
                  fillColor = ~pal()(Unemployment), 
                  fillOpacity = 0.9,
                  color = 'black',
                  weight = 1.5)
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

Answer 2

Я не считаю, что время рисования неоправданно велико - ~ 2-3 секунды, что для шейп-файла размером 2,4 Мб кажется правильным. Во всяком случае, на внешнем блеске требуется столько же времени, сколько в приложении на моем компьютере.

Чтобы сохранить постоянный градиент цвета, вы можете указать пределы в scale_fill_gradient, которые будут содержать тот же градиент, несмотря на изменения в ваших картах:

output$unemployment <- renderPlot({
  ggplot(plot.data(), 
       aes(x = long, y = lat, 
           group = group , fill =Unemployment)) +
    geom_polygon() +
    scale_fill_gradient(limits=c(0,100)) +
    coord_equal()
})