From a996487a47921ff67dc346c75ef86a8120eed877 Mon Sep 17 00:00:00 2001 From: vagudets Date: Fri, 13 Sep 2024 15:04:23 +0200 Subject: [PATCH 1/8] remove trailing whitespace --- modules/Aggregation/Aggregation.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/Aggregation/Aggregation.R b/modules/Aggregation/Aggregation.R index d5c09fac..e4cc6b97 100644 --- a/modules/Aggregation/Aggregation.R +++ b/modules/Aggregation/Aggregation.R @@ -36,7 +36,7 @@ Aggregation <- function(recipe, data) { } else { result <- data[x] }}, simplify = TRUE) - } + } } else if (!is.null(custom)) { # calCUlate aggregations from fmonth1 to ftmonth2 # for decadal, it makes sense to get all seasons and annual means too -- GitLab From 65b82a7a431ad558124d7db5e1a4460f84579a5c Mon Sep 17 00:00:00 2001 From: vagudets Date: Fri, 13 Sep 2024 15:04:40 +0200 Subject: [PATCH 2/8] formatting --- modules/Aggregation/R/agg_ini_end.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/Aggregation/R/agg_ini_end.R b/modules/Aggregation/R/agg_ini_end.R index 563745bd..bb3a410a 100644 --- a/modules/Aggregation/R/agg_ini_end.R +++ b/modules/Aggregation/R/agg_ini_end.R @@ -3,7 +3,7 @@ agg_ini_end <- function(x, ini, end, indices = NULL, method, na.rm ,ncores) { if (!is.null(ini) && is.null(indices)) { # list of vectors for the indices from ini to end pairs indices <- lapply(1:length(ini), function(x) { - ini[x]:end[x]}) + ini[x]:end[x]}) plotting_attr <- list(ini_ftime = ini, end_ftime = end) } else { # take the first and last element of each indices list for time_bounds saving -- GitLab From 70789ce2269eaa2c97d29cc969a4cfb587d90321 Mon Sep 17 00:00:00 2001 From: vagudets Date: Fri, 13 Sep 2024 15:24:20 +0200 Subject: [PATCH 3/8] Fix errors in code logic and improve plot title by differentiating years for aggregated data --- modules/Visualization/R/plot_ensemble_mean.R | 52 ++++---- .../R/plot_most_likely_terciles_map.R | 112 +++++++++--------- 2 files changed, 89 insertions(+), 75 deletions(-) diff --git a/modules/Visualization/R/plot_ensemble_mean.R b/modules/Visualization/R/plot_ensemble_mean.R index 19521f7d..28277528 100644 --- a/modules/Visualization/R/plot_ensemble_mean.R +++ b/modules/Visualization/R/plot_ensemble_mean.R @@ -114,26 +114,23 @@ plot_ensemble_mean <- function(recipe, fcst, mask = NULL, dots = NULL, outdir, o var_dots <- as.numeric(var_dots <= 0) dim(var_dots) <- dim_dots } - if (tolower(recipe$Analysis$Horizon) == "subseasonal") { - toptitle <- paste0(system_name, " / ", str_to_title(var_long_name), - "\n", "Forecast Ensemble Mean / ", "Issued on ", - format(ymd(start_date), "%d-%m-%Y")) - } else { - toptitle <- paste0(system_name, " / ", str_to_title(var_long_name), - "\n", "Forecast Ensemble Mean / ", "Init.: ", i_syear) - } + + ## TODO: Create a function + years <- lubridate::year(fcst$attrs$Dates[1, 1, which(start_date == i_syear), ]) if (is.null(attributes(fcst$attrs$time_bounds))) { - if (tolower(recipe$Analysis$Horizon) %in% c("seasonal", "decadal")) { + if (tolower(recipe$Analysis$Horizon == "subseasonal")) { + time_labels <- fcst$attrs$Dates[1, 1, which(start_date == i_syear), ] + monday <- ymd_hms(time_labels) - days(wday(ymd_hms(time_labels), week_start = 1) - 1) + sunday <- monday + days(6) + time_labels <- paste0("Valid from ", format(monday,"%d-%m"), " to ", + format(sunday, "%d-%m")) + } else { time_labels <- lubridate::month(fcst$attrs$Dates[1, 1, which(start_date == i_syear), ], label = T, abb = F) - } else if (tolower(recipe$Analysis$Horizon) == "subseasonal") { - time_labels <- fcst$attrs$Dates[1, 1, which(start_date == i_syear), ] - monday <- ymd_hms(time_labels) - days(wday(ymd_hms(time_labels), week_start = 1) - 1) - sunday <- monday + days(6) - time_labels <- paste0("Valid from ", format(monday,"%d-%m"), " to ", format(sunday, "%d-%m")) } } else { if (length(attributes(fcst$attrs$time_bounds)$plotting_attr) > 1) { + years <- NULL time_labels <- unlist(lapply(1:length(fcst$attrs$time_bounds$start), function(i) { ftime_ini <- attributes(fcst$attrs$time_bounds)$plotting_attr$ini[i] @@ -142,13 +139,17 @@ plot_ensemble_mean <- function(recipe, fcst, mask = NULL, dots = NULL, outdir, o ftime <- paste0(ftime_ini, "-", ftime_end) # title names: if (tolower(recipe$Analysis$Horizon) == "seasonal") { - ftime_ini <- init_date + ftime_ini - 1 - ftime_ini <- ifelse(ftime_ini > 12, ftime_ini - 12, ftime_ini) - ftime_ini <- month.name[ftime_ini] - ftime_end <- init_date + ftime_end - 1 - ftime_end <- ifelse(ftime_end > 12, ftime_end - 12, ftime_end) - ftime_end <- month.name[ftime_end] - toptitle <- paste(ftime_ini, "to", ftime_end) + year_ini <- year(fcst$attrs$time_bounds$start[i]) + month_ini <- month.name[month(fcst$attrs$time_bounds$start[i])] + year_end <- year(fcst$attrs$time_bounds$end[i]) + month_end <- month.name[month(fcst$attrs$time_bounds$end[i])] + ## TODO: Rename 'toptitle'? + if (year_ini == year_end) { + toptitle <- paste(month_ini, "to", month_end, year_end) + } else { + toptitle <- paste(month_ini, year_ini, "to", + month_end, year_end) + } } else if (tolower(recipe$Analysis$Horizon) == "subseasonal") { ## set to make ftime_ini be a Monday ## if init_week always Thursday, the 2nd addend can be simplified to +4 @@ -166,7 +167,6 @@ plot_ensemble_mean <- function(recipe, fcst, mask = NULL, dots = NULL, outdir, o time_labels <- attributes(fcst$attrs$time_bounds)$plotting_attr[[1]] } } - years <- lubridate::year(fcst$attrs$Dates[1, 1, which(start_date == i_syear), ]) if (recipe$Analysis$Workflow$Visualization$multi_panel) { # Define name of output file and titles @@ -175,6 +175,14 @@ plot_ensemble_mean <- function(recipe, fcst, mask = NULL, dots = NULL, outdir, o } else { titles <- NULL } + if (tolower(recipe$Analysis$Horizon) == "subseasonal") { + toptitle <- paste0(system_name, " / ", str_to_title(var_long_name), + "\n", "Forecast Ensemble Mean / ", "Issued on ", + format(ymd(start_date), "%d-%m-%Y")) + } else { + toptitle <- paste0(system_name, " / ", str_to_title(var_long_name), + "\n", "Forecast Ensemble Mean / ", "Init.: ", i_syear) + } # Plots output_configuration <- output_conf$Multipanel$forecast_ensemble_mean base_args <- list(fun = "PlotEquiMap", diff --git a/modules/Visualization/R/plot_most_likely_terciles_map.R b/modules/Visualization/R/plot_most_likely_terciles_map.R index 3787a1a9..a33a1bd9 100644 --- a/modules/Visualization/R/plot_most_likely_terciles_map.R +++ b/modules/Visualization/R/plot_most_likely_terciles_map.R @@ -122,68 +122,73 @@ plot_most_likely_terciles <- function(recipe, } else { var_dots <- NULL } - # Define top title: system name, variable, forecast date - if (tolower(recipe$Analysis$Horizon) == "subseasonal") { - toptitle <- paste0(system_name, " / ", str_to_title(var_long_name), - "\n", "Most Likely Tercile / ", "Issued on ", - format(ymd(start_date), "%d-%m-%Y")) - } else { - toptitle <- paste0(system_name, " / ", str_to_title(var_long_name), - "\n", "Most Likely Tercile / ", "Initialization: ", - i_syear) - } + # Define labels for forecast times - if (tolower(recipe$Analysis$Horizon == "subseasonal")) { - ## TODO: time_bounds case for subseasonal data - time_labels <- fcst$attrs$Dates[1, 1, which(start_date == i_syear), ] - monday <- ymd_hms(time_labels) - days(wday(ymd_hms(time_labels), week_start = 1) - 1) - sunday <- monday + days(6) - time_labels <- paste0("Valid from ", format(monday,"%d-%m"), " to ", format(sunday, "%d-%m")) - } else { - if (is.null(attributes(fcst$attrs$time_bounds))) { - ## TODO: Does this need to be redefined for subseasonal? + years <- lubridate::year(fcst$attrs$Dates[1, 1, which(start_date == i_syear), ]) + if (is.null(attributes(fcst$attrs$time_bounds))) { + if (tolower(recipe$Analysis$Horizon == "subseasonal")) { + time_labels <- fcst$attrs$Dates[1, 1, which(start_date == i_syear), ] + monday <- ymd_hms(time_labels) - days(wday(ymd_hms(time_labels), week_start = 1) - 1) + sunday <- monday + days(6) + time_labels <- paste0("Valid from ", format(monday,"%d-%m"), " to ", + format(sunday, "%d-%m")) + } else { time_labels <- lubridate::month(fcst$attrs$Dates[1, 1, which(start_date == i_syear), ], label = T, abb = F) + } + } else { + if (length(attributes(fcst$attrs$time_bounds)$plotting_attr) > 1) { + years <- NULL + time_labels <- + unlist(lapply(1:length(fcst$attrs$time_bounds$start), function(i) { + ftime_ini <- attributes(fcst$attrs$time_bounds)$plotting_attr$ini[i] + ftime_end <- attributes(fcst$attrs$time_bounds)$plotting_attr$end[i] + # labels for file name: + ftime <- paste0(ftime_ini, "-", ftime_end) + # title names: + if (tolower(recipe$Analysis$Horizon) == "seasonal") { + year_ini <- year(fcst$attrs$time_bounds$start[i]) + month_ini <- month.name[month(fcst$attrs$time_bounds$start[i])] + year_end <- year(fcst$attrs$time_bounds$end[i]) + month_end <- month.name[month(fcst$attrs$time_bounds$end[i])] + ## TODO: Rename 'toptitle'? + if (year_ini == year_end) { + toptitle <- paste(month_ini, "to", month_end, year_end) + } else { + toptitle <- paste(month_ini, year_ini, "to", + month_end, year_end) + } + } else if (tolower(recipe$Analysis$Horizon) == "subseasonal") { + ## set to make ftime_ini be a Monday + ## if init_date always Thursday, the 2nd addend can be simplified to +4 + ftime_ini <- ymd(init_date) + + ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + + weeks(ftime_ini) + ## set to make ftime_end be a Sunday + ftime_end <- ymd(init_date) + + ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + + weeks(ftime_end) + 6 + toptitle <- paste("Valid from", ftime_ini, "to", ftime_end) + } + })) } else { - if (length(attributes(fcst$attrs$time_bounds)$plotting_attr) > 1) { - time_labels <- - unlist(lapply(1:length(fcst$attrs$time_bounds$start), function(i) { - ftime_ini <- attributes(fcst$attrs$time_bounds)$plotting_attr$ini[i] - ftime_end <- attributes(fcst$attrs$time_bounds)$plotting_attr$end[i] - # labels for file name: - ftime <- paste0(ftime_ini, "-", ftime_end) - # title names: - if (tolower(recipe$Analysis$Horizon) == "seasonal") { - ftime_ini <- init_date + ftime_ini - 1 - ftime_ini <- ifelse(ftime_ini > 12, ftime_ini - 12, ftime_ini) - ftime_ini <- month.name[ftime_ini] - ftime_end <- init_date + ftime_end - 1 - ftime_end <- ifelse(ftime_end > 12, ftime_end - 12, ftime_end) - ftime_end <- month.name[ftime_end] - toptitle <- paste(ftime_ini, "to", ftime_end) - } else if (tolower(recipe$Analysis$Horizon) == "subseasonal") { - ## set to make ftime_ini be a Monday - ## if init_date always Thursday, the 2nd addend can be simplified to +4 - ftime_ini <- ymd(init_date) + - ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + - weeks(ftime_ini) - ## set to make ftime_end be a Sunday - ftime_end <- ymd(init_date) + - ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + - weeks(ftime_end) + 6 - toptitle <- paste("Valid from", ftime_ini, "to", ftime_end) - } - })) - } else { - time_labels <- attributes(fcst$attrs$time_bounds)$plotting_attr[[1]] - } + time_labels <- attributes(fcst$attrs$time_bounds)$plotting_attr[[1]] } } - years <- lubridate::year(fcst$attrs$Dates[1, 1, which(start_date == i_syear), ]) if (recipe$Analysis$Workflow$Visualization$multi_panel) { ## TODO: Ensure this works for daily and sub-daily cases titles <- as.vector(time_labels) + # Define top title: system name, variable, forecast date + if (tolower(recipe$Analysis$Horizon) == "subseasonal") { + toptitle <- paste0(system_name, " / ", str_to_title(var_long_name), + "\n", "Most Likely Tercile / ", "Issued on ", + format(ymd(start_date), "%d-%m-%Y")) + } else { + toptitle <- paste0(system_name, " / ", str_to_title(var_long_name), + "\n", "Most Likely Tercile / ", "Initialization: ", + i_syear) + } # Plots ## NOTE: PlotLayout() and PlotMostLikelyQuantileMap() are still being worked ## on. This option does not work with mask or dots for now. @@ -247,7 +252,8 @@ plot_most_likely_terciles <- function(recipe, forecast_time <- sprintf("%02d", forecast_time) } else { ## TODO: Check this - forecast_time <- sprintf("%02d", time_labels[i]) + # forecast_time <- sprintf("%02d", time_labels[i]) + forecast_time <- time_labels[i] } } else if (tolower(recipe$Analysis$Horizon) == "subseasonal") { forecast_time <- sprintf("%02d", i) -- GitLab From e023fb284ab87adcbfc0aaeb2a9f48535c38bb85 Mon Sep 17 00:00:00 2001 From: vagudets Date: Fri, 13 Sep 2024 15:31:50 +0200 Subject: [PATCH 4/8] Fix bug, add TODO --- modules/Visualization/R/plot_metrics.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/modules/Visualization/R/plot_metrics.R b/modules/Visualization/R/plot_metrics.R index 8904ed57..6ffddafc 100644 --- a/modules/Visualization/R/plot_metrics.R +++ b/modules/Visualization/R/plot_metrics.R @@ -328,11 +328,13 @@ plot_metrics <- function(recipe, data_cube, metrics, # labels for file name: forecast_time <- paste0(forecast_time_ini, "-", forecast_time_end) # title names: + ## TODO: There's probably a better way to do this, like using + ## time_bounds$start and time_bounds$end directly. forecast_time_ini <- init_month + forecast_time_ini - 1 forecat_time_ini <- ifelse(forecast_time_ini > 12, forecast_time_ini - 12, forecast_time_ini) forecast_time_ini <- month.name[forecast_time_ini] forecast_time_end <- init_month + forecast_time_end - 1 - forecat_time_end <- ifelse(forecast_time_end > 12, forecast_time_end - 12, forecast_time_end) + forecast_time_end <- ifelse(forecast_time_end > 12, forecast_time_end - 12, forecast_time_end) forecast_time_end <- month.name[forecast_time_end] toptitle <- paste(system_name, "/", str_to_title(var_long_name), -- GitLab From dab29dacbfb78cf8f5415c085dc043891de764a6 Mon Sep 17 00:00:00 2001 From: vagudets Date: Fri, 13 Sep 2024 16:34:27 +0200 Subject: [PATCH 5/8] Improve subseasonal forecast plot titles when they span different years (WIP) --- modules/Visualization/R/plot_ensemble_mean.R | 6 +++--- modules/Visualization/R/plot_most_likely_terciles_map.R | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/modules/Visualization/R/plot_ensemble_mean.R b/modules/Visualization/R/plot_ensemble_mean.R index 28277528..7e73b187 100644 --- a/modules/Visualization/R/plot_ensemble_mean.R +++ b/modules/Visualization/R/plot_ensemble_mean.R @@ -123,7 +123,7 @@ plot_ensemble_mean <- function(recipe, fcst, mask = NULL, dots = NULL, outdir, o monday <- ymd_hms(time_labels) - days(wday(ymd_hms(time_labels), week_start = 1) - 1) sunday <- monday + days(6) time_labels <- paste0("Valid from ", format(monday,"%d-%m"), " to ", - format(sunday, "%d-%m")) + format(sunday, "%d-%m"), " of ") } else { time_labels <- lubridate::month(fcst$attrs$Dates[1, 1, which(start_date == i_syear), ], label = T, abb = F) @@ -157,7 +157,7 @@ plot_ensemble_mean <- function(recipe, fcst, mask = NULL, dots = NULL, outdir, o ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + weeks(ftime_ini) ## set to make ftime_end be a Sunday - ftime_end <- ymd(init_week) + + ftime_end <- ymd(init_date) + ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + weeks(ftime_end) + 6 toptitle <- paste("Valid from", ftime_ini, "to", ftime_end) @@ -254,7 +254,7 @@ plot_ensemble_mean <- function(recipe, fcst, mask = NULL, dots = NULL, outdir, o "\n", "Ensemble Mean / ", "Issued on ", format(ymd(start_date), "%d-%m-%Y"), - "\n", time_labels[i], " of ", years[i]) + "\n", time_labels[i], years[i]) } else { toptitle <- paste0(system_name, " / ", str_to_title(var_long_name), diff --git a/modules/Visualization/R/plot_most_likely_terciles_map.R b/modules/Visualization/R/plot_most_likely_terciles_map.R index a33a1bd9..2e1dccfb 100644 --- a/modules/Visualization/R/plot_most_likely_terciles_map.R +++ b/modules/Visualization/R/plot_most_likely_terciles_map.R @@ -131,7 +131,7 @@ plot_most_likely_terciles <- function(recipe, monday <- ymd_hms(time_labels) - days(wday(ymd_hms(time_labels), week_start = 1) - 1) sunday <- monday + days(6) time_labels <- paste0("Valid from ", format(monday,"%d-%m"), " to ", - format(sunday, "%d-%m")) + format(sunday, "%d-%m"), " of ") } else { time_labels <- lubridate::month(fcst$attrs$Dates[1, 1, which(start_date == i_syear), ], label = T, abb = F) @@ -288,7 +288,7 @@ plot_most_likely_terciles <- function(recipe, "\n", "Most Likely Tercile / ", "Issued on ", format(ymd(start_date), "%d-%m-%Y"), - "\n", time_labels[i], " of ", years[i]) + "\n", time_labels[i], years[i]) } else { toptitle <- paste0(system_name, " / ", str_to_title(var_long_name), -- GitLab From acd9d35c3426efd5882418cabd495fb1c0a550c0 Mon Sep 17 00:00:00 2001 From: vagudets Date: Mon, 16 Sep 2024 11:10:52 +0200 Subject: [PATCH 6/8] Create function get_plot_time_labels() to refactor forecast plotting code --- .../Visualization/R/get_plot_time_labels.R | 66 +++++++++++++++++++ modules/Visualization/R/plot_ensemble_mean.R | 61 +++-------------- .../R/plot_most_likely_terciles_map.R | 61 +++-------------- modules/Visualization/Visualization.R | 1 + 4 files changed, 85 insertions(+), 104 deletions(-) create mode 100644 modules/Visualization/R/get_plot_time_labels.R diff --git a/modules/Visualization/R/get_plot_time_labels.R b/modules/Visualization/R/get_plot_time_labels.R new file mode 100644 index 00000000..c02c752a --- /dev/null +++ b/modules/Visualization/R/get_plot_time_labels.R @@ -0,0 +1,66 @@ +# This function returns the day, month and year labels for forecast plots. +# If the data is time-aggregated (time_bounds is not NULL); then the time +# labels reflect the aggregated period, and will include the years to avoid +# displaying incorrect or repetitive information. +# dates: the array of POSIXt Dates in the s2dv_cube +# horizon: The forecast horizon: 'subseasonal', 'seasonal' or 'decadal'. +# init_date: Initialization date as POSIXt object +# start_date: start date +# i_syear: The forecast year +# time_bounds: the array of POSIXt time_bounds from the s2dv_cube + +.get_plot_time_labels <- function(dates, horizon, init_date, start_date, + i_syear, time_bounds = NULL) { + years <- lubridate::year(dates[1, 1, which(start_date == i_syear), ]) + if (is.null(attributes(time_bounds))) { + if (horizon == "subseasonal") { + time_labels <- dates[1, 1, which(start_date == i_syear), ] + monday <- ymd_hms(time_labels) - days(wday(ymd_hms(time_labels), + week_start = 1) - 1) + sunday <- monday + days(6) + time_labels <- paste0("Valid from ", format(monday,"%d-%m"), " to ", + format(sunday, "%d-%m"), " of ") + } else { + time_labels <- lubridate::month(dates[1, 1, which(start_date == i_syear), ], + label = T, abb = F) + } + } else { + if (length(attributes(time_bounds)$plotting_attr) > 1) { + years <- NULL + time_labels <- + unlist(lapply(1:length(time_bounds$start), function(i) { + ftime_ini <- attributes(time_bounds)$plotting_attr$ini[i] + ftime_end <- attributes(time_bounds)$plotting_attr$end[i] + # labels for file name: + ftime <- paste0(ftime_ini, "-", ftime_end) + # title names: + if (horizon == "seasonal") { + year_ini <- year(time_bounds$start[i]) + month_ini <- month.name[month(time_bounds$start[i])] + year_end <- year(time_bounds$end[i]) + month_end <- month.name[month(time_bounds$end[i])] + if (year_ini == year_end) { + toptitle <- paste(month_ini, "to", month_end, year_end) + } else { + toptitle <- paste(month_ini, year_ini, "to", + month_end, year_end) + } + } else if (horizon == "subseasonal") { + ## set to make ftime_ini be a Monday + ## if init_week always Thursday, the 2nd addend can be simplified to +4 + ftime_ini <- ymd(init_date) + + ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + + weeks(ftime_ini) + ## set to make ftime_end be a Sunday + ftime_end <- ymd(init_date) + + ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + + weeks(ftime_end) + 6 + toptitle <- paste("Valid from", ftime_ini, "to", ftime_end) + } + })) + } else { + time_labels <- attributes(time_bounds)$plotting_attr[[1]] + } + } + return(list(time_labels = time_labels, years = years)) +} diff --git a/modules/Visualization/R/plot_ensemble_mean.R b/modules/Visualization/R/plot_ensemble_mean.R index 7e73b187..953aafd1 100644 --- a/modules/Visualization/R/plot_ensemble_mean.R +++ b/modules/Visualization/R/plot_ensemble_mean.R @@ -115,58 +115,15 @@ plot_ensemble_mean <- function(recipe, fcst, mask = NULL, dots = NULL, outdir, o dim(var_dots) <- dim_dots } - ## TODO: Create a function - years <- lubridate::year(fcst$attrs$Dates[1, 1, which(start_date == i_syear), ]) - if (is.null(attributes(fcst$attrs$time_bounds))) { - if (tolower(recipe$Analysis$Horizon == "subseasonal")) { - time_labels <- fcst$attrs$Dates[1, 1, which(start_date == i_syear), ] - monday <- ymd_hms(time_labels) - days(wday(ymd_hms(time_labels), week_start = 1) - 1) - sunday <- monday + days(6) - time_labels <- paste0("Valid from ", format(monday,"%d-%m"), " to ", - format(sunday, "%d-%m"), " of ") - } else { - time_labels <- lubridate::month(fcst$attrs$Dates[1, 1, which(start_date == i_syear), ], - label = T, abb = F) - } - } else { - if (length(attributes(fcst$attrs$time_bounds)$plotting_attr) > 1) { - years <- NULL - time_labels <- - unlist(lapply(1:length(fcst$attrs$time_bounds$start), function(i) { - ftime_ini <- attributes(fcst$attrs$time_bounds)$plotting_attr$ini[i] - ftime_end <- attributes(fcst$attrs$time_bounds)$plotting_attr$end[i] - # labels for file name: - ftime <- paste0(ftime_ini, "-", ftime_end) - # title names: - if (tolower(recipe$Analysis$Horizon) == "seasonal") { - year_ini <- year(fcst$attrs$time_bounds$start[i]) - month_ini <- month.name[month(fcst$attrs$time_bounds$start[i])] - year_end <- year(fcst$attrs$time_bounds$end[i]) - month_end <- month.name[month(fcst$attrs$time_bounds$end[i])] - ## TODO: Rename 'toptitle'? - if (year_ini == year_end) { - toptitle <- paste(month_ini, "to", month_end, year_end) - } else { - toptitle <- paste(month_ini, year_ini, "to", - month_end, year_end) - } - } else if (tolower(recipe$Analysis$Horizon) == "subseasonal") { - ## set to make ftime_ini be a Monday - ## if init_week always Thursday, the 2nd addend can be simplified to +4 - ftime_ini <- ymd(init_date) + - ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + - weeks(ftime_ini) - ## set to make ftime_end be a Sunday - ftime_end <- ymd(init_date) + - ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + - weeks(ftime_end) + 6 - toptitle <- paste("Valid from", ftime_ini, "to", ftime_end) - } - })) - } else { - time_labels <- attributes(fcst$attrs$time_bounds)$plotting_attr[[1]] - } - } + # Plot title labels look different depending on horizon and aggregation + labels <- .get_plot_time_labels(dates = fcst$attrs$Dates, + horizon = recipe$Analysis$Horizon, + init_date = init_date, + start_date = start_date, + i_syear = i_syear, + time_bounds = fcst$attrs$time_bounds) + time_labels <- labels$time_labels + years <- labels$years if (recipe$Analysis$Workflow$Visualization$multi_panel) { # Define name of output file and titles diff --git a/modules/Visualization/R/plot_most_likely_terciles_map.R b/modules/Visualization/R/plot_most_likely_terciles_map.R index 2e1dccfb..9d03347f 100644 --- a/modules/Visualization/R/plot_most_likely_terciles_map.R +++ b/modules/Visualization/R/plot_most_likely_terciles_map.R @@ -123,58 +123,15 @@ plot_most_likely_terciles <- function(recipe, var_dots <- NULL } - # Define labels for forecast times - years <- lubridate::year(fcst$attrs$Dates[1, 1, which(start_date == i_syear), ]) - if (is.null(attributes(fcst$attrs$time_bounds))) { - if (tolower(recipe$Analysis$Horizon == "subseasonal")) { - time_labels <- fcst$attrs$Dates[1, 1, which(start_date == i_syear), ] - monday <- ymd_hms(time_labels) - days(wday(ymd_hms(time_labels), week_start = 1) - 1) - sunday <- monday + days(6) - time_labels <- paste0("Valid from ", format(monday,"%d-%m"), " to ", - format(sunday, "%d-%m"), " of ") - } else { - time_labels <- lubridate::month(fcst$attrs$Dates[1, 1, which(start_date == i_syear), ], - label = T, abb = F) - } - } else { - if (length(attributes(fcst$attrs$time_bounds)$plotting_attr) > 1) { - years <- NULL - time_labels <- - unlist(lapply(1:length(fcst$attrs$time_bounds$start), function(i) { - ftime_ini <- attributes(fcst$attrs$time_bounds)$plotting_attr$ini[i] - ftime_end <- attributes(fcst$attrs$time_bounds)$plotting_attr$end[i] - # labels for file name: - ftime <- paste0(ftime_ini, "-", ftime_end) - # title names: - if (tolower(recipe$Analysis$Horizon) == "seasonal") { - year_ini <- year(fcst$attrs$time_bounds$start[i]) - month_ini <- month.name[month(fcst$attrs$time_bounds$start[i])] - year_end <- year(fcst$attrs$time_bounds$end[i]) - month_end <- month.name[month(fcst$attrs$time_bounds$end[i])] - ## TODO: Rename 'toptitle'? - if (year_ini == year_end) { - toptitle <- paste(month_ini, "to", month_end, year_end) - } else { - toptitle <- paste(month_ini, year_ini, "to", - month_end, year_end) - } - } else if (tolower(recipe$Analysis$Horizon) == "subseasonal") { - ## set to make ftime_ini be a Monday - ## if init_date always Thursday, the 2nd addend can be simplified to +4 - ftime_ini <- ymd(init_date) + - ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + - weeks(ftime_ini) - ## set to make ftime_end be a Sunday - ftime_end <- ymd(init_date) + - ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + - weeks(ftime_end) + 6 - toptitle <- paste("Valid from", ftime_ini, "to", ftime_end) - } - })) - } else { - time_labels <- attributes(fcst$attrs$time_bounds)$plotting_attr[[1]] - } - } + # Plot title labels look different depending on horizon and aggregation + labels <- .get_plot_time_labels(dates = fcst$attrs$Dates, + horizon = recipe$Analysis$Horizon, + init_date = init_date, + start_date = start_date, + i_syear = i_syear, + time_bounds = fcst$attrs$time_bounds) + time_labels <- labels$time_labels + years <- labels$years if (recipe$Analysis$Workflow$Visualization$multi_panel) { ## TODO: Ensure this works for daily and sub-daily cases diff --git a/modules/Visualization/Visualization.R b/modules/Visualization/Visualization.R index 52ce5068..be46f68e 100644 --- a/modules/Visualization/Visualization.R +++ b/modules/Visualization/Visualization.R @@ -6,6 +6,7 @@ source("modules/Visualization/R/plot_metrics.R") source("modules/Visualization/R/get_proj_code.R") +source("modules/Visualization/R/get_plot_time_labels.R") ## TODO: Remove after the next s2dv release source("modules/Visualization/R/tmp/PlotRobinson.R") source("modules/Visualization/R/plot_most_likely_terciles_map.R") -- GitLab From c6a1192b4d815e0c688b49463a7b8cf891e90f80 Mon Sep 17 00:00:00 2001 From: vagudets Date: Tue, 17 Sep 2024 14:04:28 +0200 Subject: [PATCH 7/8] Adapt get_plot_time_labels() to decadal case --- .../Visualization/R/get_plot_time_labels.R | 26 +++++++++++++------ 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/modules/Visualization/R/get_plot_time_labels.R b/modules/Visualization/R/get_plot_time_labels.R index c02c752a..2dfc4202 100644 --- a/modules/Visualization/R/get_plot_time_labels.R +++ b/modules/Visualization/R/get_plot_time_labels.R @@ -27,18 +27,28 @@ } else { if (length(attributes(time_bounds)$plotting_attr) > 1) { years <- NULL + start <- time_bounds$start[1, 1, which(start_date == i_syear), ] + end <- time_bounds$end[1, 1, which(start_date == i_syear), ] time_labels <- - unlist(lapply(1:length(time_bounds$start), function(i) { + unlist(lapply(1:length(start), function(i) { ftime_ini <- attributes(time_bounds)$plotting_attr$ini[i] ftime_end <- attributes(time_bounds)$plotting_attr$end[i] # labels for file name: ftime <- paste0(ftime_ini, "-", ftime_end) # title names: - if (horizon == "seasonal") { - year_ini <- year(time_bounds$start[i]) - month_ini <- month.name[month(time_bounds$start[i])] - year_end <- year(time_bounds$end[i]) - month_end <- month.name[month(time_bounds$end[i])] + if (horizon %in% c("seasonal", "decadal")) { + # start <- Subset(time_bounds$start, + # along = c("syear", "time"), + # indices = list(syear = i_syear, time = i), + # drop = TRUE) + # end <- Subset(time_bounds$end, + # along = c("syear", "time"), + # indices = list(syear = i_syear, time = i), + # drop = TRUE) + year_ini <- year(start[i]) + month_ini <- month.name[month(start[i])] + year_end <- year(end[i]) + month_end <- month.name[month(end[i])] if (year_ini == year_end) { toptitle <- paste(month_ini, "to", month_end, year_end) } else { @@ -50,11 +60,11 @@ ## if init_week always Thursday, the 2nd addend can be simplified to +4 ftime_ini <- ymd(init_date) + ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + - weeks(ftime_ini) + weeks(ftime_ini - 1) ## set to make ftime_end be a Sunday ftime_end <- ymd(init_date) + ((8 - wday(ymd(init_date), week_start = 1)) %% 7) + - weeks(ftime_end) + 6 + weeks(ftime_end - 1) + 6 toptitle <- paste("Valid from", ftime_ini, "to", ftime_end) } })) -- GitLab From b740f55cc6fbf7fb218735c771a1e751819093fe Mon Sep 17 00:00:00 2001 From: vagudets Date: Tue, 17 Sep 2024 14:04:49 +0200 Subject: [PATCH 8/8] Add Utils unit tests --- .gitlab-ci.yml | 13 + tests/test_utils.R | 9 + .../test-utils-get_plot_time_labels.R | 269 ++++++++++++++++++ 3 files changed, 291 insertions(+) create mode 100644 tests/test_utils.R create mode 100644 tests/testthat/test-utils-get_plot_time_labels.R diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ccaf0809..4dd045ce 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -40,3 +40,16 @@ unit-test-subseasonal: # This job runs in the test stage. - echo "Running subseasonal unit tests..." - Rscript ./tests/test_subseasonal.R +unit-test-utilities: # This job runs in the test stage. + stage: test + script: + - echo "Loading modules..." + - module load R/4.1.2-foss-2015a-bare + - module load CDO/1.9.8-foss-2015a + - module load GEOS/3.7.2-foss-2015a-Python-3.7.3 + - module load GDAL/2.2.1-foss-2015a + - module load PROJ/4.8.0-foss-2015a + - module list + - echo "Running subseasonal unit tests..." + - Rscript ./tests/test_utils.R + diff --git a/tests/test_utils.R b/tests/test_utils.R new file mode 100644 index 00000000..87769761 --- /dev/null +++ b/tests/test_utils.R @@ -0,0 +1,9 @@ +library(testthat) + +path_testthat <- file.path('./tests/testthat/') +files_testthat <- list.files('./tests/testthat/', pattern = 'test-utils') + +for (i_file in 1:length(files_testthat)) { + source(paste0('./tests/testthat/', files_testthat[i_file])) +} + diff --git a/tests/testthat/test-utils-get_plot_time_labels.R b/tests/testthat/test-utils-get_plot_time_labels.R new file mode 100644 index 00000000..686bdfb1 --- /dev/null +++ b/tests/testthat/test-utils-get_plot_time_labels.R @@ -0,0 +1,269 @@ +context("get_plot_time_labels.R") + +source("tools/libs.R") +source("modules/Visualization/R/get_plot_time_labels.R") +########################################### + +test_that("1. Subseasonal, time-aggregated data", { + horizon <- "subseasonal" + init_date <- "20231221" + start_date <- init_date + i_syear <- init_date + + time_bounds <- list(start = as.POSIXct("2023-12-21 09:00:00 UTC"), + end = as.POSIXct("2024-01-11 09:00:00 UTC")) + attr(time_bounds, "plotting_attr") <- list(ini_ftime = 1, + end_ftime = 4) + + dates <- as.POSIXct("2023-12-21 09:00:00 UTC") + dim(dates) <- c(sday = 1, sweek = 1, syear = 1, time = 1) + time_bounds[] <- lapply(time_bounds, + function(x) { + dim(x) <- dim(dates) + return(x) + }) + + labels <- .get_plot_time_labels( + dates = dates, + horizon = horizon, + init_date = init_date, + start_date = start_date, + i_syear = i_syear, + time_bounds = time_bounds + ) + + # Results + expect_equal( + labels$years, + NULL + ) + expect_equal( + labels$time_labels[1], + "Valid from 2023-12-25 to 2024-01-21" + ) +}) + +test_that("2. Subseasonal, week-by-week data", { + horizon <- "subseasonal" + init_date <- "20231214" + start_date <- init_date + i_syear <- init_date + + time_bounds <- NULL + + dates <- as.POSIXct(c("2023-12-21 09:00:00 UTC", "2023-12-28 09:00:00 UTC", + "2024-01-04 09:00:00 UTC", "2024-01-11 09:00:00 UTC")) + dim(dates) <- c(sday = 1, sweek = 1, syear = 1, time = 4) + + labels <- .get_plot_time_labels( + dates = dates, + horizon = horizon, + init_date = init_date, + start_date = start_date, + i_syear = i_syear, + time_bounds = time_bounds + ) + + # Results + expect_equal( + labels$years, + c(2023, 2023, 2024, 2024) + ) + expect_equal( + labels$time_labels[1], + "Valid from 18-12 to 24-12 of " + ) + expect_equal( + labels$time_labels[2], + "Valid from 25-12 to 31-12 of " + ) + expect_equal( + labels$time_labels[3], + "Valid from 01-01 to 07-01 of " + ) + expect_equal( + labels$time_labels[4], + "Valid from 08-01 to 14-01 of " + ) +}) + +test_that("3. Seasonal, time-aggregated data", { + horizon <- "seasonal" + init_date <- 10 + start_date <- "20231001" + i_syear <- "20231001" + + time_bounds <- list(start = c(as.POSIXct("2023-10-16 12:00:00 UTC"), + as.POSIXct("2023-12-16 09:00:00 UTC")), + end = c(as.POSIXct("2023-12-16 09:00:00 UTC"), + as.POSIXct("2024-03-16 09:00:00 UTC"))) + attr(time_bounds, "plotting_attr") <- list(ini_ftime = c(1, 3), + end_ftime = c(3, 6) + ) + + dates <- as.POSIXct(c("2023-10-16 12:00:00 UTC", "2023-12-16 09:00:00 UTC")) + dim(dates) <- c(sday = 1, sweek = 1, syear = 1, time = 2) + time_bounds[] <- lapply(time_bounds, + function(x) { + dim(x) <- dim(dates) + return(x) + }) + + labels <- .get_plot_time_labels( + dates = dates, + horizon = horizon, + init_date = init_date, + start_date = start_date, + i_syear = i_syear, + time_bounds = time_bounds + ) + + # Results + expect_equal( + labels$years, + NULL + ) + expect_equal( + labels$time_labels[1], + "October to December 2023" + ) + expect_equal( + labels$time_labels[2], + "December 2023 to March 2024" + ) +}) + +test_that("4. Seasonal, month-by-month data", { + horizon <- "seasonal" + init_date <- 10 + start_date <- "20231001" + i_syear <- "20231001" + + time_bounds <- NULL + + dates <- as.POSIXct(c("2023-10-16 12:00:00 UTC", "2023-11-15 12:00:00 UTC", + "2023-12-16 09:00:00 UTC", "2024-01-15 12:00:00 UTC")) + dim(dates) <- c(sday = 1, sweek = 1, syear = 1, time = 4) + + labels <- .get_plot_time_labels( + dates = dates, + horizon = horizon, + init_date = init_date, + start_date = start_date, + i_syear = i_syear, + time_bounds = time_bounds + ) + + # Results + expect_equal( + labels$years, + c(2023, 2023, 2023, 2024) + ) + expect_equal( + as.vector(labels$time_labels), + c("October", "November", "December", "January") + ) +}) + +test_that("5. Decadal, time-aggregated data", { + + horizon <- "decadal" + init_date <- 1 + start_date <- c("2020", "2021") + + time_bounds <- list(start = as.POSIXct(c("2020-11-16 UTC", "2021-11-16 UTC", + "2020-11-16 UTC", "2021-11-16 UTC")), + end = as.POSIXct(c("2021-02-15 00:00:00 UTC", + "2022-02-15 00:00:00 UTC", + "2020-12-16 12:00:00 UTC", + "2021-12-16 12:00:00 UTC"))) + attr(time_bounds, "plotting_attr") <- list(ini_ftime = c(1, 1), + end_ftime = c(4, 2) + ) + + dates <- as.POSIXct(c("2020-11-16 UTC", "2021-11-16 UTC", "2020-11-16 UTC", "2021-11-16 UTC")) + dim(dates) <- c(sday = 1, sweek = 1, syear = 2, time = 2) + time_bounds[] <- lapply(time_bounds, + function(x) { + dim(x) <- dim(dates) + return(x) + }) + + labels <- vector(mode = "list", length = 2) + for (i in 1:length(start_date)) { + labels[[i]] <- .get_plot_time_labels( + dates = dates, + horizon = horizon, + init_date = init_date, + start_date = start_date, + i_syear = start_date[i], + time_bounds = time_bounds + ) + } + + # Results + expect_equal( + labels[[1]]$years, + labels[[2]]$years, + NULL + ) + + expect_equal( + labels[[1]]$time_labels[1], + "November 2020 to February 2021" + ) + expect_equal( + labels[[1]]$time_labels[2], + "November to December 2020" + ) + expect_equal( + labels[[2]]$time_labels[1], + "November 2021 to February 2022" + ) + expect_equal( + labels[[2]]$time_labels[2], + "November to December 2021" + ) +}) + + +test_that("6. Decadal, month-by-month data", { + + horizon <- "decadal" + init_date <- 1 + start_date <- c("2020", "2021") + + dates <- as.POSIXct(c("2020-11-16 00:00:00 UTC", "2021-11-16 00:00:00 UTC", + "2020-12-16 12:00:00 UTC", "2021-12-16 12:00:00 UTC", + "2021-01-16 12:00:00 UTC", "2022-01-16 12:00:00 UTC", + "2021-02-15 00:00:00 UTC", "2022-02-15 00:00:00 UTC")) + dim(dates) <- c(sday = 1, sweek = 1, syear = 2, time = 4) + + labels <- vector(mode = "list", length = 2) + for (i in 1:length(start_date)) { + labels[[i]] <- .get_plot_time_labels( + dates = dates, + horizon = horizon, + init_date = init_date, + start_date = start_date, + i_syear = start_date[i], + time_bounds = NULL + ) + } + + # Results + expect_equal( + labels[[1]]$years, + c(2020, 2020, 2021, 2021) + ) + expect_equal( + labels[[2]]$years, + c(2021, 2021, 2022, 2022) + ) + + expect_equal( + as.vector(labels[[1]]$time_labels), + as.vector(labels[[2]]$time_labels), + c("November", "December", "January", "February") + ) +}) -- GitLab