Newer
Older
#'Conversion of 'startR_array' or 'list' objects to 's2dv_cube'
#'
#'This function converts data loaded using startR package or s2dv
#'Load function into a 's2dv_cube' object.
#'
#'@author Perez-Zanon Nuria, \email{nuria.perez@bsc.es}
#'@author Nicolau Manubens, \email{nicolau.manubens@bsc.es}
#'
#'@param object An object of class 'startR_array' generated from function
#' \code{Start} from startR package or a list output from function \code{Load}
#' from s2dv package.
#'@return The function returns a 's2dv_cube' object to be easily used with
#'functions \code{CST} from CSTools package.
#'@seealso \code{\link{s2dv_cube}}, \code{\link[s2dv]{Load}},
#'\code{\link[startR]{Start}} and \code{\link{CST_Load}}
#'repos <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc'
#'data <- Start(dat = repos,
#' var = 'tas',
#' sdate = c('20170101', '20180101'),
#' ensemble = indices(1:20),
#' time = 'all',
#' latitude = 'all',
#' longitude = indices(1:40),
#' return_vars = list(latitude = 'dat', longitude = 'dat', time = 'sdate'),
#' retrieve = TRUE)
#'data <- as.s2dv_cube(data)
#'class(data)
#'startDates <- c('20001101', '20011101', '20021101',
#' '20031101', '20041101', '20051101')
#'data <- Load(var = 'tas', exp = 'system5c3s',
#' nmember = 15, sdates = startDates,
#' leadtimemax = 3, latmin = 27, latmax = 48,
#' lonmin = -12, lonmax = 40, output = 'lonlat')
#'data <- as.s2dv_cube(data)
#'class(data)
#'}
#'@export
as.s2dv_cube <- function(object) {
if (is.list(object)) {
if (is.null(object) || (is.null(object$mod) && is.null(object$obs))) {
stop("The s2dv::Load call did not return any data.")
# First it separates in 2 equal arrays 'mod' (exp) and 'obs':
obs <- object
obs$mod <- NULL
object$obs <- NULL
names(object)[[1]] <- 'data' # exp
names(obs)[[1]] <- 'data' # obs
# Functions::
remove_matches <- function(v, patterns) {
if (length(v) > 0) {
matches <- c()
for (pattern in patterns) {
matches <- c(matches, which(grepl(pattern, v)))
}
if (length(matches) > 0) {
v <- v[-matches]
}
}
v
}
harmonize_patterns <- function(v) {
matches <- grepl('.*\\.nc$', v)
if (sum(!matches) > 0) {
match_indices <- which(!matches)
v[match_indices] <- sapply(v[match_indices], function(x) paste0(x, '*'))
}
v <- glob2rx(v)
v <- gsub('\\$.*\\$', '*', v)
v
}
if (!is.null(obs$data)) {
obs$Datasets$exp <- NULL
obs$Datasets <- obs$Datasets$obs
obs_path_patterns <- sapply(obs$Datasets, function(x) attr(x, 'source'))
obs_path_patterns <- harmonize_patterns(obs_path_patterns)
}
if (!is.null(object$data)) {
object$Datasets$obs <- NULL
object$Datasets <- object$Datasets$exp
exp_path_patterns <- sapply(object$Datasets, function(x) attr(x, 'source'))
exp_path_patterns <- harmonize_patterns(exp_path_patterns)
}
if (!is.null(obs$data) && !is.null(object$data)) {
obs$source_files <- remove_matches(obs$source_files,
exp_path_patterns)
obs$not_found_files <- remove_matches(obs$not_found_files,
exp_path_patterns)
object$source_files <- remove_matches(object$source_files,
obs_path_patterns)
object$not_found_files <- remove_matches(object$not_found_files,
obs_path_patterns)
}
result <- list()
if (!is.null(object$data)) {
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
#-----------------------
# attrs
object$attrs <- within(object, rm(list = c('data')))
object <- within(object, rm(list = names(object$attrs)))
dates <- object$attrs$Dates$start
dim(dates) <- dim(object$data)[c('sdate','ftime')]
object$attrs$Dates <- dates
# dims
object$dims <- dim(object$data)
# coords
object$coords <- sapply(names(dim(object$data)),function(x) NULL)
## sdate
object$coords$sdate <- as.POSIXct(object$coords$sdate, format = "%Y%m%d", tz = "UTC") # this parameter is mandatory in Load. Always will be named sdates
## lonlat
if (!is.null(object$attrs$lon)) {
object$coords$lon <- object$attrs$lon
object$attrs <- within(object$attrs, rm(lon))
}
if (!is.null(object$attrs$lat)) {
object$coords$lat <- object$attrs$lat
object$attrs <- within(object$attrs, rm(lat))
}
## member
object$coords$member <- 1:object$dims['member']
## dataset
object$coords$dataset <- 1:object$dims['dataset']
## ftime
object$coords$ftime <- 1:object$dims['ftime']
object <- object[c('data','dims','coords','attrs')]
#----------------------
class(object) <- 's2dv_cube'
result$exp <- object
}
if (!is.null(obs$data)) {
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
# attrs
obs$attrs <- within(obs, rm(list = c('data', 'not_found_files')))
obs <- within(obs, rm(list = names(obs$attrs)))
dates <- obs$attrs$Dates$start
dim(dates) <- dim(obs$data)[c('sdate','ftime')]
obs$attrs$Dates <- dates
# dims
obs$dims <- dim(obs$data)
# coords
obs$coords <- sapply(names(dim(obs$data)),function(x) NULL)
## sdate
obs$coords$sdate <- obs$attrs$load_parameters$sdates # this parameter is mandatory in Load. Always will be named sdates
## lonlat
if (!is.null(obs$attrs$lon)) {
obs$coords$lon <- obs$attrs$lon
obs$attrs <- within(obs$attrs, rm(lon))
}
if (!is.null(obs$attrs$lat)) {
obs$coords$lat <- obs$attrs$lat
obs$attrs <- within(obs$attrs, rm(lat))
}
## member
obs$coords$member <- 1:obs$dims['member']
## dataset
obs$coords$dataset <- 1:obs$dims['dataset']
## ftime
obs$coords$ftime <- 1:obs$dims['ftime']
obs <- obs[c('data','dims','coords','attrs')]
#----------------------
class(obs) <- 's2dv_cube'
result$obs <- obs
}
if (is.list(result)) {
if (is.null(result$exp)) {
result <- result$obs
} else if (is.null(result$obs)) {
result <- result$exp
} else {
warning("The output is a list of two 's2dv_cube' objects",
" corresponding to 'exp' and 'obs'.")
}
} else if (class(object) == 'startR_array') {
result <- list()
result$data <- as.vector(object)
dims <- dim(object)
dim(result$data) <- dims
#-----------------------------
# dims
result$dims <- dims
#-----------------------------
# attrs
## name input dat
names_dat <- names(attributes(object)$FileSelectors)
## name input vars
names_vars <- as.vector(attributes(object)$FileSelectors[[names_dat[1]]]$var[[1]])
## name time dim under common
variables_common <- names(attributes(object)$Variables$common)
name_time_dim <- variables_common[!variables_common %in% names_vars]
dates <- attributes(object)$Variables$common[[name_time_dim]]
#-----------------------------
# coords
result$coords <- sapply(names(dims),function(x) NULL)
# dataset
for (dat in names_dat[1]) {
dat_attr_names <- names(attributes(object)$Variables[[dat]])
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
## lon
known_lon_names <- s2dv:::.KnownLonNames()
lon_name_dat <- dat_attr_names[which(dat_attr_names %in% known_lon_names)]
lon_name_common <- variables_common[which(variables_common %in% known_lon_names)]
if (!is.null(lon_name_dat) & !identical(lon_name_dat, character(0))) {
result$coords[[lon_name_dat]] <- attributes(object)$Variables[[dat]][[lon_name_dat]]
} else if (!is.null(lon_name_common) & !identical(lon_name_common, character(0))) {
result$coords[[lon_name_common]] <- attributes(object)$Variables$common[[lon_name_common]]
} else {
warning("'lon' is not found in this object.")
}
## lat
known_lat_names <- s2dv:::.KnownLatNames()
lat_name_dat <- dat_attr_names[which(dat_attr_names %in% known_lat_names)]
lat_name_common <- variables_common[which(variables_common %in% known_lat_names)]
if (!is.null(lat_name_dat) & !identical(lat_name_dat, character(0))) {
result$coords[[lat_name_dat]] <- attributes(object)$Variables[[dat]][[lat_name_dat]]
} else if (!is.null(lat_name_common) & !identical(lat_name_common, character(0))) {
result$coords[[lat_name_common]] <- attributes(object)$Variables$common[[lat_name_common]]
} else {
warning("'lat' is not found in this object.")
}
## sdate
if (any(name_time_dim %in% names(dims))) {
n_sdates <- dims[which(names(dims) == 'sdate' | names(dims) == 'sdates')]
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
sdate_name <- names(dims)[which(names(dims) %in% c('sdate', 'sdates'))]
sdates <- attributes(object)$FileSelectors[[dat]][[sdate_name]]
result$coords[[sdate_name]] <- as.POSIXct(attributes(object)$FileSelectors[[dat]][[sdate_name]][[1]][1:n_sdates], format = "%Y%m%d", tz = "UTC")
} else {
if (any(c('sdate', 'sdates', 'sweek', 'sday', 'time') %in% names(dims))) {
name_time_dim <- names(dims)[which(names(dims) %in% c('sdate', 'sdates', 'sweek', 'sday', 'syear', 'time'))]
}
sdates <- NULL
sdate_name <- NULL
}
# missing other dims
result$coords <- sapply(names(result$coords), function(x) {
if (is.null(result$coords[[x]])) {
result$coords[[x]] <- 1:result$dims[x]
} else {
result$coords[[x]] <- result$coords[[x]]
}
})
Variable <- list()
if (all(names_vars %in% variables_common)) {
Variable$varName <- names_vars
attr(Variable, 'variable') <- attributes(object)$Variables$common[[names_vars]]
result$attrs$Variable <- Variable
} else if (all(names_vars %in% dat_attr_names)) {
Variable$varName <- names_vars
for (var in names_vars) {
attr(Variable, var) <- attributes(object)$Variables[[dat]][[var]]
}
}
result$attrs$Variable <- Variable
}
if (length(names_dat) > 1) {
esult$attrs$Datasets <- names_dat
Dataset <- list(list(InitializationDates = list(Member_1 = sdates)))
names(Dataset) <- list(deparse(substitute(object)))
result$attrs$Datasets <- Dataset
dim(dates) <- result$dims[c(sdate_name, name_time_dim)]
result$attrs$Dates <- dates
result$attrs$when <- Sys.time()
result$attrs$source_files <- as.vector(attributes(object)$Files)
result$attrs$load_parameters <- attributes(object)$FileSelectors