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.
#'@param remove_attrs_coords A logical value indicating whether to remain
#' attributes from coordinates (FALSE) or not (TRUE) when the data is loaded from
#' Start(). It is TRUE by default.
#'@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, remove_attrs_coords = TRUE) {
if (is.list(object)) {
if (is.null(object) || (is.null(object$mod) && is.null(object$obs))) {
stop("The s2dverification::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'
names(obs)[[1]] <- 'data'
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)) {
class(object) <- 's2dv_cube'
result$exp <- object
}
if (!is.null(obs$data)) {
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)
# lon name
known_lon_names <- s2dv:::.KnownLonNames()
# lat name
known_lat_names <- s2dv:::.KnownLatNames()
names_dat <- names(attributes(object)$FileSelectors)
names_vars <- as.vector(attributes(object)$FileSelectors[[names_dat[1]]]$var[[1]])
variables_common <- names(attributes(object)$Variables$common)
name_time_dim <- variables_common[!variables_common %in% names_vars]
name_time_dim <- name_time_dim[which(!name_time_dim %in% known_lon_names & !name_time_dim %in% known_lat_names)]
dates <- attributes(object)$Variables$common[[name_time_dim]]
# dims
dims <- dim(object)
dim(result$data) <- dims
result$dims <- dims
# coords
result$coords <- sapply(names(dims),function(x) NULL)
dat <- names_dat[1]
dat_attr_names <- names(attributes(object)$Variables[[dat]])
# 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))) {
if (isTRUE(remove_attrs_coords)) {
result$coords[[lon_name_dat]] <- as.vector(attributes(object)$Variables[[dat]][[lon_name_dat]])
} else {
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))) {
if (isTRUE(remove_attrs_coords)) {
result$coords[[lon_name_common]] <- as.vector(attributes(object)$Variables$common[[lon_name_common]])
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))) {
if (isTRUE(remove_attrs_coords)) {
result$coords[[lat_name_dat]] <- as.vector(attributes(object)$Variables[[dat]][[lat_name_dat]])
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))) {
if (isTRUE(remove_attrs_coords)) {
result$coords[[lat_name_common]] <- as.vector(attributes(object)$Variables$common[[lat_name_common]])
result$coords[[lat_name_common]] <- attributes(object)$Variables$common[[lat_name_common]]
} else {
warning("'lat' is not found in this object.")
}
# sdate
files <- attributes(object)$Files
files_str <- strsplit(files, "/")
elem <- sapply(files_str, '[', length(files_str[[1]]))
elems <- sapply(strsplit(elem, "_"), '[', 2)
input_dates <- str_sub(elems, 0,-4)
if (any(name_time_dim %in% names(dims))) {
n_sdates <- dims[which(names(dims) == 'sdate' | names(dims) == 'sdates')]
sdate_name <- names(dims)[which(names(dims) %in% c('sdate', 'sdates'))]
sdates <- attributes(object)$FileSelectors[[dat]][[sdate_name]]
# result$coords[[sdate_name]] <- as.vector(attributes(object)$FileSelectors[[dat]][[sdate_name]][[1]])
} 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]]
if (isTRUE(remove_attrs_coords)) {
attr(Variable, "variable")$dim <- NULL
}
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]]
}
}
if (isTRUE(remove_attrs_coords)) {
attr(Variable, "variable")$dim <- NULL
result$attrs$Variable <- Variable
result$attrs$Datasets <- names_dat
for (i in 2:length(names_dat)) {
if (!is.null(lon_name_dat)) {
if (any(result$coords[[lon_name_dat]] != as.vector(attributes(object)$Variables[[names_dat[i]]][[lon_name_dat]]))) {
warning("'lon' values are different for different datasets. Only values from the first will be used.")
}
}
if (!is.null(lat_name_dat)) {
if (any(result$coords[[lat_name_dat]] != as.vector(attributes(object)$Variables[[names_dat[i]]][[lat_name_dat]]))) {
warning("'lat' values are different for different datasets. Only values from the first will be used.")
}
}
}
Dataset <- list(list(InitializationDates = list(Member_1 = sdates)))
names(Dataset) <- list(deparse(substitute(object)))
result$attrs$Datasets <- Dataset
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
} else {
stop("The class of parameter 'object' is not implemented",
" to be converted into 's2dv_cube' class yet.")