Nothing
#' Parse arguments
#'
#' @importFrom assertthat assert_that is.dir is.flag is.number is.readable is.string is.writeable
#'
#' @noRd
parse_arguments <- function(plot_type,
config = NULL,
variable = NULL,
accumulate = FALSE,
mean_value = FALSE,
infile = NULL,
temp_dir = tempdir(),
out_dir = getwd(),
climate_dir = NULL,
climate_year_start = 1983,
climate_year_end = 2018,
show_extreme_climate_years = NULL,
climatology_until_eoy = FALSE,
start_date = NULL,
end_date = NULL,
country_code = "S_A",
lon_min = NULL,
lon_max = NULL,
lat_min = NULL,
lat_max = NULL,
outfile_name = NULL,
output_format = "animation",
animation_pace = 0.07,
freeze_animation = FALSE,
min_value = NULL,
max_value = NULL,
color_pal = 1,
relative = FALSE,
nbreaks = NULL,
language = "eng",
keep_files = TRUE,
states = FALSE,
attach = FALSE,
infile_attach = "auto",
dwd_logo = FALSE,
verbose = TRUE,
nc = NULL) {
#### Deal with config ####
if (is.null(config)) {
configRead <- FALSE
} else {
assert_that(is.string(config))
assert_that(file.exists(normalizePath(config, mustWork = FALSE)))
assert_that(!is.dir(config))
assert_that(is.readable(config))
configParams <- yaml::read_yaml(config)
configRead <- TRUE
}
#### All non optional parameters (either direct argument pass or via config file) ####
#### infile ####
if (missing(infile) && missing(nc)) {
if (configRead) {
infile <- tryCatch(
configParams$infile,
error = function(cond) {
stop(
paste0(
"Can't read 'infile' from config file: ",
normalizePath(config)
)
)
}
)
}
if (!configRead || is.null(infile)) {
stop(c(
"Required argument 'infile' is missing.\n",
"Specify it directly or as 'nc' or in a config file."
))
}
}
if (is.null(nc)) {
assert_that(is.string(infile))
assert_that(file.exists(normalizePath(infile, mustWork = FALSE)))
assert_that(!is.dir(infile))
assert_that(is.readable(infile))
}
#TODO Add check on nc object too.
# Evaluate all default user values extractable from infile or nc
defaultValues <- getUserOptions(infile = infile, nc = nc)
#### Check all optional parameters ####
#### temp_dir ####
if (missing(temp_dir) && configRead) {
temp_dir_config <- tryCatch(
configParams$temp_dir,
error = function(cond) {
stop(paste0(
"Can't read 'temp_dir' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(temp_dir_config)) {
temp_dir <- temp_dir_config
}
}
assert_that(is.string(temp_dir))
assert_that(is.dir(temp_dir))
assert_that(dir.exists(temp_dir))
assert_that(is.writeable(temp_dir))
#### climate_dir ####
if (missing(climate_dir) && configRead) {
out_dir_config <- tryCatch(
configParams$climate_dir,
error = function(cond) {
stop(paste0(
"Can't read 'climate_dir' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(out_dir_config)) {
climate_dir <- out_dir_config
}
}
if (is.null(climate_dir)) {
climate_dir <- temp_dir
}
assert_that(is.string(climate_dir))
assert_that(is.dir(climate_dir))
assert_that(dir.exists(climate_dir))
assert_that(is.writeable(climate_dir))
#### out_dir ####
if (missing(out_dir) && configRead) {
out_dir_config <- tryCatch(
configParams$out_dir,
error = function(cond) {
stop(paste0(
"Can't read 'out_dir' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(out_dir_config)) {
out_dir <- out_dir_config
}
}
assert_that(is.string(out_dir))
assert_that(is.dir(out_dir))
assert_that(dir.exists(out_dir))
assert_that(is.writeable(out_dir))
#### climate_year_start ####
if (missing(climate_year_start) && configRead) {
climate_year_start_config <- tryCatch(
configParams$climate_year_start,
error = function(cond) {
stop(paste0(
"Can't read 'climate_year_start' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(climate_year_start_config)) {
climate_year_start <- climate_year_start_config
}
}
assert_that(is.number(climate_year_start))
#### climate_year_end ####
if (missing(climate_year_end) && configRead) {
climate_year_end_config <- tryCatch(
configParams$climate_year_end,
error = function(cond) {
stop(paste0(
"Can't read 'climate_year_end' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(climate_year_end_config)) {
climate_year_end <- climate_year_end_config
}
}
assert_that(is.number(climate_year_end))
assert_that(climate_year_start <= climate_year_end)
#### accumulate ####
if (missing(accumulate)) {
if (configRead) {
accumulate <- tryCatch(
configParams$accumulate,
error = function(cond) {
stop(paste0(
"Can't read 'accumulate' from config file: ",
normalizePath(config)
))
}
)
}
if (!configRead || is.null(accumulate)) {
accumulate <- FALSE
}
}
assert_that(is.flag(accumulate))
#### show_extreme_climate_years ####
if (missing(show_extreme_climate_years) && configRead) {
show_extreme_climate_years_config <- tryCatch(
configParams$show_extreme_climate_years,
error = function(cond) {
stop(paste0(
"Can't read 'show_extreme_climate_years' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(show_extreme_climate_years_config)) {
show_extreme_climate_years <- show_extreme_climate_years_config
}
}
if (is.null(show_extreme_climate_years)) {
show_extreme_climate_years <- accumulate
}
if (plot_type != "absolute_map") {
assert_that(is.flag(show_extreme_climate_years))
}
#### climatology_until_eoy ####
if (missing(climatology_until_eoy)) {
if (configRead) {
climatology_until_eoy <- tryCatch(
configParams$climatology_until_eoy,
error = function(cond) {
stop(paste0(
"Can't read 'climatology_until_eoy' from config file: ",
normalizePath(config)
))
}
)
}
if (!configRead || is.null(climatology_until_eoy)) {
climatology_until_eoy <- FALSE
}
}
assert_that(is.flag(climatology_until_eoy))
#### language ####
if (missing(language) && configRead) {
language_config <- tryCatch(
configParams$language,
error = function(cond) {
stop(paste0(
"Can't read 'language' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(language_config)) {
language <- language_config
}
}
assert_that(is.string(language))
assert_that(nchar(language) == 3)
assert_that(language %in% c("eng", "deu"))
#### animation_pace ####
if (missing(animation_pace) && configRead) {
animation_pace_config <- tryCatch(
configParams$animation_pace,
error = function(cond) {
stop(paste0(
"Can't read 'animation_pace' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(animation_pace_config)) {
animation_pace <- animation_pace_config
}
}
assert_that(is.number(animation_pace))
assert_that(animation_pace > 0)
#### freeze_animation ####
if (missing(freeze_animation) && configRead) {
freeze_animation_config <- tryCatch(
configParams$freeze_animation,
error = function(cond) {
stop(paste0(
"Can't read 'freeze_animation' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(freeze_animation_config)) {
freeze_animation <- freeze_animation_config
}
}
assert_that(is.flag(freeze_animation))
#### min_value ####
if (missing(min_value) && configRead) {
min_value_config <- tryCatch(
configParams$min_value,
error = function(cond) {
stop(paste0(
"Can't read 'min_value' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(min_value_config)) {
min_value <- min_value_config
}
}
assert_that(is.null(min_value) || is.number(min_value))
#### max_value ####
if (missing(max_value) && configRead) {
max_value_config <- tryCatch(
configParams$max_value,
error = function(cond) {
stop(paste0(
"Can't read 'max_value' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(max_value_config)) {
max_value <- max_value_config
}
}
assert_that(is.null(max_value) || is.number(max_value))
if (is.number(min_value) && is.number(max_value)) {
assert_that(min_value <= max_value)
}
#### color_pal ####
if (missing(color_pal) && configRead) {
color_pal_config <- tryCatch(
configParams$color_pal,
error = function(cond) {
stop(paste0(
"Can't read 'color_pal' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(color_pal_config)) {
color_pal <- color_pal_config
}
}
assert_that(is.number(color_pal))
#### relative ####
if (missing(relative) && configRead) {
relative_config <- tryCatch(
configParams$relative,
error = function(cond) {
stop(paste0(
"Can't read 'relative' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(relative_config)) {
relative <- relative_config
}
}
assert_that(is.logical(relative))
#### nbreaks ####
if (missing(nbreaks) && configRead) {
nbreaks_config <- tryCatch(
configParams$nbreaks,
error = function(cond) {
stop(paste0(
"Can't read 'nbreaks' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(nbreaks_config)) {
nbreaks <- nbreaks_config
}
}
assert_that(is.null(nbreaks) || (is.numeric(nbreaks) && nbreaks > 0))
if (is.numeric(nbreaks)) {
nbreaks <- as.integer(nbreaks)
assert_that(is.integer(nbreaks))
}
#### variable ####
if (missing(variable)) {
if (configRead) {
variable <- tryCatch(
configParams$variable,
error = function(cond) {
stop(paste0(
"Can't read 'variable' from config file: ",
normalizePath(config)
))
}
)
}
if (!configRead || is.null(variable)) {
variable <- defaultValues$variables[1]
}
}
assert_that(is.string(variable))
if (!(variable %in% defaultValues$variables)) {
if (!is.null(nc)) stop(paste0("The given nc object does not contain the variable ", variable, "."))
else stop(paste0("The given infile ", infile, " does not contain the variable ", variable, "."))
}
#### keep_files ####
if (missing(keep_files)) {
if (configRead) {
keep_files <- tryCatch(
configParams$keep_files,
error = function(cond) {
stop(paste0(
"Can't read 'keep_files' from config file: ",
normalizePath(config)
))
}
)
}
if (!configRead || is.null(keep_files)) {
keep_files <- TRUE
}
}
assert_that(is.flag(keep_files))
#### country_code ####
if (missing(country_code)) {
if (configRead) {
country_code_config <- tryCatch(
configParams$country_code,
error = function(cond) {
stop(paste0(
"Can't read 'country_code' from config file: ",
normalizePath(config)
))
}
)
}
if (!is.null(country_code_config)) {
country_code <- country_code_config
}
}
assert_that(is.string(country_code))
assert_that(is.upper(country_code))
assert_that(nchar(country_code) == 3)
assert_that(is_valid_regioncode(country_code))
#### lon_min ####
if (missing(lon_min)) {
if (configRead) {
lon_min <- tryCatch(
configParams$lon_min,
error = function(cond) {
stop(
paste0(
"Can't read 'lon_min' from config file: ",
normalizePath(config)
)
)
}
)
}
}
if (is.null(lon_min)) {
lon_min <- defaultValues$lon_range[1]
}
assert_that(is.number(lon_min))
#### lon_max ####
if (missing(lon_max)) {
if (configRead) {
lon_max <- tryCatch(
configParams$lon_max,
error = function(cond) {
stop(
paste0(
"Can't read 'lon_max' from config file: ",
normalizePath(config)
)
)
}
)
}
}
if (is.null(lon_max)) {
lon_max <- defaultValues$lon_range[2]
}
assert_that(is.number(lon_max))
assert_that(lon_max >= lon_min)
assert_that(lon_max <= 180)
assert_that(lon_min >= -180)
#### lat_min ####
if (missing(lat_min)) {
if (configRead) {
lat_min <- tryCatch(
configParams$lat_min,
error = function(cond) {
stop(
paste0(
"Can't read 'lat_min' from config file: ",
normalizePath(config)
)
)
}
)
}
}
if (is.null(lat_min)) {
lat_min <- defaultValues$lat_range[1]
}
assert_that(is.number(lat_min))
#### lat_max ####
if (missing(lat_max)) {
if (configRead) {
lat_max <- tryCatch(
configParams$lat_max,
error = function(cond) {
stop(
paste0(
"Can't read 'lat_max' from config file: ",
normalizePath(config)
)
)
}
)
}
}
if (is.null(lat_max)) {
lat_max <- defaultValues$lat_range[2]
}
assert_that(is.number(lat_max))
assert_that(lat_max >= lat_min)
assert_that(lat_max <= 90)
assert_that(lat_min >= -90)
# If country code continental, get coordinates
if (country_code %in% c("AFR", "EUR", "TOT")) {
if (verbose) {
message(paste0("Overwriting longitude and latitude range according to country code: ", country_code, "."))
}
area <- get_continental_coordinates(country_code)
lon_min <- area$lon_min
lon_max <- area$lon_max
lat_min <- area$lat_min
lat_max <- area$lat_max
}
#### start_date ####
if (missing(start_date)) {
if (configRead) {
start_date <- tryCatch(
configParams$start_date,
error = function(cond) {
stop(paste0(
"Couldn't read 'start_date' from config file: ",
normalizePath(config)
))
}
)
}
if (!configRead || is.null(start_date)) {
start_date <- defaultValues$time_range[1]
}
}
# Accept a date or parse a string.
assert_that(is.date(start_date) || is.string(start_date))
if (is.character(start_date)) {
start_date <- as.Date(start_date)
}
#### end_date ####
if (missing(end_date)) {
if (configRead) {
end_date <- tryCatch(
configParams$end_date,
error = function(cond) {
stop(paste0(
"Can't read 'end_date' from config file: ",
normalizePath(config)
))
}
)
}
if (!configRead || is.null(end_date)) {
end_date <- defaultValues$time_range[2]
}
}
# Accept a date or parse a string.
assert_that(is.date(end_date) || is.string(end_date))
if (is.character(end_date)) {
end_date <- as.Date(end_date)
}
if(plot_type %in% c("warming_stripes_plot", "time_series_plot", "trend_plot")){
assert_that(end_date >= start_date)
start_year <- format(start_date, "%Y")
end_year <- format(end_date, "%Y")
}else{
assert_that(end_date >= start_date)
start_year <- format(start_date, "%Y")
end_year <- format(end_date, "%Y")
assert_that(start_year == end_year,
msg = "Year of start_date not equal to year of end_date")
}
if (!(accumulate || mean_value)) {
if (output_format == "graphic") {
if (start_date != end_date) {
if (plot_type != "fieldmean_plot") {
if(!(plot_type %in% c("warming_stripes_plot", "time_series_plot", "trend_plot"))){
stop("You are trying to create a multi-day graphic of non accumulated data. This is not allowed. Either accumulate the data or chose start_date equal to end_date.")
}
}
}
}
}
# Leap year check
start_doy <- as.numeric(format(start_date, format = "%j"))
finish_doy <- as.numeric(format(end_date, format = "%j"))
if (is_leap_year(start_year)) {
if (start_doy == 60 && finish_doy == 60) {
stop("You chose to only analyze a leap year date but these dates are removed in this operator. Please choose another time range.")
}
if (start_doy == 60) {
warning("Leap year dates are removed in this operator. The given start date will be adjusted to March first.")
start_date <- start_date + 1
}
if (finish_doy == 60) {
warning("Leap year dates are removed in this operator. The given end date will be adjusted to February 28th.")
end_date <- end_date - 1
}
}
#### states ####
if (missing(states)) {
if (configRead) {
states <- tryCatch(
configParams$states,
error = function(cond) {
stop(paste0(
"Can't read 'states' from config file: ",
normalizePath(config)
))
}
)
}
if (!configRead || is.null(states)) {
states <- FALSE
}
}
assert_that(is.flag(states))
if (states && !is_country(country_code)) {
stop(
"State borders can only be plotted for countries.\n",
"Either set \"states = FALSE\" or set \"country_code\" to that of a country."
)
}
#### dwd_logo ####
if (missing(dwd_logo)) {
if (configRead) {
dwd_logo <- tryCatch(
configParams$states,
error = function(cond) {
stop(paste0(
"Can't read 'dwd_logo' from config file: ",
normalizePath(config)
))
}
)
}
if (!configRead || is.null(dwd_logo)) {
dwd_logo <- FALSE
}
}
assert_that(is.flag(dwd_logo))
#### verbose ####
if (missing(verbose)) {
if (configRead) {
verbose <- tryCatch(
configParams$verbose,
error = function(cond) {
stop(paste0(
"Can't read 'verbose' from config file: ",
normalizePath(config)
))
}
)
}
if (!configRead || is.null(verbose)) {
verbose <- TRUE
}
}
assert_that(is.flag(verbose))
#### output_format ####
if (missing(output_format)) {
if (configRead) {
config_output_format <- tryCatch(
configParams$output_format,
error = function(cond) {
stop(paste0(
"Can't read 'output_format' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(config_output_format)) {
output_format <- config_output_format
}
}
}
assert_that(is.string(output_format))
assert_that(output_format %in% c("graphic", "animation"))
#### outfile_name ####
if (missing(outfile_name)) {
if (configRead) {
outfile_name_config <- tryCatch(
configParams$outfile_name,
error = function(cond) {
stop(paste0(
"Can't read 'outfile_name' from config file: ",
normalizePath(config)
))
}
)
if (!is.null(outfile_name_config)) {
outfile_name <- outfile_name_config
}
}
}
# Build outfile_name from params
if (is.null(outfile_name)) {
outfile_name <- default_out_name(
output_format = output_format,
plot_type = plot_type,
variable = variable,
country_code = country_code,
start_date = start_date,
end_date = end_date,
climate_year_start = climate_year_start,
climate_year_end = climate_year_end,
language = language
)
}
assert_that(is.character(outfile_name))
if (output_format == "animation") {
if (!endsWith(outfile_name, ".mp4")) {
outfile_name <- add_video_ext(outfile_name)
}
} else {
if (!endsWith(outfile_name, ".png")) {
outfile_name <- add_image_ext(outfile_name)
}
}
# Check consistency
if (output_format == "graphic") {
if (!(accumulate || mean_value)) {
if (start_date != end_date) {
if (!(plot_type %in% c("fieldmean_plot", "warming_stripes_plot", "time_series_plot", "trend_plot")))
stop("Creating graphics of non-accumulated data can only be done for a single day! Please choose start_date == end_date or select output_format = animation.")
}
}
}
if (attach) {
tryCatch({
#TODO Is it possible to get attach to work with an nc input as well?
if (!is.null(nc)) stop("'infile' must be provided instead of 'nc' to use the attach option")
first_day_in <- substr(basename(infile), 5, 14)
last_day_in <- substr(basename(infile), 16, 25)
if (infile_attach == "auto") {
first_day_attach <- format(paste(climate_year_start, "01", "01", sep = "-"))
last_day_attach <- as.character(as.Date(first_day_in) - 1)
infile_attach <- add_ncdf_ext(
construct_filename(
variable,
paste0(first_day_attach, "-", last_day_attach)
)
)
if (!file.exists(infile_attach)) {
stop("No unambiguous file to attach to")
}
} else {
first_day_attach <- substr(basename(infile_attach), 5, 14)
last_day_attach <- substr(basename(infile_attach), 16, 25)
}
}, error = function(cond) {
stop(paste("Could not find a file to attach the data to.
Maybe the file does not have a canonical filename."))
})
new_infile <- add_ncdf_ext(
construct_filename(
variable,
paste(first_day_attach, last_day_in, sep = "-")
)
)
new_infile <- file.path(temp_dir, new_infile)
} else {
new_infile <- infile
}
result <- list(
variable = variable,
accumulate = accumulate,
mean_value = mean_value,
temp_dir = temp_dir,
infile = infile,
climate_dir = climate_dir,
climate_year_start = climate_year_start,
climate_year_end = climate_year_end,
show_extreme_climate_years = show_extreme_climate_years,
climatology_until_eoy = climatology_until_eoy,
country_code = country_code,
out_dir = out_dir,
lon_min = lon_min,
lon_max = lon_max,
lat_min = lat_min,
lat_max = lat_max,
start_date = start_date,
end_date = end_date,
language = language,
animation_pace = animation_pace,
output_format = output_format,
min_value = min_value,
max_value = max_value,
color_pal = color_pal,
relative = relative,
nbreaks = nbreaks,
freeze_animation = freeze_animation,
outfile_name = outfile_name,
keep_files = keep_files,
states = states,
attach = attach,
infile_attach = infile_attach,
new_infile = new_infile,
dwd_logo = dwd_logo,
verbose = verbose,
nc = nc
)
if (verbose) {
original_options <- options(useFancyQuotes = FALSE)
result_output <- result
for (i in seq_along(result_output)) {
current <- result_output[[i]]
if (assertthat::is.date(current)) {
current <- as.character(current)
}
if (is.character(current)) {
result_output[[i]] <- sQuote(current)
}
}
options(original_options)
message(
paste(
"Using the following arguments:",
paste(names(result), result_output, sep = "=", collapse = ", ")
)
)
}
return(result)
}
default_out_name <- function(output_format,
plot_type,
variable,
country_code,
start_date,
end_date,
climate_year_start = NULL,
climate_year_end = NULL,
language) {
if (plot_type == "climatology_map") {
# Compute some parameters from arguments
start_date_short <- format(start_date, "%m%d")
end_date_short <- format(end_date, "%m%d")
# climatology has different style
formattedTimeRange <- paste0(climate_year_start, "-", climate_year_end, "_", start_date_short, "-", end_date_short)
} else {
# absolute, anomaly, fieldmean, fieldmean_and_anomaly
formattedTimeRange <- paste0(format(start_date, "%Y%m%d"), "-", format(end_date, "%Y%m%d"))
}
if (output_format == "graphic") {
return(
add_image_ext(
construct_filename(
variable,
plot_type,
country_code,
formattedTimeRange,
language
)
)
)
} else {
return(
add_video_ext(
construct_filename(
variable,
plot_type,
country_code,
formattedTimeRange,
language
)
)
)
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.