Shiny R dynamic heatmap with ggplot. Scale and speed issues

Question

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

When asking for help, you should include a simple [reproducible example](https://stackoverflow.com/questions/5963269/how-to-make-a-great-r-reproducible-example) with sample input and desired output that can be used to test and verify possible solutions. What does "doesn't seem to work for me" mean exactly? — MrFlick, May 01 '18 at 17:39
ok good point, I will come up with a toy example and edit the post — Mitch14, May 01 '18 at 17:51

sebdalgarno · Accepted Answer · 2018-05-07T19:38:27.650

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:

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

score 0 · Answer 2 · answered May 02 '18 at 22:35

0

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

answered May 02 '18 at 22:35

phalteman

3,442
1
29
46

do you know of a method to make the draw time faster? you lose most of the meaning when it fades in and out, makes the changes harder to spot. – Mitch14 May 03 '18 at 14:19
I agree - the slower animation makes it difficult to see the transitions. I played around with a couple ideas like drawing most of the plot beforehand and then only adding the filled layer after selecting the year, but nothing made much of a difference. My understanding is that ggplot isn't super fast at rendering plots with many layers or lots of data. Maybe your best bet is to try other plotting routines which might be faster - perhaps `ggvis`? – phalteman May 03 '18 at 16:27

Shiny R dynamic heatmap with ggplot. Scale and speed issues

2 Answers2

Linked