Using tiles in shiny
In starsTileServer: A Dynamic Tile Server for R

NOT_CRAN <- identical(tolower(Sys.getenv("NOT_CRAN")), "true")
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>",
  eval = NOT_CRAN
)

In this manual we will discuss an example of using starsTileServer for serving map tiles in a shiny app. It shows the ability to visualize different layers and dynamically change layers. To do this we will use a sample dataset from the ERA5 weather model, that includes different variables and pressure levels.

library(starsTileServer)

The sample dataset can be retrieved with the following code using the ecmwfr R package:

require(ecmwfr)
request <-
  list(
    "dataset_short_name" = "reanalysis-era5-pressure-levels",
    "product_type" = "reanalysis",
    "variable" = c("temperature", "geopotential", "u_component_of_wind", "v_component_of_wind"),
    "pressure_level" = c("875", "900", "925"),
    "year" = "2000",
    "month" = "04",
    "day" = as.character(27:29),
    "time" = sprintf("%02i:00", 0:23),
    "area" = "64/-130/-64/144",
    "format" = "netcdf",
    "target" = "ecmwfData.nc"
  )
# make sure you use your own uid and key ( https://cds.climate.copernicus.eu/#!/home )
wf_set_key("uid_to_replace", "key_to_replace", service = "cds")
ncfile <- wf_request(
  user = "uid_to_replace",
  request = request,
  transfer = TRUE,
  path = "~",
  verbose = FALSE
)

if (!file.exists(tmpGridFile <- "~/ownCloudUva/test.nc")) {
  tmpGridFile <- tempfile(fileext = ".nc")
  download.file("https://surfdrive.surf.nl/files/index.php/s/Z6YoTyzyyAsmgGS/download", tmpGridFile, extra = "-q", method = "wget")
}

Starting the tileserver

To set up the tile server we need the grid file loaded. Additionally a color function can be added. This function needs to have the same format as the color as the color mapping functions in leaflet.

weatherData <- stars::read_stars(tmpGridFile)
sf::st_crs(weatherData) <- "+proj=longlat"

colFun <- function(x,
                   alpha = 1,
                   max = 20,
                   min = -20) {
  paste0(
    suppressWarnings(leaflet::colorNumeric(
      "RdYlBu",
      domain = c(as.numeric(min), as.numeric(max))
    )(x)),
    as.character(as.raw(as.numeric(alpha) * 255))
  )
}
attr(colFun, "colorType") <- "numeric"

The tileserver needs to run in a separate process. On a personal computer this can easily be achieved by running two R processes at the same time. An alternative approach is to use callr to start a separate process.

# note the process is ran in the background, do not forget to close it as it might use quite a bit of memory.
# I have made the experience that callr seems to work poorly if the process is rather verbose
require(callr)
rp <- r_bg(args = list(grid = weatherData, colFun = colFun), function(grid, colFun) {
  starsTileServer::starsTileServer$new(grid, colFun)$run(port = 3746, docs = TRUE)
})

Sys.sleep(3)
stopifnot(rp$is_alive())

The process will print an url where documentation an testing for the server is available:

message(rp$read_error())

Shiny app

Now a small example of some interaction based on a shiny example. First we create UI, this consists of a few selection options to change the map features.

require(shiny)
require(leaflet)
require(stars)
weather <- stars::read_stars(tmpGridFile, proxy = T)

ui <- fluidPage(
  # Application title
  titlePanel("Web map"),
  sidebarLayout(
    # Sidebar with a slider input
    sidebarPanel(
      sliderInput("alpha", "Transparancy", 0, 1, .6, .01),
      selectInput("attr", "Attribute", choices = c("u", "v")),
      sliderInput(
        "time",
        "Time",
        value = min(st_get_dimension_values(weather, 4)),
        min = min(st_get_dimension_values(weather, 4)),
        max = max(st_get_dimension_values(weather, 4)),
        step = 3600,
        timezone = "+0000",
        animate = animationOptions(5000)
      ),
      selectInput("level", "level (mb)", choices = as.character(st_get_dimension_values(weather, 3))),
      sliderInput("colRange", "Range", -50, 50, c(-20, 20))
    ),
    # Show a plot of the generated distribution
    mainPanel(leafletOutput("map"))
  )
)

We use the following shiny server function:

server <- function(input, output, session) {
  # This reactive creates the URL to the tileserver, it include the different input variables in requests to the server
  # The debounce ensures the URL does not get updated to frequent
  url <- reactive({
    sprintf(
      "http://127.0.0.1:3746/map/%s/{z}/{x}/{y}?level=%s&alpha=%f&time=%s&min=%f&max=%f",
      input$attr,
      input$level,
      input$alpha,
      strftime(input$time, tz = "UTC", format = "%Y-%m-%d %H:%M:%S"),
      min(input$colRange),
      max(input$colRange)
    )
  }) %>% debounce(100)
  # This reactive downloads the color function from the server and prepares it for adding as a legend to the leaflet map
  colorFunction <- reactive({
    f <- readRDS(base::url(sprintf("http://127.0.0.1:3746/map/%s/colorfunctionnoalpha", input$attr)))
    at <- attributes(f)
    if (is.finite(max(colrange()))) {
      formals(f)$max <- max(colrange())
    }
    if (is.finite(min(colrange()))) {
      formals(f)$min <- min(colrange())
    }
    attributes(f) <- at
    f
  })
  colrange <- reactive(range(input$colRange))
  output$map <- renderLeaflet({
    leaflet() %>%
      addTiles() %>%
      fitBounds(-50, -30, 50, 50)
  })
  # This observer changes the tile layer as soon as the url is updated
  observe({
    leafletProxy("map") %>%
      clearGroup("wind") %>%
      addTiles(url(),
        group = "wind",
        options = tileOptions(useCache = TRUE, crossOrigin = TRUE)
      )
  })
  # This observe changes the legend as soon as it is updated
  observe({
    s <- seq(min(colrange()), max(colrange()), length.out = 20)
    leafletProxy("map") %>%
      clearControls() %>%
      addLegend(
        pal = colorFunction(),
        values = s,
        title = input$attr,
        position = "bottomleft"
      )
  })
}

The app can be create using the regular shiny functionality

app <- shinyApp(ui, server)

The result of this shiny app looks as follows:

f <- tempfile(fileext = ".png")
suppressMessages(webshot::appshot(
  app,
  file = f,
  delay = 45,
  vwidth = 1000,
  vheight = 600
))
magick::image_read(f)