#'Save CSTools objects of class 's2dv_cube' containig experiments or oberved #'data in NCDF 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_Load} function. #' #'@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/experiment/variable/. By default the function #'creates and saves the data into the folder "CST_Data" in the working #'directory. #' #'@seealso \code{\link{CST_Load}} #' #'@import s2dverification #'@import ncdf4 #'@import abind #' #'@examples #'\dontrun{ #'library(CSTools) #'data <- lonlat_data$exp #'destination <- "./path/" #'CST_SaveExp(data = data, destination = destination) #'} #' #'@export CST_SaveExp <- function(data, destination = "./CST_Data") { 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.") } if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") } dimname <- names(dim(data$data)) if (any(dimname == "time")) { dimname[which(dimname == "time")] <- "ftime" names(dim(data$data))[which(dimname == "time")] <- "ftime" } if (any(dimname == "memb")) { dimname[which(dimname == "memb")] <- "member" names(dim(data$data))[which(dimname == "memb")] <- "member" } if (any(dimname == "ensemble")) { dimname[which(dimname == "ensemble")] <- "member" names(dim(data$data))[which(dimname == "ensemble")] <- "member" } if (any(dimname == "longitude")) { dimname[which(dimname == "longitude")] <- "lon" names(dim(data$data))[which(dimname == "longitude")] <- "lon" } if (any(dimname == "latitude")) { dimname[which(dimname == "latitude")] <- "lat" names(dim(data$data))[which(dimname == "latitude")] <- "lat" } names(dim(data$data)) <- dimname if (is.null(dimname)) { stop("Element 'data' in parameter 'data' must have named dimensions.") } sdate_pos <- which(dimname == "sdate") if (length(sdate_pos) == 0) { stop("Element 'data' in parameter 'data' hasn't 'sdate' dimension.") } else if (length(sdate_pos) > 1) { stop("Element 'data' in parameter 'data' has more than one 'sdate'", " dimension.") } n_sdates <- dim(data$data)[sdate_pos] # number of files to create dataset_pos <- which(dimname == "dataset" | dimname == "dat") dims <- dim(data$data) if (length(dataset_pos) == 0) { warning("Element 'data' in parameter 'data' hasn't 'dataset' dimension. ", "All data is stored in the same 'dataset' folder.") data$data <- InsertDim(var = data$data, posdim = 1, lendim = 1) names(dim(data$data))[1] <- "dataset" dimname <- c("dataset", dimname) dataset_pos = 1 } else if (length(dataset_pos) > 1) { stop("Element 'data' in parameter 'data' has more than one 'dataset'", " dimension.") } n_datasets <- dim(data$data)[dataset_pos] # number of folder by dataset # dataset names: datasets <- names(data$Datasets) if (n_datasets > length(datasets)) { warning("Dimension 'dataset' in element 'data' from parameter 'data' ", "is greater than those listed in element 'Datasets' and the ", "first element is reused.") datasets <- c(datasets, rep(datasets[1], n_datasets - length(datasets))) } else if (n_datasets < length(datasets)) { warning("Dimension 'dataset' in element 'data' from parameter 'data', ", "is smaller than those listed in element 'Datasets' and only the", " first element will be used.") datasets <- datasets[1 : n_datasets] } # var names: if ('var' %in% dimname) { var_pos <- which(dimname == 'var') if (dims[var_pos] == 1) { data$data <- adrop(data$data, drop = var_pos) dimname <- names(dim(data$data)) } } var_name <- data$Variable$varName if (length(var_name) != 1) { stop("One variable name must be included in element 'Variable$varName' ", "of parameter 'data'.") } if (!is.character(var_name)) { stop("Element 'Variable$varName' of parameter 'data' ", "must be a character string.") } known_dim_names <- c("var", "lat", "latitude", "lon", "longitude", "time", "ftime", "sdate", "dataset", "dat", "nlevel", "levels") dims_var <- NULL list_pos <- 1 if (any(dimname == 'longitude') | any(dimname == 'lon')) { dim_lon <- ncdim_def(name = 'lon', units = 'degrees', vals = as.vector(data$lon), longname = 'longitude') dims_var[[list_pos]] <- dim_lon list_pos <- list_pos + 1 } if (any(dimname == 'latitude') | any(dimname == 'lat')) { dim_lat <- ncdim_def(name = 'lat', units = 'degrees_north', vals = as.vector(data$lat), longname = 'latitude') dims_var[[list_pos]] <- dim_lat list_pos <- list_pos + 1 } if (any(!(dimname %in% known_dim_names))) { dims_member <- dimname[!(dimname %in% known_dim_names)] if (length(dims_member) > 1) { stop("Ask for saving realizations or further dimensions to the mantainer.") } else { dim_memb <- ncdim_def(name = 'ensemble', units = "adim", vals = 1 : dim(data$data)[which(dimname == 'member')], longname = 'ensemble', create_dimvar = TRUE) dims_var[[list_pos]] <- dim_memb list_pos <- list_pos + 1 } } # Lead-time depends on the start date nlt <- length(data$Dates$start)/n_sdates if (any(dimname == 'level')) { stop("Ask for saving 3Dim fields to the mantainer.") } for (i in 1 : n_datasets) { path <- file.path(destination, datasets[i], var_name) dir.create(path, recursive = TRUE) startdate <- gsub("-", "", data$Datasets[[i]]$InitializationDates[[1]]) file_name <- paste0(var_name, "_", startdate, ".nc") full_filename <- file.path(path, file_name) data_dataset <- Subset(data$data, along = which(dimname == 'dataset'), indices = i) standard_order <- c("lon", "lat", "member", "ftime") change_names <- c("lon", "lat", "ensemble", "ftime") for (j in 1 : n_sdates) { n_data <- s2dverification::Subset(data_dataset, along = which(dimname == 'sdate'), indices = j, drop = TRUE) pos_standard_order <- match( standard_order, names(dim(n_data))) n_data <- aperm(n_data, pos_standard_order) names(dim(n_data)) <- change_names # Lead-time depends on the start date # The correct time should be selected from $Dates$start time_values <- as.Date(substr(data$Dates$start[(j * nlt - nlt + 1):(j * nlt)], 1, 10)) if (any(dimname == 'time') | any(dimname == 'ftime')) { dim_time <- ncdim_def(name = 'time', units = 'days since 1970-01-01', vals = as.numeric(time_values), longname = 'time', unlim = TRUE) if (i == 1 & j == 1) { dims_var[[list_pos]] <- dim_time list_pos <- list_pos + 1 } } if (!is.character(attributes(data$Variable)$units)) { units = attributes(data$Variable)$variable$units } else { units = attributes(data$Variable)$units } datanc <- ncvar_def(name = var_name, units = units, dim = dims_var, missval = -99999) file_nc <- nc_create(full_filename[j], datanc) ncvar_put(file_nc, datanc, n_data) ncatt_put(file_nc, datanc, 'coordinates', attr(data$lon, 'cdo_grid_name')) ncatt_put(file_nc, datanc, 'projection', attr(data$lon, 'projection')) nc_close(file_nc) } } }