Trouble deploying app that plots rasters from google cloud storage.


I have only been working with Shiny apps (deployed to cloud) for a few months. Here is my big challenge.

I have an app that loads a raster (Geotiff; usually 2-10MB) from Google Cloud Storage (public bucket). I plot it up and do various things to it. It, for the most part, works very nicely.

When I deploy to, it is less good. It is very, very slow to render and often disconnects.

I currently have the 'free' plan. And, I use addrasterimage. I understand that there are some concerns with 'large rasters' with this approach.

Bottom line...I have some app performance issues. I am 100% positive a lot of this is due to my being new. BUT, I am just trying to identify the 'rate limiting step' at this point and figure out how to have a deployable app that is a bit more reliable than what I currently have.

Code is below:

This shiny app will display CSO Snow Model results.


#I found that I needed to switch to bootstrappage and div(class()) (as opposed to fluidpage) to achieve
#the control that I wanted over widget widths for the mobile application...
ui = bootstrapPage(
#The following line I found to be necessary to prevent the 'zooming' that would occur when the user used dateInput.
tags$meta(name="viewport", content="width=device-width, initial-scale=1.0, user-scalable=no")
div(class = "container-fluid",
h2("MountainSnow App"),
#note that I found it necessary to use the selectize option to keep the keyboard from popping up on the mobile app.
choices = c("Chugach/Turnagin (AK)" = "ak", "Tahoe (CA)" = "ca", "Central (CO)" = "co_n",
"Southwest (CO)" = "co_s", "Mt. Hood (OR)" = "mh", "White Mtns. (NH)" = "nh",
"Central (OR)" = "or", "Sawtooths (ID)" = "st", "Wasatch (UT)" = "ut",
"East Slopes North (WA)" = "wa", "Snoqualmie Pass (WA)" = "wa_sq", "Tetons (WY)" = "wy"), selectize = FALSE),
choices = c("Snow depth (meters)" = "snod", "Snow water equivalent (meters)" = "swed"), selectize = FALSE),
#note that I found I needed to use this add attributes approach to prevent the keyboard from popping up
#for dateInput on the mobile app.
tagAppendAttributes(dateInput("date1", "Date:", value = Sys.Date(), max = Sys.Date(), min = "2022-10-01", autoclose = TRUE), readonly="", .cssSelector="input"),
sliderInput("scaleinput", "Max. value (meters):", 1, 4, 2, 0.1),
leafletOutput(outputId = "map"),

server <- function(input, output) {
#create dataframe of info on the domains.
tmp = fromJSON("")
df <- ldply (tmp, data.frame)
#delete rows that are not CSO model domains
df <- df[-c(3,7,8,11,12,16,17,18),]
#delete unneeded columns
df <- df[,-c(1,7,8,9,10,11,12,13,14,15)]
#compute center lat / lon for each domain
df <- df %>% mutate(lat = rowSums(select(., contains("lat")))/2, lon = rowSums(select(., contains("lon")))/2)
#make names lower case
df$name <- tolower(df$name)
#get alaska domain correct...
df[11,1] <- "ak"

#initial display of map
output$map <- renderLeaflet({
leaflet() %>%
setView(lng = -110, lat = 40, zoom = 4) %>%
#tons of basemap options, view here: Leaflet Provider Demo

#listen for any changes and plot grid.
observeEvent(ignoreInit = TRUE, c(input$variable, input$domain, input$date1, input$scaleinput),{

#work to assemble the URL of the file requested
m=strftime(input$date1, "%m")
d=strftime(input$date1, "%d")
y=strftime(input$date1, "%Y")
baseurl <- gsub(" ", "", paste("",input$domain, 
                               "_domain/",input$variable,"_wi_assim/",y, "_",m, "_",d, "_",input$variable,"_wi_assim.tif"))

#test if url exists...if it does not, then do nothing. Otherwise, reset plot and plot new raster.
if (url.exists(baseurl)){
  tmp.url <- gsub(" ", "", paste("/vsicurl/", baseurl))
  ras <- raster(tmp.url)
  #discrete colormap option. Set limit based on user input.
  #pal <- colorBin(c("Dark2"), c(0, input$scaleinput), 6, pretty = TRUE,
  #                na.color = "transparent")
  if (input$scaleinput <= 1.5){
    cbins <- append(seq(0,input$scaleinput,0.25),Inf)
  } else{
    cbins <- append(seq(0,input$scaleinput,0.5),Inf)
  #cbins <- append(seq(0,input$scaleinput,0.25),Inf)

  #pal <- colorBin(c("Dark2"), bins = cbins,
  #                na.color = "transparent")
  #rbins <- c(0, 2, 2.5, 3, 4, Inf)
  #pal <- colorBin(c("Set1"), bins = c(0, 2, 2.5, 3, 4, Inf),
  #                na.color = "transparent")
  pal <- colorBin(c("Set1"), bins = cbins,
                   na.color = "transparent")
  #try to reclassify the values that are 'out of range' (too high)
  #ras2 <- reclassify(ras, cbind(input$scaleinput, Inf, input$scaleinput))
  #draw the map! First erase the previous one...
  #note...we will zoom in on the requested domain, to help out the viewer
  #values below are the lat/lon of the model domain center.
  tmp2 <- which(df == input$domain, arr.ind=TRUE)
  lati = df[tmp2[1],6]
  long = df[tmp2[1],7]
  #figure out legend title
  if (input$variable == "swed"){
    legendtitle = "SWE (m)"
  } else{
    legendtitle = "Hs (m)"
  leafletProxy("map") %>%
    clearImages() %>%
    clearControls() %>%
    clearShapes() %>%
    clearMarkers() %>%
    addRasterImage(ras, colors = pal, opacity = 0.7, maxBytes = 'Inf',  layerId = "value (m)", group = "value (m)") %>%
    #addRasterImage(ras2, colors = pal, opacity = 0.7, maxBytes = 'Inf')%>%
    setView(lng = as.numeric(long), lat = as.numeric(lati), zoom = 7) %>%
    addRectangles(lng1=df[tmp2[1],5], lat1=df[tmp2[1],3], 
                  lng2=df[tmp2[1],4], lat2=df[tmp2[1],2], fillColor="transparent", weight=2 ) %>%
    addLegend(pal = pal, values = c(0, Inf), title = legendtitle) %>% #values=values(ras)
    #addLegend(pal = cpal, values = values(ras), title = legendtitle)
    addImageQuery(ras, project = TRUE,  type = "click", layerId = "value (m)", digits = 1, position = "bottomright")


observeEvent(input$map_click, {
click = input$map_click
clearMarkers() %>%
addMarkers(lng = click$lng, lat = click$lat)


Run the application

shinyApp(ui = ui, server = server)