From 8aec1fc861105acf2637f078856dbf0aab492459 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 15 Nov 2023 15:34:18 +0100 Subject: [PATCH 1/4] Allow saving arrays without sdate_dim, only required ftime_dim --- R/CST_SaveExp.R | 104 +++++++++++++++++++++++++++++------------------- man/SaveExp.Rd | 3 +- 2 files changed, 66 insertions(+), 41 deletions(-) diff --git a/R/CST_SaveExp.R b/R/CST_SaveExp.R index 7d5733f1..4917b8bf 100644 --- a/R/CST_SaveExp.R +++ b/R/CST_SaveExp.R @@ -186,7 +186,8 @@ CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate', #'@param destination A character string indicating the path where to store the #' NetCDF files. #'@param Dates A named array of dates with the corresponding sdate and forecast -#' time dimension. +#' time dimension. If there is no sdate_dim, you can set it to NULL. +#' It must have ftime_dim dimension. #'@param coords A named list with elements of the coordinates corresponding to #' the dimensions of the data parameter. The names and length of each element #' must correspond to the names of the dimensions. If any coordinate is not @@ -475,8 +476,14 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, } # Dates dimension check if (!is.null(Dates)) { - if (all(names(dim(Dates)) == c(ftime_dim, sdate_dim)) | - all(names(dim(Dates)) == c(sdate_dim, ftime_dim))) { + if (all(c(ftime_dim, sdate_dim) %in% names(dim(Dates)))) { + if (any(!names(dim(Dates)) %in% c(ftime_dim, sdate_dim))) { + if (all(dim(Dates)[!names(dim(Dates)) %in% c(ftime_dim, sdate_dim)] == 1)) { + dim(Dates) <- dim(Dates)[names(dim(Dates)) %in% c(ftime_dim, sdate_dim)] + } else { + stop("Parameter 'Dates' must have only sdate_dim and ftime_dim dimensions.") + } + } if (is.null(startdates)) { startdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') } else if ((!inherits(startdates, "POSIXct") & !inherits(startdates, "Date")) && @@ -485,15 +492,14 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, "the start dates in the format 'yyyy-mm-dd', 'yyyymmdd', 'yyyymm', ", "'POSIXct' or 'Dates' class. Files will be named with Dates instead.") startdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') - if (!is.null(format(startdates, "%Y%m%d"))) { - startdates <- format(startdates, "%Y%m%d") - } } - } else if (all(dim(Dates)[!names(dim(Dates)) %in% c(ftime_dim, sdate_dim)] == 1)) { - dim(Dates) <- dim(Dates)[names(dim(Dates)) %in% c(ftime_dim, sdate_dim)] - } else { - stop("Parameter 'Dates' must have start date dimension and ", - "forecast time dimension.") + if (!is.null(format(startdates, "%Y%m%d"))) { + startdates <- format(startdates, "%Y%m%d") + } + } else if (any(ftime_dim %in% names(dim(Dates)))) { + if (all(dim(Dates)[!names(dim(Dates)) %in% c(ftime_dim)] == 1)) { + dim(Dates) <- dim(Dates)[names(dim(Dates)) %in% c(ftime_dim, sdate_dim)] + } } } # startdates @@ -698,34 +704,52 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, } first_sdate <- last_sdate <- NULL if (!is.null(Dates)) { - # sdate definition - sdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') - differ <- as.numeric((sdates - sdates[1])/3600) - new_dim <- list(ncdim_def(name = sdate_dim, units = paste('hours since', sdates[1]), - vals = differ, - longname = sdate_dim, create_dimvar = TRUE)) - names(new_dim) <- sdate_dim - defined_dims <- c(defined_dims, new_dim) - first_sdate <- sdates[1] - last_sdate <- sdates[length(sdates)] - # ftime definition - Dates <- Reorder(Dates, c(ftime_dim, sdate_dim)) - differ_ftime <- apply(Dates, 2, function(x){as.numeric((x - x[1])/3600)}) - dim(differ_ftime) <- dim(Dates) - differ_ftime_subset <- Subset(differ_ftime, along = sdate_dim, 1, drop = 'selected') - if (all(apply(differ_ftime, 1, function(x){length(unique(x)) == 1}))) { - if (all(diff(differ_ftime_subset/24) == 1)) { + if (is.null(sdate_dim)) { + sdates <- Dates[1] + # ftime definition + leadtimes <- as.numeric(Dates - sdates)/3600 + save_hours_since <- TRUE + } else { + # sdate definition + sdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') + differ <- as.numeric((sdates - sdates[1])/3600) + new_dim <- list(ncdim_def(name = sdate_dim, units = paste('hours since', sdates[1]), + vals = differ, + longname = sdate_dim, create_dimvar = TRUE)) + names(new_dim) <- sdate_dim + defined_dims <- c(defined_dims, new_dim) + first_sdate <- sdates[1] + last_sdate <- sdates[length(sdates)] + # ftime definition + Dates <- Reorder(Dates, c(ftime_dim, sdate_dim)) + differ_ftime <- apply(Dates, 2, function(x){as.numeric((x - x[1])/3600)}) + dim(differ_ftime) <- dim(Dates) + leadtimes <- Subset(differ_ftime, along = sdate_dim, 1, drop = 'selected') + + # if (all(apply(differ_ftime, 1, function(x){length(unique(x)) == 1}))) { + # save_hours_since <- TRUE + # } else { + # warning("Time steps are not equal for all start dates. Only ", + # "forecast time values for the first start date will be saved ", + # "correctly.") + # } + save_hours_since <- TRUE # NOTE: See if units without origin are readable? + } + + if (!save_hours_since) { + # NOTE: I have doubts about this part. Are the units readable by Start? + if (all(diff(leadtimes/24) == 1)) { # daily values dim_time <- list(ncdim_def(name = ftime_dim, units = 'days', - vals = round(differ_ftime_subset/24) + 1, + vals = round(leadtimes/24) + 1, calendar = 'proleptic_gregorian', longname = ftime_dim, unlim = TRUE)) names(dim_time) <- ftime_dim defined_dims <- c(defined_dims, dim_time) - } else if (all(diff(differ_ftime_subset/24) %in% c(28, 29, 30, 31))) { + } else if (all(diff(leadtimes/24) %in% c(28, 29, 30, 31))) { # monthly values dim_time <- list(ncdim_def(name = ftime_dim, units = 'months', - vals = round(differ_ftime_subset/730) + 1, + vals = round(leadtimes/730) + 1, calendar = 'proleptic_gregorian', longname = ftime_dim, unlim = TRUE)) names(dim_time) <- ftime_dim @@ -733,20 +757,18 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, } else { # other frequency dim_time <- list(ncdim_def(name = ftime_dim, units = 'hours', - vals = differ_ftime_subset + 1, + vals = leadtimes + 1, calendar = 'proleptic_gregorian', longname = ftime_dim, unlim = TRUE)) names(dim_time) <- ftime_dim defined_dims <- c(defined_dims, dim_time) } } else { - warning("Time steps are not equal for all start dates. Only ", - "forecast time values for the first start date will be saved ", - "correctly.") + # Save in units 'hours since' dim_time <- list(ncdim_def(name = ftime_dim, units = paste('hours since', paste(sdates, collapse = ', ')), - vals = differ_ftime_subset, + vals = leadtimes, calendar = 'proleptic_gregorian', longname = ftime_dim, unlim = TRUE)) names(dim_time) <- ftime_dim @@ -823,10 +845,12 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, gsub("-", "", last_sdate)), collapse = '_'), ".nc") } else { - file_name <- paste0(paste(c(varname, extra_string, - gsub("-", "", first_sdate), - gsub("-", "", last_sdate)), - collapse = '_'), ".nc") + nc <- substr(extra_string, nchar(extra_string)-2, nchar(extra_string)) + if (nc == ".nc") { + file_name <- extra_string + } else { + file_name <- paste0(extra_string, ".nc") + } } full_filename <- file.path(destination, file_name) file_nc <- nc_create(full_filename, defined_vars) diff --git a/man/SaveExp.Rd b/man/SaveExp.Rd index c690d97e..5aeb3ca4 100644 --- a/man/SaveExp.Rd +++ b/man/SaveExp.Rd @@ -30,7 +30,8 @@ SaveExp( NetCDF files.} \item{Dates}{A named array of dates with the corresponding sdate and forecast -time dimension.} +time dimension. If there is no sdate_dim, you can set it to NULL. +It must have ftime_dim dimension.} \item{coords}{A named list with elements of the coordinates corresponding to the dimensions of the data parameter. The names and length of each element -- GitLab From 83c3582cb2ba5f0ebddaa44ffb6e65b3b746fd44 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 15 Nov 2023 15:45:44 +0100 Subject: [PATCH 2/4] Add parameter to chose time units --- R/CST_SaveExp.R | 38 ++++++++++++++++++++++++++------------ man/CST_SaveExp.Rd | 7 ++++++- man/SaveExp.Rd | 7 ++++++- 3 files changed, 38 insertions(+), 14 deletions(-) diff --git a/R/CST_SaveExp.R b/R/CST_SaveExp.R index 4917b8bf..1ccf791d 100644 --- a/R/CST_SaveExp.R +++ b/R/CST_SaveExp.R @@ -46,6 +46,9 @@ #'@param extra_string A character string to be include as part of the file name, #' for instance, to identify member or realization. It would be added to the #' file name between underscore characters. +#'@param units_time_since A logical value indicating if the time units are +#' saved as 'time unit since' (e.g. 'horurs since') (TRUE) or as time unit +#' index (e.g. days, months, or hours) (FALSE). It is set as TRUE by default. #' #'@return Multiple or single NetCDF files containing the data array.\cr #'\item{\code{single_file = TRUE}}{ @@ -87,7 +90,8 @@ CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate', ftime_dim = 'time', dat_dim = 'dataset', var_dim = 'var', memb_dim = 'member', startdates = NULL, drop_dims = NULL, - single_file = FALSE, extra_string = NULL) { + single_file = FALSE, extra_string = NULL, + units_time_since = TRUE) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube'.") @@ -172,7 +176,8 @@ CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate', memb_dim = memb_dim, drop_dims = drop_dims, extra_string = extra_string, - single_file = single_file) + single_file = single_file, + units_time_since = units_time_since) } #'Save a multidimensional array with metadata to data in NetCDF format #'@description This function allows to save a data array with metadata into a @@ -231,6 +236,9 @@ CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate', #'@param extra_string A character string to be include as part of the file name, #' for instance, to identify member or realization. It would be added to the #' file name between underscore characters (optional). +#'@param units_time_since A logical value indicating if the time units are +#' saved as 'time unit since' (e.g. 'horurs since') (TRUE) or as time unit +#' index (e.g. days, months, or hours) (FALSE). It is set as TRUE by default. #' #'@return Multiple or single NetCDF files containing the data array.\cr #'\item{\code{single_file = TRUE}}{ @@ -278,7 +286,8 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, varname = NULL, metadata = NULL, Datasets = NULL, startdates = NULL, dat_dim = 'dataset', sdate_dim = 'sdate', ftime_dim = 'time', var_dim = 'var', memb_dim = 'member', - drop_dims = NULL, single_file = FALSE, extra_string = NULL) { + drop_dims = NULL, single_file = FALSE, extra_string = NULL, + units_time_since = TRUE) { ## Initial checks # data if (is.null(data)) { @@ -369,6 +378,12 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, stop("Parameter 'extra_string' must be a character string.") } } + # units_time_since + if (!is.logical(units_time_since)) { + warning("Parameter 'units_time_since' must be a logical value. It will be ", + "set as TRUE.") + units_time_since <- TRUE + } ## Dimensions checks # Spatial coordinates @@ -726,18 +741,17 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, dim(differ_ftime) <- dim(Dates) leadtimes <- Subset(differ_ftime, along = sdate_dim, 1, drop = 'selected') - # if (all(apply(differ_ftime, 1, function(x){length(unique(x)) == 1}))) { - # save_hours_since <- TRUE - # } else { - # warning("Time steps are not equal for all start dates. Only ", - # "forecast time values for the first start date will be saved ", - # "correctly.") - # } - save_hours_since <- TRUE # NOTE: See if units without origin are readable? + if (all(apply(differ_ftime, 1, function(x){length(unique(x)) == 1}))) { + if (!units_time_since) save_hours_since <- FALSE + } else { + warning("Time steps are not equal for all start dates. Only ", + "forecast time values for the first start date will be saved ", + "correctly.") + } } if (!save_hours_since) { - # NOTE: I have doubts about this part. Are the units readable by Start? + # NOTE: Are the units readable by Start? if (all(diff(leadtimes/24) == 1)) { # daily values dim_time <- list(ncdim_def(name = ftime_dim, units = 'days', diff --git a/man/CST_SaveExp.Rd b/man/CST_SaveExp.Rd index 9352e036..19da6f2a 100644 --- a/man/CST_SaveExp.Rd +++ b/man/CST_SaveExp.Rd @@ -15,7 +15,8 @@ CST_SaveExp( startdates = NULL, drop_dims = NULL, single_file = FALSE, - extra_string = NULL + extra_string = NULL, + units_time_since = TRUE ) } \arguments{ @@ -67,6 +68,10 @@ by default.} \item{extra_string}{A character string to be include as part of the file name, for instance, to identify member or realization. It would be added to the file name between underscore characters.} + +\item{units_time_since}{A logical value indicating if the time units are +saved as 'time unit since' (e.g. 'horurs since') (TRUE) or as time unit +index (e.g. days, months, or hours) (FALSE). It is set as TRUE by default.} } \value{ Multiple or single NetCDF files containing the data array.\cr diff --git a/man/SaveExp.Rd b/man/SaveExp.Rd index 5aeb3ca4..92fb457d 100644 --- a/man/SaveExp.Rd +++ b/man/SaveExp.Rd @@ -20,7 +20,8 @@ SaveExp( memb_dim = "member", drop_dims = NULL, single_file = FALSE, - extra_string = NULL + extra_string = NULL, + units_time_since = TRUE ) } \arguments{ @@ -88,6 +89,10 @@ by default (optional).} \item{extra_string}{A character string to be include as part of the file name, for instance, to identify member or realization. It would be added to the file name between underscore characters (optional).} + +\item{units_time_since}{A logical value indicating if the time units are +saved as 'time unit since' (e.g. 'horurs since') (TRUE) or as time unit +index (e.g. days, months, or hours) (FALSE). It is set as TRUE by default.} } \value{ Multiple or single NetCDF files containing the data array.\cr -- GitLab From 7e8822bd259ab462a3e2931fb8b29d66789540f3 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 15 Nov 2023 16:38:42 +0100 Subject: [PATCH 3/4] Correction of CST_SaveExp --- R/CST_SaveExp.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/CST_SaveExp.R b/R/CST_SaveExp.R index 1ccf791d..1154a41c 100644 --- a/R/CST_SaveExp.R +++ b/R/CST_SaveExp.R @@ -340,8 +340,8 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, coords[[i_coord]] <- 1:dim(data)[i_coord] } } else { - warning(paste0("Coordinate '", i_coord, "' is not provided ", - "and it will be set as index in element coords.")) + # warning(paste0("Coordinate '", i_coord, "' is not provided ", + # "and it will be set as index in element coords.")) coords[[i_coord]] <- 1:dim(data)[i_coord] } } @@ -718,12 +718,12 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, extra_info_dim[[dat_dim]] <- list(Datasets = paste(Datasets, collapse = ', ')) } first_sdate <- last_sdate <- NULL + save_hours_since <- TRUE if (!is.null(Dates)) { if (is.null(sdate_dim)) { sdates <- Dates[1] # ftime definition leadtimes <- as.numeric(Dates - sdates)/3600 - save_hours_since <- TRUE } else { # sdate definition sdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') -- GitLab From ee6d712a2200b97f1e8cc88a014bb46490c7adc3 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 28 Nov 2023 18:34:07 +0100 Subject: [PATCH 4/4] Improve the function --- DESCRIPTION | 2 +- R/CST_SaveExp.R | 145 ++++------------ man/CST_SaveExp.Rd | 7 +- man/SaveExp.Rd | 7 +- tests/testthat/test-CST_SaveExp.R | 268 +++++++++++++++++++----------- 5 files changed, 208 insertions(+), 221 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3af5dcb1..4e41770d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -90,5 +90,5 @@ VignetteBuilder: knitr License: GPL-3 Encoding: UTF-8 LazyData: true -RoxygenNote: 7.2.0 +RoxygenNote: 7.2.3 Config/testthat/edition: 3 diff --git a/R/CST_SaveExp.R b/R/CST_SaveExp.R index 1154a41c..b4987396 100644 --- a/R/CST_SaveExp.R +++ b/R/CST_SaveExp.R @@ -46,9 +46,6 @@ #'@param extra_string A character string to be include as part of the file name, #' for instance, to identify member or realization. It would be added to the #' file name between underscore characters. -#'@param units_time_since A logical value indicating if the time units are -#' saved as 'time unit since' (e.g. 'horurs since') (TRUE) or as time unit -#' index (e.g. days, months, or hours) (FALSE). It is set as TRUE by default. #' #'@return Multiple or single NetCDF files containing the data array.\cr #'\item{\code{single_file = TRUE}}{ @@ -90,8 +87,7 @@ CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate', ftime_dim = 'time', dat_dim = 'dataset', var_dim = 'var', memb_dim = 'member', startdates = NULL, drop_dims = NULL, - single_file = FALSE, extra_string = NULL, - units_time_since = TRUE) { + single_file = FALSE, extra_string = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube'.") @@ -176,8 +172,7 @@ CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate', memb_dim = memb_dim, drop_dims = drop_dims, extra_string = extra_string, - single_file = single_file, - units_time_since = units_time_since) + single_file = single_file) } #'Save a multidimensional array with metadata to data in NetCDF format #'@description This function allows to save a data array with metadata into a @@ -236,9 +231,6 @@ CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate', #'@param extra_string A character string to be include as part of the file name, #' for instance, to identify member or realization. It would be added to the #' file name between underscore characters (optional). -#'@param units_time_since A logical value indicating if the time units are -#' saved as 'time unit since' (e.g. 'horurs since') (TRUE) or as time unit -#' index (e.g. days, months, or hours) (FALSE). It is set as TRUE by default. #' #'@return Multiple or single NetCDF files containing the data array.\cr #'\item{\code{single_file = TRUE}}{ @@ -286,8 +278,7 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, varname = NULL, metadata = NULL, Datasets = NULL, startdates = NULL, dat_dim = 'dataset', sdate_dim = 'sdate', ftime_dim = 'time', var_dim = 'var', memb_dim = 'member', - drop_dims = NULL, single_file = FALSE, extra_string = NULL, - units_time_since = TRUE) { + drop_dims = NULL, single_file = FALSE, extra_string = NULL) { ## Initial checks # data if (is.null(data)) { @@ -320,6 +311,10 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, } else if (!all(dim(data)[drop_dims] %in% 1)) { warning("Parameter 'drop_dims' can only contain dimension names ", "that are of length 1. It will not be used.") + } else if (any(drop_dims %in% c(ftime_dim, sdate_dim, dat_dim, memb_dim, var_dim))) { + warning("Parameter 'drop_dims' contains dimensions used in the computation. ", + "It will not be used.") + drop_dims <- NULL } else { data <- Subset(x = data, along = drop_dims, indices = lapply(1:length(drop_dims), function(x) 1), @@ -340,8 +335,6 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, coords[[i_coord]] <- 1:dim(data)[i_coord] } } else { - # warning(paste0("Coordinate '", i_coord, "' is not provided ", - # "and it will be set as index in element coords.")) coords[[i_coord]] <- 1:dim(data)[i_coord] } } @@ -350,7 +343,6 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, } # varname if (is.null(varname)) { - warning("Parameter 'varname' is NULL. It will be assigned to 'X'.") varname <- 'X' } else if (length(varname) > 1) { multiple_vars <- TRUE @@ -361,11 +353,6 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, stop("Parameter 'varname' must be a character string with the ", "variable names.") } - # metadata - if (is.null(metadata)) { - warning("Parameter 'metadata' is not provided so the metadata saved ", - "will be incomplete.") - } # single_file if (!inherits(single_file, 'logical')) { warning("Parameter 'single_file' must be a logical value. It will be ", @@ -378,12 +365,6 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, stop("Parameter 'extra_string' must be a character string.") } } - # units_time_since - if (!is.logical(units_time_since)) { - warning("Parameter 'units_time_since' must be a logical value. It will be ", - "set as TRUE.") - units_time_since <- TRUE - } ## Dimensions checks # Spatial coordinates @@ -394,16 +375,6 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, } else { lon_dim <- dimnames[which(dimnames %in% .KnownLonNames())] lat_dim <- dimnames[which(dimnames %in% .KnownLatNames())] - if (length(lon_dim) > 1) { - warning("Found more than one longitudinal dimension. Only the first one ", - "will be used.") - lon_dim <- lon_dim[1] - } - if (length(lat_dim) > 1) { - warning("Found more than one latitudinal dimension. Only the first one ", - "will be used.") - lat_dim <- lat_dim[1] - } } # ftime_dim if (!is.null(ftime_dim)) { @@ -413,22 +384,12 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, if (!all(ftime_dim %in% dimnames)) { stop("Parameter 'ftime_dim' is not found in 'data' dimension.") } - if (length(ftime_dim) > 1) { - warning("Parameter 'ftime_dim' has length greater than 1 and ", - "only the first element will be used.") - ftime_dim <- ftime_dim[1] - } } # sdate_dim if (!is.null(sdate_dim)) { if (!is.character(sdate_dim)) { stop("Parameter 'sdate_dim' must be a character string.") } - if (length(sdate_dim) > 1) { - warning("Parameter 'sdate_dim' has length greater than 1 and ", - "only the first element will be used.") - sdate_dim <- sdate_dim[1] - } if (!all(sdate_dim %in% dimnames)) { stop("Parameter 'sdate_dim' is not found in 'data' dimension.") } @@ -470,11 +431,6 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, stop("Parameter 'var_dim' is not found in 'data' dimension. Set it ", "as NULL if there is no variable dimension.") } - if (length(var_dim) > 1) { - warning("Parameter 'var_dim' has length greater than 1 and ", - "only the first element will be used.") - var_dim <- var_dim[1] - } n_vars <- dim(data)[var_dim] } else { n_vars <- 1 @@ -491,31 +447,36 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, } # Dates dimension check if (!is.null(Dates)) { + if (is.null(ftime_dim)) { + stop("Parameter 'Dates' must have 'ftime_dim'.") + } if (all(c(ftime_dim, sdate_dim) %in% names(dim(Dates)))) { if (any(!names(dim(Dates)) %in% c(ftime_dim, sdate_dim))) { if (all(dim(Dates)[!names(dim(Dates)) %in% c(ftime_dim, sdate_dim)] == 1)) { dim(Dates) <- dim(Dates)[names(dim(Dates)) %in% c(ftime_dim, sdate_dim)] } else { - stop("Parameter 'Dates' must have only sdate_dim and ftime_dim dimensions.") + stop("Parameter 'Dates' must have only 'sdate_dim' and 'ftime_dim' dimensions.") } } if (is.null(startdates)) { startdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') - } else if ((!inherits(startdates, "POSIXct") & !inherits(startdates, "Date")) && - (!is.character(startdates) | (any(nchar(startdates) > 10) | any(nchar(startdates) < 1)))) { + } else if (any(inherits(startdates, "POSIXct"), inherits(startdates, "Date"))) { + startdates <- format(startdates, "%Y%m%d") + } else if (any(nchar(startdates) > 10, nchar(startdates) < 1)) { warning("Parameter 'startdates' should be a character string containing ", "the start dates in the format 'yyyy-mm-dd', 'yyyymmdd', 'yyyymm', ", "'POSIXct' or 'Dates' class. Files will be named with Dates instead.") startdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') } - if (!is.null(format(startdates, "%Y%m%d"))) { - startdates <- format(startdates, "%Y%m%d") - } } else if (any(ftime_dim %in% names(dim(Dates)))) { if (all(dim(Dates)[!names(dim(Dates)) %in% c(ftime_dim)] == 1)) { dim(Dates) <- dim(Dates)[names(dim(Dates)) %in% c(ftime_dim, sdate_dim)] } } + } else if (!single_file) { + warning("Dates must be provided if 'data' must be saved in separated files. ", + "All data will be saved in a single file.") + single_file <- TRUE } # startdates if (is.null(startdates)) { @@ -524,21 +485,9 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, } else { startdates <- rep('XXX', dim(data)[sdate_dim]) } - } else { - if (is.null(sdate_dim)) { - if (length(startdates) != 1) { - warning("Parameter 'startdates' has length more than 1. Only first ", - "value will be used.") - startdates <- startdates[[1]] - } - } } # Datasets if (is.null(Datasets)) { - if (!single_file) { - warning("Parameter 'Datasets' is NULL. Files will be saved with a ", - "directory name of 'XXX'.") - } Datasets <- rep('XXX', n_datasets ) } if (inherits(Datasets, 'list')) { @@ -718,7 +667,6 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, extra_info_dim[[dat_dim]] <- list(Datasets = paste(Datasets, collapse = ', ')) } first_sdate <- last_sdate <- NULL - save_hours_since <- TRUE if (!is.null(Dates)) { if (is.null(sdate_dim)) { sdates <- Dates[1] @@ -728,8 +676,9 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, # sdate definition sdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') differ <- as.numeric((sdates - sdates[1])/3600) - new_dim <- list(ncdim_def(name = sdate_dim, units = paste('hours since', sdates[1]), - vals = differ, + new_dim <- list(ncdim_def(name = sdate_dim, + units = paste('hours since', sdates[1]), + vals = differ, calendar = 'proleptic_gregorian', longname = sdate_dim, create_dimvar = TRUE)) names(new_dim) <- sdate_dim defined_dims <- c(defined_dims, new_dim) @@ -741,53 +690,22 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, dim(differ_ftime) <- dim(Dates) leadtimes <- Subset(differ_ftime, along = sdate_dim, 1, drop = 'selected') - if (all(apply(differ_ftime, 1, function(x){length(unique(x)) == 1}))) { - if (!units_time_since) save_hours_since <- FALSE - } else { + if (!all(apply(differ_ftime, 1, function(x){length(unique(x)) == 1}))) { warning("Time steps are not equal for all start dates. Only ", "forecast time values for the first start date will be saved ", "correctly.") } } - if (!save_hours_since) { - # NOTE: Are the units readable by Start? - if (all(diff(leadtimes/24) == 1)) { - # daily values - dim_time <- list(ncdim_def(name = ftime_dim, units = 'days', - vals = round(leadtimes/24) + 1, - calendar = 'proleptic_gregorian', - longname = ftime_dim, unlim = TRUE)) - names(dim_time) <- ftime_dim - defined_dims <- c(defined_dims, dim_time) - } else if (all(diff(leadtimes/24) %in% c(28, 29, 30, 31))) { - # monthly values - dim_time <- list(ncdim_def(name = ftime_dim, units = 'months', - vals = round(leadtimes/730) + 1, - calendar = 'proleptic_gregorian', - longname = ftime_dim, unlim = TRUE)) - names(dim_time) <- ftime_dim - defined_dims <- c(defined_dims, dim_time) - } else { - # other frequency - dim_time <- list(ncdim_def(name = ftime_dim, units = 'hours', - vals = leadtimes + 1, - calendar = 'proleptic_gregorian', - longname = ftime_dim, unlim = TRUE)) - names(dim_time) <- ftime_dim - defined_dims <- c(defined_dims, dim_time) - } - } else { - # Save in units 'hours since' - dim_time <- list(ncdim_def(name = ftime_dim, - units = paste('hours since', - paste(sdates, collapse = ', ')), - vals = leadtimes, - calendar = 'proleptic_gregorian', - longname = ftime_dim, unlim = TRUE)) - names(dim_time) <- ftime_dim - defined_dims <- c(defined_dims, dim_time) - } + # Save in units 'hours since' + dim_time <- list(ncdim_def(name = ftime_dim, + units = paste('hours since', + paste(sdates, collapse = ', ')), + vals = leadtimes, + calendar = 'proleptic_gregorian', + longname = ftime_dim, unlim = TRUE)) + names(dim_time) <- ftime_dim + defined_dims <- c(defined_dims, dim_time) } # var definition @@ -995,6 +913,5 @@ SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, ncatt_put(file_nc, varname, info_var, add_info_var) } } - nc_close(file_nc) } diff --git a/man/CST_SaveExp.Rd b/man/CST_SaveExp.Rd index 19da6f2a..9352e036 100644 --- a/man/CST_SaveExp.Rd +++ b/man/CST_SaveExp.Rd @@ -15,8 +15,7 @@ CST_SaveExp( startdates = NULL, drop_dims = NULL, single_file = FALSE, - extra_string = NULL, - units_time_since = TRUE + extra_string = NULL ) } \arguments{ @@ -68,10 +67,6 @@ by default.} \item{extra_string}{A character string to be include as part of the file name, for instance, to identify member or realization. It would be added to the file name between underscore characters.} - -\item{units_time_since}{A logical value indicating if the time units are -saved as 'time unit since' (e.g. 'horurs since') (TRUE) or as time unit -index (e.g. days, months, or hours) (FALSE). It is set as TRUE by default.} } \value{ Multiple or single NetCDF files containing the data array.\cr diff --git a/man/SaveExp.Rd b/man/SaveExp.Rd index 92fb457d..5aeb3ca4 100644 --- a/man/SaveExp.Rd +++ b/man/SaveExp.Rd @@ -20,8 +20,7 @@ SaveExp( memb_dim = "member", drop_dims = NULL, single_file = FALSE, - extra_string = NULL, - units_time_since = TRUE + extra_string = NULL ) } \arguments{ @@ -89,10 +88,6 @@ by default (optional).} \item{extra_string}{A character string to be include as part of the file name, for instance, to identify member or realization. It would be added to the file name between underscore characters (optional).} - -\item{units_time_since}{A logical value indicating if the time units are -saved as 'time unit since' (e.g. 'horurs since') (TRUE) or as time unit -index (e.g. days, months, or hours) (FALSE). It is set as TRUE by default.} } \value{ Multiple or single NetCDF files containing the data array.\cr diff --git a/tests/testthat/test-CST_SaveExp.R b/tests/testthat/test-CST_SaveExp.R index f39dffe9..1044d9f1 100644 --- a/tests/testthat/test-CST_SaveExp.R +++ b/tests/testthat/test-CST_SaveExp.R @@ -31,8 +31,10 @@ cube3 <- cube1 # dat0 dates0 <- as.Date('2022-02-01', format = "%Y-%m-%d") dim(dates0) <- c(sdate = 1) + # dat1 dat1 <- array(1, dim = c(test = 1)) + # dat2 dat2 <- array(1:5, dim = c(sdate = 5, lon = 4, lat = 4, ftime = 1)) coords2 <- list(sdate = c('20000101', '20010102', '20020103', '20030104', '20040105'), @@ -43,6 +45,31 @@ dates2 <- c('20000101', '20010102', '20020103', '20030104', '20040105') dates2 <- as.Date(dates2, format = "%Y%m%d", tz = "UTC") dim(dates2) <- c(sdate = 5, ftime = 1) +# dat3 (without sdate dim) +dat3 <- array(1:5, dim = c(lon = 4, lat = 4, ftime = 2)) +coords3 <- list(sdate = c('20000101', '20010102'), + var = 'tas', + lon = 1.:4., + lat = 1.:4.) +dates3 <- c('20000101', '20010102') +dates3 <- as.Date(dates3, format = "%Y%m%d", tz = "UTC") +dim(dates3) <- c(ftime = 2) + +# dat4 (without ftime dim) +dat4 <- array(1:5, dim = c(sdate = 2, lon = 4, lat = 4)) +coords4 <- list(sdate = c('20000101', '20010102'), + var = 'tas', + lon = 1.:4., + lat = 1.:4.) +dates4 <- c('20000101', '20010102') +dates4 <- as.Date(dates4, format = "%Y%m%d", tz = "UTC") +dim(dates4) <- c(sdate = 2) + +# dates5 (Dates with extra dimensions) +dates5 <- c('20000101', '20010102', '20010102', '20010102') +dates5 <- as.Date(dates5, format = "%Y%m%d", tz = "UTC") +dim(dates5) <- c(ftime = 2, test = 1, test2 = 2) + ############################################## test_that("1. Input checks: CST_SaveExp", { @@ -63,14 +90,14 @@ test_that("1. Input checks: CST_SaveExp", { CST_SaveExp(data = cube0), paste0("Level 'attrs' must be a list with at least 'Dates' element.") ) - # cube0$attrs <- NULL - # cube0$attrs$Dates <- dates2 - # expect_warning( - # CST_SaveExp(data = cube0, sdate_dim = c('sdate', 'sweek'), - # ftime_dim = 'ftime', memb_dim = NULL, dat_dim = NULL, - # var_dim = NULL, single_file = FALSE), - # paste0("Element 'coords' not found. No coordinates will be used.") - # ) + cube0$attrs <- NULL + cube0$attrs$Dates <- dates2 + expect_warning( + CST_SaveExp(data = cube0, sdate_dim = c('sdate', 'sweek'), + ftime_dim = 'ftime', memb_dim = NULL, dat_dim = NULL, + var_dim = NULL, single_file = FALSE), + paste0("Element 'coords' not found. No coordinates will be used.") + ) # sdate_dim suppressWarnings( @@ -79,37 +106,37 @@ test_that("1. Input checks: CST_SaveExp", { paste0("Parameter 'sdate_dim' must be a character string.") ) ) - # expect_warning( - # CST_SaveExp(data = cube1, sdate_dim = c('sdate', 'sweek'), - # ftime_dim = 'ftime', memb_dim = NULL, dat_dim = NULL, - # var_dim = NULL), - # paste0("Parameter 'sdate_dim' has length greater than 1 and ", - # "only the first element will be used.") - # ) + expect_warning( + CST_SaveExp(data = cube1, sdate_dim = c('sdate', 'sweek'), + ftime_dim = 'ftime', memb_dim = NULL, dat_dim = NULL, + var_dim = NULL, extra_string = 'test'), + paste0("Parameter 'sdate_dim' has length greater than 1 and ", + "only the first element will be used.") + ) suppressWarnings( expect_error( CST_SaveExp(data = cube1, sdate_dim = 'a', ftime_dim = 'ftime'), paste0("Parameter 'sdate_dim' is not found in 'data' dimension.") ) ) - # # startdates - # expect_warning( - # CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, - # dat_dim = NULL, var_dim = NULL, startdates = 1), - # "Parameter 'startdates' is not a character string, it will not be used." - # ) - # expect_warning( - # CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, - # dat_dim = NULL, var_dim = NULL, startdates = '20100101'), - # paste0("Parameter 'startdates' doesn't have the same length ", - # "as dimension '", 'sdate',"', it will not be used.") - # ) - # # metadata - # expect_warning( - # CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, - # dat_dim = NULL, var_dim = NULL), - # paste0("No metadata found in element Variable from attrs.") - # ) + # startdates + expect_warning( + CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL, startdates = 1), + "Parameter 'startdates' is not a character string, it will not be used." + ) + expect_warning( + CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL, startdates = '20100101'), + paste0("Parameter 'startdates' doesn't have the same length ", + "as dimension '", 'sdate',"', it will not be used.") + ) + # metadata + expect_warning( + CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL), + paste0("No metadata found in element Variable from attrs.") + ) cube1$attrs$Variable$metadata <- 'metadata' expect_error( CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, @@ -117,17 +144,17 @@ test_that("1. Input checks: CST_SaveExp", { paste0("Element metadata from Variable element in attrs must be a list.") ) cube1$attrs$Variable$metadata <- list(test = 'var') - # expect_warning( - # CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, - # dat_dim = NULL, var_dim = NULL), - # paste0("Metadata is not found for any coordinate.") - # ) + expect_warning( + CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL), + paste0("Metadata is not found for any coordinate.") + ) cube1$attrs$Variable$metadata <- list(var = 'var') - # expect_warning( - # CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, - # dat_dim = NULL, var_dim = NULL), - # paste0("Metadata is not found for any variable.") - # ) + expect_warning( + CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL), + paste0("Metadata is not found for any variable.") + ) # memb_dim suppressWarnings( expect_error( @@ -174,39 +201,40 @@ test_that("1. Input checks", { Dates = as.Date('2022-02-01', format = "%Y-%m-%d")), paste0("Parameter 'Dates' must have dimension names.") ) - # # drop_dims - # expect_warning( - # SaveExp(data = dat2, coords = coords2, - # metadata = list(tas = list(level = '2m')), - # Dates = dates2, ftime_dim = 'ftime', memb_dim = NULL, - # dat_dim = NULL, var_dim = NULL, drop_dims = 1), - # paste0("Parameter 'drop_dims' must be character string containing ", - # "the data dimension names to be dropped. It will not be used.") - # ) - # expect_warning( - # SaveExp(data = dat2, coords = coords2, - # metadata = list(tas = list(level = '2m')), - # Dates = dates2, ftime_dim = 'ftime', memb_dim = NULL, - # dat_dim = NULL, var_dim = NULL, drop_dims = 'time'), - # paste0("Parameter 'drop_dims' must be character string containing ", - # "the data dimension names to be dropped. It will not be used.") - # ) - # expect_warning( - # SaveExp(data = dat2, coords = coords2, - # metadata = list(tas = list(level = '2m')), - # Dates = dates2, ftime_dim = 'ftime', memb_dim = NULL, - # dat_dim = NULL, var_dim = NULL, drop_dims = 'sdate'), - # paste0("Parameter 'drop_dims' can only contain dimension names ", - # "that are of length 1. It will not be used.") - # ) - # # varname - # expect_warning( - # SaveExp(data = dat2, coords = coords2, - # metadata = list(tas = list(level = '2m')), - # Dates = dates2, ftime_dim = 'ftime', memb_dim = NULL, - # dat_dim = NULL, var_dim = NULL), - # paste0("Parameter 'varname' is NULL. It will be assigned to 'X'.") - # ) + # drop_dims + expect_warning( + SaveExp(data = dat2, coords = coords2, + metadata = list(tas = list(level = '2m')), + Dates = dates2, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL, drop_dims = 1), + paste0("Parameter 'drop_dims' must be character string containing ", + "the data dimension names to be dropped. It will not be used.") + ) + expect_warning( + SaveExp(data = dat2, coords = coords2, + metadata = list(tas = list(level = '2m')), + Dates = dates2, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL, drop_dims = 'time'), + paste0("Parameter 'drop_dims' must be character string containing ", + "the data dimension names to be dropped. It will not be used.") + ) + expect_warning( + SaveExp(data = dat2, coords = coords2, + metadata = list(tas = list(level = '2m')), + Dates = dates2, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL, drop_dims = 'sdate'), + paste0("Parameter 'drop_dims' can only contain dimension names ", + "that are of length 1. It will not be used.") + ) + expect_warning( + SaveExp(data = dat2, coords = coords2, + metadata = list(tas = list(level = '2m')), + Dates = dates2, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL, drop_dims = 'ftime'), + paste0("Parameter 'drop_dims' contains dimensions used in the ", + "computation. It will not be used.") + ) + # varname suppressWarnings( expect_error( SaveExp(data = dat2, coords = coords2, varname = 1, @@ -215,30 +243,82 @@ test_that("1. Input checks", { "Parameter 'varname' must be a character." ) ) - # # coords - # expect_warning( - # SaveExp(data = dat2, coords = list(sdate = coords2[[1]]), - # varname = 'tas', metadata = list(tas = list(level = '2m')), - # Dates = dates2, ftime_dim = 'ftime', memb_dim = NULL, - # dat_dim = NULL, var_dim = NULL), - # "Coordinate 'lon' is not provided and it will be set as index in element coords.", - # "Coordinate 'lat' is not provided and it will be set as index in element coords.", - # "Coordinate 'ftime' is not provided and it will be set as index in element coords." - # ) - # # varname, metadata, spatial coords, unknown dim - # expect_warning( - # SaveExp(data = dat1, ftime_dim = NULL, sdate_dim = NULL, memb_dim = NULL, - # dat_dim = NULL, var_dim = NULL, single_file = TRUE), - # "Parameter 'varname' is NULL. It will be assigned to 'X'.", - # "Parameter 'metadata' is not provided so the metadata saved will be incomplete.", - # paste0("Spatial coordinates not found.") - # ) + # varname, metadata, spatial coords, unknown dim expect_error( SaveExp(data = dat1, varname = 1, ftime_dim = NULL, sdate_dim = NULL, memb_dim = NULL, dat_dim = NULL, var_dim = NULL), paste0("Parameter 'varname' must be a character string with the ", "variable names.") ) + # ftime_dim + expect_error( + SaveExp(data = dat4, coords = coords4, + metadata = list(tas = list(level = '2m')), + Dates = dates4, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL), + paste0("Parameter 'ftime_dim' is not found in 'data' dimension.") + ) + # Dates dimension check + expect_error( + SaveExp(data = dat4, coords = coords4, + metadata = list(tas = list(level = '2m')), + Dates = dates4, ftime_dim = NULL, memb_dim = NULL, + dat_dim = NULL, var_dim = NULL), + paste0("Parameter 'Dates' must have 'ftime_dim'.") + ) + expect_warning( + SaveExp(data = dat4, coords = coords4, + metadata = list(tas = list(level = '2m')), + Dates = NULL, ftime_dim = NULL, memb_dim = NULL, + dat_dim = NULL, var_dim = NULL), + paste0("Dates must be provided if 'data' must be saved in separated files. ", + "All data will be saved in a single file.") + ) + # Without ftime and sdate + expect_error( + SaveExp(data = dat3, coords = coords3, + metadata = list(tas = list(level = '2m')), + Dates = dates5, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL, sdate_dim = NULL), + paste0("Parameter 'Dates' must have only 'sdate_dim' and 'ftime_dim' dimensions.") + ) + expect_warning( + SaveExp(data = dat2, coords = coords2, + metadata = list(tas = list(level = '2m')), + startdates = c(paste(1:11, collapse = '')), + Dates = dates2, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL, sdate_dim = 'sdate'), + paste0("Parameter 'startdates' should be a character string containing ", + "the start dates in the format 'yyyy-mm-dd', 'yyyymmdd', 'yyyymm', ", + "'POSIXct' or 'Dates' class. Files will be named with Dates instead.") + ) + expect_warning( + SaveExp(data = dat2, coords = coords2, + metadata = list(tas = list(level = '2m')), + Dates = NULL, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL, sdate_dim = 'sdate'), + paste0("Dates must be provided if 'data' must be saved in separated files. ", + "All data will be saved in a single file.") + ) + # (dat3) Without sdate_dim + expect_warning( + SaveExp(data = dat3, coords = coords3, + metadata = list(tas = list(level = '2m')), + Dates = dates3, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL, sdate_dim = NULL, + extra_string = 'nosdate3.nc', single_file = FALSE), + paste0("Dates must be provided if 'data' must be saved in separated files. ", + "All data will be saved in a single file.") + ) + # (dat4) Without ftime_dim + expect_warning( + SaveExp(data = dat4, coords = coords5, + metadata = list(tas = list(level = '2m')), + Dates = dates4, ftime_dim = NULL, memb_dim = NULL, + dat_dim = NULL, var_dim = NULL, sdate_dim = 'sdate', + single_file = TRUE), + paste0("Parameter 'Dates' must have 'ftime_dim'.") + ) }) ############################################## -- GitLab