Chapter 5 Asynchronous loading and distracting your user
5.1 Distracting your user
We made the following app in the last section of chapter 3 except we only used SA2 polygons. In the iTRAQI app, we use both SA1s and SA2s - this means a lot more detail, many more polygons, and a slower load time. The following code loads both SA1s and SA2s - note how long it takes to run by either copy-pasting the code or running the first runGithub line. (Also, appreciate that a shiny server may load it even slower than the computer, especially if that server has many concurrent users!)
shiny::runGitHub("RWParsons/interactive-maps", subdir = "input/apps/05-01-async-load-1/")library(shiny)
library(leaflet)
library(tidyverse)
library(sf)
input_dir <- "./input"
sa_polygons <- readRDS(file.path(input_dir, "stacked_SA1_and_SA2_polygons_year2016_simplified.rds"))
towns <- read.csv(file.path(input_dir, "df_towns.csv"))
ui <- navbarPage(
"App-with-a-map",
id = "nav",
tabPanel(
"Map",
div(
class = "outer",
tags$head(
tags$style(HTML("
div.outer {
position: fixed;
top: 41px;
left: 0;
right: 0;
bottom: 0;
overflow: hidden;
padding: 0;
}
"))
),
leafletOutput("map", height = "100%", width = "100%")
)
)
)
server <- function(input, output, session) {
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
addPolygons(
data = sa_polygons,
fillColor = "Orange",
color = "black",
weight = 1,
group = "Polygons"
) %>%
addCircleMarkers(
lng = towns$x,
lat = towns$y,
popup = glue::glue("<b>Location:</b> {towns$acute_care_centre}"),
radius = 2,
fillOpacity = 0,
group = "Towns"
) %>%
addLayersControl(
position = "topright",
baseGroups = c("None", "Polygons"),
overlayGroups = c("Towns"),
options = layersControlOptions(collapsed = FALSE)
)
})
}
shinyApp(ui, server)There are a couple things that we can do to ensure our user doesn’t get bored and close the app. The first (and easiest) is to show a fun fact, loading spinner or some other form of brief entertainment. The second option is to load the map asynchronously: we can load part of the map and allow the user access to some of the functionality, and defer loading the computationally expensive parts a bit. For the iTRAQI app, we use both a fun fact/gif/image and asynchronous loading.
To show content, we will add a panel which displays over the app, and once the map is created, we will hide it.
To do this, we add an absolutePanel() to our UI which has the message and image that we want to display. Here, I use a function, get_display() which gets a random message from those in loading_panel_displays. I format the messages using HTML and therefore need to wrap the display with HTML() when presenting it in theabsolutePanel. Images can be added - here I have used some online but if you have images in the www/ directory of your shiny app, you can use those instead.
To hide the panel once the map is created, we need to use {shinyjs}. To allow us to use it’s functions on the UI, we need to include useShinyjs() there. Once the map is made in renderLeafet() on the server side, I hide the absolute panel with shinyjs::hide("loadingScreen").
library(shiny)
library(leaflet)
library(tidyverse)
library(sf)
library(glue)
library(shinyjs)
input_dir <- "./input"
sa_polygons <- readRDS(file.path(input_dir, "stacked_SA1_and_SA2_polygons_year2016_simplified.rds"))
towns <- read.csv(file.path(input_dir, "df_towns.csv"))
loading_panel_displays <- c(
paste(
sep = "<br>",
"<h2>First fun fact text!</h2>",
'<img src="https://www.r-project.org/logo/Rlogo.png" alt="R" style="width:200px">'
),
paste(
sep = "<br>",
"<h2>Second fun fact text!</h2>",
'<img src="https://www.rstudio.com/assets/img/logo.svg" alt="dog-1" style="width:200px;">'
)
)
get_display <- function() {
loading_panel_displays[sample(1:length(loading_panel_displays), size = 1)]
}
ui <- navbarPage(
"App-with-a-map",
id = "nav",
tabPanel(
"Map",
useShinyjs(),
div(
class = "outer",
tags$head(
tags$style(HTML("
div.outer {
position: fixed;
top: 41px;
left: 0;
right: 0;
bottom: 0;
overflow: hidden;
padding: 0;
}
"))
),
leafletOutput("map", height = "100%", width = "100%"),
absolutePanel(
id = "loadingScreen", class = "panel panel-default",
fixed = TRUE, draggable = TRUE,
left = "50%", right = "50%", bottom = "50%", top = "50%",
width = 500, height = 200,
HTML(get_display())
)
)
)
)
server <- function(input, output, session) {
output$map <- renderLeaflet({
map <- leaflet() %>%
addTiles() %>%
addPolygons(
data = sa_polygons,
fillColor = "Orange",
color = "black",
weight = 1,
group = "Polygons"
) %>%
addCircleMarkers(
lng = towns$x,
lat = towns$y,
popup = glue::glue("<b>Location:</b> {towns$acute_care_centre}"),
radius = 2,
fillOpacity = 0,
group = "Towns"
) %>%
addLayersControl(
position = "topright",
baseGroups = c("None", "Polygons"),
overlayGroups = c("Towns"),
options = layersControlOptions(collapsed = FALSE)
)
hide("loadingScreen")
map
})
}
shinyApp(ui, server)shiny::runGitHub("RWParsons/interactive-maps", subdir = "input/apps/05-02-async-load-2/")5.2 Asynchronous loading
You might notice that there is still a delay between the loading screen disappearing and the map appearing. This is because there is still some time between when the map is rendered by the server and it being drawn for us to see.
Fortunately, we can make it faster to make and display the initial map if it (initially) lacks the detailed polygons.
To load the map asynchronously, we will first render and show a relatively simple map - just the base tiles and the towns. Then, once that’s shown to the user, we will add the polygons to the now available map with leafletProxy().
To trigger this action, we will use a callback. onFlushed() can be used to register functions which occur after shiny flushes the reactive system. In our case, we can use this to trigger the adding of polygons to our map once the shiny system (with the first, simple map) is “flushed”.
Since in the iTRAQI app, we have more than one map, we trigger a function with onFlushed() that can trigger all maps, but only those maps on the current tab are actually have the content added. Since we need to check whether (1) we have triggered “to_load” the map, (2) whether the “map” exists to add content to, and (3) whether the map is already completed or not (“map_complete”), we store these in reactive values. These are values which can be updated by our function (triggered by onFlushed()) and observed to trigger the addition of map content. Every time content is flushed, the “to_load” value is updated, this triggers an observe event to add content to the map. If this finds that the map doesn’t exist or it does and the additional content has already been added, it does nothing. If the map exists and it hasn’t had the polygons added (!is.null(rvs$map) & map_complete==FALSE), it adds them, and then updates the map_complete to be TRUE so that it won’t attempt to add the same content again.
The end result is that the initial map appears quickly and is interactive and the addition of the polygons happens in the background (hopefully before the user tries to display them). In this example, we hide the loading screen once we have added the polygons but if we are confident that the user is unlikely to try to show them within the first little bit since opening the app, we could move the hide("loadingScreen") back to the renderLeafet().
library(shiny)
library(leaflet)
library(tidyverse)
library(sf)
library(glue)
library(shinyjs)
input_dir <- "./input"
sa_polygons <- readRDS(file.path(input_dir, "stacked_SA1_and_SA2_polygons_year2016_simplified.rds"))
towns <- read.csv(file.path(input_dir, "df_towns.csv"))
loading_panel_displays <- c(
paste(
sep = "<br>",
"<h2>First fun fact text!</h2>",
'<img src="https://www.r-project.org/logo/Rlogo.png" alt="R" style="width:200px">'
),
paste(
sep = "<br>",
"<h2>Second fun fact text!</h2>",
'<img src="https://www.rstudio.com/assets/img/logo.svg" alt="dog-1" style="width:200px;">'
)
)
get_display <- function() {
loading_panel_displays[sample(1:length(loading_panel_displays), size = 1)]
}
ui <- navbarPage(
"App-with-a-map",
id = "nav",
tabPanel(
"Map",
useShinyjs(),
div(
class = "outer",
tags$head(
tags$style(HTML("
div.outer {
position: fixed;
top: 41px;
left: 0;
right: 0;
bottom: 0;
overflow: hidden;
padding: 0;
}
"))
),
leafletOutput("map", height = "100%", width = "100%"),
absolutePanel(
top = 75, left = 10,
class = "panel panel-default",
selectInput("town_name", "Town Name",
choices = c("None", sort(towns$location)),
selected = "None"
)
),
absolutePanel(
id = "loadingScreen", class = "panel panel-default",
fixed = TRUE, draggable = TRUE,
left = "50%", right = "50%", bottom = "50%", top = "50%",
width = 500, height = 200,
HTML(get_display())
)
)
)
)
server <- function(input, output, session) {
rvs <- reactiveValues(to_load = NULL, map = NULL, map_complete = FALSE)
f <- function() {
if (is.null(isolate(rvs$to_load))) rvs$to_load <- 1
if (!is.null(isolate(rvs$to_load)) &
!isolate(rvs$map_complete) &
!is.null(isolate(rvs$map))) {
rvs$to_load <- isolate(rvs$to_load) + 1
}
}
session$onFlushed(f, once = FALSE)
output$map <- renderLeaflet({
rvs$map <-
leaflet() %>%
addTiles() %>%
addCircleMarkers(
lng = towns$x,
lat = towns$y,
popup = glue::glue("<b>Location:</b> {towns$acute_care_centre}"),
radius = 2,
fillOpacity = 0,
group = "Towns"
) %>%
addLayersControl(
position = "topright",
baseGroups = c("None", "Polygons"),
overlayGroups = c("Towns"),
options = layersControlOptions(collapsed = FALSE)
)
rvs$map
})
observeEvent(rvs$to_load, {
if (is.null(isolate(rvs$map)) | isolate(rvs$map_complete)) {
return()
}
leafletProxy("map") %>%
addPolygons(
data = sa_polygons,
fillColor = "Orange",
color = "black",
weight = 1,
group = "Polygons"
)
hide("loadingScreen")
if (!isolate(rvs$map_complete)) rvs$map_complete <- TRUE
})
}
shinyApp(ui, server)shiny::runGitHub("RWParsons/interactive-maps", subdir = "input/apps/05-03-async-load-3/")