Newer
Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
#'Save CSTools objects of class 's2dv_cube' containig experiment 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' in a NetCDF files to allow be reloaded using \code{CST_Loa} 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 diveded in separte folders for each experiment and variable and in separate NetCDF files for each start date. By default the function creates folders in the working directory called "CST_Data".
#'
#'@seealso \code{\link[easyNCDF]{ArrayToNc}}, \code{\link{SaveNC}} and \code{\link{CST_Load}}
#'
#'@import s2dverification
#'@import ncdf4
#'
#'@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 (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")
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)
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:
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.")
}
# 1) create paths DONE
# 2) create folders DONE
# 3) select data DONE
# 4) create files
known_dim_names <- c("lat", "latitude", "lon", "longitude", "time", "ftime",
"sdate", "dataset", "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') | 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
}
}
datanc <- ncvar_def(name = var_name, units = attributes(data$Variable)$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)
}
}
}