From 7e644d55abd101abfcda6a4c83bb173a1f9149af Mon Sep 17 00:00:00 2001 From: Nadia Milders Date: Thu, 20 Jul 2023 15:33:44 +0200 Subject: [PATCH 01/14] scorecards module code --- MODULES | 1 + autosubmit/auto-scorecards.sh | 15 + autosubmit/conf_esarchive/jobs.conf | 8 + modules/Scorecards/Scorecards.R | 179 +++++++ modules/Scorecards/tmp/LoadMetrics.R | 207 ++++++++ modules/Scorecards/tmp/SCPlotScorecard.R | 444 ++++++++++++++++++ modules/Scorecards/tmp/SCTransform.R | 42 ++ modules/Scorecards/tmp/ScorecardsMulti.R | 360 ++++++++++++++ modules/Scorecards/tmp/ScorecardsSingle.R | 343 ++++++++++++++ modules/Scorecards/tmp/ScorecardsSystemDiff.R | 350 ++++++++++++++ modules/Scorecards/tmp/Utils.R | 361 ++++++++++++++ modules/Scorecards/tmp/WeightedMetrics.R | 134 ++++++ .../recipe_scorecards_atomic.yml | 69 +++ recipes/recipe_scoreacards.yml | 105 +++++ 14 files changed, 2618 insertions(+) create mode 100644 autosubmit/auto-scorecards.sh create mode 100644 modules/Scorecards/Scorecards.R create mode 100644 modules/Scorecards/tmp/LoadMetrics.R create mode 100644 modules/Scorecards/tmp/SCPlotScorecard.R create mode 100644 modules/Scorecards/tmp/SCTransform.R create mode 100644 modules/Scorecards/tmp/ScorecardsMulti.R create mode 100644 modules/Scorecards/tmp/ScorecardsSingle.R create mode 100644 modules/Scorecards/tmp/ScorecardsSystemDiff.R create mode 100644 modules/Scorecards/tmp/Utils.R create mode 100644 modules/Scorecards/tmp/WeightedMetrics.R create mode 100644 recipes/atomic_recipes/recipe_scorecards_atomic.yml create mode 100644 recipes/recipe_scoreacards.yml diff --git a/MODULES b/MODULES index ff2a2a34..48f0a52a 100644 --- a/MODULES +++ b/MODULES @@ -19,6 +19,7 @@ elif [[ $BSC_MACHINE == "nord3v2" ]]; then module load CDO/1.9.8-foss-2019b module load R/4.1.2-foss-2019b module load OpenMPI/4.0.5-GCC-8.3.0-nord3-v2 + module load Phantomjs else diff --git a/autosubmit/auto-scorecards.sh b/autosubmit/auto-scorecards.sh new file mode 100644 index 00000000..ac26e9c1 --- /dev/null +++ b/autosubmit/auto-scorecards.sh @@ -0,0 +1,15 @@ +#!/bin/bash + +############ AUTOSUBMIT INPUTS ############ +proj_dir=%PROJDIR% +outdir=%OUTDIR% +recipe=%RECIPE% +############################### + +cd $proj_dir + +recipe=${outdir}/logs/recipes/${recipe} + +source MODULES + +Rscript /modules/Scorecards/Scorecards.R ${recipe} diff --git a/autosubmit/conf_esarchive/jobs.conf b/autosubmit/conf_esarchive/jobs.conf index 88f3565c..4767dcc1 100644 --- a/autosubmit/conf_esarchive/jobs.conf +++ b/autosubmit/conf_esarchive/jobs.conf @@ -6,3 +6,11 @@ NOTIFY_ON = PLATFORM = nord3v2 PROCESSORS = +[scorecards] +FILE = autosubmit/auto-scorecards.sh +RUNNING = ONCE +WALLCLOCK = 00:10 +PLATFORM = nord3v2 +PROCESSORS = 1 +DEPENDENCIES = verification +RECIPE = recipes/recipe_scorecards.yml diff --git a/modules/Scorecards/Scorecards.R b/modules/Scorecards/Scorecards.R new file mode 100644 index 00000000..9d4eb946 --- /dev/null +++ b/modules/Scorecards/Scorecards.R @@ -0,0 +1,179 @@ +############################################################################### +##################### SCORECARDS MODULE FOR SUNSET SUITE ###################### +############################################################################### + +##### Load source functions ##### +source('/modules/Scorecards/tmp/LoadMetrics.R') +source('/modules/Scorecards/tmp/WeightedMetrics.R') +source('/modules/Scorecards/tmp/Utils.R') +source('/modules/Scorecards/tmp/SCTransform.R') +source('/modules/Scorecards/tmp/ScorecardsSingle.R') +source('/modules/Scorecards/tmp/ScorecardsMulti.R') +source('/modules/Scorecards/tmp/ScorecardsSystemDiff.R') +source('/modules/Scorecards/tmp/SCPlotScorecard.R') + +## Define function +plot_scorecards <- function(recipe) { + + ## set parameters + input.path <- '/esarchive/scratch/nmilders/scorecards_data/to_system/cross_validation/both_cross_val/' #recipe$Run$output_dir + output.path <- recipe$Run$output_dir + + system <- recipe$Analysis$Datasets$System$name + reference <- recipe$Analysis$Datasets$Reference$name + var <- recipe$Analysis$Variables$name + start.year <- as.numeric(recipe$Analysis$Time$hcst_start) + end.year <- as.numeric(recipe$Analysis$Time$hcst_end) + forecast.months <- recipe$Analysis$Time$ftime_min : recipe$Analysis$Time$ftime_max + + start.months <- 1:12 #recipe$Analysis$Workflow$Scorecards$start_months + + regions <- recipe$Analysis$Workflow$Scorecards$regions + for (i in names(regions)){regions[[i]] <- unlist(regions[[i]])} + + metric.aggregation <- recipe$Analysis$Workflow$Scorecards$metric_aggregation + metrics.load <- unlist(strsplit(tolower(recipe$Analysis$Workflow$Skill$metric), ", | |,")) + metrics.visualize <- unlist(strsplit(tolower(recipe$Analysis$Workflow$Scorecards$metric), ", | |,")) + table.label <- recipe$Analysis$Workflow$Scorecards$table_label + fileout.label <- recipe$Analysis$Workflow$Scorecards$fileout_label + legend.white.space <- recipe$Analysis$Workflow$Scorecards$legend_white_space + col1.width <- recipe$Analysis$Workflow$Scorecards$col1_width + col2.width <- recipe$Analysis$Workflow$Scorecards$col2_width + calculate.diff <- recipe$Analysis$Workflow$Scorecards$calculate_diff + ncores <- recipe$Analysis$ncores + + ## Load data files + loaded_metrics <- LoadMetrics(system = system, + reference = reference, + var = var, + start.year = start.year, + end.year = end.year, + metrics = metrics.load, + start.months = start.months, + forecast.months = forecast.months, + input.path = input.path) + + + if('region' %in% names(dim(loaded_metrics[[1]][[1]]))){ + + ### Convert loaded metrics to array for allready aggregated data + metrics.dim <- attributes(loaded_metrics[[1]][[1]])$metrics + forecast.months.dim <- attributes(loaded_metrics[[1]][[1]])$forecast.months + start.months.dim <- attributes(loaded_metrics[[1]][[1]])$start.months + regions.dim <- regions #list('NAO' = c(lon.min = -80, lon.max = 40, lat.min = 20, lat.max = 80)) + + aggregated_metrics <- array(dim = c(system = length(loaded_metrics), + reference = length(loaded_metrics[[1]]), + metric = length(metrics.dim), + time = length(forecast.months.dim), + sdate = length(start.months.dim), + region = length(regions.dim))) + + + for (sys in 1:length(names(loaded_metrics))){ + for (ref in 1:length(names(loaded_metrics[[sys]]))){ + aggregated_metrics[sys, ref, , , , ] <- s2dv::Reorder(data = loaded_metrics[[sys]][[ref]], order = c('metric','time','sdate','region')) + } + } + + ## Add attributes + attributes(aggregated_metrics)$metrics <- metrics.load + attributes(aggregated_metrics)$start.months <- attributes(loaded_metrics[[1]][[1]])$start.months + attributes(aggregated_metrics)$forecast.months <- attributes(loaded_metrics[[1]][[1]])$forecast.months + attributes(aggregated_metrics)$regions <- regions + attributes(aggregated_metrics)$system.name <- names(loaded_metrics) + attributes(aggregated_metrics)$reference.name <- names(loaded_metrics[[1]]) + + + } else { + ## Calculate weighted mean of spatial aggregation + aggregated_metrics <- WeightedMetrics(loaded_metrics, + regions = regions, + metric.aggregation = metric.aggregation, + ncores = ncores) + }## close if + + + # if(var == 'nao'){ + # legend.white.space <- 3.75 + # col1.width <- 2 + # col2.width <- 1 + # } else{ + # legend.white.space <- col1.width <- col2.width <- NULL ## Use default values of function + # + # } + + ## Define skill scores in scorec aggragtion has been requested + + if(metric.aggregation == 'score'){ + if('rpss' %in% metrics.visualize){ + metrics.visualize[metrics.visualize == 'rpss'] <- 'rpss_score_aggr' + } + if('crpss' %in% metrics.visualize){ + metrics.visualize[metrics.visualize == 'crpss'] <- 'crpss_score_aggr' + } + } + + ## Create simple scorecard tables + ## (one system only) + ## Metrics input must be in the same order as function SC_spatial_aggregation + scorecard_single <- ScorecardsSingle(data = aggregated_metrics, + system = system, + reference = reference, + var = var, + start.year = start.year, + end.year = end.year, + start.months = start.months, + forecast.months = forecast.months, + region.names = names(regions), + metrics = metrics.visualize, + table.label = table.label, + fileout.label = fileout.label, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + output.path = output.path) + + ## Create multi system/reference scorecard tables + ## (multiple systems with one reference or one system with multiple references) + ## Metrics input must be in the same order as function SC_spatial_aggregation + if(length(system) > 1 || length(reference) > 1){ + scorecard_multi <- ScorecardsMulti(data = aggregated_metrics, + system = system, + reference = reference, + var = var, + start.year = start.year, + end.year = end.year, + start.months = start.months, + forecast.months = forecast.months, + region.names = attributes(regions)$names, + metrics = metrics.visualize, + table.label = table.label, + fileout.label = fileout.label, + output.path = output.path) + } ## close if + + + if(calculate.diff == TRUE){ + if(length(system) == 2 || length(reference) == 2){ + scorecard_diff <- ScorecardsSystemDiff(data = aggregated_metrics, + system = system, + reference = reference, + var = var, + start.year = start.year, + end.year = end.year, + start.months = start.months, + forecast.months = forecast.months, + region.names = attributes(regions)$names, + metrics = metrics.visualize, + table.label = table.label, + fileout.label = fileout.label, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + output.path = output.path) + } else {stop ("Difference scorecard can only be computed with two systems or two references.")} + } ## close if on calculate.diff + +} + diff --git a/modules/Scorecards/tmp/LoadMetrics.R b/modules/Scorecards/tmp/LoadMetrics.R new file mode 100644 index 00000000..7e68b65a --- /dev/null +++ b/modules/Scorecards/tmp/LoadMetrics.R @@ -0,0 +1,207 @@ +#' Scorecards load metrics from verification suite +#' +#'@description Scorecards function to load saved data files +#' +#'@param system A vector of character strings defining the names of the +#' system names following the archive.yml format from verification suite. +#' Accepted system names: 'ECMWF-SEAS5', 'DWD-GFCS2.1', 'CMCC-SPS3.5', +#' 'ecmwfs5','Meteo-France-System 7', 'UK-MetOffice-GloSea600', 'NCEP-CFSv2'. +#'@param reference A vector of character strings defining the names of +#' the references following the archive.yml format from verification suite +#' Pending to be test with more than one. The accepted names are: 'era5'. +#'@param var A character string following the format from +#' variable-dictionary.yml from verification suite (TO DO: multiple variables). +#' The accepted names are: 'psl', 'tas', 'sfcWind', 'prlr'. +#'@param start.year A numeric indicating the start year of the reference period +#'@param end.year A numeric indicating the end year of the reference period +#'@param start.months A vector indicating the numbers of the start months +#'@param forecast.months A vector indicating the numbers of the forecast months +#'@param input.path A character string indicating the path where metrics output +#' files from verification suite are saved (or any other compatible files) +#' +#'@return A is a list by system and reference containing an array of with +#' the following dimensions: longitude, latitude, forecast months, metrics, +#' start dates. + +#'@examples +#'\dontrun{ +#'loaded_metrics <- LoadMetrics(system = c('ECMWF-SEAS5','DWD-GFCS2.1'), +#' reference. = 'ERA5', +#' var = 'tas', +#' start.year = 1993, +#' end.year = 2016, +#' metrics = c('mean_bias', 'enscorr', 'rpss', 'crpss', 'enssprerr'), +#' start.months = sprintf("%02d", 1:12), +#' forecast.months = 1:6, +#' input.path = '/esarchive/scratch/nmilders/scorecards_data/input_data') +#'} +#'@import easyNCDF +#'@import abind +#'@export +LoadMetrics <- function(system, reference, var, start.year, end.year, + metrics, start.months, forecast.months, + inf_to_na = FALSE, + input.path) { + + # Initial checks + ## system + if (!is.character(system)) { + stop("Parameter 'system' must be a character vector with the system names.") + } + ## reference + if (!is.character(reference)) { + stop("Parameter 'reference' must be a character vector with the reference ", + "names.") + } + ## var + if (!is.character(var)) { + stop("Parameter 'var' must be a character vector with the var ", + "names.") + } + if (length(var) > 1) { + warning("Parameter 'var' must be of length one. Only the first value ", + "will be used.") + var <- var[1] + } + ## start.year + if (!is.numeric(start.year)) { + stop("Parameter 'start.year' must be a numeric value.") + } + ## end.year + if (!is.numeric(end.year)) { + stop("Parameter 'end.year' must be a numeric value.") + } + ## metrics + if (!is.character(metrics)) { + stop("Parameter 'metrics' cannot be NULL.") + } + ## start.months + if (is.character(start.months)) { + warning("Parameter 'start.months' must be a numeric vector indicating ", + "the starting months.") + start.months <- as.numeric(start.months) + } + if (!is.numeric(start.months)) { + stop("Parameter 'start.months' must be a numeric vector indicating ", + "the starting months.") + } + start.months <- sprintf("%02d", start.months) + ## Check if sdates are continuous or discrete + if (all(diff(as.numeric(start.months)) == 1)) { + consecutive_start.months <- TRUE + } else { + consecutive_start.months <- FALSE + } + ## forecast.months + if (!is.numeric(forecast.months)) { + stop("Parameter 'forecast.months' must be a numeric vector indicating ", + "the starting months.") + } + ## input.path + if (!is.character(input.path)) { + stop("Parameter 'input.path must be a character string.") + } + if (length(input.path) > 1) { + input.path <- input.path[1] + warning("Parameter 'input.path' has length greater than 1 and only the ", + "first element will be used.") + } + + ## Remove . from names + system <- gsub('.','', system, fixed = T) + reference <- gsub('.','', reference, fixed = T) + + period <- paste0(start.year, "-", end.year) + + ## Define empty list to saved data + all_metrics <- sapply(system, function(x) NULL) + ## Load data for each system + for (sys in 1:length(system)) { + ## Define empty list to saved data + by_reference <- sapply(reference, function(x) NULL) + ## Load data for each reference + for (ref in 1:length(reference)) { + ## Call function to load metrics data + met <- .Loadmetrics(input.path = input.path, # recipe$Run$output, + system = system[sys], + reference = reference[ref], + var = var, + period = period, + start.months = start.months, + forecast.months = forecast.months, + metrics = metrics) + ## Save metric data as array in reference list + by_reference[[reference[ref]]] <- met + ## Remove -Inf from crpss data if variable is precipitation + if (inf_to_na) { + by_reference[[reference]][by_reference[[reference]]==-Inf] <- NA + } + } ## close loop on reference + ## Save reference data in list of system + all_metrics[[system[sys]]] <- by_reference + } ## close loop on system + + return(all_metrics) +} ## close function + +############################################################ + +.Loadmetrics <- function(input.path, system, reference, + var, period, start.months, + forecast.months, metrics) { + + ## Load data for each start date + allfiles <- sapply(start.months, function(m) { + paste0(input.path, "/", system, "/", var, + "/scorecards_", system, "_", reference, "_", + var, "-skill_", period, "_s", m, # mod.pressure, + ".nc")}) + allfiles_exist <- sapply(allfiles, file.exists) + + # Check dims + files_exist_by_month <- seq(1:length(allfiles))[allfiles_exist] + allfiledims <- sapply(allfiles[allfiles_exist], easyNCDF::NcReadDims) + if (length(files_exist_by_month) == 0) { + stop("No files are found.") + } + + num_dims <- numeric(dim(allfiledims)[1]) + for (i in 1:dim(allfiledims)[1]) { + if (length(unique(allfiledims[i,])) > 1) { + warning(paste0("Dimensions of system ", system," with var ", var, + " don't match.")) + } + num_dims[i] <- max(allfiledims[i,]) # We take the largest dimension + } + # dims: [metric, longitude, latitude, time, smonth] + # or [metric, region, time, smonth] + + # Loop for file + m <- array(files_exist_by_month, c(sdate = length(files_exist_by_month))) + array_met_by_sdate <- apply(m, 1, function(x) { + test <- easyNCDF::NcToArray(allfiles[x], vars_to_read = metrics, unlist = T, + drop_var_dim = T) + test}) + dim(array_met_by_sdate) <- c(metric = length(metrics), allfiledims[-1,1], + sdate = length(start.months)) + + # Attributes + # Read attributes from the first existing file + if ("region" %in% rownames(allfiledims)) { + file_for_att <- ncdf4::nc_open(allfiles[allfiles_exist[1]]) + region <- ncdf4::ncatt_get(file_for_att, 'region') + ncdf4::nc_close(file_for_att) + attributes(array_met_by_sdate)$region <- region + } else { + lon <- easyNCDF::NcToArray(allfiles[allfiles_exist][1], vars_to_read = 'longitude', + unlist = T, drop_var_dim = T) + lat <- easyNCDF::NcToArray(allfiles[allfiles_exist][1], vars_to_read = 'latitude', + unlist = T, drop_var_dim = T) + attributes(array_met_by_sdate)$lon <- lon + attributes(array_met_by_sdate)$lat <- lat + } + attributes(array_met_by_sdate)$metrics <- metrics + attributes(array_met_by_sdate)$start.months <- start.months + attributes(array_met_by_sdate)$forecast.months <- forecast.months + return(array_met_by_sdate) +} diff --git a/modules/Scorecards/tmp/SCPlotScorecard.R b/modules/Scorecards/tmp/SCPlotScorecard.R new file mode 100644 index 00000000..4373057b --- /dev/null +++ b/modules/Scorecards/tmp/SCPlotScorecard.R @@ -0,0 +1,444 @@ +#'Scorecards function create simple scorecards by region (types 1 & 3) +#' +#'@description This function creates a scorecard for a single system and +#'reference combination, showing data by region and forecast month. +#' +#'@param data A multidimensional array containing spatially aggregated metrics +#' data with dimensions: metric, region, sdate and ftime. +#'@param row.dim A character string indicating the dimension name to show in the +#' rows of the plot. +#'@param subrow.dim A character string indicating the dimension name to show in +#' the sub-rows of the plot. +#'@param col.dim A character string indicating the dimension name to show in the +#' columns of the plot. +#'@param subcol.dim A character string indicating the dimension name to show in +#' the sub-columns of the plot. +#'@param legend.dim A character string indicating the dimension name to use for +#' the legend. +#'@param row.names A vector of character strings with row display names. +#'@param subrow.names A vector of character strings with sub-row display names. +#'@param col.names A vector of character strings with column display names. +#'@param subcol.names A vector of character strings with sub-column display +#' names. +#'@param row.title A character string for the title of the row names. +#'@param subrow.title A character string for the title of the sub-row names. +#'@param table.title A character string for the title of the plot. +#'@param table.subtitle A character string for the sub-title of the plot. +#'@param legend.breaks A vector of numerics or a list of vectors of numerics, +#' containing the breaks for the legends. If a vector is given as input, then +#' these breaks will be repeated for each legend.dim. A list of vectors can be +#' given as input if the legend.dims require different breaks. This parameter +#' is required even if the legend is not plotted, to define the colors in the +#' scorecard table. +#'@param plot.legend A logical value to determine if the legend is plotted. +#'@param legend.width A numeric value to define the width of the legend bars. +#'@param legend.height A numeric value to define the height of the legend bars. +#'@param palette A vector of character strings or a list of vectors of +#' character strings containing the colors to use in the legends. If a vector +#' is given as input, then these colors will be used for each legend.dim. A +#' list of vectors can be given as input if different colors are desired for +#' the legend.dims. This parameter must be included even if the the legend is +#' not plotted, to define the colors in the scorecard table. +#'@param colorunder A character string or of vector of character strings +#' defining the colors to use for data values with are inferior to the lowest +#' breaks value. This parameter will also plot a inferior triangle in the +#' legend bar. The parameter can be set to NULL if there are no inferior values. +#' If a character string is given this color will be applied to all legend.dims. +#'@param colorsup A character string or of vector of character strings +#' defining the colors to use for data values with are superior to the highest +#' breaks value. This parameter will also plot a inferior triangle in the +#' legend bar. The parameter can be set to NULL if there are no superior values. +#' If a character string is given this color will be applied to all legend.dims. +#'@param round.decimal A numeric indicating to which decimal point the data +#' is to be displayed in the scorecard table. +#'@param font.size A numeric indicating the font size on the scorecard table. +#'@param fileout A path of the location to save the scorecard plots. +#' +#'@return An image file containing the scorecard. +#'@example +#'data <- array(rnorm(1000), dim = c('sdate' = 12, 'metric' = 4, 'region' = 3, +#' 'time' = 6)) +#'row.names <- c('Tropics', 'Extra-tropical NH', 'Extra-tropical SH') +#'col.names <- c('Mean bias (K)', 'Correlation', 'RPSS','CRPSS') +#'SCPlotScorecard(data = data, row.names = row.names, col.names = col.names, +#' subcol.names = month.abb[as.numeric(1:12)], +#' row.title = 'Region', subrow.title = 'Forecast Month', +#' col.title = 'Start date', +#' table.title = "Temperature of ECMWF System 5", +#' table.subtitle = "(Ref: ERA5 1994-2016)", +#' fileout = 'test.png') +#' +#'@import kableExtra +#'@import s2dv +#'@import ClimProjDiags +#'@export +SCPlotScorecard <- function(data, row.dim = 'region', subrow.dim = 'time', + col.dim = 'metric', subcol.dim = 'sdate', + legend.dim = 'metric', row.names = NULL, + subrow.names = NULL, col.names = NULL, + subcol.names = NULL, row.title = NULL, + subrow.title = NULL, col.title = NULL, + table.title = NULL, table.subtitle = NULL, + legend.breaks = NULL, plot.legend = TRUE, + label.scale = NULL, legend.width = NULL, + legend.height = NULL, palette = NULL, + colorunder = NULL, colorsup = NULL, + round.decimal = 2, font.size = 1.1, + legend.white.space = NULL, + col1.width = NULL, col2.width = NULL, + fileout = './scorecard.png') { + # Input parameter checks + ## Check data + if (!is.array(data)) { + stop("Parameter 'data' must be a numeric array.") + } + ## Check row.dim + if (!is.character(row.dim)) { + stop("Parameter 'row.dim' must be a character string.") + } + if (!row.dim %in% names(dim(data))) { + stop("Parameter 'row.dim' is not found in 'data' dimensions.") + } + ## Check row.names + if (!is.null(row.names)) { + if (length(row.names) != as.numeric(dim(data)[row.dim])) { + stop("Parameter 'row.names' must have the same length of dimension 'row.dims'.") + } + } else { + row.names <- as.character(1:dim(data)[row.dim]) + } + ## Check subrow.dim + if (!is.character(subrow.dim)) { + stop("Parameter 'subrow.dim' must be a character string.") + } + if (!subrow.dim %in% names(dim(data))) { + stop("Parameter 'subrow.dim' is not found in 'data' dimensions.") + } + ## Check subrow.names + if (!is.null(subrow.names)) { + if (length(subrow.names) != as.numeric(dim(data)[subrow.dim])) { + stop("Parameter 'subrow.names' must have the same length of dimension 'subrow.dims'.") + } + } else { + subrow.names <- as.character(1:dim(data)[subrow.dim]) + } + ## Check col.dim + if (!is.character(col.dim)) { + stop("Parameter 'col.dim' must be a character string.") + } + if (!col.dim %in% names(dim(data))) { + stop("Parameter 'col.dim' is not found in 'data' dimensions.") + } + ## Check col.names + if (!is.null(col.names)) { + if (length(col.names) != as.numeric(dim(data)[col.dim])) { + stop("Parameter 'col.names' must have the same length of dimension 'col.dims'.") + } + } else { + col.names <- as.character(1:dim(data)[col.dim]) + } + ## Check subcol.dim + if (!is.character(subcol.dim)) { + stop("Parameter 'subcol.dim' must be a character string.") + } + if (!subcol.dim %in% names(dim(data))) { + stop("Parameter 'subcol.dim' is not found in 'data' dimensions.") + } + ## Check subcol.names + if (!is.null(subcol.names)) { + if (length(subcol.names) != as.numeric(dim(data)[subcol.dim])) { + stop("Parameter 'subcol.names' must have the same length of dimension 'subcol.dims'.") + } + } else { + subcol.names <- as.character(1:dim(data)[subcol.dim]) + } + ## Check legend.dim + if (!is.character(legend.dim)) { + stop("Parameter 'legend.dim' must be a character string.") + } + if (!legend.dim %in% names(dim(data))) { + stop("Parameter 'legend.dim' is not found in 'data' dimensions.") + } + ## Check row.title inputs + if (!is.null(row.title)) { + if (!is.character(row.title)) { + stop("Parameter 'row.title must be a character string.") + } + } else { + row.title <- "" + } + ## Check subrow.title + if (!is.null(subrow.title)) { + if (!is.character(subrow.title)) { + stop("Parameter 'subrow.title must be a character string.") + } + } else { + subrow.title <- "" + } + ## Check col.title + if (!is.null(col.title)) { + if (!is.character(col.title)) { + stop("Parameter 'col.title must be a character string.") + } + } else { + col.title <- "" + } + ## Check table.title + if (!is.null(table.title)) { + if (!is.character(table.title)) { + stop("Parameter 'table.title' must be a character string.") + } + } else { + table.title <- "" + } + ## Check table.subtitle + if (!is.null(table.subtitle)) { + if (!is.character(table.subtitle)) { + stop("Parameter 'table.subtitle' must be a character string.") + } + } else { + table.subtitle <- "" + } + # Check legend.breaks + if (is.vector(legend.breaks) && is.numeric(legend.breaks)) { + legend.breaks <- rep(list(legend.breaks), as.numeric(dim(data)[legend.dim])) + } else if (is.null(legend.breaks)) { + legend.breaks <- rep(list(seq(-1, 1, 0.2)), as.numeric(dim(data)[legend.dim])) + } else if (inherits(legend.breaks, 'list')) { + stopifnot(length(legend.breaks) == as.numeric(dim(data)[legend.dim])) + } else { + stop("Parameter 'legend.breaks' must be a numeric vector, a list or NULL.") + } + ## Check plot.legend + if (!inherits(plot.legend, 'logical')) { + stop("Parameter 'plot.legend' must be a logical value.") + } + ## Check label.scale + if (is.null(label.scale)) { + label.scale <- 1.4 + } else { + if (!is.numeric(label.scale) | length(label.scale) != 1) { + stop("Parameter 'label.scale' must be a numeric value of length 1.") + } + } + ## Check legend.width + if (is.null(legend.width)) { + legend.width <- length(subcol.names) * 46.5 + } else { + if (!is.numeric(legend.width) | length(legend.width) != 1) { + stop("Parameter 'legend.width' must be a numeric value of length 1.") + } + } + if (is.null(legend.height)) { + legend.height <- 50 + } else { + if (!is.numeric(legend.height) | length(legend.height) != 1) { + stop("Parameter 'legend.height' must be a numeric value of length 1.") + } + } + ## Check colour palette input + if (is.vector(palette)) { + palette <- rep(list(palette), as.numeric(dim(data)[legend.dim])) + } else if (is.null(palette)) { + palette <- rep(list(c('#2D004B', '#542789', '#8073AC', '#B2ABD2', '#D8DAEB', + '#FEE0B6', '#FDB863', '#E08214', '#B35806', '#7F3B08')), + as.numeric(dim(data)[legend.dim])) + } else if (inherits(palette, 'list')) { + stopifnot(length(palette) == as.numeric(dim(data)[legend.dim])) + } else { + stop("Parameter 'palette' must be a numeric vector, a list or NULL.") + } + ## Check colorunder + if (is.null(colorunder)) { + colorunder <- rep("#04040E",as.numeric(dim(data)[legend.dim])) + } else if (is.character(colorunder) && length(colorunder) == 1) { + colorunder <- rep(colorunder, as.numeric(dim(data)[legend.dim])) + } else if (is.character(colorunder) && + length(colorunder) != as.numeric(dim(data)[legend.dim])) { + stop("Parameter 'colorunder' must be a numeric vector, a list or NULL.") + } + ## Check colorsup + if (is.null(colorsup)) { + colorsup <- rep("#730C04", as.numeric(dim(data)[legend.dim])) + } else if (is.character(colorsup) && length(colorsup) == 1) { + colorsup <- rep(colorsup,as.numeric(dim(data)[legend.dim])) + } else if (is.character(colorsup) && + length(colorsup) != as.numeric(dim(data)[legend.dim])) { + stop("Parameter 'colorsup' must be a numeric vector, a list or NULL.") + } + ## Check round.decimal + if (is.null(round.decimal)) { + round.decimal <- 2 + } else if (!is.numeric(round.decimal) | length(round.decimal) != 1) { + stop("Parameter 'round.decimal' must be a numeric value of length 1.") + } + ## Check font.size + if (is.null(font.size)) { + font.size <- 1 + } else if (!is.numeric(font.size) | length(font.size) != 1) { + stop("Parameter 'font.size' must be a numeric value of length 1.") + } + ## Check legend white space + if (is.null(legend.white.space)){ + legend.white.space <- 6 + } else { + legend.white.space <- legend.white.space + } + ## Check col1.width + if (is.null(col1.width)) { + if (max(nchar(row.names)) == 1 ) { + col1.width <- max(nchar(row.names)) + } else { + col1.width <- max(nchar(row.names))/4 + } + } else if (!is.numeric(col1.width)) { + stop("Parameter 'col1.width' must be a numeric value of length 1.") + } + ## Check col2.width + if (is.null(col2.width)) { + if (max(nchar(subrow.names)) == 1 ) { + col2.width <- max(nchar(subrow.names)) + } else { + col2.width <- max(nchar(subrow.names))/4 + } + } else if (!is.numeric(col2.width)) { + stop("Parameter 'col2.width' must be a numeric value of length 1.") + } + + + # Get dimensions of inputs + n.col.names <- length(col.names) + n.subcol.names <- length(subcol.names) + n.row.names <- length(row.names) + n.subrow.names <- length(subrow.names) + + # Define table size + n.rows <- n.row.names * n.subrow.names + n.columns <- 2 + (n.col.names * n.subcol.names) + + # Column names + row.names.table <- rep("", n.rows) + for (row in 1:n.row.names) { + row.names.table[floor(n.subrow.names/2) + (row - 1) * n.subrow.names] <- row.names[row] + } + + # Define scorecard table titles + column.titles <- c(row.title, subrow.title, rep(c(subcol.names), n.col.names)) + + # Round data + data <- round(data, round.decimal) + + # Define data inside the scorecards table + for (row in 1:n.row.names) { + table_temp <- data.frame(table_column_2 = as.character(subrow.names)) + for (col in 1:n.col.names) { + table_temp <- data.frame(table_temp, + Reorder(data = Subset(x = data, along = c(col.dim, row.dim), + indices = list(col, row), drop = 'selected'), + order = c(subrow.dim, subcol.dim))) + } + if (row == 1) { + table_data <- table_temp + } else { + table_data <- rbind(table_data, table_temp) + } + } + + # All data for plotting in table + table <- data.frame(table_column_1 = row.names.table, table_data) + table_temp <- array(unlist(table[3:n.columns]), dim = c(n.rows, n.columns - 2)) + # Define colors to show in table + table_colors <- .SCTableColors(table = table_temp, n.col = n.col.names, + n.subcol = n.subcol.names, n.row = n.row.names, + n.subrow = n.subrow.names, legend.breaks = legend.breaks, + palette = palette, colorunder = colorunder, + colorsup = colorsup) + metric.color <- table_colors$metric.color + metric.text.color <- table_colors$metric.text.color + # metric.text.bold <- table_colors$metric.text.bold + + options(stringsAsFactors = FALSE) + title <- data.frame(c1 = table.title, c2 = n.columns) + subtitle <- data.frame(c1 = table.subtitle, c2 = n.columns) + header.names <- as.data.frame(data.frame(c1 = c("", col.names), + c2 = c(2, rep(n.subcol.names, n.col.names)))) + header.names2 <- as.data.frame(data.frame(c1 = c("", paste0(rep(col.title, n.col.names))), + c2 = c(2, rep(n.subcol.names, n.col.names)))) + title.space <- data.frame(c1 = "\n", c2 = n.columns) + + # Hide NA values in table + options(knitr.kable.NA = '') + + # Create HTML table + table.html.part <- list() + table.html.part[[1]] <- kbl(table, escape = F, col.names = column.titles, align = rep("c", n.columns)) %>% + kable_paper("hover", full_width = F, font_size = 14 * font.size) %>% + add_header_above(header = header.names2, font_size = 16 * font.size) %>% + add_header_above(header = title.space, font_size = 10 * font.size) %>% + add_header_above(header = header.names, font_size = 20 * font.size) %>% + add_header_above(header = title.space, font_size = 10 * font.size) %>% + add_header_above(header = subtitle, font_size = 16 * font.size, align = "left") %>% + add_header_above(header = title.space, font_size = 10 * font.size) %>% + add_header_above(header = title, font_size = 22 * font.size, align = "left") + + for (i in 1:n.col.names) { + for (j in 1:n.subcol.names) { + my.background <- metric.color[, (i - 1) * n.subcol.names + j] + my.text.color <- metric.text.color[, (i - 1) * n.subcol.names + j] + # my.bold <- metric.text.bold[(i - 1) * n.subcol.names + j] + + table.html.part[[(i - 1) * n.subcol.names + j + 1]] <- + column_spec(table.html.part[[(i - 1) * n.subcol.names + j]], + 2 + n.subcol.names * (i - 1) + j, + background = my.background[1:n.rows], + color = my.text.color[1:n.rows], + bold = T) ## strsplit(toString(bold), ', ')[[1]] + } + } + + # Define position of table borders + column.borders <- NULL + for (i in 1:n.col.names) { + column.spacing <- (n.subcol.names * i) + 2 + column.borders <- c(column.borders, column.spacing) + } + + n.last.list <- n.col.names * n.subcol.names + 1 + + table.html <- column_spec(table.html.part[[n.last.list]], 1, bold = TRUE, width_min = paste0(col1.width, 'cm')) %>% + column_spec(2, bold = TRUE, width_min = paste0(col2.width, 'cm')) %>% + column_spec(3:n.columns, width_min = "1.2cm") %>% + column_spec(c(1, 2, column.borders), border_right = "2px solid black") %>% + column_spec(1, border_left = "2px solid black") %>% + column_spec(n.columns, border_right = "2px solid black") %>% + row_spec(seq(from = 0, to = n.subrow.names * n.row.names, by = n.subrow.names), + extra_css = "border-bottom: 2px solid black", hline_after = TRUE) + + if (plot.legend == TRUE) { + # Save the scorecard (without legend) + save_kable(table.html, file = paste0(fileout, '_tmpScorecard.png'), vheight = 1) + + # White space for legend + legend.white.space <- 37.8 * legend.white.space ## converting pixels to cm + + # Create and save color bar legend + scorecard_legend <- .SCLegend(legend.breaks = legend.breaks, + palette = palette, + colorunder = colorunder, + colorsup = colorsup, + label.scale = label.scale, + legend.width = legend.width, + legend.height = legend.height, + legend.white.space = legend.white.space, + fileout = fileout) + + # Add the legends below the scorecard table + system(paste0('convert -append ', fileout, '_tmpScorecard.png ', fileout, + '_tmpScorecardLegend.png ', fileout)) + # Remove temporary scorecard table + unlink(paste0(fileout, '_tmpScorecard*.png')) + } + if (plot.legend == FALSE) { + save_kable(table.html, file = fileout) + } +} diff --git a/modules/Scorecards/tmp/SCTransform.R b/modules/Scorecards/tmp/SCTransform.R new file mode 100644 index 00000000..585e7576 --- /dev/null +++ b/modules/Scorecards/tmp/SCTransform.R @@ -0,0 +1,42 @@ +#' Scorecards spatially transform calculated means +#' +#'@description Scorecards function to spatially transform the layout of the +#'calculated metric means, to show 'Target Month' instead of 'Start Date'. +#' +#'@param data A multidimensional array of spatially aggregated data containing +#' the following dimensions; system, reference, metric, time, sdate, region. +#'@param sdate_dim A character name referring to the dimension of start date +#' in the array aggregated_metrics. +#'@param ftime_dim A character name referring to the dimension of forecast +#' time in the array aggregated_metrics. +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. It is NULL by default (1 core). +#' +#'@example +#'transformed_data <- SCTransform(data = aggregated_metrics, +#' sdate_dim = 'sdate', +#' ftime_dim = 'time') +#'@import multiApply +#'@importFrom s2dv Reorder +#'@export +SCTransform <- function(data, + sdate_dim, + ftime_dim, + ncores = NULL) { + + output <- multiApply::Apply(data = data, + target_dims = c(ftime_dim, sdate_dim), + fun = .SCTransform, + ncores = ncores)$output1 + + return(Reorder(data = output, order = names(dim(data)))) +} + +.SCTransform <- function(data) { + output <- data + n_sdates <- dim(data)[sdate_dim] + for (i in 2:dim(data)[ftime_dim]) { + output[i, ] <- data[i, c((n_sdates - i + 2):n_sdates, 1:(n_sdates - i + 1))] + } + return(output) +} diff --git a/modules/Scorecards/tmp/ScorecardsMulti.R b/modules/Scorecards/tmp/ScorecardsMulti.R new file mode 100644 index 00000000..89f1df44 --- /dev/null +++ b/modules/Scorecards/tmp/ScorecardsMulti.R @@ -0,0 +1,360 @@ +#'Function to create all multi system/reference scorecards +#' +#'@description Scorecards function to create scorecard tables for multiple systems +#' and references (types 9 to 12). +#'@param input_data is an array of spatially aggregated metrics containing the +#' following dimensions; system, reference, metric, time, sdate, region. +#'@param system a vector of character strings defining the systems following the +#' archive.yml format from verification suite +#'@param reference a vector of character strings defining the references +#' following the archive.yml format from verification suite +#'@param var a character string following the format from +#' variable-dictionary.yml from verification suite +#'@param start.year a numeric indicating the start year of the reference period +#'@param end.year a numeric indicating the end year of the reference period +#'@param start.date a vector of character strings indicating the start months +#'@param forecast.month a vector of numeric indicating the forecast months +#'@param region.names a vector of character strings containing names of the +#' regions corresponding to the input data +#'@param metrics a vector of character strings containing the metrics. +#'@param table.label a character string containing additional information to +#' include in the scorecard title +#'@param fileout.label a character string containing additional information to +#' include in the output png file when saving the scorecard. +#'@param output.path a path of the location to save the scorecard plots. +#' +#'@return +#' This function returns 4 scorecard images for each region requested, the +#' images are saved in the directory output.path. + +#'@example +#' scorecard_multi <- ScorecardsMulti(data = aggregated_metrics, +#' system.name = c('ECMWF-SEAS5','DWD-GFCS2.1'), +#' reference.name = 'ERA5', +#' var = 'tas', +#' start.year = 1993, +#' end.year = 2016, +#' start.months = 1:12, +#' forecast.months = 1:6, +#' region.names = c('Tropics', 'Extra-tropical NH', 'Extra-tropical SH') +#' metrics = c('mean_bias', 'enscorr', 'rpss','crpss', 'enssprerr'), +#' table.label = '(Interpolation = to system, Aggregation level = skill, Cross-validation = terciles)', +#' fileout.label = '_crossval-terciles_agg-skill', +#' output.path = '/esarchive/scratch/nmilders/scorecards_images/testing' +#' ) + + +ScorecardsMulti <- function(data, + system, + reference, + var, + start.year, + end.year, + start.months, + forecast.months, + region.names, + metrics, + table.label, + fileout.label, + output.path){ + + ## Checks to apply: + # first dimension in aggregated_metrics is system and second dimension is reference + # either multi-system and one reference, or multi-reference and one system + + ## Initial checks + if (is.null(table.label)){ + table.label <- "" + } + if (is.null(fileout.label)){ + fileout.label <- "" + } + + ## Make sure input_data is in correct order for using in functions: + data_order <- c('system','reference','metric','time','sdate','region') + data <- Reorder(data, data_order) + + ## Identify metrics loaded + metrics_loaded <- attributes(data)$metrics + + ## Select only the metrics to visualize from data + input_data <- Subset(data, along = 'metric', indices = match(metrics, metrics_loaded)) + attributes(input_data)$metrics <- metrics + + ## Transform data for scorecards by forecast month (types 11 & 12) + transformed_data <- SCTransform(data = input_data, + sdate_dim = 'sdate', + ftime_dim = 'time') + + ## Load configuration files + sys_dict <- read_yaml("/esarchive/scratch/nmilders/gitlab/git_clones/s2s-suite/conf/archive.yml")$esarchive + var_dict <- read_yaml("/esarchive/scratch/nmilders/gitlab/git_clones/csscorecards/inst/config/variable-dictionary.yml")$vars + + ## Get scorecards table display names from configuration files + var.name <- var_dict[[var]]$long_name + var.units <- var_dict[[var]]$units + + system.name <- NULL + reference.name <- NULL + + for(sys in 1:length(system)){ + system.name1 <- sys_dict$System[[system[sys]]]$name + system.name <- c(system.name, system.name1) + } + for(ref in 1:length(length)){ + reference.name1 <- sys_dict$Reference[[reference[ref]]]$name + reference.name <- c(reference.name, reference.name1) + } + + ## Get metric long names + metric.names.list <- .met_names(metrics, var.units) + + ## format the metric names as character instead of list + for(met in metrics){ + if(met == metrics[1]){ + metric.names <- metric.names.list[[met]] + } else { + metric.names <- c(metric.names, metric.names.list[[met]]) + } + } + + ## Define parameters depending on Multi-system or Multi-reference + if(length(system) > 1 && length(reference) == 1){ + model <- 'system' + table.model.name <- 'System' + model.name <- system.name + eval.label <- 'Ref' + eval.name <- reference.name + eval.filename <- reference + } else if(length(system) == 1 && length(reference) > 1){ + model <- 'reference' + table.model.name <- 'Reference' + model.name <- reference.name + eval.label <- 'Sys' + eval.name <- system.name + eval.filename <- system + } else {stop('Not multi system or multi reference')} + + ## Define table colors + palette <- c('#2D004B', '#542789', '#8073AC', '#B2ABD2', '#D8DAEB', '#FEE0B6', '#FDB863', '#E08214', '#B35806', '#7F3B08') + colorunder <- "#04040E" + colorsup <- "#730C04" + + ## Legend lower limit color + legend.col.inf <- .legend_col_inf(metrics, colorunder) + legend.col.inf <- legend.col.inf[metrics] + + ## Legend upper limit color + legend.col.sup <- .legend_col_sup(metrics, colorsup) + legend.col.sup <- legend.col.sup[metrics] + + ## Legend inputs + plot.legend = TRUE + label.scale = 1.4 + legend.width = 555 + legend.height = 50 + + ## Data display inputs + round.decimal = 2 + font.size = 1.1 + + legend.white.space <- col1.width <- col2.width <- NULL ## Use default values of function + + ## Loop over region + for(reg in 1:length(region.names)){ + + breaks_bias <- NULL + + ## Find position of mean bias metric to calculate breaks + if ('mean_bias' %in% metrics) { + pos_bias <- which(metrics == 'mean_bias') + if(var == 'psl'){ + data[,,pos_bias,,,] <- data[,,pos_bias,,,]/100 ## temporary + } + breaks_bias <- .SCBiasBreaks(Subset(data, along = c('metric','region'), + indices = list(pos_bias,reg))) + } + + ## Define breaks for each metric based of metric position: + legend.breaks <- .met_breaks(metrics, breaks_bias) + + ## Define scorecard titles + table.title <- paste0(var.name, ". Region: ", region.names[reg], " ", table.label) + table.subtitle <- paste0("(", eval.label, ": ", eval.name, " ", start.year, "-", end.year, ")") + + + #### Scorecard_type 9 #### + ## (no transformation or reorder) + fileout <- .Filename(model = model, eval.name = eval.filename, var = var, + start.year = start.year, end.year = end.year, scorecard.type = 9, + region = sub(" ", "-", region.names[reg]), + fileout.label = fileout.label, output.path = output.path) + if(model == 'system'){ + data_sc_9 <- Subset(input_data, c('reference','region'), list(1, reg), drop = 'selected') + } else if(model == 'reference'){ + data_sc_9 <- Subset(input_data, c('system','region'), list(1, reg), drop = 'selected') + } + SCPlotScorecard(data = data_sc_9, + row.dim = model, + subrow.dim = 'time', + col.dim = 'metric', + subcol.dim = 'sdate', + legend.dim = 'metric', + row.names = model.name, + subrow.names = forecast.months, + col.names = metric.names, + subcol.names = month.abb[as.numeric(start.months)], + table.title = table.title, + table.subtitle = table.subtitle, + row.title = table.model.name, + subrow.title = 'Forecast Month', + col.title = 'Start date', + legend.breaks = legend.breaks, + plot.legend = plot.legend, + label.scale = label.scale, + legend.width = legend.width, + legend.height = legend.height, + palette = palette, + colorunder = legend.col.inf, + colorsup = legend.col.sup, + round.decimal = round.decimal, + font.size = font.size, + legend.white.space = legend.white.space, + col1.width = 4, + col2.width = col2.width, + fileout = fileout) + + + #### Scorecard_type 10 #### + ## (reorder only) + fileout <- .Filename(model = model, eval.name = eval.filename, var = var, + start.year = start.year, end.year = end.year, scorecard.type = 10, + region = sub(" ", "-", region.names[reg]), + fileout.label = fileout.label, output.path = output.path) + new_order <- c('system', 'reference', 'metric', 'region','sdate', 'time') + if(model == 'system'){ + data_sc_10 <- Subset(Reorder(input_data, new_order), c('reference','region'), list(1, reg), drop = 'selected') + } else if(model == 'reference'){ + data_sc_10 <- Subset(Reorder(input_data, new_order), c('system','region'), list(1, reg), drop = 'selected') + } + SCPlotScorecard(data = data_sc_10, + row.dim = 'time', + subrow.dim = model, + col.dim = 'metric', + subcol.dim = 'sdate', + legend.dim = 'metric', + row.names = forecast.months, + subrow.names = model.name, + col.names = metric.names, + subcol.names = month.abb[as.numeric(start.months)], + table.title = table.title, + table.subtitle = table.subtitle, + row.title = 'Forecast month', + subrow.title = table.model.name, + col.title = 'Start date', + legend.breaks = legend.breaks, + plot.legend = plot.legend, + label.scale = label.scale, + legend.width = legend.width, + legend.height = legend.height, + palette = palette, + colorunder = legend.col.inf, + colorsup = legend.col.sup, + round.decimal = round.decimal, + font.size = font.size, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = 4, + fileout = fileout) + + + #### Scorecard_type 11 #### + ## (transformation only) + fileout <- .Filename(model = model, eval.name = eval.filename, var = var, + start.year = start.year, end.year = end.year, scorecard.type = 11, + region = sub(" ", "-", region.names[reg]), + fileout.label = fileout.label, output.path = output.path) + if(model == 'system'){ + data_sc_11 <- Subset(transformed_data, c('reference','region'), list(1, reg), drop = 'selected') + } else if(model == 'reference'){ + data_sc_11 <- Subset(transformed_data, c('system','region'), list(1, reg), drop = 'selected') + } + SCPlotScorecard(data = data_sc_11, + row.dim = model, + subrow.dim = 'time', + col.dim = 'metric', + subcol.dim = 'sdate', + legend.dim = 'metric', + row.names = model.name, + subrow.names = forecast.months, + col.names = metric.names, + subcol.names = month.abb[as.numeric(start.months)], + table.title = table.title, + table.subtitle = table.subtitle, + row.title = table.model.name, + subrow.title = 'Forecast Month', + col.title = 'Target month', + legend.breaks = legend.breaks, + plot.legend = plot.legend, + label.scale = label.scale, + legend.width = legend.width, + legend.height = legend.height, + palette = palette, + colorunder = legend.col.inf, + colorsup = legend.col.sup, + round.decimal = round.decimal, + font.size = font.size, + legend.white.space = legend.white.space, + col1.width = 4, + col2.width = col2.width, + fileout = fileout) + + + #### Scorecard_type 12 #### + ## (transformation and reorder) + fileout <- .Filename(model = model, eval.name = eval.filename, var = var, + start.year = start.year, end.year = end.year, scorecard.type = 12, + region = sub(" ", "-", region.names[reg]), + fileout.label = fileout.label, output.path = output.path) + new_order <- c('system', 'reference', 'metric', 'region','sdate', 'time') + if(model == 'system'){ + data_sc_12 <- Subset(Reorder(transformed_data, new_order), c('reference','region'), list(1, reg), drop = 'selected') + } else if(model == 'reference'){ + data_sc_12 <- Subset(Reorder(transformed_data, new_order), c('system','region'), list(1, reg), drop = 'selected') + } + SCPlotScorecard(data = data_sc_12, + row.dim = 'time', + subrow.dim = model, + col.dim = 'metric', + subcol.dim = 'sdate', + legend.dim = 'metric', + row.names = forecast.months, + subrow.names = model.name, + col.names = metric.names, + subcol.names = month.abb[as.numeric(start.months)], + table.title = table.title, + table.subtitle = table.subtitle, + row.title = 'Forecast Month', + subrow.title = table.model.name, + col.title = 'Target month', + legend.breaks = legend.breaks, + plot.legend = plot.legend, + label.scale = label.scale, + legend.width = legend.width, + legend.height = legend.height, + palette = palette, + colorunder = legend.col.inf, + colorsup = legend.col.sup, + round.decimal = round.decimal, + font.size = font.size, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = 4, + fileout = fileout) + + } ## close loop on region + + print("All multi scorecard plots created") + +} ## close function + diff --git a/modules/Scorecards/tmp/ScorecardsSingle.R b/modules/Scorecards/tmp/ScorecardsSingle.R new file mode 100644 index 00000000..56f08204 --- /dev/null +++ b/modules/Scorecards/tmp/ScorecardsSingle.R @@ -0,0 +1,343 @@ +#'Function to create all single system/reference scorecards +#' +#'@description Scorecards function to create scorecard tables for one system and +#' one reference combination (types 1 to 4). +#'@param input_data is an array of spatially aggregated metrics containing the +#' following dimensions; system, reference, metric, time, sdate, region. +#'@param system a vector of character strings defining the systems following the +#' archive.yml format from verification suite +#'@param reference a vector of character strings defining the references +#' following the archive.yml format from verification suite +#'@param var a character string following the format from +#' variable-dictionary.yml from verification suite +#'@param start.year a numeric indicating the start year of the reference period +#'@param end.year a numeric indicating the end year of the reference period +#'@param start.date a vector of character strings indicating the start months +#'@param forecast.month a vector of numeric indicating the forecast months +#'@param region.names a vector of character strings containing names of the +#' regions corresponding to the input data +#'@param metrics a vector of character strings containing the metrics. +#'@param table.label a character string containing additional information to +#' include in the scorecard title +#'@param fileout.label a character string containing additional information to +#' include in the output png file when saving the scorecard. +#'@param output.path a path of the location to save the scorecard plots +#' +#'@return +#' This function returns 4 scorecards images, saved in the directory output.path +#'@examples +#' scorecard_single <- ScorecardsSingle(data = aggregated_metrics, +#' system.name = c('ECMWF-SEAS5','DWD-GFCS2.1'), +#' reference.name = 'ERA5', +#' var = 'tas', +#' start.year = 1993, +#' end.year = 2016, +#' start.months = 1:12, +#' forecast.months = 1:6, +#' region.names = c('Tropics', 'Extra-tropical NH', 'Extra-tropical SH') +#' metrics = c('mean_bias', 'enscorr', 'rpss','crpss', 'enssprerr'), +#' table.label = '(Interpolation = to system, Aggregation level = skill, Cross-validation = terciles)', +#' fileout.label = '_crossval-terciles_agg-skill', +#' output.path = '/esarchive/scratch/nmilders/scorecards_images/test' +#' ) +#'@export +ScorecardsSingle <- function(data, system, reference, var, start.year, end.year, + start.months, forecast.months, region.names, + metrics, legend.breaks = NULL, + table.label = NULL, fileout.label = NULL, + legend.white.space = NULL, + col1.width = NULL, col2.width = NULL, + output.path){ + + ## Checks to apply: + # First dimension in aggregated_metrics is system and second dimension is reference + # To allow 1 region - if region = 1 --> only scorecards 1 & 3 need to be plotted + # If any dimension of input dat is 1, make sure dimension is still present in array + + ## Initial checks + # data + if (!is.array(data)) { + stop("Parameter 'data' must be an array with named dimensions.") + } + if (!is.array(data)) { + stop("Parameter 'data' must be an array with named dimensions.") + } + if (is.null(names(dim(data)))) { + stop("Parameter 'data' must have dimenision names.") + } + if (!all(c('system','reference','metric','time','sdate','region') %in% + names(dim(data)))) { + stop("Dimension names of 'data' must be: 'system','reference','metric', + 'time','sdate','region'.") + } + if (is.null(table.label)){ + table.label <- "" + } + if (is.null(fileout.label)){ + fileout.label <- "" + } + + ## Make sure input_data is in correct order for using in functions: + data_order <- c('system', 'reference', 'metric', 'time', 'sdate', 'region') + data <- Reorder(data, data_order) + + ## Identify metrics loaded + metrics_loaded <- attributes(data)$metrics + + ## Select only the metrics to visualize from data + input_data <- Subset(data, along = 'metric', indices = match(metrics, metrics_loaded)) + attributes(input_data)$metrics <- metrics + + ## Transform data for scorecards by forecast month (types 3 & 4) + transformed_data <- SCTransform(data = input_data, + sdate_dim = 'sdate', + ftime_dim = 'time') + + ## Load configuration files + sys_dict <- read_yaml("/esarchive/scratch/nmilders/gitlab/git_clones/s2s-suite/conf/archive.yml")$esarchive + var_dict <- read_yaml("/esarchive/scratch/nmilders/gitlab/git_clones/csscorecards/inst/config/variable-dictionary.yml")$vars + + ## Get scorecards table display names from configuration files + var.name <- var_dict[[var]]$long_name + var.units <- var_dict[[var]]$units + + ## Get metric long names + metric.names.list <- .met_names(metrics, var.units) + + ## format the metric names as character instead of list + for(met in metrics){ + if(met == metrics[1]){ + metric.names <- metric.names.list[[met]] + } else { + metric.names <- c(metric.names, metric.names.list[[met]]) + } + } + + ## Define table colors + palette <- c('#2D004B', '#542789', '#8073AC', '#B2ABD2', '#D8DAEB', '#FEE0B6', '#FDB863', '#E08214', '#B35806', '#7F3B08') + colorunder <- "#04040E" + colorsup <- "#730C04" + + ## Legend lower limit color + legend.col.inf <- .legend_col_inf(metrics, colorunder) + legend.col.inf <- legend.col.inf[metrics] + + ## Legend upper limit color + legend.col.sup <- .legend_col_sup(metrics, colorsup) + legend.col.sup <- legend.col.sup[metrics] + + ## Legend inputs + plot.legend = TRUE + label.scale = 1.4 + legend.width = 555 + legend.height = 50 + + ## Data display inputs + round.decimal = 2 + font.size = 1.1 + + ## Loop over system and reference for each scorecard plot + for (sys in 1:dim(input_data)['system']) { + for (ref in 1:dim(input_data)['reference']) { + + ## TO DO: Apply check to each scorecard function + ## check dimension 'metric' exists: + if (!("metric" %in% names(dim(input_data)))) { + dim(input_data) <- c(metric = 1, dim(input_data)) + } + + ## Find position of mean bias metric to calculate breaks + breaks_bias <- NULL + if ('mean_bias' %in% metrics){ + stopifnot(identical(names(dim(Subset(input_data, c('system', 'reference'), list(sys, ref), drop = 'selected'))), c('metric','time','sdate','region'))) + temp_data <- Subset(input_data, c('system', 'reference'), list(sys, ref), drop = 'selected') + pos_bias <- which(metrics == 'mean_bias') + if(var == 'psl'){ + temp_data[pos_bias,,,] <- temp_data[pos_bias,,,]/100 + } + breaks_bias <- .SCBiasBreaks(Subset(temp_data, along = 'metric', + indices = pos_bias)) + } + + ## Define breaks for each metric based of metric position: + legend.breaks <- .met_breaks(metrics, breaks_bias) + + ## Put breaks in same order as metrics + legend.breaks <- legend.breaks[metrics] + + ## Get scorecards table display names from configuration files + system.name <- sys_dict$System[[system[sys]]]$name + reference.name <- sys_dict$Reference[[reference[ref]]]$name + + ## Define scorecard titles + table.title <- paste0(var.name, " of ", system.name, " ", table.label) + table.subtitle <- paste0("(Ref: ", reference.name, " ", start.year, "-", end.year, ")") + + ############################################################################# + + #### Scorecard_type 1 #### + ## (no transformation or reorder) + fileout <- .Filename(system = system[sys], reference = reference[ref], var = var, + start.year = start.year, end.year = end.year, scorecard.type = 1, + fileout.label = fileout.label, output.path = output.path) + data_sc_1 <- Subset(input_data, c('system', 'reference'), list(sys, ref), drop = 'selected') + SCPlotScorecard(data = data_sc_1, + row.dim = 'region', + subrow.dim = 'time', + col.dim = 'metric', + subcol.dim = 'sdate', + legend.dim = 'metric', + row.names = region.names, + subrow.names = forecast.months, + col.names = metric.names, + subcol.names = month.abb[as.numeric(start.months)], + table.title = table.title, + table.subtitle = table.subtitle, + row.title = 'Region', + subrow.title = 'Forecast Month', + col.title = 'Start date', + legend.breaks = legend.breaks, + plot.legend = plot.legend, + label.scale = label.scale, + legend.width = legend.width, + legend.height = legend.height, + palette = palette, + colorunder = legend.col.inf, + colorsup = legend.col.sup, + round.decimal = round.decimal, + font.size = font.size, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + fileout = fileout) + + + #### Scorecard_type 2 #### + ## (reorder only) + ## Scorecard type 2 is same as type 1 for only one region, therefore is + ## only plotted if more that one region is requested + if(dim(input_data)['region'] > 1) { + fileout <- .Filename(system = system[sys], reference = reference[ref], var = var, + start.year = start.year, end.year = end.year, scorecard.type = 2, + fileout.label = fileout.label, output.path = output.path) + new_order <- c('metric', 'region', 'sdate', 'time') + data_sc_2 <- Reorder(Subset(input_data, c('system', 'reference'), list(sys, ref), drop = 'selected'), new_order) + SCPlotScorecard(data = data_sc_2, + row.dim = 'time', + subrow.dim = 'region', + col.dim = 'metric', + subcol.dim = 'sdate', + legend.dim = 'metric', + row.names = forecast.months, + subrow.names = region.names, + col.names = metric.names, + subcol.names = month.abb[as.numeric(start.months)], + table.title = table.title, + table.subtitle = table.subtitle, + row.title = 'Forecast Month', + subrow.title = 'Region', + col.title = 'Start date', + legend.breaks = legend.breaks, + plot.legend = plot.legend, + label.scale = label.scale, + legend.width = legend.width, + legend.height = legend.height, + palette = palette, + colorunder = legend.col.inf, + colorsup = legend.col.sup, + round.decimal = round.decimal, + font.size = font.size, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + fileout = fileout) + } ## close if + + + #### Scorecard_type 3 #### + ## (transformation only) + fileout <- .Filename(system = system[sys], reference = reference[ref], var = var, + start.year = start.year, end.year = end.year, scorecard.type = 3, + fileout.label = fileout.label, output.path = output.path) + data_sc_3 <- Subset(transformed_data, c('system', 'reference'), list(sys, ref), drop = 'selected') + SCPlotScorecard(data = data_sc_3, + row.dim = 'region', + subrow.dim = 'time', + col.dim = 'metric', + subcol.dim = 'sdate', + legend.dim = 'metric', + row.names = region.names, + subrow.names = forecast.months, + col.names = metric.names, + subcol.names = month.abb[as.numeric(start.months)], + table.title = table.title, + table.subtitle = table.subtitle, + row.title = 'Region', + subrow.title = 'Forecast Month', + col.title = 'Target month', + legend.breaks = legend.breaks, + plot.legend = plot.legend, + label.scale = label.scale, + legend.width = legend.width, + legend.height = legend.height, + palette = palette, + colorunder = legend.col.inf, + colorsup = legend.col.sup, + round.decimal = round.decimal, + font.size = font.size, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + fileout = fileout) + + + #### Scorecard_type 4 #### + ## (transformation and reorder) + ## Scorecard type 4 is same as type 3 for only one region, therefore is + ## only plotted if more that one region is requested + if(dim(input_data)['region'] > 1) { + fileout <- .Filename(system = system[sys], reference = reference[ref], var = var, + start.year = start.year, end.year = end.year, scorecard.type = 4, + fileout.label = fileout.label, output.path = output.path) + new_order <- c('metric', 'region', 'sdate', 'time') + data_sc_4 <- Reorder(Subset(transformed_data, c('system', 'reference'), list(sys, ref), drop = 'selected'), new_order) + SCPlotScorecard(data = data_sc_4, + row.dim = 'time', + subrow.dim = 'region', + col.dim = 'metric', + subcol.dim = 'sdate', + legend.dim = 'metric', + row.names = forecast.months, + subrow.names = region.names, + col.names = metric.names, + subcol.names = month.abb[as.numeric(start.months)], + table.title = table.title, + table.subtitle = table.subtitle, + row.title = 'Forecast Month', + subrow.title = 'Region', + col.title = 'Target month', + legend.breaks = legend.breaks, + plot.legend = plot.legend, + label.scale = label.scale, + legend.width = legend.width, + legend.height = legend.height, + palette = palette, + colorunder = legend.col.inf, + colorsup = legend.col.sup, + round.decimal = round.decimal, + font.size = font.size, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + fileout = fileout) + } ## close if + + } ## close loop on ref + } ## close loop on sys + + print("All single system scorecard plots created") + +} ## close function + + + diff --git a/modules/Scorecards/tmp/ScorecardsSystemDiff.R b/modules/Scorecards/tmp/ScorecardsSystemDiff.R new file mode 100644 index 00000000..a19b1651 --- /dev/null +++ b/modules/Scorecards/tmp/ScorecardsSystemDiff.R @@ -0,0 +1,350 @@ +#'Function to create all multi system/reference scorecards +#' +#'@description Scorecards function to create scorecard tables for multiple systems +#' and references (types 9 to 12). +#'@param input_data is an array of spatially aggregated metrics containing the +#' following dimensions; system, reference, metric, time, sdate, region. +#'@param system a vector of character strings defining the systems following the +#' archive.yml format from verification suite +#'@param reference a vector of character strings defining the references +#' following the archive.yml format from verification suite +#'@param var a character string following the format from +#' variable-dictionary.yml from verification suite +#'@param start.year a numeric indicating the start year of the reference period +#'@param end.year a numeric indicating the end year of the reference period +#'@param start.date a vector of character strings indicating the start months +#'@param forecast.month a vector of numeric indicating the forecast months +#'@param region.names a vector of character strings containing names of the +#' regions corresponding to the input data +#'@param metrics a vector of character strings containing the metrics. +#'@param table.label a character string containing additional information to +#' include in the scorecard title +#'@param fileout.label a character string containing additional information to +#' include in the output png file when saving the scorecard. +#'@param output.path a path of the location to save the scorecard plots. +#' +#'@return +#' This function returns 4 scorecard images for each region requested, the +#' images are saved in the directory output.path. + +#'@example +#' scorecard_diff <- ScorecardsDiff(data = aggregated_metrics, +#' system.name = c('ECMWF-SEAS5','DWD-GFCS2.1'), +#' reference.name = 'ERA5', +#' var = 'tas', +#' start.year = 1993, +#' end.year = 2016, +#' start.months = 1:12, +#' forecast.months = 1:6, +#' region.names = c('Tropics', 'Extra-tropical NH', 'Extra-tropical SH') +#' metrics = c('mean_bias', 'enscorr', 'rpss','crpss', 'enssprerr'), +#' table.label = '(Interpolation = to system, Aggregation level = skill, Cross-validation = terciles)', +#' fileout.label = '_crossval-terciles_agg-skill', +#' output.path = '/esarchive/scratch/nmilders/scorecards_images/testing' +#' ) + + +ScorecardsSystemDiff <- function(data, + system, + reference, + var, + start.year, + end.year, + start.months, + forecast.months, + region.names, + metrics, + table.label = NULL, + fileout.label = NULL, + legend.white.space = NULL, + col1.width = NULL, + col2.width = NULL, + output.path){ + + ## Checks to apply: + # first dimension in aggregated_metrics is system and second dimension is reference + # either multi-system and one reference, or multi-reference and one system + + ## Initial checks + if (is.null(table.label)){ + table.label <- "" + } + if (is.null(fileout.label)){ + fileout.label <- "" + } + + ## Make sure input_data is in correct order for using in functions: + data_order <- c('system','reference','metric','time','sdate','region') + data <- Reorder(data, data_order) + + ## Identify metrics loaded + metrics_loaded <- attributes(data)$metrics + + ## Select only the metrics to visualize from data + input_data <- Subset(data, along = 'metric', indices = match(metrics, metrics_loaded)) + attributes(input_data)$metrics <- metrics + + ## Calculate difference between two systems/references + if(length(system) == 2 && length(reference) == 1){ + dataset1 <- Subset(input_data, c('system', 'reference'), list(1, 1), drop = 'selected') + dataset2 <- Subset(input_data, c('system', 'reference'), list(2, 1), drop = 'selected') + } + else if(length(system) == 1 && length(reference) == 2){ + dataset1 <- Subset(input_data, c('system', 'reference'), list(1, 1), drop = 'selected') + dataset2 <- Subset(input_data, c('system', 'reference'), list(1, 2), drop = 'selected') + } + + ## Calculate difference of mean_bias from 0 for each dataset + if ('mean_bias' %in% metrics){ + pos_bias <- which(metrics == 'mean_bias') + dataset1[pos_bias,,,] <- abs(dataset1[pos_bias,,,]) + dataset2[pos_bias,,,] <- abs(dataset2[pos_bias,,,]) + } + + ## Calculate difference of enssprerr from 1 for each dataset + if ('enssprerr' %in% metrics){ + pos_enssprerr <- which(metrics == 'enssprerr') + dataset1[pos_enssprerr,,,] <- abs(1-dataset1[pos_enssprerr,,,]) + dataset2[pos_enssprerr,,,] <- abs(1-dataset2[pos_enssprerr,,,]) + } + + diff_data <- dataset1 - dataset2 + + # Transform data for scorecards by forecast month (types 3 & 4) + transformed_data <- SCTransform(data = diff_data, + sdate_dim = 'sdate', + ftime_dim = 'time') + + ## Load configuration files + sys_dict <- read_yaml("/esarchive/scratch/nmilders/gitlab/git_clones/s2s-suite/conf/archive.yml")$esarchive + var_dict <- read_yaml("/esarchive/scratch/nmilders/gitlab/git_clones/csscorecards/inst/config/variable-dictionary.yml")$vars + + ## Get scorecards table display names from configuration files + var.name <- var_dict[[var]]$long_name + var.units <- var_dict[[var]]$units + + system.name <- NULL + reference.name <- NULL + + for(sys in 1:length(system)){ + system.name1 <- sys_dict$System[[system[sys]]]$name + system.name <- c(system.name, system.name1) + } + for(ref in 1:length(reference)){ + reference.name1 <- sys_dict$Reference[[reference[ref]]]$name + reference.name <- c(reference.name, reference.name1) + } + + ## Get metric long names + metric.names.list <- .met_names(metrics, var.units) + + ## format the metric names as character instead of list + for(met in metrics){ + if(met == metrics[1]){ + metric.names <- metric.names.list[[met]] + } else { + metric.names <- c(metric.names, metric.names.list[[met]]) + } + } + + ## Define parameters depending on system compariosn or reference comparison + if(length(system) > 1 && length(reference) == 1){ + comparison <- system + model <- 'system' + table.model.name <- 'System' + model.name <- system.name + eval.label <- 'Ref' + eval.name <- reference.name + eval.filename <- reference + } else if(length(system) == 1 && length(reference) > 1){ + comparison <- reference + model <- 'reference' + table.model.name <- 'Reference' + model.name <- reference.name + eval.label <- 'Sys' + eval.name <- system.name + eval.filename <- system + } else {stop('Not multi system or multi reference')} + + ## Define table colors + palette <- c('#2D004B', '#542789', '#8073AC', '#B2ABD2', '#D8DAEB', '#FEE0B6', '#FDB863', '#E08214', '#B35806', '#7F3B08') + colorunder <- "#04040E" + colorsup <- "#730C04" + + ## Legend inputs + plot.legend = TRUE + label.scale = 1.4 + legend.width = 555 + legend.height = 50 + + ## Data display inputs + round.decimal = 2 + font.size = 1.1 + + ## Define breaks for each metric based of metric position: + legend.breaks <- c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5) + + ## Define scorecard titles + table.title <- paste0(var.name, " - Difference: ", model.name[1], " - ", model.name[2], " ",table.label) + table.subtitle <- paste0("(", eval.label, ": ", eval.name, " ", start.year, "-", end.year, ")") + + #### Scorecard_type 1 #### + ## (no transformation or reorder) + + fileout <- .Filename(system = paste0("diff_",comparison[1],"_",comparison[2]), reference = eval.filename, var = var, + start.year = start.year, end.year = end.year, scorecard.type = 1, + fileout.label = fileout.label, output.path = output.path) + SCPlotScorecard(data = diff_data, + row.dim = 'region', + subrow.dim = 'time', + col.dim = 'metric', + subcol.dim = 'sdate', + legend.dim = 'metric', + row.names = region.names, + subrow.names = forecast.months, + col.names = metric.names, + subcol.names = month.abb[as.numeric(start.months)], + table.title = table.title, + table.subtitle = table.subtitle, + row.title = 'Region', + subrow.title = 'Forecast Month', + col.title = 'Start date', + legend.breaks = legend.breaks, + plot.legend = plot.legend, + label.scale = label.scale, + legend.width = legend.width, + legend.height = legend.height, + palette = palette, + colorunder = colorunder, + colorsup = colorsup, + round.decimal = round.decimal, + font.size = font.size, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + fileout = fileout) + + + #### Scorecard_type 2 #### + ## (reorder only) + ## Scorecard type 2 is same as type 1 for only one region, therefore is + ## only plotted if more that one region is requested + if(dim(input_data)['region'] > 1) { + fileout <- .Filename(system = paste0("diff_",comparison[1],"_",comparison[2]), reference = eval.filename, var = var, + start.year = start.year, end.year = end.year, scorecard.type = 2, + fileout.label = fileout.label, output.path = output.path) + new_order <- c('metric', 'region', 'sdate', 'time') + data_sc_2 <- Reorder(diff_data, new_order) + SCPlotScorecard(data = data_sc_2, + row.dim = 'time', + subrow.dim = 'region', + col.dim = 'metric', + subcol.dim = 'sdate', + legend.dim = 'metric', + row.names = forecast.months, + subrow.names = region.names, + col.names = metric.names, + subcol.names = month.abb[as.numeric(start.months)], + table.title = table.title, + table.subtitle = table.subtitle, + row.title = 'Forecast Month', + subrow.title = 'Region', + col.title = 'Start date', + legend.breaks = legend.breaks, + plot.legend = plot.legend, + label.scale = label.scale, + legend.width = legend.width, + legend.height = legend.height, + palette = palette, + colorunder = colorunder, + colorsup = colorsup, + round.decimal = round.decimal, + font.size = font.size, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + fileout = fileout) + } ## close if + + + #### Scorecard_type 3 #### + ## (transformation only) + fileout <- .Filename(system = paste0("diff_",comparison[1],"_",comparison[2]), reference = eval.filename, var = var, + start.year = start.year, end.year = end.year, scorecard.type = 3, + fileout.label = fileout.label, output.path = output.path) + SCPlotScorecard(data = transformed_data, + row.dim = 'region', + subrow.dim = 'time', + col.dim = 'metric', + subcol.dim = 'sdate', + legend.dim = 'metric', + row.names = region.names, + subrow.names = forecast.months, + col.names = metric.names, + subcol.names = month.abb[as.numeric(start.months)], + table.title = table.title, + table.subtitle = table.subtitle, + row.title = 'Region', + subrow.title = 'Forecast Month', + col.title = 'Target month', + legend.breaks = legend.breaks, + plot.legend = plot.legend, + label.scale = label.scale, + legend.width = legend.width, + legend.height = legend.height, + palette = palette, + colorunder = colorunder, + colorsup = colorsup, + round.decimal = round.decimal, + font.size = font.size, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + fileout = fileout) + + + #### Scorecard_type 4 #### + ## (transformation and reorder) + ## Scorecard type 4 is same as type 3 for only one region, therefore is + ## only plotted if more that one region is requested + if(dim(input_data)['region'] > 1) { + fileout <- .Filename(system = paste0("diff_",comparison[1],"_",comparison[2]), reference = eval.filename, var = var, + start.year = start.year, end.year = end.year, scorecard.type = 4, + fileout.label = fileout.label, output.path = output.path) + new_order <- c('metric', 'region', 'sdate', 'time') + data_sc_4 <- Reorder(transformed_data, new_order) + SCPlotScorecard(data = data_sc_4, + row.dim = 'time', + subrow.dim = 'region', + col.dim = 'metric', + subcol.dim = 'sdate', + legend.dim = 'metric', + row.names = forecast.months, + subrow.names = region.names, + col.names = metric.names, + subcol.names = month.abb[as.numeric(start.months)], + table.title = table.title, + table.subtitle = table.subtitle, + row.title = 'Forecast Month', + subrow.title = 'Region', + col.title = 'Target month', + legend.breaks = legend.breaks, + plot.legend = plot.legend, + label.scale = label.scale, + legend.width = legend.width, + legend.height = legend.height, + palette = palette, + colorunder = colorunder, + colorsup = colorsup, + round.decimal = round.decimal, + font.size = font.size, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + fileout = fileout) + } ## close if + +print("All system difference scorecard plots created") + +} ## close function + diff --git a/modules/Scorecards/tmp/Utils.R b/modules/Scorecards/tmp/Utils.R new file mode 100644 index 00000000..6ba49e8c --- /dev/null +++ b/modules/Scorecards/tmp/Utils.R @@ -0,0 +1,361 @@ +############### FUNCTIONS FOR SCORECARDS ################ + + +## Define metric names + +.met_names <- function(metrics, var.units) { # metrics is a object with the names of the metrics to be displayed + result <- list() + if ('mean_bias' %in% metrics) { + result <- append(result, list('mean_bias' = paste0('Mean bias (', var.units,')'))) + } + if ('enscorr' %in% metrics) { + result <- append(result, list('enscorr' = 'Correlation')) + } + if ('rps' %in% metrics ) { + result <- append(result, list('rps' = 'RPS')) + } + if ('frps' %in% metrics ) { + result <- append(result, list('frps' = 'Fair RPS')) + } + if ('rpss' %in% metrics) { + result <- append(result, list('rpss' = 'RPSS')) + } + if ('rpss_score_aggr' %in% metrics) { + result <- append(result, list('rpss_score_aggr' = 'RPSS')) + } + if ('frpss' %in% metrics) { + result <- append(result, list('frpss' = 'Fair RPSS')) + } + if ('crps' %in% metrics) { + result <- append(result, list('crps' = 'CRPS')) + } + if ('crpss' %in% metrics) { + result <- append(result, list('crpss' = 'CRPSS')) + } + if ('crpss_score_aggr' %in% metrics) { + result <- append(result, list('crpss_score_aggr' = 'CRPSS')) + } + if ('bss10' %in% metrics) { + result <- append(result, list('bss10' = 'Brier skill score 10%')) + } + if ('bss90' %in% metrics) { + result <- append(result, list('bss90' = 'Brier skill score 90%')) + } + if ('enssprerr' %in% metrics ) { + result <- append(result, list('enssprerr' = 'Spread-to-error ratio')) + } + if ('rmsss' %in% metrics ) { + result <- append(result, list('rmsss' = 'RMSSS')) + } + return(result) +} + + + +## Define metrics breaks for each input metric + +.met_breaks <- function(metrics, breaks_bias) { # metrics is a object with the names of the metrics to be displayed + result <- list() + if ('mean_bias' %in% metrics) { + result <- append(result, list('mean_bias' = breaks_bias)) + } + if ('enscorr' %in% metrics) { + result <- append(result, list('enscorr' = c(-1, -0.8, -0.6, -0.4, -0.2, 0, 0.2, 0.4, 0.6, 0.8, 1))) + } + if ('rps' %in% metrics ) { + result <- append(result, list('rps' = c(0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.8, 1))) + } + if ('frps' %in% metrics ) { + result <- append(result, list('frps' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5))) + } + if ('rpss' %in% metrics) { + result <- append(result, list('rpss' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5))) + } + if ('rpss_score_aggr' %in% metrics) { + result <- append(result, list('rpss_score_aggr' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5))) + } + if ('frpss' %in% metrics) { + result <- append(result, list('frpss' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5))) + } + if ('crps' %in% metrics) { + result <- append(result, list('crps' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5))) + } + if ('crpss' %in% metrics) { + result <- append(result, list('crpss' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5))) + } + if ('crpss_score_aggr' %in% metrics) { + result <- append(result, list('crpss_score_aggr' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5))) + } + if ('bss10' %in% metrics) { + result <- append(result, list('bss10' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5))) + } + if ('bss90' %in% metrics) { + result <- append(result, list('bss90' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5))) + } + if ('enssprerr' %in% metrics ) { + result <- append(result, list('enssprerr' = c(0, 0.6, 0.7, 0.8, 0.9, 1, 1.2, 1.4, 1.6, 1.8, 2))) + } + if ('rmsss' %in% metrics ) { + result <- append(result, list('rmsss' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5))) + } + return(result) +} + +## Define legend lower limit color + +.legend_col_inf <- function(metrics, colorunder) { + result <- list() + if ('mean_bias' %in% metrics) { + result <- append(result, list('mean_bias' = colorunder)) + } + if ('enscorr' %in% metrics) { + result <- append(result, list('enscorr' = NULL)) + } + if ('rps' %in% metrics ) { + result <- append(result, list('rps' = NULL)) + } + if ('frps' %in% metrics ) { + result <- append(result, list('frps' = NULL)) + } + if ('rpss' %in% metrics) { + result <- append(result, list('rpss' = colorunder)) + } + if ('rpss_score_aggr' %in% metrics) { + result <- append(result, list('rpss_score_aggr' = colorunder)) + } + if ('frpss' %in% metrics) { + result <- append(result, list('frpss' = colorunder)) + } + if ('crps' %in% metrics) { + result <- append(result, list('crps' = NULL)) + } + if ('crpss' %in% metrics) { + result <- append(result, list('crpss' = colorunder)) + } + if ('crpss_score_aggr' %in% metrics) { + result <- append(result, list('crpss_score_aggr' = colorunder)) + } + if ('bss10' %in% metrics) { + result <- append(result, list('bss10' = colorunder)) + } + if ('bss90' %in% metrics) { + result <- append(result, list('bss90' = colorunder)) + } + if ('enssprerr' %in% metrics ) { + result <- append(result, list('enssprerr' = NULL)) + } + if ('rmsss' %in% metrics ) { + result <- append(result, list('rmsss' = colorunder)) + } + return(result) +} + + +## Define legend upper limit color + +.legend_col_sup <- function(metrics, colorsup) { + result <- list() + if ('mean_bias' %in% metrics) { + result <- append(result, list('mean_bias' = colorsup)) + } + if ('enscorr' %in% metrics) { + result <- append(result, list('enscorr' = NULL)) + } + if ('rps' %in% metrics ) { + result <- append(result, list('rps' = NULL)) + } + if ('frps' %in% metrics ) { + result <- append(result, list('frps' = NULL)) + } + if ('rpss' %in% metrics) { + result <- append(result, list('rpss' = colorsup)) + } + if ('rpss_score_aggr' %in% metrics) { + result <- append(result, list('rpss_score_aggr' = colorsup)) + } + if ('frpss' %in% metrics) { + result <- append(result, list('frpss' = colorsup)) + } + if ('crps' %in% metrics) { + result <- append(result, list('crps' = colorsup)) + } + if ('crpss' %in% metrics) { + result <- append(result, list('crpss' = colorsup)) + } + if ('crpss_score_aggr' %in% metrics) { + result <- append(result, list('crpss_score_aggr' = colorsup)) + } + if ('bss10' %in% metrics) { + result <- append(result, list('bss10' = colorsup)) + } + if ('bss90' %in% metrics) { + result <- append(result, list('bss90' = colorsup)) + } + if ('enssprerr' %in% metrics ) { + result <- append(result, list('enssprerr' = colorsup)) + } + if ('rmsss' %in% metrics ) { + result <- append(result, list('rmsss' = colorsup)) + } + return(result) +} + + + + +## Output file name to save scorecard +.Filename <- function(system = NULL, reference = NULL, model = NULL, eval.name = NULL, + var = NULL, start.year = NULL, end.year = NULL, scorecard.type = NULL, + region = NULL, fileout.label = NULL, output.path = NULL) { + + ## Remove . from names + system <- gsub('.','', system, fixed = T) + reference <- gsub('.','', reference, fixed = T) + + period <- paste0(start.year, "-", end.year) + + if (scorecard.type == 1 || scorecard.type == 2 || scorecard.type == 3 || scorecard.type == 4 ) { + scorecard_save_path <- paste0(output.path, + "/scorecard-", scorecard.type, "_", system, "_", + reference, "_", var, "_", period, + fileout.label, ".png") + } else { + scorecard_save_path <- paste0(output.path, + "/scorecard-", scorecard.type, "_multi-", + tolower(model), "_", eval.name, "_", + var, "_", period, "_", region, + fileout.label, ".png") + } + + return(scorecard_save_path) +} + +# Scorecards function to assign background color of table cells, +# color of text in table and to bold the text. +# +# It will return a list with 2 arrays: +# (1) metric.color, A 2-dimensional array with character strings containing the +# color codes for each cell background. +# (2) metric.text.color, A 2-dimensional array with character strings +# containing the color codes for each cell text. +.SCTableColors <- function(table, n.col, n.subcol, n.row, n.subrow, + legend.breaks, palette, colorunder, colorsup) { + # Define rows and columns + n.rows <- n.row * n.subrow + n.columns <- n.col * n.subcol + + ## Set table background colors + metric.color <- array(colorunder, c(n.row * n.subrow, n.columns)) + metric.text.color <- array("#2A2A2A", c(n.row * n.subrow , n.columns)) + # metric.text.bold <- array(TRUE, c(n.row * n.subrow , n.columns - 2)) ## Setting all values to bold + + ## Define cell and text colors to show in table + for (i in 1:n.col) { + metric.int <- legend.breaks[[i]] + for (rr in 1:n.rows) { + for (j in 1:n.subcol) { + for (pp in 1:(length(metric.int) - 1)) { + if (is.nan(table[rr,((i - 1) * n.subcol + j)])) { + metric.color[rr,((i - 1) * n.subcol + j)] <- "gray" + } else { + if (table[rr,((i - 1) * n.subcol + j)] >= + metric.int[pp] && table[rr,((i - 1) * n.subcol + j)] <= + metric.int[pp+1]) { + metric.color[rr,((i - 1) * n.subcol + j)] <- palette[[i]][pp] #palette[pp] + } + if (table[rr,((i - 1) * n.subcol + j)] < metric.int[1]) { + metric.color[rr,((i - 1) * n.subcol + j)] <- colorunder[i] + } + if (table[rr,((i - 1) * n.subcol + j)] >= + metric.int[length(metric.int)]) { + metric.color[rr,((i - 1) * n.subcol + j)] <- colorsup[i] + } + } + ## color text in white and bold if background is white or dark blue or dark red: + if (is.nan(table[rr,((i - 1) * n.subcol + j)]) || + (!is.nan(table[rr,((i - 1) * n.subcol + j)]) && pp == 1 && + table[rr,((i - 1) * n.subcol + j)] < metric.int[2]) || + (!is.nan(table[rr,((i - 1) * n.subcol + j)]) && pp == 2 && + table[rr,((i - 1) * n.subcol + j)] < metric.int[3]) || + (!is.nan(table[rr,((i - 1) * n.subcol + j)]) && pp == (length(metric.int) - 1) && + table[rr,((i - 1) * n.subcol + j)] >= metric.int[length(metric.int) - 1]) || + (!is.nan(table[rr,((i - 1) * n.subcol + j)]) && pp == (length(metric.int) - 2) && + table[rr,((i - 1) * n.subcol + j)] >= metric.int[length(metric.int) - 2])) { + metric.text.color[rr,((i - 1) * n.subcol + j)] <- "white" + #metric.text.bold[rr,((i - 1) * n.subcol + j)] <- TRUE + } + } + } + } + } + + return(list(metric.color = metric.color, + metric.text.color = metric.text.color)) + +} + +# Scorecards function to create the color bar legends for the required metrics +# and paste them below the scorecard table +.SCLegend <- function(legend.breaks, palette, colorunder, colorsup, + label.scale, legend.width, legend.height, + legend.white.space, fileout) { + + ## Create color bar legends for each metric + for (i in 1:length(palette)) { + png(filename = paste0(fileout, '_tmpLegend', i, '.png'), width = legend.width, + height = legend.height) + ColorBar(brks = legend.breaks[[i]], cols = palette[[i]], vertical = FALSE, + label_scale = label.scale, col_inf = colorunder[[i]], + col_sup = colorsup[[i]]) + dev.off() + if (i == 1) { + ## Add white space to the left of the first color bar legend + system(paste0('convert ', fileout, '_tmpLegend1.png -background white -splice ', + legend.white.space, 'x0 ', fileout, '_tmpScorecardLegend.png')) + } else { + system(paste0('convert +append ', fileout, '_tmpScorecardLegend.png ', + fileout, '_tmpLegend', i, '.png ', fileout, + '_tmpScorecardLegend.png')) + } + } + unlink(paste0(fileout,'_tmpLegend*.png')) +} + +# Function to calculate color bar breaks for bias metric +.SCBiasBreaks <- function(data){ + + bias.minmax_max <- quantile(data, 0.98, na.rm = TRUE) + bias.minmax_min <- quantile(data, 0.02, na.rm = TRUE) + bias.max <- max(abs(bias.minmax_min), abs(bias.minmax_max)) + + ## one point more than the colors below (the intervals) + bias.int <- bias.max * c(-1, -0.8, -0.6, -0.4, -0.2, 0, 0.2, 0.4, 0.6, 0.8, 1) + + ## round to 2 significance figures + bias.int <- signif(bias.int, digits = 2) + + return(bias.int) +} + +# Function to calculate color bar breaks for CRPS metric +.SCCrpsBreaks <- function(data){ + + crps.max <- quantile(data, 0.98, na.rm = TRUE) + + crps.int <- crps.max * c(0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1) + + ## round to 2 significance figures + crps.int <- signif(crps.int, digits = 2) + + return(crps.int) +} + +# Auxiliary function to get the names of the longitude coordinate +.KnownLonNames <- function() { + known_lon_names <- c('lon', 'lons', 'longitude', 'x', 'i', 'nav_lon') +} + +# Auxiliary function to get the names of the latitude coordinate +.KnownLatNames <- function() { + known_lat_names <- c('lat', 'lats', 'latitude', 'y', 'j', 'nav_lat') +} diff --git a/modules/Scorecards/tmp/WeightedMetrics.R b/modules/Scorecards/tmp/WeightedMetrics.R new file mode 100644 index 00000000..aea23c56 --- /dev/null +++ b/modules/Scorecards/tmp/WeightedMetrics.R @@ -0,0 +1,134 @@ +#' Scorecards spatial aggregation of loaded metrics +#' +#'@description Scorecards function to perform the spatial aggregation of the +#' loaded metrics for the specified regions. +#' +#'@param loaded_metrics is a list of arrays containing the metrics loaded by the +#' function SC_load_metrics. +#'@param region is a named list of vectors containing the desired regions to +#' analyze. For each region the following should be specified in this order: +#' lon_min, lon_max, lat_min, lat_max. +#'@param metric.aggregation a character indicating whether the skill score RPS +#' and CRPSS are calculated from aggregated scores or aggregated skill score +#' directly, either 'score' or 'skill' respectively +#'@param ncores is the number of cores to use for the calculation. +#' +#'@return An array with the following dimensions: system, reference, metrics, +#' time, sdate, region. +#' +#'@examples +#'regions <- list('global' = c(lon.min = 0, lon.max = 360, lat.min = -90, lat.max = 90), +#' 'europe' = c(lon.min = -10, lon.max = 40, lat.min = 30, lat.max = 70)) +#'aggregated_metrics <- WeightedMetrics(loaded_metrics, +#' regions = regions, +#' metric.aggregation = 'skill', +#' ncores = 4) +#'@import multiApply +#'@importFrom ClimProjDiags WeightedMean +#'@importFrom s2dv Reorder +#'@export +WeightedMetrics <- function(loaded_metrics, regions, metric.aggregation, + ncores = NULL, na.rm = TRUE) { + ## Initial checks + # loaded_metrics + if (any(sapply(loaded_metrics, function(x) { + sapply(x, function(y) {is.null(dim(y))}) + }))) { + stop(paste0("Parameter 'loaded_metrics' must be a list of lists of arrays ", + "with named dimensions.")) + } + # regions + if (!all(sapply(regions, is.numeric))) { + stop(paste0("Parameter 'regions' must be a named list of vectors ", + "containing the desired regions to analyze.")) + } + # metric.aggregation + if (!is.character(metric.aggregation)) { + stop("Parameter 'metric.aggregation' must be a character indicating.") + } + # ncores + if (!is.numeric(ncores)) { + stop("Parameter 'ncores' must be an integer.") + } + + ## Get metric names + ## TO DO: check all metric are in the same order for all sys + metrics <- attributes(loaded_metrics[[1]][[1]])$metrics + forecast.months <- attributes(loaded_metrics[[1]][[1]])$forecast.months + start.months <- attributes(loaded_metrics[[1]][[1]])$start.months + + all_metric_means <- array(dim = c(metric = length(metrics), + time = length(forecast.months), + sdate = length(start.months), + region = length(regions), + reference = length(loaded_metrics[[1]]), + system = length(loaded_metrics))) + + ## Loop over system + for (sys in 1:length(loaded_metrics)) { + ## Loop over reference + for (ref in 1:length(loaded_metrics[[sys]])) { + dimnames <- names(dim(loaded_metrics[[sys]][[ref]])) + lon_dim_name <- dimnames[which(dimnames %in% .KnownLonNames())] + lat_dim_name <- dimnames[which(dimnames %in% .KnownLatNames())] + ## Get latitude and longitude from attributes of loaded metrics + ## Loop over region + for (reg in 1:length(regions)) { + ## Calculate weighted means for defined regions for each system and reference + weighted.mean <- WeightedMean(data = loaded_metrics[[sys]][[ref]], + lon = as.vector(attributes(loaded_metrics[[sys]][[ref]])$lon), + lat = as.vector(attributes(loaded_metrics[[sys]][[ref]])$lat), + region = regions[[reg]], + londim = lon_dim_name, + latdim = lat_dim_name, + na.rm = na.rm, + ncores = ncores) + all_metric_means[, , , reg, ref, sys] <- weighted.mean + } ## close loop on region + } ## close loop on reference + } ## close loop on system + + ## skill aggregation: + if (metric.aggregation == 'score') { + if (all(c("rps", "rps_clim") %in% metrics)) { + ## Calculate RPSS from aggregated RPS and RPS_clim + all_metric_means <- multiApply::Apply(data = all_metric_means, + target_dims = 'metric', + fun = function(x, met) { + res <- 1 - x[which(met == 'rps')] / x[which(met == 'rps_clim')] + c(x, res)}, met = metrics, + output_dims = 'metric', + ncores = ncores)$output1 + ## Define name of newly calculated RPSS metric + metrics <- c(metrics, "rpss_score_aggr") + } + if (all(c("crps", "crps_clim") %in% metrics)) { + ## Calculate CRPSS from aggragated CRPS and CRPS_clim + all_metric_means <- multiApply::Apply(data = all_metric_means, + target_dims = 'metric', + fun = function(x, met) { + res <- 1 - x[which(met == 'crps')] / x[which(met == 'crps_clim')] + c(x, res)}, + met = metrics, + output_dims = 'metric', + ncores = ncores)$output1 + ## Define name of newly calculated CRPSS metric + metrics <- c(metrics, "crpss_score_aggr") + } + ## Add warning in case metric.aggregation == 'score' but 1 of the metrics from each pair is missing + } + ## reorder dimensions in array + all_metric_means <- s2dv::Reorder(all_metric_means, c('system','reference','metric','time','sdate','region')) + + ## Add attributes + attributes(all_metric_means)$metrics <- metrics + attributes(all_metric_means)$start.months <- attributes(loaded_metrics[[1]][[1]])$start.months + attributes(all_metric_means)$forecast.months <- attributes(loaded_metrics[[1]][[1]])$forecast.months + attributes(all_metric_means)$regions <- regions + attributes(all_metric_means)$system.name <- names(loaded_metrics) + attributes(all_metric_means)$reference.name <- names(loaded_metrics[[1]]) + + return(all_metric_means) + +} ## close function + diff --git a/recipes/atomic_recipes/recipe_scorecards_atomic.yml b/recipes/atomic_recipes/recipe_scorecards_atomic.yml new file mode 100644 index 00000000..fc88af22 --- /dev/null +++ b/recipes/atomic_recipes/recipe_scorecards_atomic.yml @@ -0,0 +1,69 @@ +Description: + Author: nmilders + Info: scorecards data + +Analysis: + Horizon: seasonal # Mandatory, str: either subseasonal, seasonal, or decadal + Variables: + name: tas # Mandatory, str: tas prlr psl sfcWind + freq: monthly_mean # Mandatory, str: either monthly_mean or daily_mean + Datasets: + System: + name: ECMWF-SEAS5 # Mandatory ECMWF-SEAS5, CMCC-SPS3.5, DWD-GCFS2.1 + Multimodel: no # Mandatory, bool: Either yes/true or no/false + Reference: + name: ERA5 # Mandatory, str: Reference codename. See docu. + Time: + sdate: '0101' ## MMDD + fcst_year: # Optional, int: Forecast year 'YYYY' + hcst_start: '1993' # Mandatory, int: Hindcast start year 'YYYY' + hcst_end: '2016' # Mandatory, int: Hindcast end year 'YYYY' + ftime_min: 1 # Mandatory, int: First leadtime time step in months + ftime_max: 6 # Mandatory, int: Last leadtime time step in months + Region: + latmin: -90 # Mandatory, int: minimum latitude + latmax: 90 # Mandatory, int: maximum latitude + lonmin: 0 # Mandatory, int: minimum longitude + lonmax: 359.9 # Mandatory, int: maximum longitude + Regrid: + method: bilinear # conservative for prlr, bilinear for tas, psl, sfcWind + type: to_system + Workflow: + Calibration: + method: raw # Mandatory, str: Calibration method. See docu. + save: 'none' + Anomalies: + compute: yes + cross_validation: yes + save: 'none' + Skill: + metric: mean_bias EnsCorr rps rpss crps crpss EnsSprErr # str: Skill metric or list of skill metrics. See docu. + cross_validation: yes + save: 'all' + Probabilities: + percentiles: [[1/3, 2/3]] # frac: Quantile thresholds. + save: 'none' + Indicators: + index: no + Scorecards: + regions: + Extra-tropical NH: {lon.min: 0, lon.max: 360, lat.min: 30, lat.max: 90} + Tropics: {lon.min: 0, lon.max: 360, lat.min: -30, lat.max: 30} + Extra-tropical SH : {lon.min: 0, lon.max: 360, lat.min: -30, lat.max: -90} + start_months: NULL + metric: mean_bias enscorr rpss crpss enssprerr + metric_aggregation: 'score' + table_label: NULL + fileout_label: NULL + col1_width: NULL + col2_width: NULL + calculate_diff: FALSE + #output_path: /esarchive/scratch/nmilders/scorecards_images/testing + ncores: 7 # Optional, int: number of cores, defaults to 1 + remove_NAs: # Optional, bool: Whether NAs are removed, defaults to FALSE + Output_format: Scorecards #S2S4E +Run: + Loglevel: INFO + Terminal: yes + output_dir: /esarchive/scratch/nmilders/scorecards_data/to_system/cross_validation/both_cross_val/ + code_dir: /esarchive/scratch/nmilders/gitlab/git_clones/s2s-suite/ diff --git a/recipes/recipe_scoreacards.yml b/recipes/recipe_scoreacards.yml new file mode 100644 index 00000000..a50fd572 --- /dev/null +++ b/recipes/recipe_scoreacards.yml @@ -0,0 +1,105 @@ +################################################################################ +## RECIPE DESCRIPTION +################################################################################ + +Description: + Author: V. Agudetse + Info: Test for recipe splitting + +################################################################################ +## ANALYSIS CONFIGURATION +################################################################################ + +Analysis: + Horizon: Seasonal + Variables: # ECVs and Indicators? + - {name: tas, freq: monthly_mean} + Datasets: + System: # multiple systems for single model, split if Multimodel = F + - {name: ECMWF-SEAS5} + Multimodel: False # single option + Reference: + - {name: ERA5} # multiple references for single model? + Time: + sdate: # list, split + - '0101' + - '0201' + - '0301' + - '0401' + - '0501' + - '0601' + - '0701' + - '0801' + - '0901' + - '1001' + - '1101' + - '1201' + #fcst_year: '2020' # list, don't split, handled internally + hcst_start: '1993' # single option + hcst_end: '2016' # single option + ftime_min: 1 # single option + ftime_max: 6 # single option + Region: # multiple lists, split? Add region name if length(Region) > 1 + - {name: "global", latmin: -90, latmax: 90, lonmin: 0, lonmax: 359.9} + Regrid: + method: bilinear ## TODO: allow multiple methods? + type: to_system + Workflow: + Anomalies: + compute: yes + cross_validation: yes + save: 'none' + Calibration: + method: raw ## TODO: list, split? + save: 'none' + Skill: + metric: mean_bias EnsCorr rps rpss crps crpss EnsSprErr # list, don't split + cross_validation: yes + save: 'all' + Probabilities: + percentiles: [[1/3, 2/3]] # list, don't split + save: 'none' + Visualization: + plots: skill_metrics + Indicators: + index: no # ? + # Scorecards: + # regions: + # Extra-tropical NH: {lon.min: 0, lon.max: 360, lat.min: 30, lat.max: 90} + # Tropics: {lon.min: 0, lon.max: 360, lat.min: -30, lat.max: 30} + # Extra-tropical SH : {lon.min: 0, lon.max: 360, lat.min: -30, lat.max: -90} + # start_months: NULL + # metric: mean_bias enscorr rpss crpss enssprerr + # metric_aggregation: 'score' + # table_label: NULL + # fileout_label: NULL + # col1_width: NULL + # col2_width: NULL + # calculate_diff: FALSE + # #output_path: /esarchive/scratch/nmilders/scorecards_images/testing + ncores: 7 + remove_NAs: no # bool, don't split + Output_format: Scorecards # string, don't split + +################################################################################ +## Run CONFIGURATION +################################################################################ +Run: + Loglevel: INFO + Terminal: yes + output_dir: /esarchive/scratch/nmilders/scorecards_data/test/ + code_dir: /esarchive/scratch/nmilders/gitlab/git_clones/s2s-suite/ + autosubmit: yes + # fill only if using autosubmit + auto_conf: + script: /esarchive/scratch/nmilders/gitlab/git_clones/s2s-suite/execute_scorecards_data_loading.R # replace with the path to your script + expid: a6a3 # replace with your EXPID + hpc_user: bsc32878 # replace with your hpc username + wallclock: 03:00 # hh:mm + processors_per_job: 8 + platform: nord3v2 + email_notifications: yes # enable/disable email notifications. Change it if you want to. + email_address: nadia.milders@bsc.es # replace with your email address + notify_completed: yes # notify me by email when a job finishes + notify_failed: yes # notify me by email when a job fails + -- GitLab From de0ae0a1dc6d5e6877d6ad8c8b71ea5cd92aab9a Mon Sep 17 00:00:00 2001 From: Victoria Agudetse Roures Date: Tue, 25 Jul 2023 16:12:37 +0200 Subject: [PATCH 02/14] Set recipe name in autosubmit conf and set output directory in Scorecards script --- autosubmit/auto-scorecards.sh | 2 +- modules/Scorecards/Scorecards.R | 4 ++++ tools/prepare_outputs.R | 1 - tools/write_autosubmit_conf.R | 1 + 4 files changed, 6 insertions(+), 2 deletions(-) diff --git a/autosubmit/auto-scorecards.sh b/autosubmit/auto-scorecards.sh index 1456a9b0..a1033a46 100644 --- a/autosubmit/auto-scorecards.sh +++ b/autosubmit/auto-scorecards.sh @@ -12,4 +12,4 @@ recipe=${outdir}/logs/recipes/${recipe} source MODULES -Rscript modules/Scorecards/Scorecards.R ${recipe} +Rscript modules/Scorecards/Scorecards.R ${recipe} ${outdir} diff --git a/modules/Scorecards/Scorecards.R b/modules/Scorecards/Scorecards.R index e677d403..0a46f75f 100644 --- a/modules/Scorecards/Scorecards.R +++ b/modules/Scorecards/Scorecards.R @@ -3,7 +3,11 @@ source('modules/Scorecards/R/plot_scorecards.R') args = commandArgs(trailingOnly = TRUE) recipe_file <- args[1] +output_dir <- args[2] + +# Read recipe and set outdir recipe <- read_yaml(recipe_file) +recipe$Run$output_dir <- output_dir recipe$Analysis$Datasets$System <- recipe$Analysis$Datasets$System[[1]] recipe$Analysis$Datasets$Reference <- recipe$Analysis$Datasets$Reference[[1]] recipe$Analysis$Variables <- recipe$Analysis$Variables[[1]] diff --git a/tools/prepare_outputs.R b/tools/prepare_outputs.R index f54325ec..a3cc9b56 100644 --- a/tools/prepare_outputs.R +++ b/tools/prepare_outputs.R @@ -31,7 +31,6 @@ prepare_outputs <- function(recipe_file, recipe$recipe_path <- recipe_file recipe$name <- tools::file_path_sans_ext(basename(recipe_file)) - output_dir = recipe$Run$output_dir # Create output folders if (!uniqueID) { diff --git a/tools/write_autosubmit_conf.R b/tools/write_autosubmit_conf.R index a425566d..f0e1088a 100644 --- a/tools/write_autosubmit_conf.R +++ b/tools/write_autosubmit_conf.R @@ -71,6 +71,7 @@ write_autosubmit_conf <- function(recipe, nchunks) { ## modules? Info that goes on script, e.g. output directory conf$common$OUTDIR <- recipe$Run$output_dir conf$common$SCRIPT <- recipe$Run$auto_conf$script + conf$common$RECIPE <- paste0(recipe$name, ".yml") } # Write config file inside autosubmit dir ## TODO: Change write.type depending on autosubmit version -- GitLab From deaaf1d1fdf8f7a0869d3adfe8e435c19cf15d43 Mon Sep 17 00:00:00 2001 From: Victoria Agudetse Roures Date: Wed, 26 Jul 2023 16:16:00 +0200 Subject: [PATCH 03/14] Add libraries, change scorecards input dir --- modules/Scorecards/R/plot_scorecards.R | 18 +++++++++--------- tools/libs.R | 6 +++++- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/modules/Scorecards/R/plot_scorecards.R b/modules/Scorecards/R/plot_scorecards.R index ac1e4c14..a6e0483b 100644 --- a/modules/Scorecards/R/plot_scorecards.R +++ b/modules/Scorecards/R/plot_scorecards.R @@ -3,21 +3,21 @@ ############################################################################### ##### Load source functions ##### -source('/modules/Scorecards/tmp/LoadMetrics.R') -source('/modules/Scorecards/tmp/WeightedMetrics.R') -source('/modules/Scorecards/tmp/Utils.R') -source('/modules/Scorecards/tmp/SCTransform.R') -source('/modules/Scorecards/tmp/ScorecardsSingle.R') -source('/modules/Scorecards/tmp/ScorecardsMulti.R') -source('/modules/Scorecards/tmp/ScorecardsSystemDiff.R') -source('/modules/Scorecards/tmp/SCPlotScorecard.R') +source('modules/Scorecards/tmp/LoadMetrics.R') +source('modules/Scorecards/tmp/WeightedMetrics.R') +source('modules/Scorecards/tmp/Utils.R') +source('modules/Scorecards/tmp/SCTransform.R') +source('modules/Scorecards/tmp/ScorecardsSingle.R') +source('modules/Scorecards/tmp/ScorecardsMulti.R') +source('modules/Scorecards/tmp/ScorecardsSystemDiff.R') +source('modules/Scorecards/tmp/SCPlotScorecard.R') ## Define function plot_scorecards <- function(recipe) { ## set parameters # input.path <- '/esarchive/scratch/nmilders/scorecards_data/to_system/cross_validation/both_cross_val/' #recipe$Run$output_dir - input.path <- recipe$Run$output_dir + input.path <- paste0(recipe$Run$output_dir, "/outputs/Skill/") output.path <- recipe$Run$output_dir system <- recipe$Analysis$Datasets$System$name diff --git a/tools/libs.R b/tools/libs.R index a67f9549..326a2689 100644 --- a/tools/libs.R +++ b/tools/libs.R @@ -18,7 +18,11 @@ library(ggplot2) library(rnaturalearth) library(cowplot) library(stringr) -library(pryr) # To check mem usage. +library(pryr) +library(ncdf4) +library(formattable) ## to plot horizontal color bars - used ?? +library(kableExtra) +# To check mem usage. # Functions ## To be removed when new package is done by library(CSOperational) -- GitLab From ef8df994b9caff53bfb8888b81104bac4ff604b4 Mon Sep 17 00:00:00 2001 From: Nadia Milders Date: Thu, 27 Jul 2023 11:50:46 +0200 Subject: [PATCH 04/14] included rps_clim and crps_clim in metrics --- modules/Scorecards/R/plot_scorecards.R | 347 +++++++++++++------------ 1 file changed, 185 insertions(+), 162 deletions(-) diff --git a/modules/Scorecards/R/plot_scorecards.R b/modules/Scorecards/R/plot_scorecards.R index ac1e4c14..1ceb0124 100644 --- a/modules/Scorecards/R/plot_scorecards.R +++ b/modules/Scorecards/R/plot_scorecards.R @@ -3,178 +3,201 @@ ############################################################################### ##### Load source functions ##### -source('/modules/Scorecards/tmp/LoadMetrics.R') -source('/modules/Scorecards/tmp/WeightedMetrics.R') -source('/modules/Scorecards/tmp/Utils.R') -source('/modules/Scorecards/tmp/SCTransform.R') -source('/modules/Scorecards/tmp/ScorecardsSingle.R') -source('/modules/Scorecards/tmp/ScorecardsMulti.R') -source('/modules/Scorecards/tmp/ScorecardsSystemDiff.R') -source('/modules/Scorecards/tmp/SCPlotScorecard.R') +source('./modules/Scorecards/tmp/LoadMetrics.R') +source('./modules/Scorecards/tmp/WeightedMetrics.R') +source('./modules/Scorecards/tmp/Utils.R') +source('./modules/Scorecards/tmp/SCTransform.R') +source('./modules/Scorecards/tmp/ScorecardsSingle.R') +source('./modules/Scorecards/tmp/ScorecardsMulti.R') +source('./modules/Scorecards/tmp/ScorecardsSystemDiff.R') +source('./modules/Scorecards/tmp/SCPlotScorecard.R') ## Define function plot_scorecards <- function(recipe) { - - ## set parameters - # input.path <- '/esarchive/scratch/nmilders/scorecards_data/to_system/cross_validation/both_cross_val/' #recipe$Run$output_dir - input.path <- recipe$Run$output_dir - output.path <- recipe$Run$output_dir - - system <- recipe$Analysis$Datasets$System$name - reference <- recipe$Analysis$Datasets$Reference$name - var <- recipe$Analysis$Variables$name - start.year <- as.numeric(recipe$Analysis$Time$hcst_start) - end.year <- as.numeric(recipe$Analysis$Time$hcst_end) - forecast.months <- recipe$Analysis$Time$ftime_min : recipe$Analysis$Time$ftime_max - - start.months <- 1:12 #recipe$Analysis$Workflow$Scorecards$start_months - - regions <- recipe$Analysis$Workflow$Scorecards$regions - for (i in names(regions)){regions[[i]] <- unlist(regions[[i]])} - - metric.aggregation <- recipe$Analysis$Workflow$Scorecards$metric_aggregation - metrics.load <- unlist(strsplit(tolower(recipe$Analysis$Workflow$Skill$metric), ", | |,")) - metrics.visualize <- unlist(strsplit(tolower(recipe$Analysis$Workflow$Scorecards$metric), ", | |,")) - table.label <- recipe$Analysis$Workflow$Scorecards$table_label - fileout.label <- recipe$Analysis$Workflow$Scorecards$fileout_label - legend.white.space <- recipe$Analysis$Workflow$Scorecards$legend_white_space - col1.width <- recipe$Analysis$Workflow$Scorecards$col1_width - col2.width <- recipe$Analysis$Workflow$Scorecards$col2_width - calculate.diff <- recipe$Analysis$Workflow$Scorecards$calculate_diff - ncores <- recipe$Analysis$ncores - - ## Load data files - loaded_metrics <- LoadMetrics(system = system, - reference = reference, - var = var, - start.year = start.year, - end.year = end.year, - metrics = metrics.load, - start.months = start.months, - forecast.months = forecast.months, - input.path = input.path) - + + ## set parameters + input.path <- recipe$Run$output_dir + output.path <- recipe$Run$output_dir + + system <- recipe$Analysis$Datasets$System$name + reference <- recipe$Analysis$Datasets$Reference$name + var <- recipe$Analysis$Variables$name + start.year <- as.numeric(recipe$Analysis$Time$hcst_start) + end.year <- as.numeric(recipe$Analysis$Time$hcst_end) + forecast.months <- recipe$Analysis$Time$ftime_min : recipe$Analysis$Time$ftime_max + + start.months <- 1:12 #recipe$Analysis$Workflow$Scorecards$start_months + + regions <- recipe$Analysis$Workflow$Scorecards$regions + for (i in names(regions)){regions[[i]] <- unlist(regions[[i]])} + + metric.aggregation <- recipe$Analysis$Workflow$Scorecards$metric_aggregation + metrics.load <- unlist(strsplit(tolower(recipe$Analysis$Workflow$Skill$metric), ", | |,")) + + ## Define skill scores in score aggregation has been requested + + if(metric.aggregation == 'score'){ + if('rps' %in% metrics.load){ + metrics.load <- c(metrics.load, 'rps_clim') + } + if('crps' %in% metrics.load){ + metrics.load <- c(metrics.load, 'crps_clim') + } + } + + metrics.visualize <- unlist(strsplit(tolower(recipe$Analysis$Workflow$Scorecards$metric), ", | |,")) + + ## Define skill scores in score aggregation has been requested + + if(metric.aggregation == 'score'){ + if('rpss' %in% metrics.visualize){ + metrics.visualize[metrics.visualize == 'rpss'] <- 'rpss_score_aggr' + } + if('crpss' %in% metrics.visualize){ + metrics.visualize[metrics.visualize == 'crpss'] <- 'crpss_score_aggr' + } + } + + table.label <- recipe$Analysis$Workflow$Scorecards$table_label + fileout.label <- recipe$Analysis$Workflow$Scorecards$fileout_label + legend.white.space <- recipe$Analysis$Workflow$Scorecards$legend_white_space + col1.width <- recipe$Analysis$Workflow$Scorecards$col1_width + col2.width <- recipe$Analysis$Workflow$Scorecards$col2_width + calculate.diff <- recipe$Analysis$Workflow$Scorecards$calculate_diff + ncores <- recipe$Analysis$ncores + + ## Load data files + loaded_metrics <- LoadMetrics(system = system, + reference = reference, + var = var, + start.year = start.year, + end.year = end.year, + metrics = metrics.load, + start.months = start.months, + forecast.months = forecast.months, + input.path = input.path) + + + if('region' %in% names(dim(loaded_metrics[[1]][[1]]))){ - if('region' %in% names(dim(loaded_metrics[[1]][[1]]))){ - - ### Convert loaded metrics to array for allready aggregated data - metrics.dim <- attributes(loaded_metrics[[1]][[1]])$metrics - forecast.months.dim <- attributes(loaded_metrics[[1]][[1]])$forecast.months - start.months.dim <- attributes(loaded_metrics[[1]][[1]])$start.months - regions.dim <- regions #list('NAO' = c(lon.min = -80, lon.max = 40, lat.min = 20, lat.max = 80)) - - aggregated_metrics <- array(dim = c(system = length(loaded_metrics), - reference = length(loaded_metrics[[1]]), - metric = length(metrics.dim), - time = length(forecast.months.dim), - sdate = length(start.months.dim), - region = length(regions.dim))) - - - for (sys in 1:length(names(loaded_metrics))){ - for (ref in 1:length(names(loaded_metrics[[sys]]))){ - aggregated_metrics[sys, ref, , , , ] <- s2dv::Reorder(data = loaded_metrics[[sys]][[ref]], order = c('metric','time','sdate','region')) - } - } - - ## Add attributes - attributes(aggregated_metrics)$metrics <- metrics.load - attributes(aggregated_metrics)$start.months <- attributes(loaded_metrics[[1]][[1]])$start.months - attributes(aggregated_metrics)$forecast.months <- attributes(loaded_metrics[[1]][[1]])$forecast.months - attributes(aggregated_metrics)$regions <- regions - attributes(aggregated_metrics)$system.name <- names(loaded_metrics) - attributes(aggregated_metrics)$reference.name <- names(loaded_metrics[[1]]) - - - } else { - ## Calculate weighted mean of spatial aggregation - aggregated_metrics <- WeightedMetrics(loaded_metrics, - regions = regions, - metric.aggregation = metric.aggregation, - ncores = ncores) - }## close if + ### Convert loaded metrics to array for allready aggregated data + metrics.dim <- attributes(loaded_metrics[[1]][[1]])$metrics + forecast.months.dim <- attributes(loaded_metrics[[1]][[1]])$forecast.months + start.months.dim <- attributes(loaded_metrics[[1]][[1]])$start.months + regions.dim <- regions #list('NAO' = c(lon.min = -80, lon.max = 40, lat.min = 20, lat.max = 80)) - - # if(var == 'nao'){ - # legend.white.space <- 3.75 - # col1.width <- 2 - # col2.width <- 1 - # } else{ - # legend.white.space <- col1.width <- col2.width <- NULL ## Use default values of function - # - # } + aggregated_metrics <- array(dim = c(system = length(loaded_metrics), + reference = length(loaded_metrics[[1]]), + metric = length(metrics.dim), + time = length(forecast.months.dim), + sdate = length(start.months.dim), + region = length(regions.dim))) - ## Define skill scores in scorec aggragtion has been requested - if(metric.aggregation == 'score'){ - if('rpss' %in% metrics.visualize){ - metrics.visualize[metrics.visualize == 'rpss'] <- 'rpss_score_aggr' - } - if('crpss' %in% metrics.visualize){ - metrics.visualize[metrics.visualize == 'crpss'] <- 'crpss_score_aggr' + for (sys in 1:length(names(loaded_metrics))){ + for (ref in 1:length(names(loaded_metrics[[sys]]))){ + aggregated_metrics[sys, ref, , , , ] <- s2dv::Reorder(data = loaded_metrics[[sys]][[ref]], order = c('metric','time','sdate','region')) } } - ## Create simple scorecard tables - ## (one system only) - ## Metrics input must be in the same order as function SC_spatial_aggregation - scorecard_single <- ScorecardsSingle(data = aggregated_metrics, - system = system, - reference = reference, - var = var, - start.year = start.year, - end.year = end.year, - start.months = start.months, - forecast.months = forecast.months, - region.names = names(regions), - metrics = metrics.visualize, - table.label = table.label, - fileout.label = fileout.label, - legend.white.space = legend.white.space, - col1.width = col1.width, - col2.width = col2.width, - output.path = output.path) - - ## Create multi system/reference scorecard tables - ## (multiple systems with one reference or one system with multiple references) - ## Metrics input must be in the same order as function SC_spatial_aggregation - if(length(system) > 1 || length(reference) > 1){ - scorecard_multi <- ScorecardsMulti(data = aggregated_metrics, - system = system, - reference = reference, - var = var, - start.year = start.year, - end.year = end.year, - start.months = start.months, - forecast.months = forecast.months, - region.names = attributes(regions)$names, - metrics = metrics.visualize, - table.label = table.label, - fileout.label = fileout.label, - output.path = output.path) - } ## close if + ## Add attributes + attributes(aggregated_metrics)$metrics <- metrics.load + attributes(aggregated_metrics)$start.months <- attributes(loaded_metrics[[1]][[1]])$start.months + attributes(aggregated_metrics)$forecast.months <- attributes(loaded_metrics[[1]][[1]])$forecast.months + attributes(aggregated_metrics)$regions <- regions + attributes(aggregated_metrics)$system.name <- names(loaded_metrics) + attributes(aggregated_metrics)$reference.name <- names(loaded_metrics[[1]]) - if(calculate.diff == TRUE){ - if(length(system) == 2 || length(reference) == 2){ - scorecard_diff <- ScorecardsSystemDiff(data = aggregated_metrics, - system = system, - reference = reference, - var = var, - start.year = start.year, - end.year = end.year, - start.months = start.months, - forecast.months = forecast.months, - region.names = attributes(regions)$names, - metrics = metrics.visualize, - table.label = table.label, - fileout.label = fileout.label, - legend.white.space = legend.white.space, - col1.width = col1.width, - col2.width = col2.width, - output.path = output.path) - } else {stop ("Difference scorecard can only be computed with two systems or two references.")} - } ## close if on calculate.diff - + } else { + ## Calculate weighted mean of spatial aggregation + aggregated_metrics <- WeightedMetrics(loaded_metrics, + regions = regions, + metric.aggregation = metric.aggregation, + ncores = ncores) + }## close if + + + # if(var == 'nao'){ + # legend.white.space <- 3.75 + # col1.width <- 2 + # col2.width <- 1 + # } else{ + # legend.white.space <- col1.width <- col2.width <- NULL ## Use default values of function + # + # } + + ## Define skill scores in score aggregation has been requested + + if(metric.aggregation == 'score'){ + if('rpss' %in% metrics.visualize){ + metrics.visualize[metrics.visualize == 'rpss'] <- 'rpss_score_aggr' + } + if('crpss' %in% metrics.visualize){ + metrics.visualize[metrics.visualize == 'crpss'] <- 'crpss_score_aggr' + } + } + + ## Create simple scorecard tables + ## (one system only) + ## Metrics input must be in the same order as function SC_spatial_aggregation + scorecard_single <- ScorecardsSingle(data = aggregated_metrics, + system = system, + reference = reference, + var = var, + start.year = start.year, + end.year = end.year, + start.months = start.months, + forecast.months = forecast.months, + region.names = names(regions), + metrics = metrics.visualize, + table.label = table.label, + fileout.label = fileout.label, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + output.path = output.path) + + ## Create multi system/reference scorecard tables + ## (multiple systems with one reference or one system with multiple references) + ## Metrics input must be in the same order as function SC_spatial_aggregation + if(length(system) > 1 || length(reference) > 1){ + scorecard_multi <- ScorecardsMulti(data = aggregated_metrics, + system = system, + reference = reference, + var = var, + start.year = start.year, + end.year = end.year, + start.months = start.months, + forecast.months = forecast.months, + region.names = attributes(regions)$names, + metrics = metrics.visualize, + table.label = table.label, + fileout.label = fileout.label, + output.path = output.path) + } ## close if + + + if(calculate.diff == TRUE){ + if(length(system) == 2 || length(reference) == 2){ + scorecard_diff <- ScorecardsSystemDiff(data = aggregated_metrics, + system = system, + reference = reference, + var = var, + start.year = start.year, + end.year = end.year, + start.months = start.months, + forecast.months = forecast.months, + region.names = attributes(regions)$names, + metrics = metrics.visualize, + table.label = table.label, + fileout.label = fileout.label, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + output.path = output.path) + } else {stop ("Difference scorecard can only be computed with two systems or two references.")} + } ## close if on calculate.diff + } - + -- GitLab From fa3a6151339f90d0a16609ee9d1c7e6a936002e5 Mon Sep 17 00:00:00 2001 From: Nadia Milders Date: Thu, 27 Jul 2023 13:36:22 +0200 Subject: [PATCH 05/14] cleaned code --- modules/Scorecards/R/plot_scorecards.R | 23 +---------------------- 1 file changed, 1 insertion(+), 22 deletions(-) diff --git a/modules/Scorecards/R/plot_scorecards.R b/modules/Scorecards/R/plot_scorecards.R index 1ceb0124..29470ef6 100644 --- a/modules/Scorecards/R/plot_scorecards.R +++ b/modules/Scorecards/R/plot_scorecards.R @@ -116,28 +116,7 @@ plot_scorecards <- function(recipe) { metric.aggregation = metric.aggregation, ncores = ncores) }## close if - - - # if(var == 'nao'){ - # legend.white.space <- 3.75 - # col1.width <- 2 - # col2.width <- 1 - # } else{ - # legend.white.space <- col1.width <- col2.width <- NULL ## Use default values of function - # - # } - - ## Define skill scores in score aggregation has been requested - - if(metric.aggregation == 'score'){ - if('rpss' %in% metrics.visualize){ - metrics.visualize[metrics.visualize == 'rpss'] <- 'rpss_score_aggr' - } - if('crpss' %in% metrics.visualize){ - metrics.visualize[metrics.visualize == 'crpss'] <- 'crpss_score_aggr' - } - } - + ## Create simple scorecard tables ## (one system only) ## Metrics input must be in the same order as function SC_spatial_aggregation -- GitLab From 42b277b87e1348f2ad42dd1b437fed764ba141b2 Mon Sep 17 00:00:00 2001 From: Victoria Agudetse Roures Date: Fri, 28 Jul 2023 15:07:57 +0200 Subject: [PATCH 06/14] Fix wrong line, add creating of /plots/Scorecards dir --- modules/Scorecards/R/plot_scorecards.R | 4 ++-- modules/Scorecards/execute_scorecards.R | 17 +++++++++++++++++ 2 files changed, 19 insertions(+), 2 deletions(-) create mode 100644 modules/Scorecards/execute_scorecards.R diff --git a/modules/Scorecards/R/plot_scorecards.R b/modules/Scorecards/R/plot_scorecards.R index 50e23bf8..c89868a5 100644 --- a/modules/Scorecards/R/plot_scorecards.R +++ b/modules/Scorecards/R/plot_scorecards.R @@ -18,7 +18,8 @@ plot_scorecards <- function(recipe) { ## set parameters input.path <- paste0(recipe$Run$output_dir, "/outputs/Skill/") - output.path <- recipe$Run$output_dir + output.path <- paste0(recipe$Run$output_dir, "/plots/Scorecards/") + dir.create(output.path, recursive = T, showWarnings = F) system <- recipe$Analysis$Datasets$System$name reference <- recipe$Analysis$Datasets$Reference$name @@ -80,7 +81,6 @@ plot_scorecards <- function(recipe) { if('region' %in% names(dim(loaded_metrics[[1]][[1]]))){ ->>>>>>> fa3a6151339f90d0a16609ee9d1c7e6a936002e5 ### Convert loaded metrics to array for allready aggregated data metrics.dim <- attributes(loaded_metrics[[1]][[1]])$metrics diff --git a/modules/Scorecards/execute_scorecards.R b/modules/Scorecards/execute_scorecards.R new file mode 100644 index 00000000..b71d7f4f --- /dev/null +++ b/modules/Scorecards/execute_scorecards.R @@ -0,0 +1,17 @@ +source('tools/libs.R') +source('modules/Scorecards/R/plot_scorecards.R') + +args = commandArgs(trailingOnly = TRUE) +recipe_file <- args[1] +output_dir <- args[2] + +## TODO: Replace with function +# Read recipe and set outdir +recipe <- read_yaml(recipe_file) +recipe$Run$output_dir <- output_dir +recipe$Analysis$Datasets$System <- recipe$Analysis$Datasets$System[[1]] +recipe$Analysis$Datasets$Reference <- recipe$Analysis$Datasets$Reference[[1]] +recipe$Analysis$Variables <- recipe$Analysis$Variables[[1]] + +# Plot Scorecards +plot_scorecards(recipe) -- GitLab From 009dd249e4beaf215d6a9185677b5d966f8f0ee3 Mon Sep 17 00:00:00 2001 From: Victoria Agudetse Roures Date: Fri, 28 Jul 2023 15:38:50 +0200 Subject: [PATCH 07/14] Only run Scorecards job if Scorecards section is in the recipe --- tools/write_autosubmit_conf.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tools/write_autosubmit_conf.R b/tools/write_autosubmit_conf.R index f0e1088a..bcf2cfee 100644 --- a/tools/write_autosubmit_conf.R +++ b/tools/write_autosubmit_conf.R @@ -51,6 +51,9 @@ write_autosubmit_conf <- function(recipe, nchunks) { "FAILED") } jobs$verification$PROCESSORS <- recipe$Run$auto_conf$processors_per_job # ncores? + if (!("Scorecards" %in% names(recipe$Analysis$Workflow))) { + jobs$scorecards <- NULL + } # Return to original list if (auto_specs$auto_version == "4.0.0") { conf$JOBS <- jobs -- GitLab From d672b32886cf3db9d0327709d3a430657ea1641c Mon Sep 17 00:00:00 2001 From: Victoria Agudetse Roures Date: Fri, 28 Jul 2023 15:39:22 +0200 Subject: [PATCH 08/14] Reorganize functions and scripts --- autosubmit/auto-scorecards.sh | 2 +- autosubmit/conf_esarchive/jobs.conf | 2 +- modules/Scorecards/Scorecards.R | 198 ++++++++++++++++++++++-- modules/Scorecards/execute_scorecards.R | 3 +- 4 files changed, 189 insertions(+), 16 deletions(-) diff --git a/autosubmit/auto-scorecards.sh b/autosubmit/auto-scorecards.sh index a1033a46..4b527372 100644 --- a/autosubmit/auto-scorecards.sh +++ b/autosubmit/auto-scorecards.sh @@ -12,4 +12,4 @@ recipe=${outdir}/logs/recipes/${recipe} source MODULES -Rscript modules/Scorecards/Scorecards.R ${recipe} ${outdir} +Rscript modules/Scorecards/execute_scorecards.R ${recipe} ${outdir} diff --git a/autosubmit/conf_esarchive/jobs.conf b/autosubmit/conf_esarchive/jobs.conf index f9d26634..c99236dd 100644 --- a/autosubmit/conf_esarchive/jobs.conf +++ b/autosubmit/conf_esarchive/jobs.conf @@ -9,6 +9,6 @@ PROCESSORS = [scorecards] FILE = autosubmit/auto-scorecards.sh WALLCLOCK = 00:10 -PLATFORM = nord3v2 +PLATFORM = nord3v2 ## Change?? PROCESSORS = 1 DEPENDENCIES = verification diff --git a/modules/Scorecards/Scorecards.R b/modules/Scorecards/Scorecards.R index 0a46f75f..6086ecb2 100644 --- a/modules/Scorecards/Scorecards.R +++ b/modules/Scorecards/Scorecards.R @@ -1,13 +1,185 @@ -source('tools/libs.R') -source('modules/Scorecards/R/plot_scorecards.R') - -args = commandArgs(trailingOnly = TRUE) -recipe_file <- args[1] -output_dir <- args[2] - -# Read recipe and set outdir -recipe <- read_yaml(recipe_file) -recipe$Run$output_dir <- output_dir -recipe$Analysis$Datasets$System <- recipe$Analysis$Datasets$System[[1]] -recipe$Analysis$Datasets$Reference <- recipe$Analysis$Datasets$Reference[[1]] -recipe$Analysis$Variables <- recipe$Analysis$Variables[[1]] +############################################################################### +##################### SCORECARDS MODULE FOR SUNSET SUITE ###################### +############################################################################### + +##### Load source functions ##### +source('modules/Scorecards/tmp/LoadMetrics.R') +source('modules/Scorecards/tmp/WeightedMetrics.R') +source('modules/Scorecards/tmp/Utils.R') +source('modules/Scorecards/tmp/SCTransform.R') +source('modules/Scorecards/tmp/ScorecardsSingle.R') +source('modules/Scorecards/tmp/ScorecardsMulti.R') +source('modules/Scorecards/tmp/ScorecardsSystemDiff.R') +source('modules/Scorecards/tmp/SCPlotScorecard.R') + + +## TODO: Change function name to 'Scorecards'? +## Define function +plot_scorecards <- function(recipe) { + + ## set parameters + input.path <- paste0(recipe$Run$output_dir, "/outputs/Skill/") + output.path <- paste0(recipe$Run$output_dir, "/plots/Scorecards/") + dir.create(output.path, recursive = T, showWarnings = F) + + system <- recipe$Analysis$Datasets$System$name + reference <- recipe$Analysis$Datasets$Reference$name + var <- recipe$Analysis$Variables$name + start.year <- as.numeric(recipe$Analysis$Time$hcst_start) + end.year <- as.numeric(recipe$Analysis$Time$hcst_end) + forecast.months <- recipe$Analysis$Time$ftime_min : recipe$Analysis$Time$ftime_max + + start.months <- 1:12 #recipe$Analysis$Workflow$Scorecards$start_months + + regions <- recipe$Analysis$Workflow$Scorecards$regions + for (i in names(regions)){regions[[i]] <- unlist(regions[[i]])} + + metric.aggregation <- recipe$Analysis$Workflow$Scorecards$metric_aggregation + metrics.load <- unlist(strsplit(tolower(recipe$Analysis$Workflow$Skill$metric), ", | |,")) + + ## Define skill scores in score aggregation has been requested + + if(metric.aggregation == 'score'){ + if('rps' %in% metrics.load){ + metrics.load <- c(metrics.load, 'rps_clim') + } + if('crps' %in% metrics.load){ + metrics.load <- c(metrics.load, 'crps_clim') + } + } + + metrics.visualize <- unlist(strsplit(tolower(recipe$Analysis$Workflow$Scorecards$metric), ", | |,")) + + ## Define skill scores in score aggregation has been requested + + if(metric.aggregation == 'score'){ + if('rpss' %in% metrics.visualize){ + metrics.visualize[metrics.visualize == 'rpss'] <- 'rpss_score_aggr' + } + if('crpss' %in% metrics.visualize){ + metrics.visualize[metrics.visualize == 'crpss'] <- 'crpss_score_aggr' + } + } + + table.label <- recipe$Analysis$Workflow$Scorecards$table_label + fileout.label <- recipe$Analysis$Workflow$Scorecards$fileout_label + legend.white.space <- recipe$Analysis$Workflow$Scorecards$legend_white_space + col1.width <- recipe$Analysis$Workflow$Scorecards$col1_width + col2.width <- recipe$Analysis$Workflow$Scorecards$col2_width + calculate.diff <- recipe$Analysis$Workflow$Scorecards$calculate_diff + ncores <- recipe$Analysis$ncores + + ## Load data files + loaded_metrics <- LoadMetrics(system = system, + reference = reference, + var = var, + start.year = start.year, + end.year = end.year, + metrics = metrics.load, + start.months = start.months, + forecast.months = forecast.months, + input.path = input.path) + + + if('region' %in% names(dim(loaded_metrics[[1]][[1]]))){ + + ### Convert loaded metrics to array for allready aggregated data + metrics.dim <- attributes(loaded_metrics[[1]][[1]])$metrics + forecast.months.dim <- attributes(loaded_metrics[[1]][[1]])$forecast.months + start.months.dim <- attributes(loaded_metrics[[1]][[1]])$start.months + regions.dim <- regions #list('NAO' = c(lon.min = -80, lon.max = 40, lat.min = 20, lat.max = 80)) + + aggregated_metrics <- array(dim = c(system = length(loaded_metrics), + reference = length(loaded_metrics[[1]]), + metric = length(metrics.dim), + time = length(forecast.months.dim), + sdate = length(start.months.dim), + region = length(regions.dim))) + + + for (sys in 1:length(names(loaded_metrics))){ + for (ref in 1:length(names(loaded_metrics[[sys]]))){ + aggregated_metrics[sys, ref, , , , ] <- s2dv::Reorder(data = loaded_metrics[[sys]][[ref]], order = c('metric','time','sdate','region')) + } + } + + ## Add attributes + attributes(aggregated_metrics)$metrics <- metrics.load + attributes(aggregated_metrics)$start.months <- attributes(loaded_metrics[[1]][[1]])$start.months + attributes(aggregated_metrics)$forecast.months <- attributes(loaded_metrics[[1]][[1]])$forecast.months + attributes(aggregated_metrics)$regions <- regions + attributes(aggregated_metrics)$system.name <- names(loaded_metrics) + attributes(aggregated_metrics)$reference.name <- names(loaded_metrics[[1]]) + + + } else { + ## Calculate weighted mean of spatial aggregation + aggregated_metrics <- WeightedMetrics(loaded_metrics, + regions = regions, + metric.aggregation = metric.aggregation, + ncores = ncores) + }## close if + + ## Create simple scorecard tables + ## (one system only) + ## Metrics input must be in the same order as function SC_spatial_aggregation + scorecard_single <- ScorecardsSingle(data = aggregated_metrics, + system = system, + reference = reference, + var = var, + start.year = start.year, + end.year = end.year, + start.months = start.months, + forecast.months = forecast.months, + region.names = names(regions), + metrics = metrics.visualize, + table.label = table.label, + fileout.label = fileout.label, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + output.path = output.path) + + ## Create multi system/reference scorecard tables + ## (multiple systems with one reference or one system with multiple references) + ## Metrics input must be in the same order as function SC_spatial_aggregation + if(length(system) > 1 || length(reference) > 1){ + scorecard_multi <- ScorecardsMulti(data = aggregated_metrics, + system = system, + reference = reference, + var = var, + start.year = start.year, + end.year = end.year, + start.months = start.months, + forecast.months = forecast.months, + region.names = attributes(regions)$names, + metrics = metrics.visualize, + table.label = table.label, + fileout.label = fileout.label, + output.path = output.path) + } ## close if + + + if(calculate.diff == TRUE){ + if(length(system) == 2 || length(reference) == 2){ + scorecard_diff <- ScorecardsSystemDiff(data = aggregated_metrics, + system = system, + reference = reference, + var = var, + start.year = start.year, + end.year = end.year, + start.months = start.months, + forecast.months = forecast.months, + region.names = attributes(regions)$names, + metrics = metrics.visualize, + table.label = table.label, + fileout.label = fileout.label, + legend.white.space = legend.white.space, + col1.width = col1.width, + col2.width = col2.width, + output.path = output.path) + } else {stop ("Difference scorecard can only be computed with two systems or two references.")} + } ## close if on calculate.diff + +} + diff --git a/modules/Scorecards/execute_scorecards.R b/modules/Scorecards/execute_scorecards.R index b71d7f4f..95bf4bb9 100644 --- a/modules/Scorecards/execute_scorecards.R +++ b/modules/Scorecards/execute_scorecards.R @@ -1,5 +1,5 @@ source('tools/libs.R') -source('modules/Scorecards/R/plot_scorecards.R') +source('modules/Scorecards/Scorecards.R') args = commandArgs(trailingOnly = TRUE) recipe_file <- args[1] @@ -15,3 +15,4 @@ recipe$Analysis$Variables <- recipe$Analysis$Variables[[1]] # Plot Scorecards plot_scorecards(recipe) +print("##### SCORECARDS SAVED TO THE OUTPUT DIRECTORY #####") -- GitLab From c1a73fd3e7d7f883a48a635301b93252beb15083 Mon Sep 17 00:00:00 2001 From: Victoria Agudetse Roures Date: Fri, 28 Jul 2023 15:39:49 +0200 Subject: [PATCH 09/14] Uncomment scorecards --- recipes/recipe_scorecards.yml | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/recipes/recipe_scorecards.yml b/recipes/recipe_scorecards.yml index a50fd572..88b63b6e 100644 --- a/recipes/recipe_scorecards.yml +++ b/recipes/recipe_scorecards.yml @@ -63,20 +63,20 @@ Analysis: plots: skill_metrics Indicators: index: no # ? - # Scorecards: - # regions: - # Extra-tropical NH: {lon.min: 0, lon.max: 360, lat.min: 30, lat.max: 90} - # Tropics: {lon.min: 0, lon.max: 360, lat.min: -30, lat.max: 30} - # Extra-tropical SH : {lon.min: 0, lon.max: 360, lat.min: -30, lat.max: -90} - # start_months: NULL - # metric: mean_bias enscorr rpss crpss enssprerr - # metric_aggregation: 'score' - # table_label: NULL - # fileout_label: NULL - # col1_width: NULL - # col2_width: NULL - # calculate_diff: FALSE - # #output_path: /esarchive/scratch/nmilders/scorecards_images/testing + Scorecards: + regions: + Extra-tropical NH: {lon.min: 0, lon.max: 360, lat.min: 30, lat.max: 90} + Tropics: {lon.min: 0, lon.max: 360, lat.min: -30, lat.max: 30} + Extra-tropical SH : {lon.min: 0, lon.max: 360, lat.min: -30, lat.max: -90} + start_months: NULL + metric: mean_bias enscorr rpss crpss enssprerr + metric_aggregation: 'score' + table_label: NULL + fileout_label: NULL + col1_width: NULL + col2_width: NULL + calculate_diff: FALSE + #output_path: /esarchive/scratch/nmilders/scorecards_images/testing ncores: 7 remove_NAs: no # bool, don't split Output_format: Scorecards # string, don't split -- GitLab From e4636673160e3aeedfb42815944e5de529da3964 Mon Sep 17 00:00:00 2001 From: vagudets Date: Thu, 3 Aug 2023 10:36:10 +0200 Subject: [PATCH 10/14] Add 'execute' parameter to scorecards --- recipes/recipe_scorecards.yml | 2 +- recipes/recipe_scorecards_vic.yml | 1 + tools/write_autosubmit_conf.R | 5 ++++- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/recipes/recipe_scorecards.yml b/recipes/recipe_scorecards.yml index 88b63b6e..434426d0 100644 --- a/recipes/recipe_scorecards.yml +++ b/recipes/recipe_scorecards.yml @@ -64,6 +64,7 @@ Analysis: Indicators: index: no # ? Scorecards: + execute: yes # yes/no regions: Extra-tropical NH: {lon.min: 0, lon.max: 360, lat.min: 30, lat.max: 90} Tropics: {lon.min: 0, lon.max: 360, lat.min: -30, lat.max: 30} @@ -76,7 +77,6 @@ Analysis: col1_width: NULL col2_width: NULL calculate_diff: FALSE - #output_path: /esarchive/scratch/nmilders/scorecards_images/testing ncores: 7 remove_NAs: no # bool, don't split Output_format: Scorecards # string, don't split diff --git a/recipes/recipe_scorecards_vic.yml b/recipes/recipe_scorecards_vic.yml index 8ff72168..9abd5193 100644 --- a/recipes/recipe_scorecards_vic.yml +++ b/recipes/recipe_scorecards_vic.yml @@ -64,6 +64,7 @@ Analysis: Indicators: index: no # ? Scorecards: + execute: yes # yes/no regions: Extra-tropical NH: {lon.min: 0, lon.max: 360, lat.min: 30, lat.max: 90} Tropics: {lon.min: 0, lon.max: 360, lat.min: -30, lat.max: 30} diff --git a/tools/write_autosubmit_conf.R b/tools/write_autosubmit_conf.R index bcf2cfee..bfc708bc 100644 --- a/tools/write_autosubmit_conf.R +++ b/tools/write_autosubmit_conf.R @@ -51,7 +51,10 @@ write_autosubmit_conf <- function(recipe, nchunks) { "FAILED") } jobs$verification$PROCESSORS <- recipe$Run$auto_conf$processors_per_job # ncores? - if (!("Scorecards" %in% names(recipe$Analysis$Workflow))) { + # Only include Scorecards job if section exists in the recipe and + # is set to 'execute: True' + if (!("Scorecards" %in% names(recipe$Analysis$Workflow)) || + (!recipe$Analysis$Workflow$Scorecards$execute)) { jobs$scorecards <- NULL } # Return to original list -- GitLab From 77f029f91bca00b1b840bea8a8de1faa1c45cb9a Mon Sep 17 00:00:00 2001 From: Victoria Agudetse Roures Date: Fri, 1 Sep 2023 10:29:56 +0200 Subject: [PATCH 11/14] Fix bug in platform configuration --- autosubmit/conf_esarchive/jobs.conf | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/autosubmit/conf_esarchive/jobs.conf b/autosubmit/conf_esarchive/jobs.conf index c99236dd..f9d26634 100644 --- a/autosubmit/conf_esarchive/jobs.conf +++ b/autosubmit/conf_esarchive/jobs.conf @@ -9,6 +9,6 @@ PROCESSORS = [scorecards] FILE = autosubmit/auto-scorecards.sh WALLCLOCK = 00:10 -PLATFORM = nord3v2 ## Change?? +PLATFORM = nord3v2 PROCESSORS = 1 DEPENDENCIES = verification -- GitLab From 319658313a97ea5556ff3f112e9b169a995fbf81 Mon Sep 17 00:00:00 2001 From: Nadia Milders Date: Wed, 6 Sep 2023 11:20:26 +0200 Subject: [PATCH 12/14] included bug fix in LoadMetrics function --- modules/Scorecards/tmp/LoadMetrics.R | 42 +++++++++++++++++----------- 1 file changed, 25 insertions(+), 17 deletions(-) diff --git a/modules/Scorecards/tmp/LoadMetrics.R b/modules/Scorecards/tmp/LoadMetrics.R index 7e68b65a..e5e15421 100644 --- a/modules/Scorecards/tmp/LoadMetrics.R +++ b/modules/Scorecards/tmp/LoadMetrics.R @@ -36,7 +36,7 @@ #' input.path = '/esarchive/scratch/nmilders/scorecards_data/input_data') #'} #'@import easyNCDF -#'@import abind +#'@import multiApply #'@export LoadMetrics <- function(system, reference, var, start.year, end.year, metrics, start.months, forecast.months, @@ -147,24 +147,24 @@ LoadMetrics <- function(system, reference, var, start.year, end.year, ############################################################ .Loadmetrics <- function(input.path, system, reference, - var, period, start.months, - forecast.months, metrics) { + var, period, start.months, + forecast.months, metrics) { ## Load data for each start date allfiles <- sapply(start.months, function(m) { - paste0(input.path, "/", system, "/", var, - "/scorecards_", system, "_", reference, "_", - var, "-skill_", period, "_s", m, # mod.pressure, - ".nc")}) + paste0(input.path, "/", system, "/", var, + "/scorecards_", system, "_", reference, "_", + var, "-skill_", period, "_s", m, # mod.pressure, + ".nc")}) allfiles_exist <- sapply(allfiles, file.exists) - + # Check dims files_exist_by_month <- seq(1:length(allfiles))[allfiles_exist] allfiledims <- sapply(allfiles[allfiles_exist], easyNCDF::NcReadDims) if (length(files_exist_by_month) == 0) { stop("No files are found.") } - + num_dims <- numeric(dim(allfiledims)[1]) for (i in 1:dim(allfiledims)[1]) { if (length(unique(allfiledims[i,])) > 1) { @@ -175,16 +175,24 @@ LoadMetrics <- function(system, reference, var, start.year, end.year, } # dims: [metric, longitude, latitude, time, smonth] # or [metric, region, time, smonth] - + # Loop for file - m <- array(files_exist_by_month, c(sdate = length(files_exist_by_month))) - array_met_by_sdate <- apply(m, 1, function(x) { - test <- easyNCDF::NcToArray(allfiles[x], vars_to_read = metrics, unlist = T, - drop_var_dim = T) - test}) + dim(allfiles) <- c(dat = 1, sdate = length(allfiles)) + + array_met_by_sdate <- Apply(data = allfiles, target_dims = 'dat', fun = function(x) { + if (file.exists(x)) { + res <- easyNCDF::NcToArray(x, vars_to_read = metrics, unlist = T, + drop_var_dim = T) + names(dim(res)) <- NULL + } else { + res <- array(dim = c(length(metrics), allfiledims[-1,1])) + names(dim(res)) <- NULL + } + res})$output1 + dim(array_met_by_sdate) <- c(metric = length(metrics), allfiledims[-1,1], - sdate = length(start.months)) - + sdate = length(allfiles)) + # Attributes # Read attributes from the first existing file if ("region" %in% rownames(allfiledims)) { -- GitLab From cfe336b7820f30e110df93785bfc36fb4964b1bc Mon Sep 17 00:00:00 2001 From: Victoria Agudetse Roures Date: Thu, 7 Sep 2023 10:52:10 +0200 Subject: [PATCH 13/14] Add scorecards job to MARS config, remove minor bug in esarchive conf, modify recipe --- autosubmit/conf_esarchive/proj.conf | 2 +- autosubmit/conf_mars/jobs.yml | 7 +++++++ recipes/recipe_scorecards_vic.yml | 3 +-- 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/autosubmit/conf_esarchive/proj.conf b/autosubmit/conf_esarchive/proj.conf index 1e8ffd03..7322a971 100644 --- a/autosubmit/conf_esarchive/proj.conf +++ b/autosubmit/conf_esarchive/proj.conf @@ -3,4 +3,4 @@ MODULES = "MODULES" OUTDIR = SCRIPT = -RECIPE = recipes/recipe_scorecards_vic.yml +RECIPE = diff --git a/autosubmit/conf_mars/jobs.yml b/autosubmit/conf_mars/jobs.yml index 2d8e32af..aba048bc 100644 --- a/autosubmit/conf_mars/jobs.yml +++ b/autosubmit/conf_mars/jobs.yml @@ -6,3 +6,10 @@ JOBS: NOTIFY_ON: PLATFORM: NORD3 PROCESSORS: + scorecards: + FILE: autosubmit/auto-scorecards.sh + WALLCLOCK: 00:10 + PLATFORM: NORD3 + PROCESSORS: 1 + DEPENDENCIES: verification + diff --git a/recipes/recipe_scorecards_vic.yml b/recipes/recipe_scorecards_vic.yml index 9abd5193..16a3cfae 100644 --- a/recipes/recipe_scorecards_vic.yml +++ b/recipes/recipe_scorecards_vic.yml @@ -36,7 +36,7 @@ Analysis: - '1201' fcst_year: hcst_start: '1993' # single option - hcst_end: '2016' # single option + hcst_end: '2003' # single option ftime_min: 1 # single option ftime_max: 6 # single option Region: # multiple lists, split? Add region name if length(Region) > 1 @@ -77,7 +77,6 @@ Analysis: col1_width: NULL col2_width: NULL calculate_diff: FALSE - #output_path: /esarchive/scratch/nmilders/scorecards_images/testing ncores: 14 remove_NAs: no # bool, don't split Output_format: Scorecards # string, don't split -- GitLab From 36a4de00242e2fbe095245c0e42c2ad0b47c4d5a Mon Sep 17 00:00:00 2001 From: Victoria Agudetse Roures Date: Thu, 7 Sep 2023 13:18:48 +0200 Subject: [PATCH 14/14] Add memuse back --- tools/libs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/libs.R b/tools/libs.R index 9e4de9ba..4a1e71e3 100644 --- a/tools/libs.R +++ b/tools/libs.R @@ -23,7 +23,7 @@ library(pryr) library(ncdf4) library(formattable) ## to plot horizontal color bars - used ?? library(kableExtra) -# To check mem usage. +library(memuse) # To check mem usage. # Functions ## To be removed when new package is done by library(CSOperational) -- GitLab