Commit a1ce26b6 authored by Conor Anderson's avatar Conor Anderson

User-facing updates for this implementation

parent 35461e38
......@@ -10,8 +10,8 @@ RUN apt-get update &&\
RUN mv /srv/shiny-server/app/shiny-server.conf /etc/shiny-server/shiny-server.conf
RUN cd /srv/shiny-server/app &&\
Rscript -e "install.packages(\"devtools\", repos = \"https://cloud.r-project.org/\")" &&\
Rscript -e "source(\"https://gitlab.com/ConorIA/conjuntool/snippets/1788463/raw\")" &&\
Rscript -e "devtools::install_github(\"rstudio/DT\")" &&\
Rscript -e "install.packages(c('remotes', 'jsonlite'), repos = 'https://cloud.r-project.org/')" &&\
Rscript -e "source('https://gitlab.com/ConorIA/conjuntool/snippets/1978145/raw')" &&\
Rscript -e "remotes::install_github('rstudio/DT')" &&\
sudo -u shiny bash -c "Rscript -e \"webshot::install_phantomjs()\"" &&\
rm -rf /tmp/*
crop_req <- function(key, shp) {
if (debug_flag) message("Asking plumber to crop ", key)
r <- POST(URLencode(paste0(plumber_address, "/crop?key=", key)),
config = list(add_headers(accept = "application/octet-stream")),
authenticate(plumber_user, plumber_password),
body = base64encode(serialize(shp, NULL)), encode = "json")
crop_req <- function(request) {
if (debug_flag) message("Asking plumber to crop ", nrow(request$meta), " models")
if (r$status_code != 200) {
stop("There was an error")
}
r <- POST(URLencode(paste0(plumber_address, "cropncdf")),
config = list(add_headers(accept = "application/json")),
authenticate(plumber_user, plumber_password),
body = request, encode = "json")
res <- jsonlite::parse_json(rawToChar(content(r)))
URLencode(res$filename, reserved = TRUE)
return(r$status_code == 200)
}
......@@ -10,19 +10,18 @@ get_gcm_files <- function(choices, baseline = NULL, projection = NULL, model = N
}
# Do we need to borrow from the experiments for our baseline?
coyote <- (!is.null(baseline) && paste0(baseline[length(baseline)], "12") > "200512")
coyote <- ((!is.null(baseline) && paste0(baseline[length(baseline)], "12") > "200512") || (is.null(baseline) && paste0(projection[0], "01") < "200601"))
pending_ensembles <- if (is.null(ensemble)) unique(choices$Ensemble) else ensemble
pending_scenarios <- if (is.null(scenario)) unique(choices$Scenario[-which(choices$Scenario == "historical")]) else scenario
if (is.null(baseline)) period <- projection
if (is.null(projection)) {
if (coyote) {
tmp <- expand.grid("historical", pending_scenarios, stringsAsFactors = FALSE)
pending_scenarios <- list()
for (i in 1:nrow(tmp)) pending_scenarios <- c(pending_scenarios, list(unname(unlist(tmp[i,]))))
rm(tmp)
} else {
pending_scenarios <- "historical"
}
if (coyote) {
tmp <- expand.grid("historical", pending_scenarios, stringsAsFactors = FALSE)
pending_scenarios <- list()
for (i in 1:nrow(tmp)) pending_scenarios <- c(pending_scenarios, list(unname(unlist(tmp[i,]))))
rm(tmp)
} else if (is.null(projection)) {
pending_scenarios <- "historical"
period <- baseline
}
......
On this page you can crop the GCM data from a single model. You can choose to upload an ESRI shapefile (with the necessary auxilary files) in a single ZIP archive, or you can manually choose a single point, or two corners of a rectangle object.
On this page you can crop the GCM data from the available models. You can choose to upload an ESRI shapefile (with the necessary auxilary files) in a single ZIP archive, or you can manually choose two corners of a rectangle object. You will receive an email at the email that you provide when the data are ready for download.
Click on the map to choose coordinates. You can verify or modify the coordinates in the "Manual Coordinates" panel.
......@@ -10,4 +10,4 @@ You should _not_ provide both a Shapefile _and_ manual input. However, if in dou
- If you want to use a different Shapefile, uploading it will replace any previously uploaded Shapefiles.
**This functionality remains a work in progress and is only lightly tested. In particular, the only models that are available are those that are packaged as a single _.nc_ file from 2006 to 2100. Models that are packaged by decade, for example, are not available, nor are the historical runs. Sometime the extent that is passed up to raster doesn't work. If that happens, try again, or try using a shapefile.**
**This functionality is very fresh and is only lightly tested. There are probably a lot of bugs for which there is no code to handle them. Please report bugs to the [Conjuntool issues page](https://gitlab.com/ConorIA/conjuntool). Please also note that there is a known issue: sometimes the extent that is passed up to raster doesn't work. If that happens, try again, or try using a shapefile.**
......@@ -458,11 +458,31 @@ shinyServer(function(input, output, session) {
)
### Resample Data (WIP)
crop_model_in <- callModule(singleModelSelect, "crop_model_in",
choices = reactive(get_choices(input$var_filter_crop, lim = TRUE)),
coords = reactiveVal(NULL),
projection = reactiveVal(NULL))
get_choices_crop <- reactive({
get_choices(input$var_filter_crop, lim = FALSE)
})
output$ScenarioFilter_crop = renderUI({
choices <- get_choices_crop()
scenarios <- unname(unlist(unique(choices %>% dplyr::select(Scenario))))
checkboxGroupInput("scen_filter_in_crop", "Select Scenarios", scenarios[-1])
})
output$RunFilter_crop = renderUI({
choices <- get_choices_crop()
checkboxGroupInput("run_filter_in_crop",
"Select Ensembles/runs",
unname(unlist(unique(choices %>% dplyr::select(Ensemble)))), "r1i1p1")
})
output$ModFilter_crop = renderUI({
choices <- get_choices_crop()
checkboxGroupInput("mod_filter_in_crop",
"Select Model",
unname(unlist(unique(choices %>% dplyr::select(Model)))))
})
output$resample_map <- renderLeaflet({
leaflet() %>%
addProviderTiles("CartoDB.Positron") %>%
......@@ -535,57 +555,92 @@ shinyServer(function(input, output, session) {
}
})
## This regex from: https://stackoverflow.com/q/43661458
isValidEmail <- function(x) {
(!is.null(x) && grepl("\\<[A-Z0-9._%+-][email protected][A-Z0-9.-]+\\.[A-Z]{2,}\\>", as.character(x),
ignore.case = TRUE))
}
output$latlon_checkbox <- renderUI({
model <- try(req(crop_model_in()))
selections <- if (!any(is.null(c(input$scen_filter_in_crop, input$run_filter_in_crop, input$mod_filter_in_crop)))) {
length(input$var_filter_crop) * length(input$scen_filter_in_crop) * length(input$run_filter_in_crop) * length(input$mod_filter_in_crop)
} else {
0
}
shp <- try(req(input$shapefile))
content <- '<b>To do:</b>'
if (all(c(input$Lat1, input$Lat2, input$Lon1, input$Lon2) %in% -999) &&
content <- '<b>To do:</b><br>'
if (!isValidEmail(input$crop_email)) {
content <- c(content, '<i class="far fa-square"></i> Enter an email address.')
} else {
content <- c(content, '<i class="far fa-check-square"></i> Enter an email address.</i>')
}
if (any(c(input$Lat1, input$Lat2, input$Lon1, input$Lon2) %in% -999) &&
is.null(input$shapefile)) {
content <- c(content, '<i class="far fa-square"></i> Select at least one point or upload a .shp')
content <- c(content, '<i class="far fa-square"></i> Select two points or upload a .shp')
} else {
content <- c(content, '<i class="far fa-check-square"></i> Select at least one point or upload a .shp')
content <- c(content, '<i class="far fa-check-square"></i> Select two points or upload a .shp')
}
if (inherits(model, "try-error")) {
content <- c(content, '<i class="far fa-square"></i> Choose a mod/var/scen to process.')
if (!selections %in% 1:20) {
content <- c(content, '<i class="far fa-square"></i> Choose up to 20 var/scen/mod/run to process.')
} else {
content <- c(content, '<i class="far fa-check-square"></i> Choose a mod/var/scen to process.</i>')
content <- c(content, '<i class="far fa-check-square"></i> Choose up to 20 var/scen/mod/run to process.')
}
content <- c(content, paste("<b><br>Your selections:", selections, "</b>"))
HTML(paste(content, collapse = "<br>"))
})
output$crop_action <- renderUI({
if ((!all(c(input$Lat1, input$Lat2, input$Lon1, input$Lon2) %in% -999) ||
!is.null(input$shapefile)) &
!is.null(crop_model_in())) {
if ((!any(c(input$Lat1, input$Lat2, input$Lon1, input$Lon2) %in% -999) ||
!is.null(input$shapefile)) && isValidEmail(input$crop_email) &&
(!any(is.null(c(input$scen_filter_in_crop, input$run_filter_in_crop, input$mod_filter_in_crop))) &&
(length(input$var_filter_crop) * length(input$scen_filter_in_crop) * length(input$run_filter_in_crop) * length(input$mod_filter_in_crop)) <= 20)) {
actionButton("crop_go", "Process!")
} else {
NULL
}
})
get_crop_link <- eventReactive(input$crop_go, {
observeEvent(input$crop_go, {
message("Button pressed")
meta <- crop_model_in()
key = unlist(meta$Files)
if (!is.null(input$shapefile)) {
if (!any(c(input$Lat1, input$Lat2, input$Lon1, input$Lon2) %in% -999)) {
bbox <- matrix(c(input$Lon1, input$Lat1,
input$Lon1, input$Lat2,
input$Lon2, input$Lat2,
input$Lon2, input$Lat1,
input$Lon1, input$Lat1),
ncol = 2, byrow = TRUE)
shp <- SpatialPolygons(list(Polygons(list(Polygon(bbox)), ID = "a")), proj4string = CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +nodefs"))
} else {
shp_data <- unzip_shp()
shp <- shp_data$shp
}
period <- input$crop_year_in[1]:input$crop_year_in[2]
meta <- get_gcm_files(get_choices_crop(),
baseline = NULL,
projection = period,
model = input$mod_filter_in_crop,
scenario = input$scen_filter_in_crop,
ensemble = input$run_filter_in_crop)
request <- list(meta = meta,
shp = jsonlite::base64_enc(serialize(shp, NULL)),
period = period,
email = input$crop_email)
submission <- crop_req(request)
if (submission) {
showModal(modalDialog(title = "Request submitted",
sprintf("You data request has been submitted successfully. You should receive an email at %s soon. If you do not receive an email, please report the issue to https://gitlab.com/ConorIA/conjuntool/issues", input$crop_email)))
} else {
xmin <- isolate(min(input$Lon1, input$Lon2))
xmax <- isolate(max(input$Lon1, input$Lon2))
ymin <- isolate(min(input$Lat1, input$Lat2))
ymax <- isolate(max(input$Lat1, input$Lat2))
shp <- extent(c(xmin, xmax, ymin, ymax))
showModal(modalDialog(title = "Request failed",
sprintf("Unfortunately there was an error submitting your request. Please report the issue to https://gitlab.com/ConorIA/conjuntool/issues", input$crop_email)))
}
saveRDS(list(key, shp), "debug.rds")
crop_req(key, shp)
})
output$cropped_data_link = renderUI({
link <- get_crop_link()
link <- paste0(plumber_address, "download?filepath=", link)
tags$a(href = link, target = "blank", "Click here for your data")
})
output$source <- renderUI({
......
......@@ -166,19 +166,31 @@ dashboardPage(
box(width = 2,
uiOutput("latlon_checkbox"),
uiOutput("crop_action"),
conditionalPanel("input.crop_go", htmlOutput("cropped_data_link"))
conditionalPanel("input.crop_go")
)
),
fluidRow(
box(
width = 3,
selectInput("var_filter_crop", "Select Variables", c("tas", "tasmax", "tasmin", "pr")),
singleModelSelectInput("crop_model_in", "Select Model")
#sliderInput("crop_year_in", label = "Years to Include", min = 2006,
# max = 2100, value = c(2011, 2100), step = 1,
# round = FALSE, sep = "", ticks = FALSE)
),
height = 7,
tabBox(
# The id lets us use input$tabset1 on the server to find the current tab
id = "tabset2", width = 3, height = "45vh",
tabPanel("1: Basics",
selectInput("var_filter_crop", "Select Variables", c("tas", "tasmax", "tasmin", "pr")),
uiOutput("ScenarioFilter_crop"),
sliderInput("crop_year_in", label = "Years to Include", min = 1850,
max = 2100, value = c(1981, 2100), step = 1,
round = FALSE, sep = "", ticks = FALSE),
textInput("crop_email", "Enter your email to receive data")
),
tabPanel("2: Models",
HTML("Choose the models to include in the analysis. An empty list will use ALL available models.<br/><br/>"),
uiOutput("ModFilter_crop"), style = "max-height: 40vh; overflow-y: auto;"
),
tabPanel("3: Runs",
HTML("Choose the ensembles and scenarios to analyze. Some models may not have output for all ensembles / runs.<br/><br/>"),
uiOutput("RunFilter_crop"), style = "max-height: 40vh; overflow-y: auto;"
)
),
box(
width = 9,
leafletOutput("resample_map")
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment