带有 ggplot 的 Shiny R 动态热图。规模和速度问题

Question

我正在尝试使用一些 public 信息来制作加拿大的一些劳动力统计热图。使用 census, and data from Statistics Canada 中的空间文件（这些是不需要深入研究的大型 zip 文件）。下面是一个工作示例，它说明了我遇到的两个问题，区域之间的相对变化很小（尽管周期之间可能存在很大的绝对变化，并且缓慢的绘制 time.To 使它起作用，您需要下载来自人口普查的 .zip 文件 link 并将文件解压缩到数据文件夹。

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

我没有发现绘图时间长得不合理，约为 2-3 秒，对于 2.4mb 的 shapefile 来说似乎是正确的。无论如何，它在我机器上的应用程序中所花费的时间与在外部闪亮所花费的时间一样长。

要保持恒定的颜色渐变，您可以在 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()
})

Answer 2

对于这种类型的动画，使用 leaflet 比 ggplot 快得多，因为 leaflet 允许您只重新渲染多边形，而不是整个地图。

我使用另外两个技巧来加速动画：

我加入了reactive之外的数据。在反应式中，它只是一个简单的子集。请注意，加入可以在应用程序外部完成并作为预处理的 .rds 文件读入。
我用 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)

带有 ggplot 的 Shiny R 动态热图。规模和速度问题

Shiny R dynamic heatmap with ggplot. Scale and speed issues

r

ggplot2

shiny

r-leaflet