Hello.
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 shinyapps.io, 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.
library(shiny)
library(raster)
library(leaflet)
library(plyr)
library(dplyr)
library(jsonlite)
library(RCurl)
library(htmltools)
library(leafem)
#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$head(
tags$meta(name="viewport", content="width=device-width, initial-scale=1.0, user-scalable=no")
),
div(class = "container-fluid",
h2("MountainSnow App"),
div(class="row",
div(class="col-xs-6",
#note that I found it necessary to use the selectize option to keep the keyboard from popping up on the mobile app.
selectInput("domain","Domain:",
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),
),
div(class="col-xs-6",
selectInput("variable","Variable:",
choices = c("Snow depth (meters)" = "snod", "Snow water equivalent (meters)" = "swed"), selectize = FALSE),
),
),
div(class="row",
div(class="col-xs-6",
#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"),
),
div(class="col-xs-6",
sliderInput("scaleinput", "Max. value (meters):", 1, 4, 2, 0.1),
),
),
div(class="row",
div(class="col-sm-12",
leafletOutput(outputId = "map"),
),
),
),
)
server <- function(input, output) {
#create dataframe of info on the domains.
tmp = fromJSON("https://raw.githubusercontent.com/snowmodel-tools/preprocess_python/master/CSO_domains.json")
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
addProviderTiles("Esri.WorldTopoMap")
})
#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("https://storage.googleapis.com/cso_test_upload/",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
leafletProxy('map')%>%
clearMarkers() %>%
addMarkers(lng = click$lng, lat = click$lat)
})
}
Run the application
shinyApp(ui = ui, server = server)