diff --git a/modules/Crossval/Crossval_anomalies.R b/modules/Crossval/Crossval_anomalies.R index 8de05c4b08424614337a054247acf1a9ee828729..0467480908424c3c32c32a67a4b650d9c0ab8c0e 100644 --- a/modules/Crossval/Crossval_anomalies.R +++ b/modules/Crossval/Crossval_anomalies.R @@ -299,7 +299,7 @@ Crossval_anomalies <- function(recipe, data) { tmp_lims2 <- append(tmp_lims2, list(tmp_lims)) names(tmp_lims2)[length(tmp_lims2)] <- as.character(categories[[ps]][l]) } - if (recipe$Analysis$Workflow$Probabilities$save == 'yes') { + if (recipe$Analysis$Workflow$Probabilities$save %in% c("all", "percentiles_only")) { save_percentiles(recipe = recipe, percentiles = tmp_lims2, data_cube = data$obs, agg = "global", outdir = NULL) @@ -356,16 +356,18 @@ Crossval_anomalies <- function(recipe, data) { # Save forecast if ((recipe$Analysis$Workflow$Anomalies$save %in% c('all', 'exp_only', 'fcst_only')) && !is.null(data$fcst)) { - save_forecast(recipe = recipe, data_cube = data$fcst, type = 'fcst') + save_forecast(recipe = recipe, data_cube = data$fcst, type = 'fcst', + agg = agg) } # Save hindcast if (recipe$Analysis$Workflow$Anomalies$save %in% c('all', 'exp_only')) { - save_forecast(recipe = recipe, data_cube = ano_hcst, type = 'hcst') + save_forecast(recipe = recipe, data_cube = ano_hcst, type = 'hcst', + agg = agg) } # Save observation if (recipe$Analysis$Workflow$Anomalies$save == 'all') { - save_observations(recipe = recipe, data_cube = ano_obs) + save_observations(recipe = recipe, data_cube = ano_obs, agg = agg) } } # Save probability bins diff --git a/modules/Crossval/Crossval_metrics.R b/modules/Crossval/Crossval_metrics.R index 13635a54e5feb8fdf5b8b9258be0f5321dad8ec8..1532fdc217fa944b6463b92e1711a84ffef46892 100644 --- a/modules/Crossval/Crossval_metrics.R +++ b/modules/Crossval/Crossval_metrics.R @@ -25,6 +25,13 @@ Crossval_metrics <- function(recipe, ncores <- recipe$Analysis$ncores alpha <- recipe$Analysis$Skill$alpha na.rm <- recipe$Analysis$remove_NAs + # latlon or region aggregated + if ('latitude' %in% names(dim(data$obs$data))) { + agg = 'global' + } else if ('region' %in% names(dim(data$obs$data))) { + agg = 'region' + } + # ---------------------- # If the data$ref_obs is not NULL this is not needed: cross.method <- recipe$Analysis$cross.method @@ -371,7 +378,7 @@ Crossval_metrics <- function(recipe, recipe$Run$output_dir <- paste0(recipe$Run$output_dir, "/", "outputs/Skill/") save_metrics(recipe = recipe, metrics = skill_metrics, - data_cube = data$obs, agg = 'global', + data_cube = data$obs, agg = agg, outdir = recipe$Run$output_dir) recipe$Run$output_dir <- original_dir } diff --git a/modules/Saving/R/Utils.R b/modules/Saving/R/Utils.R index 18442583b9141c38961af269c79c214c6ce41faf..8c2d22bed4196c61536aa32c736ba67445a6f9d7 100644 --- a/modules/Saving/R/Utils.R +++ b/modules/Saving/R/Utils.R @@ -67,3 +67,16 @@ return(list(lon = longitude, lat = latitude)) } + +.get_region <- function(data_cube) { + # Creates region object for ArrayToNc + if (!("region" %in% names(data_cube$coords))) { + stop("'region' dimension now found in s2dv_cube coordinates'") + } + region <- list(region = data_cube$coords$region) + dim(region$region) <- c(region = length(region$region)) + ## TODO: Add other attributes from data_cube$attres$Variable$metadata$region + attr(region$region, "variables")$region <- list(create_dimvar = TRUE, + long_name = "Aggregated region") + return(region) +} diff --git a/modules/Saving/R/save_forecast.R b/modules/Saving/R/save_forecast.R index baace3eaf1bf7fb4ec7638f7f1fbfc30035e2207..d7fe542d8a337d43cfa23c1edb1fe77b123e52eb 100644 --- a/modules/Saving/R/save_forecast.R +++ b/modules/Saving/R/save_forecast.R @@ -74,6 +74,8 @@ save_forecast <- function(recipe, } if (tolower(agg) == "global") { fcst <- list(Reorder(fcst, c(lalo, 'ensemble', 'time'))) + } else if (tolower(agg) == "region") { + fcst <- list(Reorder(fcst, c("region", 'ensemble', 'time'))) } else { fcst <- list(Reorder(fcst, c('country', 'ensemble', 'time'))) } @@ -85,6 +87,12 @@ save_forecast <- function(recipe, var.expname <- paste0(variable, '_country') var.longname <- paste0("Country-Aggregated ", var.longname) var.units <- subset_cube$attrs$Variable$metadata[[variable]]$units + } else if (tolower(agg) == "region") { + dims <- c("region", "ensemble", "time") + var.expname <- variable + var.sdname <- var.sdname + var.longname <- paste0("Region-aggregated ", var.longname) + var.units <- subset_cube$attrs$Variable$metadata[[variable]]$units } else { dims <- c(lalo, 'ensemble', 'time') var.expname <- variable @@ -131,6 +139,10 @@ save_forecast <- function(recipe, if (tolower(agg) == "country") { country <- get_countries(grid) ArrayToNc(append(country, times, fcst), outfile) + } else if (tolower(agg) == "region") { + region <- .get_region(data_cube) + vars <- c(region, times, fcst) + ArrayToNc(vars, outfile) } else { latitude <- data_cube$coords$lat[1:length(data_cube$coords$lat)] longitude <- data_cube$coords$lon[1:length(data_cube$coords$lon)] diff --git a/modules/Saving/R/save_metrics.R b/modules/Saving/R/save_metrics.R index edbed814fb95d2b1e031ec08f4d25a7b57d65f72..d5fe91bd3e64005e88dd2a41d13352caf7429cb1 100644 --- a/modules/Saving/R/save_metrics.R +++ b/modules/Saving/R/save_metrics.R @@ -101,10 +101,15 @@ save_metrics <- function(recipe, ## the code extra_string <- get_filename("", recipe, variable, fcst.sdate, agg, names(subset_metric)[[i]]) - SaveExp(data = subset_metric[[i]], destination = outdir, + if (tolower(agg) == "region") { + coords <- list(region = data_cube$coords[['region']]) + } else { + coords <- list(latitude = data_cube$coords[['latitude']], + longitude = data_cube$coords[['longitude']]) + } + SaveExp(data = subset_metric[[i]], destination = outdir, Dates = dates, - coords = list(latitude = data_cube$coords[['latitude']], - longitude = data_cube$coords[['longitude']]), + coords = coords, time_bounds = time_bounds, varname = names(subset_metric)[[i]], metadata = data_cube$attrs$Variable$metadata, Datasets = NULL, @@ -119,10 +124,10 @@ save_metrics <- function(recipe, # Remove singleton dimensions and rearrange lon, lat and time dims if (tolower(agg) == "global") { subset_metric <- lapply(subset_metric, function(x) { - Reorder(x, c(lalo, 'time'))}) + Reorder(x, c(lalo, 'time'))}) } else { subset_metric <- lapply(subset_metric, function(x) { - Reorder(x, c("region", "time"))}) + Reorder(x, c('region', 'time'))}) } attr(subset_metric[[1]], 'global_attrs') <- global_attributes @@ -156,12 +161,8 @@ save_metrics <- function(recipe, country <- get_countries(grid) ArrayToNc(append(country, times$time, subset_metric), outfile) } else if (tolower(agg) == "region") { - region <- list(region = array(1:dim(metrics[[1]])['region'], - c(dim(metrics[[1]])['region']))) - ## TODO: check metadata when more than 1 region is store in the data array - attr(region, 'variables') <- data_cube$attrs$Variable$metadata['region'] - vars <- c(region, times) - vars <- c(vars, subset_metric) + region <- .get_region(data_cube) + vars <- c(region, times, subset_metric) ArrayToNc(vars, outfile) } else { latitude <- data_cube$coords$lat[1:length(data_cube$coords$lat)] diff --git a/modules/Saving/R/save_observations.R b/modules/Saving/R/save_observations.R index 747e0bd9916e0f8bc055e04abbd9dd56458c3e33..b6ed41418cd14c50426f40ee673bbb25c0724b78 100644 --- a/modules/Saving/R/save_observations.R +++ b/modules/Saving/R/save_observations.R @@ -60,6 +60,8 @@ save_observations <- function(recipe, } if (tolower(agg) == "global") { fcst <- list(Reorder(fcst, c(lalo, 'time'))) + } else if (tolower(agg) == "region") { + fcst <- list(Reorder(fcst, c("region", "time"))) } else { fcst <- list(Reorder(fcst, c('country', 'time'))) } @@ -71,6 +73,12 @@ save_observations <- function(recipe, var.expname <- paste0(variable, '_country') var.longname <- paste0("Country-Aggregated ", var.longname) var.units <- data_cube$attrs$Variable$metadata[[variable]]$units + } else if (tolower(agg) == "region") { + dims <- c("region", "time") + var.expname <- variable + var.sdname <- var.sdname + var.longname <- paste0("Region-aggregated ", var.longname) + var.units <- subset_cube$attrs$Variable$metadata[[variable]]$units } else { dims <- c(lalo, 'time') var.expname <- variable @@ -125,6 +133,10 @@ save_observations <- function(recipe, if (tolower(agg) == "country") { country <- get_countries(grid) ArrayToNc(append(country, times$time, fcst), outfile) + } else if (tolower(agg) == "region") { + region <- .get_region(data_cube) + vars <- c(region, times, fcst) + ArrayToNc(vars, outfile) } else { latitude <- data_cube$coords$lat[1:length(data_cube$coords$lat)] longitude <- data_cube$coords$lon[1:length(data_cube$coords$lon)] diff --git a/modules/Saving/R/save_percentiles.R b/modules/Saving/R/save_percentiles.R index 633be6e9dfe20916bec2c31f6cf7cb2c7534adb0..d5b4ae6188e3d4239b7b92436d7c8f8123136c96 100644 --- a/modules/Saving/R/save_percentiles.R +++ b/modules/Saving/R/save_percentiles.R @@ -102,8 +102,10 @@ save_percentiles <- function(recipe, ## TODO: replace with proper standard names percentile <- names(subset_percentiles[i]) long_name <- paste0(gsub("^.*_", "", percentile), "th percentile") - if (tolower(agg) == "country") { + if (tolower(agg) == "region") { dims <- c('Country', 'time') + } else if (tolower(agg) == "region") { + dims <- c("region", "time") } else { dims <- c(lalo, 'time') } @@ -116,6 +118,10 @@ save_percentiles <- function(recipe, if (tolower(agg) == "country") { country <- get_countries(grid) ArrayToNc(append(country, time, subset_percentiles), outfile) + } else if (tolower(agg) == "region") { + region <- .get_region(data_cube) + vars <- c(region, times, subset_percentiles) + ArrayToNc(vars, outfile) } else { latitude <- data_cube$coords$lat[1:length(data_cube$coords$lat)] longitude <- data_cube$coords$lon[1:length(data_cube$coords$lon)] diff --git a/modules/Saving/R/save_probabilities.R b/modules/Saving/R/save_probabilities.R index 7e452bd713d1ac40fea4a0bcf9bb6a554bf76ff2..e3df5a1e154ae07b3dbf00480bc031cace126ada 100644 --- a/modules/Saving/R/save_probabilities.R +++ b/modules/Saving/R/save_probabilities.R @@ -11,7 +11,7 @@ save_probabilities <- function(recipe, # data_cube: s2dv_cube containing the data and metadata # outdir: directory where the files should be saved # type: 'exp' (hcst and fcst) or 'obs' - # agg: aggregation, "global" or "country" + # agg: aggregation, "global" or "region" # type: 'hcst' or 'fcst' lalo <- c("latitude", "longitude") @@ -79,14 +79,14 @@ save_probabilities <- function(recipe, Reorder(x, c(lalo, 'time'))}) } else { probs_syear <- lapply(probs_syear, function(x) { - Reorder(x, c('country', 'time'))}) + Reorder(x, c('region', 'time'))}) } for (bin in 1:length(probs_syear)) { prob_bin <- names(probs_syear[bin]) long_name <- paste0(prob_bin, " probability category") - if (tolower(agg) == "country") { - dims <- c('Country', 'time') + if (tolower(agg) == "region") { + dims <- c('region', 'time') } else { dims <- c(lalo, 'time') } @@ -121,9 +121,11 @@ save_probabilities <- function(recipe, "probs") # Get grid data and metadata and export to netCDF - if (tolower(agg) == "country") { - country <- get_countries(grid) - ArrayToNc(append(country, times, probs_syear), outfile) + ## TODO: Move this segment outside of the loop + if (tolower(agg) == "region") { + region <- .get_region(data_cube) + vars <- c(region, times, probs_syear) + ArrayToNc(vars, outfile) } else { latitude <- data_cube$coords$lat[1:length(data_cube$coords$lat)] longitude <- data_cube$coords$lon[1:length(data_cube$coords$lon)] diff --git a/modules/Saving/R/tmp/ArrayToNc.R b/modules/Saving/R/tmp/ArrayToNc.R new file mode 100644 index 0000000000000000000000000000000000000000..55d7057ba20fe12776106bf1f0410166b754d8d3 --- /dev/null +++ b/modules/Saving/R/tmp/ArrayToNc.R @@ -0,0 +1,580 @@ +#'Save multidimensional R arrays into NetCDF files +#' +#'@author N. Manubens \email{nicolau.manubens@bsc.es} +#'@description This function takes as input one or a list of multidimensional R +#'arrays and stores them in a NetCDF file, using the \code{ncdf4} package. The +#'full path and name of the resulting file must be specified. Metadata can be +#'attached to the arrays and propagated into the NetCDF file in 3 possible +#'ways: +#' \describe{ +#' \item{Via the list names if a list of arrays is provided:}{ +#' Each name in the input list, corresponding to one multidimensional +#' array, will be interpreted as the name of the variable it contains. +#' +#' E.g.: +#' \code{ +#' ArrayToNc(arrays = list(temperature = array(1:9, c(3, 3))), +#' file_path = 'example.nc') +#' } +#' } +#' \item{Via the dimension names of each provided array:}{ +#' The dimension names of each of the provided arrays will be interpreted +#' as names for the dimensions of the NetCDF files. Read further for +#' special dimension names that will trigger special behaviours, such as +#' 'time' and 'var'. +#' +#' E.g.: +#' \code{ +#' temperature <- array(rnorm(100 * 50 * 10), dim = c(100, 50, 10)) +#' names(dim(temperature)) <- c('longitude', 'latitude', 'time') +#' ArrayToNc(list(temperature = temperature), file_path = 'example.nc') +#' } +#' } +#' \item{Via the attribute 'variables' of each provided array:}{ +#' The arrays can be provided with metadata in an attribute named +#' 'variables', which is expected to be a named list of named lists, where +#' the names of the container list are the names of the variables present +#' in the provided array, and where each sub-list contains metadata for +#' each of the variables. The attribute names and values supported in the +#' sub-lists must follow the same format the package \code{ncdf4} uses to +#' represent the NetCDF file headers. +#' +#' E.g.: +#' \code{ +#' a <- array(1:400, dim = c(5, 10, 4, 2)) +#' metadata <- list( +#' tos = list(addOffset = 100, +#' scaleFact = 10, +#' dim = list(list(name = 'time', +#' unlim = FALSE))), +#' tas = list(addOffset = 100, +#' scaleFact = 10, +#' dim = list(list(name = 'time', +#' unlim = FALSE))) +#' ) +#' attr(a, 'variables') <- metadata +#' names(dim(a)) <- c('lat', 'lon', 'time', 'var') +#' ArrayToNc(a, 'tmp.nc') +#' } +#' } +#' } +#'The special dimension names are 'var'/'variable' and 'time'.\cr +#'If a dimension is named 'var' or 'variable', \code{ArrayToNc} will interpret +#'each array entry along such dimension corresponds to a separate new variable, +#'hence will create a new variable inside the NetCDF file and will use it to +#'store all the data in the provided array for the corresponding entry along the +#''var'/'variable' dimension.\cr +#'If a dimension is named 'time', by default it will be interpreted and built as +#'an unlimited dimension. The 'time' dimension must be the last dimension of the +#'array (the right-most). If a 'var'/'variable' dimension is present, the 'time' +#'dimension can be also placed on its left (i.e. the one before the last +#'dimension). The default behaviour of creating the 'time' as unlimited +#'dimension can be disabled by setting manually the attribute +#'\code{unlim = FALSE}, as shown in the previous example.\cr\cr +#'\code{a2nc} is an alias of \code{ArrayToNc}. +#' +#'@param arrays One or a list of multidimensional data arrays. The list can be +#' provided with names, which will be interpreted as variable names. The arrays +#' can be provided with dimension names. The arrays can be provided with +#' metadata in the attribute 'variables' (read section Description for details). +#'@param file_path Path and name of the NetCDF file to be created. +#' +#'@return This function returns NULL. +#' +#'@import ncdf4 +#'@importFrom stats setNames +#'@examples +#' \dontrun{ +#'# Minimal use case +#'ArrayToNc(array(1:9, c(3, 3)), 'tmp.nc') +#'# Works with arrays of any number of dimensions +#'ArrayToNc(array(1:27, c(3, 3, 3)), 'tmp.nc') +#' +#'# Arrays can also be provided in [named] lists +#'ArrayToNc(list(tos = array(1:27, c(3, 3, 3))), 'tmp.nc') +#' +#'# Or with dimension names +#'# 'var' dimension name will generate multiple variables in the +#'# resulting NetCDF file +#'a <- array(1:27, dim = c(3, 3, 3)) +#'names(dim(a)) <- c('lon', 'lat', 'var') +#'ArrayToNc(a, 'tmp.nc') +#' +#'# 'variable' as dimension name will do the same +#'a <- array(1:27, dim = c(3, 3, 3)) +#'names(dim(a)) <- c('lon', 'lat', 'variable') +#'ArrayToNc(a, 'tmp.nc') +#' +#'# The 'time' dimension will be built as unlimited dimension, by default +#'a <- array(1:1600, dim = c(10, 20, 4, 2)) +#'names(dim(a)) <- c('lat', 'lon', 'time', 'var') +#'ArrayToNc(a, 'tmp.nc') +#' +#'# The dimension 'var'/'variable' can be in any position and can have any +#'# length. +#'a <- array(1:1600, dim = c(10, 20, 4, 2)) +#'names(dim(a)) <- c('lat', 'var', 'lon', 'time') +#'ArrayToNc(a, 'tmp.nc') +#' +#'# Multiple arrays can be provided in a list +#'a <- array(1:400, dim = c(5, 10, 4, 2)) +#'names(dim(a)) <- c('lat', 'lon', 'time', 'var') +#'ArrayToNc(list(a, a), 'tmp.nc') +#' +#'# If no dimension names are given to an array, new names will be automatically +#'# generated +#'a <- array(1:400, dim = c(5, 10, 4, 2)) +#'b <- array(1:400, dim = c(5, 11, 4, 2)) +#'names(dim(a)) <- c('lat', 'lon', 'time', 'var') +#'ArrayToNc(list(a, b), 'tmp.nc') +#' +#'# Metadata can be provided for each variable in each array, via the +#'# attribute 'variables'. In this example the metadata is empty. +#'a <- array(1:400, dim = c(5, 10, 4, 2)) +#'metadata <- list( +#' tos = list(), +#' tas = list()) +#'attr(a, 'variables') <- metadata +#'names(dim(a)) <- c('lat', 'lon', 'time', 'var') +#'ArrayToNc(a, 'tmp.nc') +#' +#'# Variable names can be manually specified +#'a <- array(1:400, dim = c(5, 10, 4, 2)) +#'metadata <- list( +#' tos = list(name = 'name1'), +#' tas = list(name = 'name2')) +#'attr(a, 'variables') <- metadata +#'names(dim(a)) <- c('lat', 'lon', 'time', 'var') +#'ArrayToNc(a, 'tmp.nc') +#'# Units can be specified +#'a <- array(1:400, dim = c(5, 10, 4, 2)) +#'metadata <- list( +#' tos = list(units = 'K'), +#' tas = list(units = 'K')) +#'attr(a, 'variables') <- metadata +#'names(dim(a)) <- c('lat', 'lon', 'time', 'var') +#'ArrayToNc(a, 'tmp.nc') +#' +#'# addOffset and scaleFactor can be specified +#'a <- array(1:400, dim = c(5, 10, 4, 2)) +#'metadata <- list( +#' tos = list(addOffset = 100, +#' scaleFact = 10), +#' tas = list(addOffset = 100, +#' scaleFact = 10)) +#'attr(a, 'variables') <- metadata +#'names(dim(a)) <- c('lat', 'lon', 'time', 'var') +#'ArrayToNc(a, 'tmp.nc') +#' +#'# Global attributes can be specified +#'a <- array(rnorm(10), dim = c(a = 5, b = 2)) +#'attrs <- list(variables = +#' list(tas = list(var_attr_1 = 'test_1_var', +#' var_attr_2 = 2)), +#' global_attrs = list(global_attr_name_1 = 'test_1_global', +#' global_attr_name_2 = 2)) +#'attributes(a) <- c(attributes(a), attrs) +#'ArrayToNc(a, 'tmp.nc') +#' +#'# Unlimited dimensions can be manually created +#'a <- array(1:400, dim = c(5, 10, 4, 2)) +#'metadata <- list( +#' tos = list(addOffset = 100, +#' scaleFact = 10, +#' dim = list(list(name = 'unlimited', +#' unlim = TRUE))), +#' tas = list(addOffset = 100, +#' scaleFact = 10, +#' dim = list(list(name = 'unlimited', +#' unlim = TRUE)))) +#'attr(a, 'variables') <- metadata +#'names(dim(a)) <- c('lat', 'lon', 'unlimited', 'var') +#'ArrayToNc(a, 'tmp.nc') +#' +#'# A 'time' dimension can be built without it necessarily being unlimited +#'a <- array(1:400, dim = c(5, 10, 4, 2)) +#'metadata <- list( +#' tos = list(addOffset = 100, +#' scaleFact = 10, +#' dim = list(list(name = 'time', +#' unlim = FALSE))), +#' tas = list(addOffset = 100, +#' scaleFact = 10, +#' dim = list(list(name = 'time', +#' unlim = FALSE)))) +#'attr(a, 'variables') <- metadata +#'names(dim(a)) <- c('lat', 'lon', 'time', 'var') +#'ArrayToNc(a, 'tmp.nc') +#' +# Multiple arrays with data for multiple variables can be saved into a +# NetCDF file at once. +#'tos <- array(1:400, dim = c(5, 10, 4)) +#'metadata <- list(tos = list(units = 'K')) +#'attr(tos, 'variables') <- metadata +#'names(dim(tos)) <- c('lat', 'lon', 'time') +#'lon <- seq(0, 360 - 360 / 10, length.out = 10) +#'dim(lon) <- length(lon) +#'metadata <- list(lon = list(units = 'degrees_east')) +#'attr(lon, 'variables') <- metadata +#'names(dim(lon)) <- 'lon' +#'lat <- seq(-90, 90, length.out = 5) +#'dim(lat) <- length(lat) +#'metadata <- list(lat = list(units = 'degrees_north')) +#'attr(lat, 'variables') <- metadata +#'names(dim(lat)) <- 'lat' +#'ArrayToNc(list(tos, lon, lat), 'tmp.nc') +#'} +#' +#'@export +ArrayToNc <- function(arrays, file_path) { + # Check parameter arrays. + if (is.array(arrays)) { + arrays <- list(arrays) + } + if (any(!sapply(arrays, function(x) is.array(x) && + (is.numeric(x) || is.logical(x) || is.character(x))))) { + stop("The parameter 'arrays' must be one or a list of numeric or logical arrays.") + } + # Check parameter file_path. + if (!is.character(file_path)) { + stop("Parameter 'file_path' must be a character string.") + } + + defined_dims <- list() + defined_vars <- list() + global_attrs <- list() + var_dim <- NULL + for (i in 1:length(arrays)) { + array_attrs <- attributes(arrays[[i]]) + if ('variables' %in% names(array_attrs)) { + vars_info <- array_attrs[['variables']] + array_attrs <- array_attrs[-which(names(array_attrs) == 'variables')] + } else { + vars_info <- NULL + } + #global_attrs[names(array_attrs)] <- array_attrs + if ('global_attrs' %in% names(array_attrs)) { + global_attrs <- c(global_attrs, array_attrs[['global_attrs']]) + } + var_dim <- which(names(dim(arrays[[i]])) %in% c('var', 'variable')) + if (length(var_dim) > 0) { + var_dim <- var_dim[1] + num_vars <- dim(arrays[[i]])[var_dim] + } else { + var_dim <- NULL + num_vars <- 1 + } + # Defining ncdf4 variable objects + for (j in 1:num_vars) { + var_info <- vars_info[[j]] + if (length(var_info) == 0) { + var_info <- list() + } + dim_names <- names(dim(arrays[[i]])) + if (!is.null(dim_names)) { + if (any(is.na(dim_names) | (sapply(dim_names, nchar) == 0))) { + stop("The provided arrays must have all named dimensions or ", + "all unnamed dimensions.") + } + } + provided_dims <- sapply(var_info$dim, '[[', 'name') + var_built_dims <- NULL + for (k in 1:length(dim(arrays[[i]]))) { + if (!identical(k, var_dim)) { + final_dim_position <- k - ifelse(!is.null(var_dim) && k > var_dim, 1, 0) + dim_name <- dim_names[k] + if (!is.null(dim_name) && (dim_name %in% provided_dims)) { + dim_info <- var_info$dim[[which(provided_dims == dim_name)]] + } else { + dim_info <- list() + } + if (!('name' %in% names(dim_info))) { + if (!is.null(dim_name)) { + dim_info[['name']] <- dim_name + } else { + dim_info[['name']] <- paste0('dim', final_dim_position) + } + } else { + if (!is.character(dim_info[['name']])) { + stop("The provided 'name' for the ", k, "th dimension in the ", i, "th array must be a character string.") + } + dim_info[['name']] <- dim_info[['name']][1] + } + if (!('len' %in% names(dim_info))) { + dim_info[['len']] <- unname(dim(arrays[[i]])[k]) + } else { + if (!is.numeric(dim_info[['len']])) { + stop("The provided 'len' for the ", k, "th dimension in the ", i, "th array must be a numeric value.") + } + dim_info[['len']] <- as.integer(round(dim_info[['len']][1])) + if (dim_info[['len']] != dim(arrays[[i]])[k]) { + stop("The provided 'len' for the ", k, "th dimension in the ", i, "th array does not match the actual length of the provided array.") + } + } + if (!('unlim' %in% names(dim_info))) { + dim_info[['unlim']] <- ifelse(dim_info[['name']] == 'time', TRUE, FALSE) + } else { + if (!is.logical(dim_info[['unlim']])) { + stop("The provided 'unlim' for the ", k, "th dimension in the ", i, "th array must be a logical value.") + } + dim_info[['unlim']] <- dim_info[['unlim']][1] + } + if (!('units' %in% names(dim_info))) { + dim_info[['units']] <- '' + } else { + if (!is.character(dim_info[['units']])) { + stop("The provided 'units' for the ", k, "th dimension in the ", i, "th array must be a character string.") + } + dim_info[['units']] <- dim_info[['units']][1] + } + if (!('vals' %in% names(dim_info))) { + dim_info[['vals']] <- 1:dim_info[['len']] + } else { + if (!(is.numeric(dim_info[['vals']]))) { + stop("The provided 'vals' for the ", k, "th dimension in the ", i, "th array must be a numeric vector.") + } + if (dim_info[['units']] == '') { + dim_info[['vals']] <- as.integer(dim_info[['vals']]) + } + if (length(dim_info[['vals']]) != dim_info[['len']]) { + stop("The length of the provided 'vals' for the ", k, "th dimension in the ", i, "th array does not match the length of the provided array.") + } + } + if (!('create_dimvar' %in% names(dim_info))) { + if (dim_info[['units']] == '') { + dim_info[['create_dimvar']] <- FALSE + } else { + dim_info[['create_dimvar']] <- TRUE + } + } else { + if (!is.logical(dim_info[['create_dimvar']])) { + stop("The provided 'create_dimvar' for the ", k, "th dimension in the ", i, "th array must be a logical value.") + } + dim_info[['create_dimvar']] <- dim_info[['create_dimvar']][1] + if (dim_info[['units']] != '' && !dim_info[['create_dimvar']]) { + stop("Provided 'units' for the ", k, "th dimension in the ", i, "th array but 'create_dimvar' set to FALSE.") + } + } + if (!('calendar' %in% names(dim_info))) { + dim_info[['calendar']] <- NA + } else { + if (!is.character(dim_info[['calendar']])) { + stop("The provided 'calendar' for the ", k, "th dimension in the ", i, "th array must be a character string.") + } + dim_info[['calendar']] <- dim_info[['calendar']][1] + } + if (!('longname' %in% names(dim_info))) { + dim_info[['longname']] <- dim_info[['name']] + } else { + if (!is.character(dim_info[['longname']])) { + stop("The provided 'longname' for the ", k, "th dimension in the ", i, "th array must be a character string.") + } + dim_info[['longname']] <- dim_info[['longname']][1] + } + if (dim_info[['name']] %in% names(defined_dims)) { + items_to_check <- c('name', 'len', 'unlim', 'units', 'vals', + 'create_dimvar', 'longname') + if (!identical(dim_info[items_to_check], + defined_dims[[dim_info[['name']]]][items_to_check]) || + !(identical(dim_info[['calendar']], defined_dims[[dim_info[['name']]]][['calendar']]) || + (is.na(dim_info[['calendar']]) && is.null(defined_dims[[dim_info[['name']]]][['calendar']])))) { + stop("The dimension '", dim_info[['name']], "' is ", + "defined or used more than once in the provided ", + "data but the dimension specifications do not ", + "match.") + } + } else { + new_dim <- list(ncdim_def(dim_info[['name']], dim_info[['units']], + dim_info[['vals']], dim_info[['unlim']], + dim_info[['create_dimvar']], + dim_info[['calendar']], + dim_info[['longname']])) + names(new_dim) <- dim_info[['name']] + defined_dims <- c(defined_dims, new_dim) + } + var_built_dims <- c(var_built_dims, dim_info[['name']]) + } + } + if (!('name' %in% names(var_info))) { + var_name_from_md <- names(vars_info)[j] + var_name_from_ar <- names(arrays)[i] + if (is.character(var_name_from_md) && + !is.na(var_name_from_md) && + (nchar(var_name_from_md) > 0)) { + var_name <- var_name_from_md + } else if (is.character(var_name_from_ar) && + !is.na(var_name_from_ar) && + (nchar(var_name_from_ar) > 0)){ + var_name <- var_name_from_ar + } else { + var_name <- paste0('var', i, '_', j) + } + var_info[['name']] <- var_name + } else { + if (!is.character(var_info[['name']])) { + stop("The provided 'name' for the ", j, "th variable in the ", i, "th array must be a character string.") + } + var_info[['name']] <- var_info[['name']][1] + } + if (!('units' %in% names(var_info))) { + var_info[['units']] <- '' + } else { + if (!is.character(var_info[['units']])) { + stop("The provided 'units' for the ", j, "th variable in the ", i, "th array must be a character string.") + } + var_info[['units']] <- var_info[['units']][1] + } + if (!('missval' %in% names(var_info))) { + var_info[['missval']] <- NULL + } else { + if (!is.numeric(var_info[['missval']])) { + stop("The provided 'missval' for the ", j, "th variable in the ", i, "th array must be a numeric value.") + } + var_info[['missval']] <- var_info[['missval']][1] + } + if (!('longname' %in% names(var_info))) { + var_info[['longname']] <- var_info[['name']] + } else { + if (!is.character(var_info[['longname']])) { + stop("The provided 'longname' for the ", j, "th variable in the ", i, "th array must be a character string.") + } + var_info[['longname']] <- var_info[['longname']][1] + } + if (!('prec' %in% names(var_info))) { + if (typeof(arrays[[i]]) == 'logical') { + var_info[['prec']] <- 'short' + } else if (typeof(arrays[[i]]) == 'character') { + var_info[['prec']] <- 'char' + attr(arrays[[i]], "variables")[[var_info[['name']]]] <- list(prec = 'char') + } else if (typeof(arrays[[i]]) == 'integer') { + var_info[['prec']] <- 'integer' + } else { + var_info[['prec']] <- 'double' + } + } else { + if (!is.character(var_info[['prec']])) { + stop("The provided 'prec' for the ", j, "th variable in the ", i, "th array must be a character string.") + } + var_info[['prec']] <- var_info[['prec']][1] + } + + if (var_info[['prec']] == 'char') { + dimnchar_name <- paste0(var_info[['name']], "_length") + dimnchar <- ncdim_def(dimnchar_name, "", 1:max(sapply(arrays[[i]], nchar)), + create_dimvar = FALSE) + defined_dims[[dimnchar_name]] <- dimnchar + var_built_dims <- c(dimnchar_name, var_built_dims) + } + new_var <- list(ncvar_def(var_info[['name']], var_info[['units']], + defined_dims[var_built_dims], + var_info[['missval']], + var_info[['longname']], var_info[['prec']])) + names(new_var) <- var_info[['name']] + defined_vars <- c(defined_vars, new_var) + } + } + ncdf_object <- nc_create(file_path, defined_vars) + var_counter <- 1 + # Putting the data and extra attributes. + for (i in 1:length(arrays)) { + array_attrs <- attributes(arrays[[i]]) + if ('variables' %in% names(array_attrs)) { + vars_info <- array_attrs[['variables']] + } else { + vars_info <- NULL + } + var_dim <- which(names(dim(arrays[[i]])) %in% c('var', 'variable')) + if (length(var_dim) > 0) { + var_dim <- var_dim[1] + num_vars <- dim(arrays[[i]])[var_dim] + } else { + var_dim <- NULL + num_vars <- 1 + } + for (j in 1:num_vars) { + var_info <- vars_info[[j]] + if (length(var_info) == 0) { + var_info <- list() + } + if (!('scaleFact' %in% names(var_info))) { + scale_factor <- 1 + } else { + if (!is.numeric(var_info[['scaleFact']])) { + stop("The provided 'scaleFact' for the ", j, "th variable in the ", i, "th array must be a numeric value.") + } + scale_factor <- var_info[['scaleFact']][1] + } + if (!('addOffset' %in% names(var_info))) { + add_offset <- 0 + } else { + if (!is.numeric(var_info[['addOffset']])) { + stop("The provided 'addOffset' for the ", j, "th variable in the ", i, "th array must be a numeric value.") + } + add_offset <- var_info[['addOffset']][1] + } + if (!is.null(var_info[['prec']]) && var_info[['prec']] == 'char') { + ncvar_put(ncdf_object, defined_vars[[var_counter]]$name, + arrays[[i]]) + } else if (is.null(var_dim)) { + if (scale_factor != 1 || add_offset != 0) { + ncvar_put(ncdf_object, defined_vars[[var_counter]]$name, + (arrays[[i]] - add_offset) / scale_factor, + count = dim(arrays[[i]])) + } else { + ncvar_put(ncdf_object, defined_vars[[var_counter]]$name, + arrays[[i]], + count = dim(arrays[[i]])) + } + } else { + if (scale_factor != 1 || add_offset != 0) { + ncvar_put(ncdf_object, defined_vars[[var_counter]]$name, + (.subset(arrays[[i]], var_dim, j, drop = 'selected') - add_offset) / scale_factor, + count = dim(arrays[[i]])[-var_dim]) + } else { + ncvar_put(ncdf_object, defined_vars[[var_counter]]$name, + .subset(arrays[[i]], var_dim, j, drop = 'selected'), + count = dim(arrays[[i]])[-var_dim]) + } + } + if (scale_factor != 1 || add_offset != 0) { + ncatt_put(ncdf_object, defined_vars[[var_counter]]$name, 'scale_factor', scale_factor) + ncatt_put(ncdf_object, defined_vars[[var_counter]]$name, 'add_offset', add_offset) + } + if ('coordinates' %in% names(var_info)) { + if (!is.character(var_info[['coordinates']])) { + stop("The attribute 'coordinates' must be a character string.") + } + coords <- strsplit(var_info[['coordinates']], ' ')[[1]] + if (!(all(coords %in% sapply(defined_vars, '[[', 'name') | + coords %in% sapply(defined_dims[which(sapply(defined_dims, '[[', 'create_dimvar'))], '[[', 'name')))) { + coords <- coords[which(coords %in% sapply(defined_vars, '[[', 'name') | + coords %in% sapply(defined_dims[which(sapply(defined_dims, '[[', 'create_dimvar'))], '[[', 'name'))] + .warning("Some of the dimensions appearing in 'coordinates' have been removed because they point to undefined variables.") + } + ncatt_put(ncdf_object, defined_vars[[var_counter]]$name, 'coordinates', paste(coords, collapse = ' ')) + } + attrs_to_skip <- which(names(var_info) %in% c('addOffset', 'scaleFact', 'coordinates', 'dim')) + attrs_to_add <- names(var_info) + if (length(attrs_to_skip) > 0) { + attrs_to_add <- attrs_to_add[-attrs_to_skip] + } + for (attribute_name in attrs_to_add) { + if (is.numeric(var_info[[attribute_name]]) || + is.character(var_info[[attribute_name]])) { + ncatt_put(ncdf_object, defined_vars[[var_counter]]$name, attribute_name, var_info[[attribute_name]]) + } + } + var_counter <- var_counter + 1 + } + } + # Adding global attributes + if (length(global_attrs) > 0) { + for (attr_name in names(global_attrs)) { + ncatt_put(ncdf_object, 0, attr_name, global_attrs[[attr_name]]) + } + } + nc_close(ncdf_object) + invisible(NULL) +} +#' @rdname ArrayToNc +a2nc <- ArrayToNc diff --git a/modules/Saving/R/tmp/CST_SaveExp.R b/modules/Saving/R/tmp/CST_SaveExp.R new file mode 100644 index 0000000000000000000000000000000000000000..d87fe8ab2565b1b4822406f1fac4ccf3e87faa08 --- /dev/null +++ b/modules/Saving/R/tmp/CST_SaveExp.R @@ -0,0 +1,920 @@ +#'Save objects of class 's2dv_cube' to data in NetCDF format +#' +#'@author Perez-Zanon Nuria, \email{nuria.perez@bsc.es} +#' +#'@description This function allows to divide and save a object of class +#''s2dv_cube' into a NetCDF file, allowing to reload the saved data using +#'\code{CST_Start} or \code{CST_Load} functions. It also allows to save any +#''s2dv_cube' object that follows the NetCDF attributes conventions. +#' +#'@param data An object of class \code{s2dv_cube}. +#'@param destination A character string containing the directory name in which +#' to save the data. NetCDF file for each starting date are saved into the +#' folder tree: 'destination/Dataset/variable/'. By default the function +#' saves the data into the working directory. +#'@param sdate_dim A character string indicating the name of the start date +#' dimension. By default, it is set to 'sdate'. It can be NULL if there is no +#' start date dimension. +#'@param ftime_dim A character string indicating the name of the forecast time +#' dimension. If 'Dates' are used, it can't be NULL. If there is no forecast +#' time dimension, 'Dates' will be set to NULL and will not be used. By +#' default, it is set to 'time'. +#'@param dat_dim A character string indicating the name of dataset dimension. +#' It can be NULL if there is no dataset dimension. By default, it is set to +#' 'dataset'. +#'@param var_dim A character string indicating the name of variable dimension. +#' It can be NULL if there is no variable dimension. By default, it is set to +#' 'var'. +#'@param memb_dim A character string indicating the name of the member +#' dimension. It can be NULL if there is no member dimension. By default, it is +#' set to 'member'. +#'@param startdates A vector of dates that will be used for the filenames +#' when saving the data in multiple files (single_file = FALSE). It must be a +#' vector of the same length as the start date dimension of data. It must be a +#' vector of class \code{Dates}, \code{'POSIXct'} or character with lenghts +#' between 1 and 10. If it is NULL, the coordinate corresponding the the start +#' date dimension or the first Date of each time step will be used as the name +#' of the files. It is NULL by default. +#'@param single_file A logical value indicating if all object is saved in a +#' single file (TRUE) or in multiple files (FALSE). When it is FALSE, +#' the array is separated for datasets, variable and start date. When there are +#' no specified time dimensions, the data will be saved in a single file by +#' default. The output file name when 'single_file' is TRUE is a character +#' string containing: '__.nc'; when it is FALSE, +#' it is '_.nc'. It is FALSE by default. +#'@param drop_dims (optional) A vector of character strings indicating the +#' dimension names of length 1 that need to be dropped in order that they don't +#' appear in the netCDF file. Only is allowed to drop dimensions that are not +#' used in the computation. The dimensions used in the computation are the ones +#' specified in: sdate_dim, ftime_dim, dat_dim, var_dim and memb_dim. It is +#' NULL by default. +#'@param extra_string (Optional) A character string to be included as part of +#' the file name, for instance, to identify member or realization. When +#' single_file is TRUE, the 'extra_string' will substitute all the default +#' file name; when single_file is FALSE, the 'extra_string' will be added +#' in the file name as: '__.nc'. It is NULL by +#' default. +#'@param units_hours_since (Optional) A logical value only available for the +#' case: 'Dates' have forecast time and start date dimension, 'single_file' is +#' TRUE and 'time_bounds' are not used. When it is TRUE, it saves the forecast +#' time with units of 'hours since'; if it is FALSE, the time units will be a +#' number of time steps with its corresponding frequency (e.g. n days, n months +#' or n hours). It is FALSE by default. +#'@param global_attrs (Optional) A list with elements containing the global +#' attributes to be saved in the NetCDF. +#' +#'@return Multiple or single NetCDF files containing the data array.\cr +#'\item{\code{single_file is TRUE}}{ +#' All data is saved in a single file located in the specified destination +#' path with the following name (by default): +#' '__.nc'. Multiple variables +#' are saved separately in the same file. The forecast time units +#' are calculated from each start date (if sdate_dim is not NULL) or from +#' the time step. If 'units_hours_since' is TRUE, the forecast time units +#' will be 'hours since '. If 'units_hours_since' is FALSE, +#' the forecast time units are extracted from the frequency of the time steps +#' (hours, days, months); if no frequency is found, the units will be ’hours +#' since’. When the time units are 'hours since' the time ateps are assumed to +#' be equally spaced. +#'} +#'\item{\code{single_file is FALSE}}{ +#' The data array is subset and stored into multiple files. Each file +#' contains the data subset for each start date, variable and dataset. Files +#' with different variables and datasets are stored in separated directories +#' within the following directory tree: 'destination/Dataset/variable/'. +#' The name of each file will be by default: '_.nc'. +#' The forecast time units are calculated from each start date (if sdate_dim +#' is not NULL) or from the time step. The forecast time units will be 'hours +#' since '. +#'} +#' +#'@seealso \code{\link[startR]{Start}}, \code{\link{as.s2dv_cube}} and +#'\code{\link{s2dv_cube}} +#' +#'@examples +#'\dontrun{ +#'data <- lonlat_temp_st$exp +#'CST_SaveExp(data = data, ftime_dim = 'ftime', var_dim = 'var', +#' dat_dim = 'dataset', sdate_dim = 'sdate') +#'} +#' +#'@export +CST_SaveExp <- function(data, destination = "./", startdates = NULL, + sdate_dim = 'sdate', ftime_dim = 'time', + memb_dim = 'member', dat_dim = 'dataset', + var_dim = 'var', drop_dims = NULL, + single_file = FALSE, extra_string = NULL, + global_attrs = NULL, units_hours_since = FALSE) { + # Check 's2dv_cube' + if (!inherits(data, 's2dv_cube')) { + stop("Parameter 'data' must be of the class 's2dv_cube'.") + } + # Check object structure + if (!all(c('data', 'attrs') %in% names(data))) { + stop("Parameter 'data' must have at least 'data' and 'attrs' elements ", + "within the 's2dv_cube' structure.") + } + if (!inherits(data$attrs, 'list')) { + stop("Level 'attrs' must be a list with at least 'Dates' element.") + } + # metadata + if (!is.null(data$attrs$Variable$metadata)) { + if (!inherits(data$attrs$Variable$metadata, 'list')) { + stop("Element metadata from Variable element in attrs must be a list.") + } + } + # Dates + if (is.null(data$attrs$Dates)) { + stop("Element 'Dates' from 'attrs' level cannot be NULL.") + } + if (is.null(dim(data$attrs$Dates))) { + stop("Element 'Dates' from 'attrs' level must have time dimensions.") + } + # sdate_dim + if (!is.null(sdate_dim)) { + if (!is.character(sdate_dim)) { + stop("Parameter 'sdate_dim' must be a character string.") + } + } + # startdates + if (is.null(startdates)) { + if (is.character(data$coords[[sdate_dim]])) { + startdates <- data$coords[[sdate_dim]] + } + } + + SaveExp(data = data$data, + destination = destination, + coords = data$coords, + Dates = data$attrs$Dates, + time_bounds = data$attrs$time_bounds, + startdates = startdates, + varname = data$attrs$Variable$varName, + metadata = data$attrs$Variable$metadata, + Datasets = data$attrs$Datasets, + sdate_dim = sdate_dim, ftime_dim = ftime_dim, + memb_dim = memb_dim, + dat_dim = dat_dim, var_dim = var_dim, + drop_dims = drop_dims, + single_file = single_file, + extra_string = extra_string, + global_attrs = global_attrs, + units_hours_since = units_hours_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 +#'NetCDF file, allowing to reload the saved data using \code{Start} function +#'from StartR package. If the original 's2dv_cube' object has been created from +#'\code{CST_Load()}, then it can be reloaded with \code{Load()}. +#' +#'@author Perez-Zanon Nuria, \email{nuria.perez@bsc.es} +#' +#'@param data A multi-dimensional array with named dimensions. +#'@param destination A character string indicating the path where to store the +#' NetCDF files. +#'@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 +#' provided, it is set as an index vector with the values from 1 to the length +#' of the corresponding dimension. +#'@param Dates A named array of dates with the corresponding sdate and forecast +#' time dimension. If there is no sdate_dim, you can set it to NULL. +#' It must have ftime_dim dimension. +#'@param time_bounds (Optional) A list of two arrays of dates containing +#' the lower (first array) and the upper (second array) time bounds +#' corresponding to Dates. Each array must have the same dimensions as Dates. +#' If 'Dates' parameter is NULL, 'time_bounds' are not used. It is NULL by +#' default. +#'@param startdates A vector of dates that will be used for the filenames +#' when saving the data in multiple files (single_file = FALSE). It must be a +#' vector of the same length as the start date dimension of data. It must be a +#' vector of class \code{Dates}, \code{'POSIXct'} or character with lenghts +#' between 1 and 10. If it is NULL, the coordinate corresponding the the start +#' date dimension or the first Date of each time step will be used as the name +#' of the files. It is NULL by default. +#'@param varname A character string indicating the name of the variable to be +#' saved. +#'@param metadata A named list where each element is a variable containing the +#' corresponding information. The information must be contained in a list of +#' lists for each variable. +#'@param Datasets A vector of character string indicating the names of the +#' datasets. +#'@param sdate_dim A character string indicating the name of the start date +#' dimension. By default, it is set to 'sdate'. It can be NULL if there is no +#' start date dimension. +#'@param ftime_dim A character string indicating the name of the forecast time +#' dimension. By default, it is set to 'time'. It can be NULL if there is no +#' forecast time dimension. +#'@param dat_dim A character string indicating the name of dataset dimension. +#' By default, it is set to 'dataset'. It can be NULL if there is no dataset +#' dimension. +#'@param var_dim A character string indicating the name of variable dimension. +#' By default, it is set to 'var'. It can be NULL if there is no variable +#' dimension. +#'@param memb_dim A character string indicating the name of the member +#' dimension. By default, it is set to 'member'. It can be NULL if there is no +#' member dimension. +#'@param drop_dims (optional) A vector of character strings indicating the +#' dimension names of length 1 that need to be dropped in order that they don't +#' appear in the netCDF file. Only is allowed to drop dimensions that are not +#' used in the computation. The dimensions used in the computation are the ones +#' specified in: sdate_dim, ftime_dim, dat_dim, var_dim and memb_dim. It is +#' NULL by default. +#'@param single_file A logical value indicating if all object is saved in a +#' single file (TRUE) or in multiple files (FALSE). When it is FALSE, +#' the array is separated for datasets, variable and start date. When there are +#' no specified time dimensions, the data will be saved in a single file by +#' default. The output file name when 'single_file' is TRUE is a character +#' string containing: '__.nc'; when it is FALSE, +#' it is '_.nc'. It is FALSE by default. +#'@param extra_string (Optional) A character string to be included as part of +#' the file name, for instance, to identify member or realization. When +#' single_file is TRUE, the 'extra_string' will substitute all the default +#' file name; when single_file is FALSE, the 'extra_string' will be added +#' in the file name as: '__.nc'. It is NULL by +#' default. +#'@param global_attrs (Optional) A list with elements containing the global +#' attributes to be saved in the NetCDF. +#'@param units_hours_since (Optional) A logical value only available for the +#' case: Dates have forecast time and start date dimension, single_file is +#' TRUE and 'time_bounds' is NULL. When it is TRUE, it saves the forecast time +#' with units of 'hours since'; if it is FALSE, the time units will be a number +#' of time steps with its corresponding frequency (e.g. n days, n months or n +#' hours). It is FALSE by default. +#' +#'@return Multiple or single NetCDF files containing the data array.\cr +#'\item{\code{single_file is TRUE}}{ +#' All data is saved in a single file located in the specified destination +#' path with the following name (by default): +#' '__.nc'. Multiple variables +#' are saved separately in the same file. The forecast time units +#' are calculated from each start date (if sdate_dim is not NULL) or from +#' the time step. If 'units_hours_since' is TRUE, the forecast time units +#' will be 'hours since '. If 'units_hours_since' is FALSE, +#' the forecast time units are extracted from the frequency of the time steps +#' (hours, days, months); if no frequency is found, the units will be ’hours +#' since’. When the time units are 'hours since' the time ateps are assumed to +#' be equally spaced. +#'} +#'\item{\code{single_file is FALSE}}{ +#' The data array is subset and stored into multiple files. Each file +#' contains the data subset for each start date, variable and dataset. Files +#' with different variables and datasets are stored in separated directories +#' within the following directory tree: 'destination/Dataset/variable/'. +#' The name of each file will be by default: '_.nc'. +#' The forecast time units are calculated from each start date (if sdate_dim +#' is not NULL) or from the time step. The forecast time units will be 'hours +#' since '. +#'} +#' +#'@examples +#'\dontrun{ +#'data <- lonlat_temp_st$exp$data +#'lon <- lonlat_temp_st$exp$coords$lon +#'lat <- lonlat_temp_st$exp$coords$lat +#'coords <- list(lon = lon, lat = lat) +#'Datasets <- lonlat_temp_st$exp$attrs$Datasets +#'varname <- 'tas' +#'Dates <- lonlat_temp_st$exp$attrs$Dates +#'metadata <- lonlat_temp_st$exp$attrs$Variable$metadata +#'SaveExp(data = data, coords = coords, Datasets = Datasets, varname = varname, +#' Dates = Dates, metadata = metadata, single_file = TRUE, +#' ftime_dim = 'ftime', var_dim = 'var', dat_dim = 'dataset') +#'} +#' +#'@import easyNCDF +#'@importFrom s2dv Reorder +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@export +SaveExp <- function(data, destination = "./", coords = NULL, + Dates = NULL, time_bounds = NULL, startdates = NULL, + varname = NULL, metadata = NULL, Datasets = NULL, + sdate_dim = 'sdate', ftime_dim = 'time', + memb_dim = 'member', dat_dim = 'dataset', var_dim = 'var', + drop_dims = NULL, single_file = FALSE, extra_string = NULL, + global_attrs = NULL, units_hours_since = FALSE) { + ## Initial checks + # data + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + dimnames <- names(dim(data)) + if (is.null(dimnames)) { + stop("Parameter 'data' must be an array with named dimensions.") + } + if (!is.null(attributes(data)$dimensions)) { + attributes(data)$dimensions <- NULL + } + # destination + if (!is.character(destination) | length(destination) > 1) { + stop("Parameter 'destination' must be a character string of one element ", + "indicating the name of the file (including the folder if needed) ", + "where the data will be saved.") + } + # drop_dims + if (!is.null(drop_dims)) { + if (!is.character(drop_dims) | any(!drop_dims %in% names(dim(data)))) { + warning("Parameter 'drop_dims' must be character string containing ", + "the data dimension names to be dropped. It will not be used.") + } 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), + drop = 'selected') + dimnames <- names(dim(data)) + } + } + # coords + if (!is.null(coords)) { + if (!inherits(coords, 'list')) { + stop("Parameter 'coords' must be a named list of coordinates.") + } + if (is.null(names(coords))) { + stop("Parameter 'coords' must have names corresponding to coordinates.") + } + } else { + coords <- sapply(dimnames, function(x) 1:dim(data)[x]) + } + # varname + if (is.null(varname)) { + varname <- 'X' + } else if (length(varname) > 1) { + multiple_vars <- TRUE + } else { + multiple_vars <- FALSE + } + if (!all(sapply(varname, is.character))) { + stop("Parameter 'varname' must be a character string with the ", + "variable names.") + } + # single_file + if (!inherits(single_file, 'logical')) { + warning("Parameter 'single_file' must be a logical value. It will be ", + "set as FALSE.") + single_file <- FALSE + } + # extra_string + if (!is.null(extra_string)) { + if (!is.character(extra_string)) { + stop("Parameter 'extra_string' must be a character string.") + } + } + # global_attrs + if (!is.null(global_attrs)) { + if (!inherits(global_attrs, 'list')) { + stop("Parameter 'global_attrs' must be a list.") + } + } + + ## Dimensions checks + # Spatial coordinates + if (!any(dimnames %in% .KnownLonNames()) | + !any(dimnames %in% .KnownLatNames())) { + lon_dim <- NULL + lat_dim <- NULL + } else { + lon_dim <- dimnames[which(dimnames %in% .KnownLonNames())] + lat_dim <- dimnames[which(dimnames %in% .KnownLatNames())] + } + # ftime_dim + if (!is.null(ftime_dim)) { + if (!is.character(ftime_dim)) { + stop("Parameter 'ftime_dim' must be a character string.") + } + if (!all(ftime_dim %in% dimnames)) { + stop("Parameter 'ftime_dim' is not found in 'data' dimension. Set it ", + "as NULL if there is no forecast time dimension.") + } + } + # sdate_dim + if (!is.null(sdate_dim)) { + if (!is.character(sdate_dim)) { + stop("Parameter 'sdate_dim' must be a character string.") + } + if (!all(sdate_dim %in% dimnames)) { + stop("Parameter 'sdate_dim' is not found in 'data' dimension.") + } + } + # memb_dim + if (!is.null(memb_dim)) { + if (!is.character(memb_dim)) { + stop("Parameter 'memb_dim' must be a character string.") + } + if (!all(memb_dim %in% dimnames)) { + stop("Parameter 'memb_dim' is not found in 'data' dimension. Set it ", + "as NULL if there is no member dimension.") + } + } + # dat_dim + if (!is.null(dat_dim)) { + if (!is.character(dat_dim)) { + stop("Parameter 'dat_dim' must be a character string.") + } + if (!all(dat_dim %in% dimnames)) { + stop("Parameter 'dat_dim' is not found in 'data' dimension. Set it ", + "as NULL if there is no Datasets dimension.") + } + n_datasets <- dim(data)[dat_dim] + } else { + n_datasets <- 1 + } + # var_dim + if (!is.null(var_dim)) { + if (!is.character(var_dim)) { + stop("Parameter 'var_dim' must be a character string.") + } + if (!all(var_dim %in% dimnames)) { + stop("Parameter 'var_dim' is not found in 'data' dimension. Set it ", + "as NULL if there is no variable dimension.") + } + n_vars <- dim(data)[var_dim] + } else { + n_vars <- 1 + } + # minimum dimensions + if (all(dimnames %in% c(var_dim, dat_dim))) { + if (!single_file) { + warning("Parameter data has only ", + paste(c(var_dim, dat_dim), collapse = ' and '), " dimensions ", + "and it cannot be splitted in multiple files. All data will ", + "be saved in a single file.") + single_file <- TRUE + } + } + # Dates (1): initial checks + if (!is.null(Dates)) { + if (!any(inherits(Dates, "POSIXct"), inherits(Dates, "Date"))) { + stop("Parameter 'Dates' must be of 'POSIXct' or 'Dates' class.") + } + if (is.null(dim(Dates))) { + stop("Parameter 'Dates' must have dimension names.") + } + if (all(is.null(ftime_dim), is.null(sdate_dim))) { + warning("Parameters 'ftime_dim' and 'sdate_dim' can't both be NULL ", + "if 'Dates' are used. 'Dates' will not be used.") + Dates <- NULL + } + # sdate_dim in Dates + if (!is.null(sdate_dim)) { + if (!sdate_dim %in% names(dim(Dates))) { + warning("Parameter 'sdate_dim' is not found in 'Dates' dimension. ", + "Dates will not be used.") + Dates <- NULL + } + } + # ftime_dim in Dates + if (!is.null(ftime_dim)) { + if (!ftime_dim %in% names(dim(Dates))) { + warning("Parameter 'ftime_dim' is not found in 'Dates' dimension. ", + "Dates will not be used.") + Dates <- NULL + } + } + } + # time_bounds + if (!is.null(time_bounds)) { + if (!inherits(time_bounds, 'list')) { + stop("Parameter 'time_bounds' must be a list with two dates arrays.") + } + time_bounds_dims <- lapply(time_bounds, function(x) dim(x)) + if (!identical(time_bounds_dims[[1]], time_bounds_dims[[2]])) { + stop("Parameter 'time_bounds' must have 2 arrays with same dimensions.") + } + if (is.null(Dates)) { + time_bounds <- NULL + } else { + name_tb <- sort(names(time_bounds_dims[[1]])) + name_dt <- sort(names(dim(Dates))) + if (!identical(dim(Dates)[name_dt], time_bounds_dims[[1]][name_tb])) { + stop(paste0("Parameter 'Dates' and 'time_bounds' must have same length ", + "of all dimensions.")) + } + } + } + # Dates (2): Check dimensions + if (!is.null(Dates)) { + if (any(dim(Dates)[!names(dim(Dates)) %in% c(ftime_dim, sdate_dim)] != 1)) { + stop("Parameter 'Dates' can have only 'sdate_dim' and 'ftime_dim' ", + "dimensions of length greater than 1.") + } + # drop dimensions of length 1 different from sdate_dim and ftime_dim + dim(Dates) <- dim(Dates)[names(dim(Dates)) %in% c(ftime_dim, sdate_dim)] + + # add ftime if needed + if (is.null(ftime_dim)) { + warning("A 'time' dimension of length 1 will be added to 'Dates'.") + dim(Dates) <- c(time = 1, dim(Dates)) + dim(data) <- c(time = 1, dim(data)) + dimnames <- names(dim(data)) + ftime_dim <- 'time' + if (!is.null(time_bounds)) { + time_bounds <- lapply(time_bounds, function(x) { + dim(x) <- c(time = 1, dim(x)) + return(x) + }) + } + units_hours_since <- TRUE + } + # add sdate if needed + if (is.null(sdate_dim)) { + if (!single_file) { + dim(Dates) <- c(dim(Dates), sdate = 1) + dim(data) <- c(dim(data), sdate = 1) + dimnames <- names(dim(data)) + sdate_dim <- 'sdate' + if (!is.null(time_bounds)) { + time_bounds <- lapply(time_bounds, function(x) { + dim(x) <- c(dim(x), sdate = 1) + return(x) + }) + } + if (!is.null(startdates)) { + if (length(startdates) != 1) { + warning("Parameter 'startdates' must be of length 1 if 'sdate_dim' is NULL.", + "They won't be used.") + startdates <- NULL + } + } + } + units_hours_since <- TRUE + } + } + # startdates + if (!is.null(Dates)) { + # check startdates + if (is.null(startdates)) { + startdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') + } 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') + } + } 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)) { + if (is.null(sdate_dim)) { + startdates <- 'XXX' + } else { + startdates <- rep('XXX', dim(data)[sdate_dim]) + } + } else { + if (any(inherits(startdates, "POSIXct"), inherits(startdates, "Date"))) { + startdates <- format(startdates, "%Y%m%d") + } + if (!is.null(sdate_dim)) { + if (dim(data)[sdate_dim] != length(startdates)) { + warning(paste0("Parameter 'startdates' doesn't have the same length ", + "as dimension '", sdate_dim,"', it will not be used.")) + startdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') + startdates <- format(startdates, "%Y%m%d") + } + } + } + + # Datasets + if (is.null(Datasets)) { + Datasets <- rep('XXX', n_datasets ) + } + if (inherits(Datasets, 'list')) { + Datasets <- names(Datasets) + } + if (n_datasets > length(Datasets)) { + warning("Dimension 'Datasets' in 'data' is greater than those listed in ", + "element 'Datasets' and the first element will be reused.") + Datasets <- c(Datasets, rep(Datasets[1], n_datasets - length(Datasets))) + } else if (n_datasets < length(Datasets)) { + warning("Dimension 'Datasets' in 'data' is smaller than those listed in ", + "element 'Datasets' and only the firsts elements will be used.") + Datasets <- Datasets[1:n_datasets] + } + + ## NetCDF dimensions definition + excluded_dims <- var_dim + if (!is.null(Dates)) { + excluded_dims <- c(excluded_dims, sdate_dim, ftime_dim) + } + if (!single_file) { + excluded_dims <- c(excluded_dims, dat_dim) + } + + ## Unknown dimensions check + alldims <- c(dat_dim, var_dim, sdate_dim, lon_dim, lat_dim, ftime_dim, memb_dim) + if (!all(dimnames %in% alldims)) { + unknown_dims <- dimnames[which(!dimnames %in% alldims)] + memb_dim <- c(memb_dim, unknown_dims) + } + + filedims <- c(dat_dim, var_dim, sdate_dim, lon_dim, lat_dim, ftime_dim, memb_dim) + filedims <- filedims[which(!filedims %in% excluded_dims)] + + # Delete unneded coords + coords[c(names(coords)[!names(coords) %in% filedims])] <- NULL + out_coords <- NULL + for (i_coord in filedims) { + # vals + if (i_coord %in% names(coords)) { + if (length(coords[[i_coord]]) != dim(data)[i_coord]) { + warning(paste0("Coordinate '", i_coord, "' has different lenght as ", + "its dimension and it will not be used.")) + out_coords[[i_coord]] <- 1:dim(data)[i_coord] + } else if (is.numeric(coords[[i_coord]]) || + is.character(coords[[i_coord]])) { + out_coords[[i_coord]] <- as.vector(coords[[i_coord]]) + } else { + out_coords[[i_coord]] <- 1:dim(data)[i_coord] + } + } else { + out_coords[[i_coord]] <- 1:dim(data)[i_coord] + } + dim(out_coords[[i_coord]]) <- dim(data)[i_coord] + + ## metadata + if (i_coord %in% names(metadata)) { + if ('variables' %in% names(attributes(metadata[[i_coord]]))) { + # from Start: 'lon' or 'lat' + attrs <- attributes(metadata[[i_coord]])[['variables']] + attrs[[i_coord]]$dim <- NULL + attr(out_coords[[i_coord]], 'variables') <- attrs + } else if (inherits(metadata[[i_coord]], 'list')) { + # from Start and Load: main var + attr(out_coords[[i_coord]], 'variables') <- list(metadata[[i_coord]]) + names(attributes(out_coords[[i_coord]])$variables) <- i_coord + } else if (!is.null(attributes(metadata[[i_coord]]))) { + # from Load + attrs <- attributes(metadata[[i_coord]]) + # We remove because some attributes can't be saved + attrs <- NULL + attr(out_coords[[i_coord]], 'variables') <- list(attrs) + names(attributes(out_coords[[i_coord]])$variables) <- i_coord + } + } + } + + if (!single_file) { + for (i in 1:n_datasets) { + path <- file.path(destination, Datasets[i], varname) + for (j in 1:n_vars) { + if (!dir.exists(path[j])) { + dir.create(path[j], recursive = TRUE) + } + startdates <- gsub("-", "", startdates) + dim(startdates) <- c(length(startdates)) + names(dim(startdates)) <- sdate_dim + if (is.null(dat_dim) & is.null(var_dim)) { + data_subset <- data + } else if (is.null(dat_dim)) { + data_subset <- Subset(data, c(var_dim), list(j), drop = 'selected') + } else if (is.null(var_dim)) { + data_subset <- Subset(data, along = c(dat_dim), list(i), drop = 'selected') + } else { + data_subset <- Subset(data, c(dat_dim, var_dim), list(i, j), drop = 'selected') + } + target <- names(dim(data_subset))[which(!names(dim(data_subset)) %in% c(sdate_dim, ftime_dim))] + target_dims_data <- c(target, ftime_dim) + if (is.null(Dates)) { + input_data <- list(data_subset, startdates) + target_dims <- list(target_dims_data, NULL) + } else if (!is.null(time_bounds)) { + input_data <- list(data_subset, startdates, Dates, + time_bounds[[1]], time_bounds[[2]]) + target_dims = list(target_dims_data, NULL, + ftime_dim, ftime_dim, ftime_dim) + } else { + input_data <- list(data_subset, startdates, Dates) + target_dims = list(target_dims_data, NULL, ftime_dim) + } + Apply(data = input_data, + target_dims = target_dims, + fun = .saveexp, + destination = path[j], + coords = out_coords, + ftime_dim = ftime_dim, + varname = varname[j], + metadata_var = metadata[[varname[j]]], + extra_string = extra_string, + global_attrs = global_attrs) + } + } + } else { + # time_bnds + if (!is.null(time_bounds)) { + time_bnds <- c(time_bounds[[1]], time_bounds[[2]]) + } + # Dates + remove_metadata_dim <- TRUE + if (!is.null(Dates)) { + if (is.null(sdate_dim)) { + sdates <- Dates[1] + # ftime definition + leadtimes <- as.numeric(difftime(Dates, sdates, units = "hours")) + } else { + # sdate definition + sdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') + differ <- as.numeric(difftime(sdates, sdates[1], units = "hours")) + dim(differ) <- dim(data)[sdate_dim] + differ <- list(differ) + names(differ) <- sdate_dim + out_coords <- c(differ, out_coords) + attrs <- list(units = paste('hours since', sdates[1]), + calendar = 'proleptic_gregorian', longname = sdate_dim) + attr(out_coords[[sdate_dim]], 'variables')[[sdate_dim]] <- attrs + # ftime definition + Dates <- Reorder(Dates, c(ftime_dim, sdate_dim)) + differ_ftime <- array(dim = dim(Dates)) + for (i in 1:length(sdates)) { + differ_ftime[, i] <- as.numeric(difftime(Dates[, i], Dates[1, i], + units = "hours")) + } + 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}))) { + warning("Time steps are not equal for all start dates. Only ", + "forecast time values for the first start date will be saved ", + "correctly.") + } + } + if (all(!units_hours_since, is.null(time_bounds))) { + if (all(diff(leadtimes/24) == 1)) { + # daily values + units <- 'days' + leadtimes_vals <- round(leadtimes/24) + 1 + } else if (all(diff(leadtimes/24) %in% c(28, 29, 30, 31))) { + # monthly values + units <- 'months' + leadtimes_vals <- round(leadtimes/(30.437*24)) + 1 + } else { + # other frequency + units <- 'hours' + leadtimes_vals <- leadtimes + 1 + } + } else { + units <- paste('hours since', paste(sdates, collapse = ', ')) + leadtimes_vals <- leadtimes + } + + # Add time_bnds + if (!is.null(time_bounds)) { + if (is.null(sdate_dim)) { + sdates <- Dates[1] + time_bnds <- c(time_bounds[[1]], time_bounds[[2]]) + leadtimes_bnds <- as.numeric(difftime(time_bnds, sdates, units = "hours")) + dim(leadtimes_bnds) <- c(dim(Dates), bnds = 2) + } else { + # assuming they have sdate and ftime + time_bnds <- lapply(time_bounds, function(x) { + x <- Reorder(x, c(ftime_dim, sdate_dim)) + return(x) + }) + time_bnds <- c(time_bounds[[1]], time_bounds[[2]]) + dim(time_bnds) <- c(dim(Dates), bnds = 2) + differ_bnds <- array(dim = c(dim(time_bnds))) + for (i in 1:length(sdates)) { + differ_bnds[, i, ] <- as.numeric(difftime(time_bnds[, i, ], Dates[1, i], + units = "hours")) + } + # NOTE (TODO): Add a warning when they are not equally spaced? + leadtimes_bnds <- Subset(differ_bnds, along = sdate_dim, 1, drop = 'selected') + } + # Add time_bnds + leadtimes_bnds <- Reorder(leadtimes_bnds, c('bnds', ftime_dim)) + leadtimes_bnds <- list(leadtimes_bnds) + names(leadtimes_bnds) <- 'time_bnds' + out_coords <- c(leadtimes_bnds, out_coords) + attrs <- list(units = paste('hours since', paste(sdates, collapse = ', ')), + calendar = 'proleptic_gregorian', + long_name = 'time bounds', unlim = FALSE) + attr(out_coords[['time_bnds']], 'variables')$time_bnds <- attrs + } + # Add ftime var + dim(leadtimes_vals) <- dim(data)[ftime_dim] + leadtimes_vals <- list(leadtimes_vals) + names(leadtimes_vals) <- ftime_dim + out_coords <- c(leadtimes_vals, out_coords) + attrs <- list(units = units, calendar = 'proleptic_gregorian', + longname = ftime_dim, + dim = list(list(name = ftime_dim, unlim = TRUE))) + if (!is.null(time_bounds)) { + attrs$bounds = 'time_bnds' + } + attr(out_coords[[ftime_dim]], 'variables')[[ftime_dim]] <- attrs + for (j in 1:n_vars) { + remove_metadata_dim <- FALSE + metadata[[varname[j]]]$dim <- list(list(name = ftime_dim, unlim = TRUE)) + } + # Reorder ftime_dim to last + if (length(dim(data)) != which(names(dim(data)) == ftime_dim)) { + order <- c(names(dim(data))[which(!names(dim(data)) %in% c(ftime_dim))], ftime_dim) + data <- Reorder(data, order) + } + } + # var definition + extra_info_var <- NULL + for (j in 1:n_vars) { + varname_j <- varname[j] + metadata_j <- metadata[[varname_j]] + if (is.null(var_dim)) { + out_coords[[varname_j]] <- data + } else { + out_coords[[varname_j]] <- Subset(data, var_dim, j, drop = 'selected') + } + if (!is.null(metadata_j)) { + if (remove_metadata_dim) metadata_j$dim <- NULL + attr(out_coords[[varname_j]], 'variables') <- list(metadata_j) + names(attributes(out_coords[[varname_j]])$variables) <- varname_j + } + # Add global attributes + if (!is.null(global_attrs)) { + attributes(out_coords[[varname_j]])$global_attrs <- global_attrs + } + } + if (is.null(extra_string)) { + first_sdate <- startdates[1] + last_sdate <- startdates[length(startdates)] + gsub("-", "", first_sdate) + file_name <- paste0(paste(c(varname, + gsub("-", "", first_sdate), + gsub("-", "", last_sdate)), + collapse = '_'), ".nc") + } else { + 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) + ArrayToNc(out_coords, full_filename) + } +} + +.saveexp <- function(data, coords, destination = "./", + startdates = NULL, dates = NULL, + time_bnds1 = NULL, time_bnds2 = NULL, + ftime_dim = 'time', varname = 'var', + metadata_var = NULL, extra_string = NULL, + global_attrs = NULL) { + remove_metadata_dim <- TRUE + if (!is.null(dates)) { + if (!any(is.null(time_bnds1), is.null(time_bnds2))) { + time_bnds <- c(time_bnds1, time_bnds2) + time_bnds <- as.numeric(difftime(time_bnds, dates[1], units = "hours")) + dim(time_bnds) <- c(dim(data)[ftime_dim], bnds = 2) + time_bnds <- Reorder(time_bnds, c('bnds', ftime_dim)) + time_bnds <- list(time_bnds) + names(time_bnds) <- 'time_bnds' + coords <- c(time_bnds, coords) + attrs <- list(units = paste('hours since', dates[1]), + calendar = 'proleptic_gregorian', + longname = 'time bounds') + attr(coords[['time_bnds']], 'variables')$time_bnds <- attrs + } + # Add ftime_dim + differ <- as.numeric(difftime(dates, dates[1], units = "hours")) + dim(differ) <- dim(data)[ftime_dim] + differ <- list(differ) + names(differ) <- ftime_dim + coords <- c(differ, coords) + attrs <- list(units = paste('hours since', dates[1]), + calendar = 'proleptic_gregorian', + longname = ftime_dim, + dim = list(list(name = ftime_dim, unlim = TRUE))) + if (!is.null(time_bnds1)) { + attrs$bounds = 'time_bnds' + } + attr(coords[[ftime_dim]], 'variables')[[ftime_dim]] <- attrs + metadata_var$dim <- list(list(name = ftime_dim, unlim = TRUE)) + remove_metadata_dim <- FALSE + } + # Add data + coords[[varname]] <- data + if (!is.null(metadata_var)) { + if (remove_metadata_dim) metadata_var$dim <- NULL + attr(coords[[varname]], 'variables') <- list(metadata_var) + names(attributes(coords[[varname]])$variables) <- varname + } + # Add global attributes + if (!is.null(global_attrs)) { + attributes(coords[[varname]])$global_attrs <- global_attrs + } + + if (is.null(extra_string)) { + file_name <- paste0(varname, "_", startdates, ".nc") + } else { + file_name <- paste0(varname, "_", extra_string, "_", startdates, ".nc") + } + full_filename <- file.path(destination, file_name) + ArrayToNc(coords, full_filename) +} diff --git a/modules/Saving/Saving.R b/modules/Saving/Saving.R index e9e4a5b408cacf3638953c021dd557c69f54e81a..baca54fcc384db2ba60943a0e943a8bbd1cb350f 100644 --- a/modules/Saving/Saving.R +++ b/modules/Saving/Saving.R @@ -14,6 +14,10 @@ source("modules/Saving/R/get_times.R") source("modules/Saving/R/get_latlon.R") source("modules/Saving/R/get_global_attributes.R") source("modules/Saving/R/drop_dims.R") +## TODO: Remove when packages are released +source("modules/Saving/R/tmp/ArrayToNc.R") +source("modules/Saving/R/tmp/CST_SaveExp.R") + Saving <- function(recipe, data, skill_metrics = NULL,