...
 
Commits (19)
#### -- Packrat Autoloader (version 0.4.8-1) -- ####
source("packrat/init.R")
#### -- End Packrat Autoloader -- ####
if (!requireNamespace("stringi")) install.packages("stringi")
.cache/*
.Rhistory
.Rproj.user
deploy.sh
local_settings.R
packrat/lib*/
packrat/src/
plumber_settings.R
shiny/packrat/lib*/
shiny/packrat/src/
shiny/shiny.Rproj
updateip.sh
get_choices <- function(file_dir, var, lim = FALSE) {
print(sprintf("Getting choices for %s in %s", var, file_dir))
filenames <- if (lim) {
grep("200601-210012.nc$", dir(file.path(file_dir, var, "verified")), value = TRUE)
} else {
dir(file.path(file_dir, var, "verified"))
}
choices <- as_tibble(t(sapply(filenames, ncdf4.helpers::get.split.filename.cmip5)))
names(choices) <- c("Variable", "Period", "Model", "Scenario", "Ensemble", "Range", "Start", "End")
choices <- choices %>%
mutate(Model = gsub("([0-9])-([0-9])", paste0("\\1", ".", "\\2"), gsub("([0-9])-([0-9])", paste0("\\1", ".", "\\2"), Model)),
Scenario = sub("rcp([0-9])([0-9])", paste0("RCP", "\\1", ".", "\\2"), Scenario),
Filenames = filenames)
choices
}
get_gcm_ts <- function(meta) {
st_point <- storr::storr_rds(".cache/point-cache", default_namespace = "point")
# Process each NetCDF file
print("Collecting the NetCDF time series...")
registerDoParallel(no_of_cores)
withProgress(message = 'Getting time series in parallel', value = 0, {
dat <- foreach(row=1:nrow(meta), .combine=bind_rows) %dopar% {
var <- meta$Var[row]
lat_cell <- meta$Lat_Cell[row]
lon_cell <- meta$Lon_Cell[row]
fs <- unlist(meta$Files[row])
for (f in 1:length(fs)) {
key <- paste(fs[f], lat_cell, lon_cell, sep = "_")
time_tmp <- NULL
if (st_point$exists(key)) {
print("Hit the cache.")
time_tmp <- st_point$get(key)
if (!inherits(time_tmp, "tbl_df") || ncol(time_tmp) != 8) { ## Invalidate old cache entries.
st_point$del(key)
time_tmp <- NULL
}
}
if (is.null(time_tmp)) {
print("Missed the cache")
# Get the time
components <- get.split.filename.cmip5(fs[f])
nc_nc <- nc_open(file.path(file_dir, var, "verified", fs[f]))
nc_time <- try(nc.get.time.series(nc_nc, v = var, time.dim.name = "time"), silent = TRUE)
if (inherits(nc_time, "try-error")) {
nc_time <- ncvar_get(nc_nc, "time")
nc_time_units <- ncatt_get(nc_nc, "time", attname="units")$value
nc_time_origin <- strsplit(nc_time_units, " ")
nc_time_origin <- unlist(nc_time_origin)[3]
nc_time <- as.yearmon(ymd(nc_time_origin) + nc_time)
if (paste0(format(nc_time[1], format = "%Y"), format(nc_time[1], format = "%m")) != unname(components['tstart']) || paste0(format(nc_time[length(nc_time)], format = "%Y"), format(nc_time[length(nc_time)], format = "%m")) != unname(components['tend'])) {
stop(paste("Error processing time for", fs[f]))
}
} else {
nc_time <- as.yearmon(format(nc_time, format = "%Y-%m-%d hh:mm:ss"))
}
# Now load only that grid data
nc_var <- nc.get.var.subset.by.axes(nc_nc, var, axis.indices = list(X = lon_cell, Y = lat_cell))
# Close the nc connection
nc_close(nc_nc); rm(nc_nc)
# Note, does this still apply?
if (dim(nc_var)[1] > 1 || dim(nc_var)[2] > 1) {
warning("We got two latitud or longitude cells. We'll average across them.")
nc_var <- apply(nc_var, 3, mean)
} else {
nc_var <- nc_var[1, 1, ]
}
if (var %in% c("tas", "tasmax", "tasmin")) nc_var <- nc_var - 273.15
time_tmp <- tibble(Var = var,
Model = meta$Model[row],
Scenario = meta$Scenario[row],
Ensemble = meta$Ensemble[row],
Time = nc_time,
Year = format(as.yearmon(Time), format = "%Y"),
Month = format(as.yearmon(Time), format = "%m"),
Value = nc_var)
rm(nc_var, nc_time); gc()
st_point$set(key, time_tmp)
print("Cached data")
}
if (f == 1) {
time_series <- time_tmp
} else {
start_row <- which(time_tmp$Time == (time_series$Time[nrow(time_series)] + 1/12))
if (length(start_row) != 0) time_series <- suppressWarnings(bind_rows(time_series, time_tmp[start_row:nrow(time_tmp),]))
}
}
incProgress((nrow(meta)/no_of_cores)^-1, detail = paste(row, "of", nrow(meta)))
time_series$Scenario <- meta$Scenario[row] # This needs to be at the end so we don't override the other files.
time_series
}
})
print("Done collecting the NetCDF files...")
# Return our tibble
dat %>% distinct() ##FIXME: Why do I get so many dupes?
}
\ No newline at end of file
lookup_table_bounds <- function(choices) {
var <- unique(choices$Variable)
## As far as I can tell, the model bounds never change, regardless of scenario, experiment etc. So we just need one file for each
# Note, we could confirm this if it weren't for https://github.com/tidyverse/dplyr/issues/3088
choices <- choices %>% group_by(Model) %>% summarize(Filename = head(Filenames, 1))
get_bounds <- function(file_dir, var, x) {
nc_nc <- nc_open(file.path(file_dir, var, "verified", x))
lon_bnds <- try(ncvar_get(nc_nc, "lon_bnds"), silent = TRUE)
if (inherits(lon_bnds, "try-error")) {
lon_bnds <- ncvar_get(nc_nc, "lon_bounds")
}
lat_bnds <- try(ncvar_get(nc_nc, "lat_bnds"), silent = TRUE)
if (inherits(lat_bnds, "try-error")) {
lat_bnds <- ncvar_get(nc_nc, "lat_bounds")
}
c(Lat_Bot = list(lat_bnds[1,]), Lat_Top = list(lat_bnds[2,]),
Lon_Lef = list(lon_bnds[1,]), Lon_Rig = list(lon_bnds[2,]))
}
bounds <- choices$Filename %>%
map(~get_bounds(file_dir, var, .)) %>%
map_df(~tibble(Lat_Bot = .[1], Lat_Top = .[2], Lon_Lef = .[3], Lon_Rig = .[4]))
bind_cols(choices %>% dplyr::select(-`Filename`), bounds)
}
Version: 1.0
RestoreWorkspace: Default
SaveWorkspace: Default
AlwaysSaveHistory: Default
EnableCodeIndexing: Yes
UseSpacesForTab: Yes
NumSpacesForTab: 2
Encoding: UTF-8
RnwWeave: Sweave
LaTeX: pdfLaTeX
StripTrailingWhitespace: Yes
version: '2'
services:
conjuntool:
build: ./shiny
restart: always
volumes:
- ./shiny/local_settings.R:/srv/shiny-server/app/local_settings.R:ro
- ./shiny/shiny-server.conf:/etc/shiny-server/shiny-server.conf:ro
expose:
- 80
plumber:
build: ./plumber
restart: always
volumes:
- /data/climate_data:/data/climate_data
- ./plumber/plumber_settings.R:/plumber_settings.R:ro
lb:
image: 'dockercloud/haproxy:1.2.1'
links:
- plumber:8000
volumes:
- /var/run/docker.sock:/var/run/docker.sock
haproxy:
image: eeacms/haproxy
depends_on:
- conjuntool
environment:
FRONTEND_PORT: "80"
BACKENDS: "conjuntool"
BACKENDS_PORT: "3838"
DNS_ENABLED: "true"
LOG_LEVEL: "info"
COOKIES_ENABLED: "true"
expose:
- 80
local({
## Helper function to get the path to the library directory for a
## given packrat project.
getPackratLibDir <- function(projDir = NULL) {
path <- file.path("packrat", "lib", R.version$platform, getRversion())
if (!is.null(projDir)) {
## Strip trailing slashes if necessary
projDir <- sub("/+$", "", projDir)
## Only prepend path if different from current working dir
if (!identical(normalizePath(projDir), normalizePath(getwd())))
path <- file.path(projDir, path)
}
path
}
## Ensure that we set the packrat library directory relative to the
## project directory. Normally, this should be the working directory,
## but we also use '.rs.getProjectDirectory()' if necessary (e.g. we're
## rebuilding a project while within a separate directory)
libDir <- if (exists(".rs.getProjectDirectory"))
getPackratLibDir(.rs.getProjectDirectory())
else
getPackratLibDir()
## Unload packrat in case it's loaded -- this ensures packrat _must_ be
## loaded from the private library. Note that `requireNamespace` will
## succeed if the package is already loaded, regardless of lib.loc!
if ("packrat" %in% loadedNamespaces())
try(unloadNamespace("packrat"), silent = TRUE)
if (suppressWarnings(requireNamespace("packrat", quietly = TRUE, lib.loc = libDir))) {
# Check 'print.banner.on.startup' -- when NA and RStudio, don't print
print.banner <- packrat::get_opts("print.banner.on.startup")
if (print.banner == "auto" && is.na(Sys.getenv("RSTUDIO", unset = NA))) {
print.banner <- TRUE
} else {
print.banner <- FALSE
}
return(packrat::on(print.banner = print.banner))
}
## Escape hatch to allow RStudio to handle bootstrapping. This
## enables RStudio to provide print output when automagically
## restoring a project from a bundle on load.
if (!is.na(Sys.getenv("RSTUDIO", unset = NA)) &&
is.na(Sys.getenv("RSTUDIO_PACKRAT_BOOTSTRAP", unset = NA))) {
Sys.setenv("RSTUDIO_PACKRAT_BOOTSTRAP" = "1")
setHook("rstudio.sessionInit", function(...) {
# Ensure that, on sourcing 'packrat/init.R', we are
# within the project root directory
if (exists(".rs.getProjectDirectory")) {
owd <- getwd()
setwd(.rs.getProjectDirectory())
on.exit(setwd(owd), add = TRUE)
}
source("packrat/init.R")
})
return(invisible(NULL))
}
## Bootstrapping -- only performed in interactive contexts,
## or when explicitly asked for on the command line
if (interactive() || "--bootstrap-packrat" %in% commandArgs(TRUE)) {
message("Packrat is not installed in the local library -- ",
"attempting to bootstrap an installation...")
## We need utils for the following to succeed -- there are calls to functions
## in 'restore' that are contained within utils. utils gets loaded at the
## end of start-up anyhow, so this should be fine
library("utils", character.only = TRUE)
## Install packrat into local project library
packratSrcPath <- list.files(full.names = TRUE,
file.path("packrat", "src", "packrat")
)
## No packrat tarballs available locally -- try some other means of installation
if (!length(packratSrcPath)) {
message("> No source tarball of packrat available locally")
## There are no packrat sources available -- try using a version of
## packrat installed in the user library to bootstrap
if (requireNamespace("packrat", quietly = TRUE) && packageVersion("packrat") >= "0.2.0.99") {
message("> Using user-library packrat (",
packageVersion("packrat"),
") to bootstrap this project")
}
## Couldn't find a user-local packrat -- try finding and using devtools
## to install
else if (requireNamespace("devtools", quietly = TRUE)) {
message("> Attempting to use devtools::install_github to install ",
"a temporary version of packrat")
library(stats) ## for setNames
devtools::install_github("rstudio/packrat")
}
## Try downloading packrat from CRAN if available
else if ("packrat" %in% rownames(available.packages())) {
message("> Installing packrat from CRAN")
install.packages("packrat")
}
## Fail -- couldn't find an appropriate means of installing packrat
else {
stop("Could not automatically bootstrap packrat -- try running ",
"\"'install.packages('devtools'); devtools::install_github('rstudio/packrat')\"",
"and restarting R to bootstrap packrat.")
}
# Restore the project, unload the temporary packrat, and load the private packrat
packrat::restore(prompt = FALSE, restart = TRUE)
## This code path only reached if we didn't restart earlier
unloadNamespace("packrat")
requireNamespace("packrat", lib.loc = libDir, quietly = TRUE)
return(packrat::on())
}
## Multiple packrat tarballs available locally -- try to choose one
## TODO: read lock file and infer most appropriate from there; low priority because
## after bootstrapping packrat a restore should do the right thing
if (length(packratSrcPath) > 1) {
warning("Multiple versions of packrat available in the source directory;",
"using packrat source:\n- ", shQuote(packratSrcPath))
packratSrcPath <- packratSrcPath[[1]]
}
lib <- file.path("packrat", "lib", R.version$platform, getRversion())
if (!file.exists(lib)) {
dir.create(lib, recursive = TRUE)
}
lib <- normalizePath(lib, winslash = "/")
message("> Installing packrat into project private library:")
message("- ", shQuote(lib))
surround <- function(x, with) {
if (!length(x)) return(character())
paste0(with, x, with)
}
## The following is performed because a regular install.packages call can fail
peq <- function(x, y) paste(x, y, sep = " = ")
installArgs <- c(
peq("pkgs", surround(packratSrcPath, with = "'")),
peq("lib", surround(lib, with = "'")),
peq("repos", "NULL"),
peq("type", surround("source", with = "'"))
)
installCmd <- paste(sep = "",
"utils::install.packages(",
paste(installArgs, collapse = ", "),
")")
fullCmd <- paste(
surround(file.path(R.home("bin"), "R"), with = "\""),
"--vanilla",
"--slave",
"-e",
surround(installCmd, with = "\"")
)
system(fullCmd)
## Tag the installed packrat so we know it's managed by packrat
## TODO: should this be taking information from the lockfile? this is a bit awkward
## because we're taking an un-annotated packrat source tarball and simply assuming it's now
## an 'installed from source' version
## -- InstallAgent -- ##
installAgent <- 'InstallAgent: packrat 0.4.8-1'
## -- InstallSource -- ##
installSource <- 'InstallSource: source'
packratDescPath <- file.path(lib, "packrat", "DESCRIPTION")
DESCRIPTION <- readLines(packratDescPath)
DESCRIPTION <- c(DESCRIPTION, installAgent, installSource)
cat(DESCRIPTION, file = packratDescPath, sep = "\n")
# Otherwise, continue on as normal
message("> Attaching packrat")
library("packrat", character.only = TRUE, lib.loc = lib)
message("> Restoring library")
restore(restart = FALSE)
# If the environment allows us to restart, do so with a call to restore
restart <- getOption("restart")
if (!is.null(restart)) {
message("> Packrat bootstrap successfully completed. ",
"Restarting R and entering packrat mode...")
return(restart())
}
# Callers (source-erers) can define this hidden variable to make sure we don't enter packrat mode
# Primarily useful for testing
if (!exists(".__DONT_ENTER_PACKRAT_MODE__.") && interactive()) {
message("> Packrat bootstrap successfully completed. Entering packrat mode...")
packrat::on()
}
Sys.unsetenv("RSTUDIO_PACKRAT_BOOTSTRAP")
}
})
This diff is collapsed.
auto.snapshot: TRUE
use.cache: TRUE
print.banner.on.startup: auto
vcs.ignore.lib: TRUE
vcs.ignore.src: TRUE
external.packages:
local.repos:
load.external.packages.on.startup: TRUE
ignored.packages:
quiet.package.installation: TRUE
snapshot.recommended.packages: FALSE
snapshot.fields:
Imports
Depends
LinkingTo
FROM trestletech/plumber
MAINTAINER Conor Anderson <[email protected]>
COPY api/plumber.R /api/plumber.R
RUN apt-get update &&\
apt-get install -y --no-install-recommends curl libnetcdf-dev &&\
apt-get clean && rm -rf /tmp/* /var/lib/apt/lists/*
RUN cd /api &&\
Rscript -e "source('https://gitlab.com/ConorIA/conjuntool/snippets/1788463/raw')" &&\
rm -rf /tmp/*
CMD ["/api/plumber.R"]
This diff is collapsed.
# Debug options
debug_flag = FALSE
# File storage location
# File tree should look like this:
#
# <file_dir>
# └── <cmip> (e.g. "CMIP5", "CMIP6")
# └── <var> (e.g. "tas", "pr")
# └── verified
# └── <filename>
#
file_dir = "/data/climate_data"
# Cache details
cache_root = file.path(file_dir, ".cache")
st_avg = storr::storr_rds(file.path(cache_root, "avg-cache"), default_namespace = "avg")
st_point = storr::storr_rds(file.path(cache_root, "point-cache"), default_namespace = "point")
st_meta = storr::storr_rds(file.path(cache_root, "meta-cache"), default_namespace = "meta")
cache_ver = "2018-12-06"
# Users and Passwords
users = c()
passwords = c()
aur/icu57
aur/udunits
community/netcdf
community/netcdf-fortran
community/gdal
Dockerfile
local_settings*
*.Rproj
FROM rocker/shiny
MAINTAINER Conor Anderson <[email protected]>
COPY . /srv/shiny-server/app
RUN apt-get update &&\
apt-get install -y --no-install-recommends curl libgdal-dev libjq-dev libnetcdf-dev libssl-dev libudunits2-dev &&\
apt-get clean && rm -rf /tmp/* /var/lib/apt/lists/*
RUN mv /srv/shiny-server/app/shiny-server.conf /etc/shiny-server/shiny-server.conf
RUN cd /srv/shiny-server/app &&\
Rscript -e "source(\"https://gitlab.com/ConorIA/conjuntool/snippets/1788463/raw\")" &&\
sudo -u shiny bash -c "Rscript -e \"webshot::install_phantomjs()\"" &&\
rm -rf /tmp/*
calc_anoms <- function(datin) {
calc_anoms <- function(datin, var) {
if (has_name(datin, "Ensembles")) {
warning("It seems you already averaged the ensembles. This function needs to be run first.")
......@@ -22,7 +22,7 @@ calc_anoms <- function(datin) {
col <- 5
}
do_calc <- function(i, dat_hist, dat_proj, grouping, col) {
do_calc <- function(i, dat_hist, dat_proj, grouping, col, var) {
scenario <- if (str_detect(dat_hist$Scenario[i], pattern = "RCP[024568.]{3}")) {
str_extract(dat_hist$Scenario[i], pattern = "RCP[024568.]{3}")
} else {
......@@ -38,7 +38,11 @@ calc_anoms <- function(datin) {
matched[, col] <- unlist(dat_hist[i, col])
for (co in (col+1):number_of_cols) {
for (ro in 1:nrow(matched)) {
matched[ro, co] <- matched[ro, co] - matched[ro, col]
if (var %in% c("tas", "tasmin", "tasmax")) {
matched[ro, co] <- matched[ro, co] - matched[ro, col]
} else {
matched[ro, co] <- (matched[ro, co] - matched[ro, col]) / matched[ro, col] * 100
}
}
}
if (has_name(dat_hist, "Note") && length(dat_hist$Note[i] > 0)) {
......@@ -46,5 +50,6 @@ calc_anoms <- function(datin) {
}
matched
}
do.call("bind_rows", lapply(1:nrow(dat_hist), do_calc, dat_hist, dat_proj, grouping, col))
do.call("bind_rows", lapply(1:nrow(dat_hist), do_calc, dat_hist, dat_proj, grouping, col, var))
}
convert_units <- function(tab, var) {
if (debug_flag) message("convert_units")
if (var %in% c("tas", "tasmin", "tasmax")) {
return(mutate(tab, Value = Value - 273.15))
} else if (var %in% c("pr", "prc")) {
tab <- mutate(tab, Days = days_in_month(as.Date(paste(Year,
Month,
"01", sep = "-"))))
return(dplyr::select(mutate(tab, Value = Value * (Days*86400)), -Days))
} else {
stop("Unrecognized variable in convert_units.")
}
}
\ No newline at end of file
get_bounds <- function(var) {
if (debug_flag) message(sprintf("Getting model bounds for %s", var))
r <- POST(URLencode(paste0(plumber_address, "/bounds?var=", var)),
config = list(add_headers(accept = "application/octet-stream")),
authenticate(plumber_user, plumber_password))
stop_for_status(r)
unserialize(content(r))
}
\ No newline at end of file
get_cache <- function(key) {
if (debug_flag) message("Asking plumber for ", key)
r <- POST(URLencode(paste0(plumber_address, "/cacheget?key=", key)),
config = list(add_headers(accept = "application/octet-stream")),
authenticate(plumber_user, plumber_password))
stop_for_status(r)
unserialize(content(r))
}
set_cache <- function(key, table) {
if (debug_flag) message("Asking plumber to save ", key)
r <- POST(URLencode(paste0(plumber_address, "/cacheset?key=", key)),
config = list(add_headers(accept = "application/octet-stream")),
authenticate(plumber_user, plumber_password),
body = jsonlite::toJSON(table), encoding = "json")
stop_for_status(r)
if (r$status_code != 200) warning("There was an error saving this table.")
}
get_choices <- function(var, lim = FALSE) {
if (debug_flag) message(sprintf("Getting choices for %s", var))
r <- POST(URLencode(paste0(plumber_address, "/choices?var=", var,
"&lim=", as.character(lim))),
config = list(add_headers(accept = "application/octet-stream")),
authenticate(plumber_user, plumber_password))
stop_for_status(r)
unserialize(content(r))
}
get_coords <- function(coords_in) {
print(sprintf("Getting coordinates for input %s", coords_in))
if (debug_flag) message("Getting coordinates for input ", coords_in)
if (length(unlist(strsplit(coords_in, split = ","))) == 2) {
print("Input is of length two")
if (debug_flag) message("Input is of length two")
coerce_coords <- suppressWarnings(as.numeric(unlist(strsplit(coords_in, split = ","))))
}
if (exists("coerce_coords") && !any(is.na(coerce_coords))) {
print("Coordinates were passed directly")
if (debug_flag) message("Coordinates were passed directly")
coords <- data.frame(lon = coerce_coords[2], lat = coerce_coords[1])
rm(coerce_coords)
} else {
......@@ -14,6 +14,6 @@ get_coords <- function(coords_in) {
lat = coords$results$geometry$location$lat)
}
if(nrow(coords) > 1) warning("We got more than one result. We'll use the first.")
print(coords)
if (debug_flag) message(coords)
coords[1,]
}
\ No newline at end of file
get_gcm_files <- function(choices, baseline = NULL, projection = NULL, model = NULL, scenario = NULL, ensemble = NULL) {
print("get_gcm_files()")
if (debug_flag) message("get_gcm_files()")
# If we want both the baseline and the projections, we'll run this twice, once for each period.
if (!is.null(baseline) && !is.null(projection)) {
baseline_files <- get_gcm_files(dir, baseline, NULL, model, scenario, ensemble)
projection_files <- get_gcm_files(dir, NULL, projection, model, scenario, ensemble)
baseline_files <- get_gcm_files(choices, baseline, NULL, model, scenario, ensemble)
projection_files <- get_gcm_files(choices, NULL, projection, model, scenario, ensemble)
return(bind_rows(baseline_files, projection_files))
}
......
get_gcm_ts <- function(meta) {
if (debug_flag) message("Collecting the NetCDF time series...")
showNotification("We'll collect the necessary files.")
keys <- unlist(apply(meta, 1, function(x) { paste(x$Files, x$Lat_Cell, x$Lon_Cell, sep = "_") }))
scenarios <- unlist(apply(meta, 1, function(x) { rep(x$Scenario, length(x$Files)) }))
urls = paste0(plumber_address, "/timeseries?key=", keys)
reqs <- lapply(urls, function(x) {
HttpRequest$new(
url = x,
opts = list(timeout = 6e4),
auth = auth(plumber_user, plumber_password, "basic")
)$post()
})
res <- AsyncVaried$new(.list = reqs)
res$request()
if (any(res$status_code() != 200)) {
warning(sum(res$status_code() != 200), " urls failed. Retrying in one minute.")
showNotification(sprintf(
"This is taking longer than we expected. This probably means you've selected \
an area that hasn't been cached before. We'll keep working on the %i remaining files. \
Next time this should be much faster!", sum(res$status_code() != 200)),
duration = 60, type = "message")
Sys.sleep(60)
rm(reqs)
reqs <- lapply(urls, function(x) {
HttpRequest$new(
url = x,
opts = list(timeout = 12e5),
auth = auth(plumber_user, plumber_password, "basic")
)$post()
})
rm(res)
res <- AsyncVaried$new(.list = reqs)
res$request()
}
if (any(res$status_code() != 200)) {
warning(sum(res$status_code() != 200), " urls failed. Retrying in one minute.")
showNotification(sprintf("We are still waiting on %i file(s). Give us one more minute \
and we'll try again.", sum(res$status_code() != 200)),
duration = 60, type = "warning")
Sys.sleep(60)
res$request()
}
conts <- res$content()
if (any(res$status_code() != 200)) {
warning(sum(res$status_code() != 200), " urls failed upon retry.")
conts <- conts[res$status_code() == 200]
scenarios <- scenarios[res$status_code() == 200]
showNotification(
sprintf("%i file(s) still failed. These results are incomplete. Please use more conservative filters, or try again in a few minutes.",
sum(res$status_code() != 200)),
duration = NULL, closeButton = TRUE, type = "error")
}
out <- lapply(conts, unserialize)
out <- mapply(function(x, y) {mutate(x, Scenario = y)}, out, scenarios, SIMPLIFY = FALSE)
dat <- suppressWarnings(do.call("bind_rows", out))
dat$Time <- as.yearmon(dat$Time)
message("Done collecting the NetCDF files...")
# Return our tibble
dat %>% distinct() ##FIXME: Why do I get so many dupes?
}
\ No newline at end of file
......@@ -2,28 +2,27 @@ get_metadata <- function(choices, coords, baseline = NULL,
projection = NULL, model = NULL, scenario = NULL,
ensemble = NULL) {
st_meta <- storr::storr_rds(".cache/meta-cache", default_namespace = "meta")
var <- unique(choices$Variable)
if (debug_flag) message("get_metadata")
print("Getting metadata")
var <- unique(choices$Variable)
if (is.null(model)) model <- unique(choices$Model)
if (is.null(scenario)) scenario <- unique(choices$Scenario)
if (!is.null(baseline)) scenario <- c(scenario, "historical")
if (is.null(ensemble)) ensemble <- unique(choices$Ensemble)
cases <- choices %>% dplyr::select(Model, Scenario, Ensemble) %>%
filter(Model %in% model & Scenario %in% scenario & Ensemble %in% ensemble) %>%
distinct()
if(!is.null(baseline)) {
coyote <- (!is.null(baseline) && paste0(baseline[length(baseline)], "12") > "200512")
if (!is.null(baseline)) {
coyote <- (!is.null(baseline) && paste0(baseline[2], "12") > "200512")
gcm_baseline_key <- if (coyote) {
paste0("lookup_table_files_baseline_coyote_", var)
} else {
paste0("lookup_table_files_baseline_", var)
}
baseline_shorts_key <- paste0(gcm_baseline_key, "_known_shorts_",
min(baseline), "_", max(baseline))
baseline[1], "_", baseline[2])
short_cases <- if (coyote) {
mutate(cases,
......@@ -35,15 +34,16 @@ get_metadata <- function(choices, coords, baseline = NULL,
filter(cases, Scenario == "historical")
}
if (st_meta$exists(gcm_baseline_key)) {
gcm_baseline_files <- st_meta$get(gcm_baseline_key)
known_shorts <- if (st_meta$exists(baseline_shorts_key)) {
st_meta$get(baseline_shorts_key)
} else {
NULL
gcm_baseline_files <- get_cache(gcm_baseline_key)
if (all(gcm_baseline_files != "NULL")) {
known_shorts <- get_cache(baseline_shorts_key)
if (all(known_shorts == "NULL")) {
known_shorts <- NULL
}
hist_files <- semi_join(gcm_baseline_files, short_cases) %>%
filter(Start <= paste0(min(baseline), "01") & End >= paste0(max(baseline), "12"))
filter(Start <= paste0(baseline[1], "01") & End >= paste0(baseline[2], "12"))
short_cases <- anti_join(short_cases, hist_files)
if (!is.null(known_shorts)) short_cases <- anti_join(short_cases, known_shorts)
} else {
......@@ -51,7 +51,7 @@ get_metadata <- function(choices, coords, baseline = NULL,
}
if (nrow(short_cases) > 0) {
print("Baseline cases were short.")
message("Baseline cases were short.")
new_hist_files <- get_gcm_files(choices, baseline,
projection = NULL,
model = unique(short_cases$Model),
......@@ -62,12 +62,11 @@ get_metadata <- function(choices, coords, baseline = NULL,
distinct(Model, Scenario, Ensemble, Start, End, .keep_all = TRUE)
gcm_baseline_files <- bind_rows(gcm_baseline_files, new_hist_files) %>%
distinct(Model, Scenario, Ensemble, Start, End, .keep_all = TRUE)
st_meta$set(key = gcm_baseline_key, value = gcm_baseline_files)
set_cache(gcm_baseline_key, gcm_baseline_files)
}
short_cases <- anti_join(short_cases, hist_files %>% dplyr::select(Model, Scenario, Ensemble))
if (nrow(short_cases) > 0) {
st_meta$set(key = baseline_shorts_key,
value = bind_rows(known_shorts, short_cases) %>% distinct)
set_cache(baseline_shorts_key, bind_rows(known_shorts, short_cases) %>% distinct)
}
}
} else {
......@@ -78,19 +77,20 @@ get_metadata <- function(choices, coords, baseline = NULL,
gcm_projection_key <- paste0("lookup_table_files_projection_", var)
projection_shorts_key <- paste0(gcm_projection_key, "_known_shorts_",
min(projection), "_", max(projection))
projection[1], "_", projection[2])
short_cases <- filter(cases, Scenario != "historical")
if (st_meta$exists(gcm_projection_key)) {
gcm_projection_files <- st_meta$get(gcm_projection_key)
known_shorts <- if (st_meta$exists(projection_shorts_key)) {
st_meta$get(projection_shorts_key)
} else {
NULL
gcm_projection_files <- get_cache(gcm_projection_key)
if (all(gcm_projection_files != "NULL")) {
known_shorts <- get_cache(projection_shorts_key)
if (all(known_shorts == "NULL")) {
known_shorts <- NULL
}
proj_files <- semi_join(gcm_projection_files, short_cases) %>%
filter(Start <= paste0(min(projection), "01") & End >= paste0(max(projection), "12"))
filter(Start <= paste0(projection[1], "01") & End >= paste0(projection[2], "12"))
short_cases <- anti_join(short_cases, proj_files)
if (!is.null(known_shorts)) short_cases <- anti_join(short_cases, known_shorts)
} else {
......@@ -98,7 +98,7 @@ get_metadata <- function(choices, coords, baseline = NULL,
}
if (nrow(short_cases) > 0) {
print("Projection models were short.")
message("Projection models were short.")
new_proj_files <- get_gcm_files(choices, baseline = NULL,
projection,
model = unique(short_cases$Model),
......@@ -109,12 +109,11 @@ get_metadata <- function(choices, coords, baseline = NULL,
distinct(Model, Scenario, Ensemble, Start, End, .keep_all = TRUE)
gcm_projection_files <- bind_rows(gcm_projection_files, new_proj_files) %>%
distinct(Model, Scenario, Ensemble, Start, End, .keep_all = TRUE)
st_meta$set(key = gcm_projection_key, value = gcm_projection_files)
set_cache(gcm_projection_key, gcm_projection_files)
}
short_cases <- anti_join(short_cases, proj_files %>% dplyr::select(Model, Scenario, Ensemble))
if (nrow(short_cases) > 0) {
st_meta$set(key = projection_shorts_key,
value = bind_rows(known_shorts, short_cases) %>% distinct)
set_cache(projection_shorts_key, bind_rows(known_shorts, short_cases) %>% distinct)
}
}
} else {
......@@ -122,18 +121,7 @@ get_metadata <- function(choices, coords, baseline = NULL,
}
if(!is.null(coords)) {
# It is overkill to do this for each variable, but I'll do it this way to be safe.
if (st_meta$exists(paste0("lookup_table_bounds_", var))) {
cached <- TRUE
bounds_tab <- st_meta$get(paste0("lookup_table_bounds_", var))
} else {
cached <- FALSE
bounds_tab <- lookup_table_bounds(choices)
}
if (!cached) st_meta$set(key = paste0("lookup_table_bounds_", var), value = bounds_tab)
rm(cached)
bounds_tab <- get_bounds(var)
# Convert Western longitudes to degrees East
lon <- ifelse(coords$lon <0, 360 + coords$lon, coords$lon)
......@@ -142,8 +130,14 @@ get_metadata <- function(choices, coords, baseline = NULL,
latlon_cells <- bounds_tab %>% group_by(Model) %>% summarize(Lat_Cell = which(unlist(Lat_Bot) <= coords$lat & unlist(Lat_Top) >= coords$lat),
Lon_Cell = which(unlist(Lon_Lef) <= lon & unlist(Lon_Rig) >= lon))
left_join(bind_rows(hist_files, proj_files), latlon_cells) %>% add_column(Var = var, .before = 1)
meta <- left_join(bind_rows(hist_files, proj_files), latlon_cells) %>% add_column(Var = var, .before = 1)
} else {
bind_rows(hist_files, proj_files)
meta <- bind_rows(hist_files, proj_files)
}
meta %>%
mutate(No_of_Files = lengths(Files)) %>%
arrange(Model, Scenario, Ensemble, No_of_Files) %>%
group_by(Model, Scenario, Ensemble) %>%
summarize_all(head, 1) %>%
dplyr::select(-No_of_Files)
}
......@@ -28,7 +28,7 @@ poll_files <- function(filtered, period, coyote, scenario, ensemble) {
# Start with out start date
start_row <- max(which(model_stats$Start <= paste0(min(period), "01")))
if (length(start_row) == 0) {
print("Add some code to panic because no start")
stop("No start!")
} else {
model_files <- filtered %>% filter(Model == mod, Scenario == model_stats$Scenario[start_row], Ensemble == model_stats$Ensemble[start_row], Length == model_stats$Length[start_row]) %>% dplyr::select(Start, End, Filenames)
next_row <- suppressWarnings(try(min(which(as.yearmon(model_stats$Start, format = "%Y%m") == (as.yearmon(model_stats$End[start_row], format = "%Y%m") + 1/12) | (model_stats$Start <= model_stats$End[start_row] & model_stats$End > model_stats$End[start_row]))), silent = TRUE))
......@@ -42,7 +42,7 @@ poll_files <- function(filtered, period, coyote, scenario, ensemble) {
}
}
if (next_row == Inf) {
print(paste("Not enough data for", mod))
message(paste("Not enough data for", mod))
} else {
out$Start[out$Model == mod] <- model_files$Start[max(which(model_files$Start <= paste0(min(period), "01")))]
out$End[out$Model == mod] <- model_files$End[min(which(model_files$End >= paste0(max(period), "12")))]
......
......@@ -11,7 +11,7 @@ process_raw_anom_ts <- function(time_series, anom_period_in, baseline, projectio
# Choose our period of analysis
time_series$Year <- as.integer(time_series$Year)
print(sprintf("The input period is %s", anom_period_in))
if (debug_flag) message("The input period is ", anom_period_in)
if (anom_period_in == "Annual") {
grouping <- c("Var", "Model", "Scenario", "Ensemble", "Year")
......
......@@ -10,7 +10,7 @@ _Conjuntool_ is a free, open source platform for the accessing and processing Ge
1. __GCM Plots__: Plot time series of GCM data, and produce monthly or annual time series for download.
2. __GCM Anomalies__: Read GCM data and generate $\Delta T$ Anomalies (change factors) over a chosen baseline.
3. __Overlay Map__: Show an overlay map of the time-period average temperature for the selected model and period.
3. __Overlay Map__: Show an overlay map of the time-period average selected data over a user-defined period.
## Why "_Conjuntool_"?:
......
## Data location
# Conjuntool assumes that you have amassed all necessary NetCDF files form the ESGF
# These should be sorted into folders by variable, e.g. "tas", "tasmin", etc.
# For now these are hard-coded, so you will need to change the relevant line of code to include other variables
# For more info on the ESGF, see https://esgf-node.llnl.gov/projects/esgf-llnl/
file_dir = ""
## Debug options
# Some options that allow for debug
options(shiny.reactlog = FALSE)
debug_flag = FALSE
## Google Maps API key
# Conjuntool uses Google Maps to for geocoding locations. Enter your key here.
# If you don' t have a key, get one at https://developers.google.com/maps/documentation/javascript/get-api-key
google_key = ""
## Plumber Settings
# There is a plumber API that interacts with the netCDF files on the server.
# Contact the Conjuntool author for credentials.
# If you want to self-host the plumber API, change the address here.
plumber_address = "https://api.conr.ca/conjuntool/"
plumber_user = ""
plumber_password = ""
## Number of cores to use
# Conjuntool parallelizes some heavy functions. Set the number of cores to use.
no_of_cores = detectCores() - 1
no_of_cores = detectCores()/2
This diff is collapsed.
run_as shiny;
server {
listen 3838;
location / {
site_dir /srv/shiny-server/app/;
log_dir /var/log/shiny-server;
directory_index off;
}
}
# pkgs = c("shiny", "shinydashboard", "leaflet", "plotly")
# lapply(pkgs, library, character.only = TRUE)
library("shiny")
library("shinydashboard")
library("leaflet")
library("lubridate")
library("plotly")
library("httr")
source(dir("modules", full.names = TRUE))
r <- GET("https://gitlab.com/api/v4/projects/4693398/repository/commits",
config = list(add_headers(accept = "application/json")))
stop_for_status(r)
commits <- jsonlite::fromJSON(rawToChar(r$content))
dashboardPage(
dashboardHeader(title = "Conjuntool"),
dashboardSidebar(
......@@ -29,9 +33,9 @@ dashboardPage(
box(width = 12,
includeHTML("include/fontawesome5.html"),
withMathJax(includeMarkdown("README.md")),
HTML(paste("<p align=\"right\">You are using <i>Conjuntool</i> as of git commit sha:",
system('git rev-parse --short --verify HEAD', intern = T),
"</p>"))
HTML(sprintf("<p align=\"right\">You are using <i>Conjuntool</i> on %s (commit sha: %s)",
unname(Sys.info()['nodename']),
commits$short_id[1]))
)
)
), # End README
......@@ -42,7 +46,10 @@ dashboardPage(
box(
title = "Input",
width = 3,
selectInput("var_filter_plot", "Select Variables", c("tas", "tasmax", "tasmin", "pr")),
selectInput("var_filter_plot", "Select Variables", c("tas", "tasmax", "tasmin", "pr", "prc")),
checkboxInput("convert_units_plot",
HTML("Convert <b>K</b> to <b>&#176;C</b> OR <b>kg&#8901;m<sup>-2</sup>&#8901;s<sup>-1</sup></b> to <b>mm</b>."),
TRUE),
singleModelSelectInput("plot_model_in", "Select Model"),
sliderInput("year_in", label = "Projection Period", min = 2006,
max = 2100, value = c(2011, 2100), step = 1,
......@@ -70,13 +77,16 @@ dashboardPage(
id = "tabset1", width = 3,
tabPanel("1: Def. params",
selectInput("var_filter", "Select Variables", c("tas", "tasmax", "tasmin", "pr", "prc")),
checkboxInput("convert_units",
HTML("Convert <b>K</b> to <b>&#176;C</b> OR <b>kg&#8901;m<sup>-2</sup>&#8901;s<sup>-1</sup></b> to <b>mm</b>."),
TRUE),
sliderInput("baseline_in", label = "Baseline", min = 1850,
max = 2015, value = c(1981, 2010), sep = "", ticks = FALSE),
HTML("<i>Note, model projections begin in 2005, so any baseline past that date will include \"climate change\".</i><br/><br/>"),
max = year(today()) - 1, value = c(1981, 2010), sep = "", ticks = FALSE),
HTML("<i>Model projections begin in 2005, so any baseline past that date will include climate change forcing.</i><br/><br/>"),
sliderInput("projection_in", label = "Projection Period", min = 2006,
max = 2100, value = c(2011, 2100), sep = "", ticks = FALSE),
HTML("<i>Note, the baseline can't be longer than the projections. This isn't controlled for presently in the code.</i> <br/><br/>"),
radioButtons("period_limits", "Limit Casting", choices = c("no limit" = "none", "hindcast only" = "hind", "forecast only" = "fore"), selected = NULL,
HTML("<i>The baseline can't be longer than the projections. Future periods will be defined based on the baseline length, i.e. if projection is the same length as the baseline, there will be one future period; if it is thrice as long, there will be three future periods.</i><br/><br/>"),
radioButtons("period_limits", "Limit Casting", choices = c("do not limit" = "none", "hindcast only" = "hind", "forecast only" = "fore"), selected = NULL,
inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL),
textInput("anom_city_in", "Location", value = "UTSC, Scarborough, ON", width = NULL, placeholder = NULL),
leafletOutput("anom_map", height = 200)
......@@ -98,7 +108,6 @@ dashboardPage(
tabPanel("5: Add. Opts.",
HTML("Use this tab to change the period of the analysis or to manipulate the final table.<br/><br/>"),
selectInput("anom_period_in", "Change Period of Analysis", c("Annual", "Seasonal", "Monthly")),
conditionalPanel("$('#anoms_out').hasClass('recalculating')", HTML('<i class="fas fa-circle-notch fa-spin"></i> <b>Recalculating</b><br/><br/>')),
uiOutput("anom_selected_periods"),
checkboxGroupInput("add_proc", "Additional Processing", list("Baseline Averages", "Calculate Anomalies", "Average Ensembles/Runs"), inline = FALSE),
HTML("<i>Note, some of the above options will only apply if you select multiple runs / scenarios from one model.</i> <br/><br/>")
......@@ -108,22 +117,15 @@ dashboardPage(
box(
width = 9,
status = "success",
conditionalPanel("$('#anoms_out').hasClass('recalculating')",
HTML('<p style="font-size:20px" align="right"><i class="fas fa-circle-notch fa-spin"></i> <b>Recalculating</b></p>')),
conditionalPanel("output.anoms_out", htmlOutput("anom_table_header")),
uiOutput("precip_anom_note"),
div(style = 'overflow-x: scroll', dataTableOutput("anoms_out")),
br(),
conditionalPanel("output.anoms_out", downloadButton("download_data", "Download this table")
)
)
),
fluidRow(
box(
width = 3,
title = "Debug Downloads",
collapsible = TRUE,
collapsed = TRUE,
downloadButton("download_input", "Download input settings"),
downloadButton("download_debug_meta", "Download file metadata"),
downloadButton("download_debug", "Download full ts")
conditionalPanel("output.anoms_out",
downloadButton("download_data", "Download this table"),
downloadButton("download_anom_ts", "Download full timeseries") )
)
)
), # End tab 2
......@@ -211,7 +213,15 @@ dashboardPage(
fluidRow(
box(width = 12,
includeMarkdown("include/source.md"),
uiOutput("source")
HTML(
paste0(
"<ul>",
paste0(
"<li>",
sprintf('<a href="https://gitlab.com/ConorIA/conjuntool/commit/%s" target="_blank">%s</a>: %s',
commits$short_id, commits$short_id, gsub("\\n", "", commits$title)), collapse = "</li>"),
"</li></ul>")
)
)
)
) # End tab 5
......