Shiny R dynamic heatmap with ggplot. Scale and spe

问题:

I am attempting to use some public information to produce a heat-map of Canada for some labor statistics. Using the spacial files from the census, and data from Statistics Canada (these are large zip files that are not necessary to dig into). Below is a working example that illustrates both the problems I am having with little relative change between regions( though there may be a big absolute change between periods, and the slow draw time.To get this to work, you need to download the .zip file from the census link and unzip the files to a data folder.

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)

Any help with either of the issues would be greatly appreciated

回答1:

For this type of animation it is much faster to use leaflet instead of ggplot as leaflet allows you to only re-render the polygons, not the entire map.

I use two other tricks to speed up the animation:

1. I join the data outside of the reactive. Within the reactive it is just a simple subset. Note, the join could be done outside of the app and read in as a pre-processed .rds file.

2. I simplify the polygons with the rmapshaper package to reduce drawing time by leaflet. Again, this could be done outside the app to reduce loading time at the start.

The animation could likely be even more seamless if you use circles (i.e. centroid of each province) instead of polygons. Circle size could vary with Unemployment value.

Note, you need the leaflet, sf, dplyr and rmapshaper packages for this approach.

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)

回答2:

I didn't find the drawing time to be unreasonably long at ~2-3 seconds, which for a 2.4mb shapefile seems about right. It takes just as long outside shiny as it does in the app on my machine, anyway.

To hold a constant colour gradient you can specify limits in scale_fill_gradient which will hold the same gradient despite changes to your maps:

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()
})