diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 8cd9e963bf92843ac7de669222149d1c4dbddfc4..ef540fe63c5bdfb2b3ee3bfb3a3e9e6513f1b2a5 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -7,5 +7,4 @@ build: - module load CDO/1.9.8-foss-2015a - R CMD build --resave-data . - R CMD check --as-cran --no-manual --run-donttest startR_*.tar.gz - - R -e 'covr::package_coverage()' diff --git a/DESCRIPTION b/DESCRIPTION index 27d4a775592e188fc7353cc232e428e3c33edf61..f1a9778c8fcd0d67ab57e621d3ba8a52351ed19c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: startR Title: Automatically Retrieve Multidimensional Distributed Data Sets -Version: 2.1.0-4 +Version: 2.1.0-5 Authors@R: c( person("BSC-CNS", role = c("aut", "cph")), person("Nicolau", "Manubens", , "nicolau.manubens@bsc.es", role = c("aut")), @@ -32,7 +32,8 @@ Imports: PCICt Suggests: stats, - utils + utils, + testthat License: LGPL-3 URL: https://earth.bsc.es/gitlab/es/startR/ BugReports: https://earth.bsc.es/gitlab/es/startR/-/issues diff --git a/R/ByChunks.R b/R/ByChunks.R index dd101120d1b394ba8cae6eca7f8bf1cb43688f8f..8185763bf5c31d388bdb28d5ab3873d8636f46d9 100644 --- a/R/ByChunks.R +++ b/R/ByChunks.R @@ -354,7 +354,17 @@ ByChunks <- function(step_fun, cube_headers, ..., chunks = 'auto', # Check all input headers have matching dimensions cube_index <- 1 for (cube_header in cube_headers) { - if (!all(attr(cube_header, 'Dimensions') == all_dims_merged[names(attr(cube_header, 'Dimensions'))])) { + + # Check if all the margin dims are consistent among datasets + if (!all(chunked_dims %in% names(attr(cube_header, "Dimensions")))) { + trouble_dim_name <- chunked_dims[which(!chunked_dims %in% + names(attr(cube_header, "Dimensions")))] + stop(paste0("Found margin dimension, ", toString(trouble_dim_name), + ", is not in input data ", cube_index, ".")) + } + + # Only check margin dimensions (i.e., chunked_dims) + if (!all(attr(cube_header, 'Dimensions')[chunked_dims] == all_dims_merged[names(attr(cube_header, 'Dimensions'))][chunked_dims])) { stop("All provided 'cube_headers' must have matching dimension lengths ", "with each other.") } diff --git a/R/Start.R b/R/Start.R index ff4b97831b5c7337cdab1da166b9016895ac92b3..b361eb1073c6131c7d9f81b4af34c5922b9aedd1 100644 --- a/R/Start.R +++ b/R/Start.R @@ -208,6 +208,10 @@ #'section 'electronics' has items 'a', 'b' and 'c' but section 'clothing' has #'items 'd', 'e', 'f'. Otherwise Start() would expect to find the same #'item names in all the sections. +#'If values() is used to define dimensions, it is possible to provide different +#'values of the depending dimension for each depended dimension values. For +#'example, if \code{section = c('electronics', 'clothing')}, we can use +#'\code{item = list(electronics = c('a', 'b', 'c'), clothing = c('d', 'e', 'f'))}. #'\cr\cr #'The \bold{name of another dimension} to be specified in '_across', #'only available for inner dimensions, must be a character string with the name @@ -857,6 +861,10 @@ Start <- function(..., # dim = indices/selectors, if (!is.logical(merge_across_dims)) { stop("Parameter 'merge_across_dims' must be TRUE or FALSE.") } + if (merge_across_dims & is.null(inner_dims_across_files)) { + merge_across_dims <- FALSE + .warning("Parameter 'merge_across_dims' is changed to FALSE because there is no *_across argument.") + } # Check merge_across_dims_narm if (!is.logical(merge_across_dims_narm)) { @@ -872,46 +880,12 @@ Start <- function(..., # dim = indices/selectors, dim_names <- names(dim_params) # Look for chunked dims chunks <- look_for_chunks(dim_params, dim_names) - + # Check pattern_dims - if (is.null(pattern_dims)) { - .warning(paste0("Parameter 'pattern_dims' not specified. Taking the first dimension, '", - dim_names[1], "' as 'pattern_dims'.")) - pattern_dims <- dim_names[1] - } else if (is.character(pattern_dims) && (length(pattern_dims) > 0)) { - pattern_dims <- unique(pattern_dims) - } else { - stop("Parameter 'pattern_dims' must be a vector of character strings.") - } - if (any(names(var_params) %in% pattern_dims)) { - stop("'*_var' parameters specified for pattern dimensions. Remove or fix them.") - } - # Find the pattern dimension with the pattern specifications - found_pattern_dim <- NULL - for (pattern_dim in pattern_dims) { - # Check all specifications in pattern_dim are valid - dat <- datasets <- dim_params[[pattern_dim]] - if (is.null(dat) || !(is.character(dat) && all(nchar(dat) > 0)) && !is.list(dat)) { - stop(paste0("Parameter '", pattern_dim, - "' must be a list of lists with pattern specifications or a vector of character strings.")) - } - if (!is.null(dim_reorder_params[[pattern_dim]])) { - .warning(paste0("A reorder for the selectors of '", pattern_dim, - "' has been specified, but it is a pattern dimension and the reorder will be ignored.")) - } - if (is.list(dat) || any(sapply(dat, is.list))) { - if (is.null(found_pattern_dim)) { - found_pattern_dim <- pattern_dim - } else { - stop("Found more than one pattern dim with pattern specifications (list of lists). One and only one pattern dim must contain pattern specifications.") - } - } - } - if (is.null(found_pattern_dim)) { - .warning(paste0("Could not find any pattern dim with explicit data set descriptions (in the form of list of lists). Taking the first pattern dim, '", pattern_dims[1], "', as dimension with pattern specifications.")) - found_pattern_dim <- pattern_dims[1] - } - + # Function found_pattern_dims may change pattern_dims in the .GlobalEnv + found_pattern_dim <- found_pattern_dims(pattern_dims, dim_names, var_params, + dim_params, dim_reorder_params) + # Check all *_reorder are NULL or functions, and that they all have # a matching dimension param. i <- 1 @@ -976,17 +950,17 @@ Start <- function(..., # dim = indices/selectors, # Check if pattern_dims is the first item in metadata_dims if ((pattern_dims %in% metadata_dims) & metadata_dims[1] != pattern_dims) { - metadata_dims <- c(metadata_dims[-1], metadata_dims[1]) + metadata_dims <- c(pattern_dims, metadata_dims[-which(metadata_dims == pattern_dims)]) } # Check if metadata_dims has more than 2 elements if ((metadata_dims[1] == pattern_dims & length(metadata_dims) > 2)) { - .warning(paste0("Parameter 'metadata_dims' has too many elements which serve repetitive ", - "function. Keep '", metadata_dims[1], "' and '", metadata_dims[2], "' only.")) - metadata_dims <- metadata_dims[1:2] + .warning(paste0("Parameter 'metadata_dims' has too many elements which serve repetitive ", + "function. Keep '", metadata_dims[1], "' and '", metadata_dims[2], "' only.")) + metadata_dims <- metadata_dims[1:2] } else if (!(pattern_dims %in% metadata_dims) & length(metadata_dims) > 1) { - .warning(paste0("Parameter 'metadata_dims' has too many elements which serve repetitive ", - "function. Keep '", metadata_dims[1], "' only.")) - metadata_dims <- metadata_dims[1] + .warning(paste0("Parameter 'metadata_dims' has too many elements which serve repetitive ", + "function. Keep '", metadata_dims[1], "' only.")) + metadata_dims <- metadata_dims[1] } # Once the pattern dimension with dataset specifications is found, @@ -998,64 +972,13 @@ Start <- function(..., # dim = indices/selectors, chunks[[found_pattern_dim]]['n_chunks'], found_pattern_dim) dim_params[[found_pattern_dim]] <- dim_params[[found_pattern_dim]][dats_to_take] - dat <- datasets <- dim_params[[found_pattern_dim]] - dat_info_names <- c('name', 'path')#, 'nc_var_name', 'suffix', 'var_min', 'var_max', 'dimnames') - dat_to_fetch <- c() + dat <- dim_params[[found_pattern_dim]] + #NOTE: This function creates the object 'dat_names' dat_names <- c() - if (!is.list(dat)) { - dat <- as.list(dat) - } else { - if (!any(sapply(dat, is.list))) { - dat <- list(dat) - } - } - for (i in 1:length(dat)) { - if (is.character(dat[[i]]) && length(dat[[i]]) == 1 && nchar(dat[[i]]) > 0) { - if (grepl('^(\\./|\\.\\./|/.*/|~/)', dat[[i]])) { - dat[[i]] <- list(path = dat[[i]]) - } else { - dat[[i]] <- list(name = dat[[i]]) - } - } else if (!is.list(dat[[i]])) { - stop(paste0("Parameter '", pattern_dim, - "' is incorrect. It must be a list of lists or character strings.")) - } - #if (!(all(names(dat[[i]]) %in% dat_info_names))) { - # stop("Error: parameter 'dat' is incorrect. There are unrecognized components in the information of some of the datasets. Check 'dat' in ?Load for details.") - #} - if (!('name' %in% names(dat[[i]]))) { - dat[[i]][['name']] <- paste0('dat', i) - if (!('path' %in% names(dat[[i]]))) { - stop(paste0("Parameter '", found_pattern_dim, - "' is incorrect. A 'path' should be provided for each dataset if no 'name' is provided.")) - } - } else if (!('path' %in% names(dat[[i]]))) { - dat_to_fetch <- c(dat_to_fetch, i) - } - #if ('path' %in% names(dat[[i]])) { - # if (!('nc_var_name' %in% names(dat[[i]]))) { - # dat[[i]][['nc_var_name']] <- '$var_name$' - # } - # if (!('suffix' %in% names(dat[[i]]))) { - # dat[[i]][['suffix']] <- '' - # } - # if (!('var_min' %in% names(dat[[i]]))) { - # dat[[i]][['var_min']] <- '' - # } - # if (!('var_max' %in% names(dat[[i]]))) { - # dat[[i]][['var_max']] <- '' - # } - #} - dat_names <- c(dat_names, dat[[i]][['name']]) - } - if ((length(dat_to_fetch) > 0) && (length(dat_to_fetch) < length(dat))) { - .warning("'path' has been provided for some datasets. Any information in the configuration file related to these will be ignored.") - } - if (length(dat_to_fetch) > 0) { - stop("Specified only the name for some data sets, but not the path ", - "pattern. This option has not been yet implemented.") - } - + dat <- mount_dat(dat, pattern_dims, found_pattern_dim, dat_names) + + dim_params[[found_pattern_dim]] <- dat_names + # Reorder inner_dims_across_files (to make the keys be the file dimensions, # and the values to be the inner dimensions that go across it). if (!is.null(inner_dims_across_files)) { @@ -1153,7 +1076,24 @@ Start <- function(..., # dim = indices/selectors, if (length(var_entries_to_add) > 0) { synonims[names(var_params)[var_entries_to_add]] <- as.list(names(var_params)[var_entries_to_add]) } - + + # Check if return_vars name is inner dim name. If it is synonim, change back to inner dim name + # and return a warning. + use_syn_names <- which(names(return_vars) %in% unlist(synonims) & + !names(return_vars) %in% names(synonims)) + if (!identical(use_syn_names, integer(0))) { + for (use_syn_name in use_syn_names) { + wrong_name <- names(return_vars)[use_syn_name] + names(return_vars)[use_syn_name] <- names(unlist( + lapply(lapply(synonims, '%in%', + names(return_vars)[use_syn_name]), + which))) + .warning(paste0("The name '", wrong_name, "' in parameter 'return_vars' in synonim. ", + "Change it back to the inner dimension name, '", + names(return_vars)[use_syn_name], "'.")) + } + } + # Check selector_checker if (is.null(selector_checker) || !is.function(selector_checker)) { stop("Parameter 'selector_checker' must be a function.") @@ -1268,8 +1208,6 @@ Start <- function(..., # dim = indices/selectors, stop("Parameter 'silent' must be logical.") } - dim_params[[found_pattern_dim]] <- dat_names - if (!silent) { .message(paste0("Exploring files... This will take a variable amount ", "of time depending on the issued request and the ", @@ -1366,59 +1304,49 @@ Start <- function(..., # dim = indices/selectors, stop("All dimensions in 'metadata_dims' must be file dimensions.") } } + + # Add attributes indicating whether this dimension selector is value or indice + tmp <- lapply(dat_selectors[which(dim_names != pattern_dims)], add_value_indices_flag) + dat_selectors <- c(dat_selectors[pattern_dims], tmp) + ## Look for _var params that should be requested automatically. - for (dim_name in dim_names) { - if (!(dim_name %in% pattern_dims)) { - if (is.null(attr(dat_selectors[[dim_name]], 'values')) || - is.null(attr(dat_selectors[[dim_name]], 'indices'))) { - flag <- ((any(dat_selectors[[dim_name]] %in% c('all', 'first', 'last'))) || - (is.numeric(unlist(dat_selectors[[dim_name]])))) - attr(dat_selectors[[dim_name]], 'values') <- !flag - attr(dat_selectors[[dim_name]], 'indices') <- flag - } - ## The following code 'rewrites' var_params for all datasets. If providing different - ## path pattern repositories with different file/inner dimensions, var_params might - ## have to be handled for each dataset separately. - if ((attr(dat_selectors[[dim_name]], 'values') || (dim_name %in% c('var', 'variable'))) && - !(dim_name %in% names(var_params)) && !(dim_name %in% file_dims)) { - if (dim_name %in% c('var', 'variable')) { - var_params <- c(var_params, setNames(list('var_names'), dim_name)) - .warning(paste0("Found specified values for dimension '", dim_name, "' but no '", - dim_name, "_var' requested. ", '"', dim_name, "_var = '", - 'var_names', "'", '"', " has been automatically added to ", - "the Start call.")) - } else { - var_params <- c(var_params, setNames(list(dim_name), dim_name)) - .warning(paste0("Found specified values for dimension '", dim_name, "' but no '", - dim_name, "_var' requested. ", '"', dim_name, "_var = '", - dim_name, "'", '"', " has been automatically added to ", - "the Start call.")) - } + for (dim_name in dim_names[-which(dim_names == pattern_dims)]) { + ## The following code 'rewrites' var_params for all datasets. If providing different + ## path pattern repositories with different file/inner dimensions, var_params might + ## have to be handled for each dataset separately. + if ((attr(dat_selectors[[dim_name]], 'values') || (dim_name %in% c('var', 'variable'))) && + !(dim_name %in% names(var_params)) && !(dim_name %in% file_dims)) { + if (dim_name %in% c('var', 'variable')) { + var_params <- c(var_params, setNames(list('var_names'), dim_name)) + .warning(paste0("Found specified values for dimension '", dim_name, "' but no '", + dim_name, "_var' provided. ", '"', dim_name, "_var = '", + 'var_names', "'", '"', " has been automatically added to ", + "the Start call.")) + } else { + var_params <- c(var_params, setNames(list(dim_name), dim_name)) + .warning(paste0("Found specified values for dimension '", dim_name, "' but no '", + dim_name, "_var' requested. ", '"', dim_name, "_var = '", + dim_name, "'", '"', " has been automatically added to ", + "the Start call.")) } } - } -#================================================== - # Check if return_vars name is inner dim name. If it is synonim, change back to - # inner dim name and return a warning. - dim_params_found_file_dims <- dim_params[found_file_dims[[i]]] - if (any(names(return_vars) %in% unlist(synonims) & - !names(return_vars) %in% names(synonims))) { - use_syn_names <- which(names(return_vars) %in% unlist(synonims) & - !names(return_vars) %in% names(synonims)) - for (use_syn_name in use_syn_names) { - wrong_name <- names(return_vars)[use_syn_name] - names(return_vars)[use_syn_name] <- names(unlist( - lapply(lapply(synonims, '%in%', - names(return_vars)[use_syn_name]), - which))) - .warning(paste0("The name '", wrong_name, - "' in parameter 'return_vars' in synonim. ", - "Change it back to the inner dimension name, '", - names(return_vars)[use_syn_name], "'.")) + if (attr(dat_selectors[[dim_name]], 'indices') & !(dim_name %in% names(var_params))) { + if (dim_name %in% transform_vars) { + var_params <- c(var_params, setNames(list(dim_name), dim_name)) + .warning(paste0("Found dimension '", dim_name, "' is required to transform but no '", + dim_name, "_var' provided. ", '"', dim_name, "_var = '", + dim_name, "'", '"', " has been automatically added to ", + "the Start call.")) + } else if (dim_name %in% names(dim_reorder_params)) { + var_params <- c(var_params, setNames(list(dim_name), dim_name)) + .warning(paste0("Found dimension '", dim_name, "' is required to reorder but no '", + dim_name, "_var' provided. ", '"', dim_name, "_var = '", + dim_name, "'", '"', " has been automatically added to ", + "the Start call.")) + } } } -#===================================================== ## (Check the *_var parameters). if (any(!(unlist(var_params) %in% names(return_vars)))) { @@ -1432,15 +1360,17 @@ Start <- function(..., # dim = indices/selectors, paste(paste0("'", unlist(var_params), "'"), collapse = ', '))) } + # Examine the selectors of file dim and create 'replace_values', which uses the first + # explicit selector (i.e., character) for all file dimensions. replace_values <- vector('list', length = length(file_dims)) names(replace_values) <- file_dims - # Take the first selector for all possible file dimensions for (file_dim in file_dims) { if (file_dim %in% names(var_params)) { .warning(paste0("The '", file_dim, "_var' param will be ignored since '", file_dim, "' is a file dimension (for the dataset with pattern ", dat[[i]][['path']], ").")) } + # If the selector is a vector or a list of 2 without names (represent the value range) if (!is.list(dat_selectors[[file_dim]]) || (is.list(dat_selectors[[file_dim]]) && length(dat_selectors[[file_dim]]) == 2 && @@ -1449,6 +1379,9 @@ Start <- function(..., # dim = indices/selectors, } first_class <- class(dat_selectors[[file_dim]][[1]]) first_length <- length(dat_selectors[[file_dim]][[1]]) + + # Length will be > 1 if it is list since beginning, e.g., depending dim is a list with + # names as depended dim. for (j in 1:length(dat_selectors[[file_dim]])) { sv <- selector_vector <- dat_selectors[[file_dim]][[j]] if (!identical(first_class, class(sv)) || @@ -1457,13 +1390,31 @@ Start <- function(..., # dim = indices/selectors, "be vectors of the same length and of the same class.") } if (is.character(sv) && !((length(sv) == 1) && (sv[1] %in% c('all', 'first', 'last')))) { + #NOTE: ???? It doesn't make any changes. dat_selectors[[file_dim]][[j]] <- selector_checker(selectors = sv, return_indices = FALSE) - # Take chunk if needed - dat_selectors[[file_dim]][[j]] <- dat_selectors[[file_dim]][[j]][chunk_indices(length(dat_selectors[[file_dim]][[j]]), - chunks[[file_dim]]['chunk'], - chunks[[file_dim]]['n_chunks'], - file_dim)] + # Take chunk if needed (only defined dim; undefined dims will be chunked later in + # find_ufd_value(). + if (chunks[[file_dim]]['n_chunks'] > 1) { + desired_chunk_indices <- chunk_indices( + length(dat_selectors[[file_dim]][[j]]), + chunks[[file_dim]]['chunk'], + chunks[[file_dim]]['n_chunks'], + file_dim) + dat_selectors[[file_dim]][[j]] <- dat_selectors[[file_dim]][[j]][desired_chunk_indices] + # chunk the depending dim as well + if (file_dim %in% depending_file_dims) { + depending_dim_name <- names(which(file_dim == depending_file_dims)) + # Chunk it only if it is defined dim (i.e., list of character with names of depended dim) + if (!(length(dat_selectors[[depending_dim_name]]) == 1 && + dat_selectors[[depending_dim_name]] %in% c('all', 'first', 'last'))) { + if (sapply(dat_selectors[[depending_dim_name]], is.character)) { + dat_selectors[[depending_dim_name]] <- + dat_selectors[[depending_dim_name]][desired_chunk_indices] + } + } + } + } } else if (!(is.numeric(sv) || (is.character(sv) && (length(sv) == 1) && (sv %in% c('all', 'first', 'last'))) || (is.list(sv) && (length(sv) == 2) && (all(sapply(sv, is.character)) || @@ -1472,18 +1423,39 @@ Start <- function(..., # dim = indices/selectors, } } sv <- dat_selectors[[file_dim]][[1]] + # 'replace_values' has the first selector (if it's character) or NULL (if it's not explicitly + # defined) for each file dimension. if (is.character(sv) && !((length(sv) == 1) && (sv[1] %in% c('all', 'first', 'last')))) { - replace_values[[file_dim]] <- dat_selectors[[file_dim]][[1]][1] + replace_values[[file_dim]] <- sv[1] } } #print("C") # Now we know which dimensions whose selectors are provided non-explicitly. undefined_file_dims <- file_dims[which(sapply(replace_values, is.null))] defined_file_dims <- file_dims[which(!(file_dims %in% undefined_file_dims))] - # Quickly check if the depending dimensions are provided properly. + # Quickly check if the depending dimensions are provided properly. The check is only for + # if the depending and depended file dims are both explicited defined. for (file_dim in file_dims) { if (file_dim %in% names(depending_file_dims)) { + + # Return error if depended dim is a list of values while depending dim is not + # defined (i.e., indices or 'all') + if (file_dim %in% defined_file_dims & + !(depending_file_dims[[file_dim]] %in% defined_file_dims)) { + stop(paste0("The depended dimension, ", file_dim, ", is explictly defined ", + "by a list of values, while the depending dimension, ", + depending_file_dims[[file_dim]], ", is not explictly defined. ", + "Specify ", depending_file_dims[[file_dim]], " by characters.")) + } + ## TODO: Detect multi-dependancies and forbid. + #NOTE: The if statement below is tricky. It tries to distinguish if the depending dim + # has the depended dim as the names of the list. However, if the depending dim + # doesn't have list names and its length is 2 (i.e., list( , )), Start() thinks + # it means the range, just like `lat = values(list(10, 20))`. And because of this, + # we won't enter the following if statement, and the error will occur later in + # SelectorChecker(). Need to find a way to distinguish if list( , ) means range or + # just the values. if (all(c(file_dim, depending_file_dims[[file_dim]]) %in% defined_file_dims)) { if (length(dat_selectors[[file_dim]]) != length(dat_selectors[[depending_file_dims[[file_dim]]]][[1]])) { stop(paste0("If providing selectors for the depending ", @@ -1497,10 +1469,15 @@ Start <- function(..., # dim = indices/selectors, "provided vectors of selectors must match ", "exactly the selectors of the dimension it ", "depends on, '", depending_file_dims[[file_dim]], "'.")) + } else if (is.null(names(dat_selectors[[file_dim]]))) { + .warning(paste0("The selectors for the depending dimension '", file_dim, "' do not ", + "have list names. Assume that the order of the selectors matches the ", + "depended dimensions '", depending_file_dims[[file_dim]], "''s order.")) } } } } + # Find the possible values for the selectors that are provided as # indices. If the requested file is on server, impossible operation. if (length(grep("^http", dat[[i]][['path']])) > 0) { @@ -1555,114 +1532,23 @@ Start <- function(..., # dim = indices/selectors, dataset_has_files[i] <- TRUE ## TODO: Improve message here if no variable found: if (length(undefined_file_dims) > 0) { - # Looking for the first values, parsed from first_file. - first_values <- vector('list', length = length(undefined_file_dims)) - names(first_values) <- undefined_file_dims - found_values <- 0 - stop <- FALSE - try_dim <- 1 - last_success <- 1 - while ((found_values < length(undefined_file_dims)) && !stop) { - u_file_dim <- undefined_file_dims[try_dim] - if (is.null(first_values[[u_file_dim]])) { - path_with_globs_and_tag <- .ReplaceVariablesInString(dat[[i]][['path']], - replace_values[-which(file_dims == u_file_dim)], - allow_undefined_key_vars = TRUE) - found_value <- .FindTagValue(path_with_globs_and_tag, - first_file, u_file_dim) - if (!is.null(found_value)) { - found_values <- found_values + 1 - last_success <- try_dim - first_values[[u_file_dim]] <- found_value - replace_values[[u_file_dim]] <- found_value - } - } - try_dim <- (try_dim %% length(undefined_file_dims)) + 1 - if (try_dim == last_success) { - stop <- TRUE - } - } - if (found_values < length(undefined_file_dims)) { - stop(paste0("Path pattern of dataset '", dat[[i]][['name']], - "' is too complex. Could not automatically ", - "detect values for all non-explicitly defined ", - "indices. Check its pattern: ", dat[[i]][['path']])) - } - ## TODO: Replace ReplaceGlobExpressions by looped call to FindTagValue? As done above - ## Maybe it can solve more cases actually. I got warnings in ReplGlobExp with a typical - ## cmor case, requesting all members and chunks for fixed var and sdate. Not fixing - ## sdate raised 'too complex' error. - # Replace shell globs in path pattern and keep the file_dims as tags - dat[[i]][['path']] <- .ReplaceGlobExpressions(dat[[i]][['path']], first_file, replace_values, - file_dims, dat[[i]][['name']], path_glob_permissive) - # Now time to look for the available values for the non - # explicitly defined selectors for the file dimensions. - #print("H") - # Check first the ones that do not depend on others. - ufd <- c(undefined_file_dims[which(!(undefined_file_dims %in% names(depending_file_dims)))], - undefined_file_dims[which(undefined_file_dims %in% names(depending_file_dims))]) - - for (u_file_dim in ufd) { - replace_values[undefined_file_dims] <- first_values - replace_values[[u_file_dim]] <- '*' - depended_dim <- NULL - depended_dim_values <- NA - -#NOTE: Here 'selectors' is always 1. Is it supposed to be like this? - selectors <- dat_selectors[[u_file_dim]][[1]] - if (u_file_dim %in% names(depending_file_dims)) { - depended_dim <- depending_file_dims[[u_file_dim]] - depended_dim_values <- dat_selectors[[depended_dim]][[1]] - dat_selectors[[u_file_dim]] <- vector('list', length = length(depended_dim_values)) - names(dat_selectors[[u_file_dim]]) <- depended_dim_values - } else { - dat_selectors[[u_file_dim]] <- list() - } - if (u_file_dim %in% unlist(depending_file_dims)) { - depending_dims <- names(depending_file_dims)[which(sapply(depending_file_dims, function(x) u_file_dim %in% x))] - replace_values[depending_dims] <- rep('*', length(depending_dims)) - } - for (j in 1:length(depended_dim_values)) { - parsed_values <- c() - if (!is.null(depended_dim)) { - replace_values[[depended_dim]] <- depended_dim_values[j] - } - path_with_globs <- .ReplaceVariablesInString(dat[[i]][['path']], replace_values) - found_files <- Sys.glob(path_with_globs) - ## TODO: Enhance this error message, or change by warning. - ## Raises if a wrong sdate is specified, for example. - if (length(found_files) == 0) { - .warning(paste0("Could not find files for any '", u_file_dim, - "' for '", depended_dim, "' = '", - depended_dim_values[j], "'.")) - dat_selectors[[u_file_dim]][[j]] <- NA - } else { - for (found_file in found_files) { - path_with_globs_and_tag <- .ReplaceVariablesInString(dat[[i]][['path']], - replace_values[-which(file_dims == u_file_dim)], - allow_undefined_key_vars = TRUE) - parsed_values <- c(parsed_values, - .FindTagValue(path_with_globs_and_tag, found_file, - u_file_dim)) - } - dat_selectors[[u_file_dim]][[j]] <- selector_checker(selectors = selectors, - var = unique(parsed_values), - return_indices = FALSE) - # Take chunk if needed - dat_selectors[[u_file_dim]][[j]] <- dat_selectors[[u_file_dim]][[j]][chunk_indices(length(dat_selectors[[u_file_dim]][[j]]), - chunks[[u_file_dim]]['chunk'], - chunks[[u_file_dim]]['n_chunks'], - u_file_dim)] - } - } - } + # Note: "dat[[i]][['path']]" is changed by the function below. + dat_selectors <- find_ufd_value(undefined_file_dims, dat, i, replace_values, + first_file, file_dims, path_glob_permissive, + depending_file_dims, dat_selectors, selector_checker, + chunks) #print("I") } else { + #NOTE: If there is no non-explicitly defined dim, use the first found file + # to modify. Problem: '*' doesn't catch all the possible file. Only use + # the first file. dat[[i]][['path']] <- .ReplaceGlobExpressions(dat[[i]][['path']], first_file, replace_values, defined_file_dims, dat[[i]][['name']], path_glob_permissive) } } } + dat[[i]][['selectors']] <- dat_selectors + # Now fetch for the first available file if (dataset_has_files[i]) { known_dims <- file_dims @@ -1679,24 +1565,33 @@ Start <- function(..., # dim = indices/selectors, sub_array_of_not_found_files <- array(!dataset_has_files[i], dim = files_to_load) names(dim(sub_array_of_not_found_files)) <- known_dims - j <- 1 - if (!exists('selector_indices_save')) { - selector_indices_save <- vector('list', length = length(dat)) - } - if (!exists('selectors_total_list')) { - selectors_total_list <- vector('list', length = length(dat)) + + if (largest_dims_length) { + if (!exists('selector_indices_save')) { + selector_indices_save <- vector('list', length = length(dat)) + } + if (!exists('selectors_total_list')) { + selectors_total_list <- vector('list', length = length(dat)) + } + selector_indices_save[[i]] <- vector('list', length = prod(files_to_load)) + selectors_total_list[[i]] <- vector('list', length = prod(files_to_load)) } - selector_indices_save[[i]] <- vector('list', length = prod(files_to_load)) - selectors_total_list[[i]] <- vector('list', length = prod(files_to_load)) + j <- 1 + # NOTE: This while loop has these objects that are used afterward: 'sub_array_of_files_to_load', + # 'sub_array_of_not_found_files', 'indices_of_first_files_with_data', 'selectors_of_first_files_with_data'; + # 'selector_indices_save' and 'selectors_total_list' are used if 'largest_dims_length = T'. while (j <= prod(files_to_load)) { selector_indices <- which(sub_array_of_files_to_load == j, arr.ind = TRUE)[1, ] names(selector_indices) <- known_dims - tmp <- selector_indices - tmp[which(known_dims == found_pattern_dim)] <- i - selector_indices_save[[i]][[j]] <- tmp + if (largest_dims_length) { + tmp <- selector_indices + tmp[which(known_dims == found_pattern_dim)] <- i + selector_indices_save[[i]][[j]] <- tmp + } + # This 'selectors' is only used in this while loop selectors <- sapply(1:length(known_dims), function (x) { vector_to_pick <- 1 @@ -1706,9 +1601,13 @@ Start <- function(..., # dim = indices/selectors, dat_selectors[known_dims][[x]][[vector_to_pick]][selector_indices[x]] }) names(selectors) <- known_dims - selectors_total_list[[i]][[j]] <- selectors - names(selectors_total_list[[i]][[j]]) <- known_dims + if (largest_dims_length) { + selectors_total_list[[i]][[j]] <- selectors + names(selectors_total_list[[i]][[j]]) <- known_dims + } + + # 'replace_values' and 'file_path' are only used in this while loop replace_values[known_dims] <- selectors if (!dataset_has_files[i]) { if (any(is.na(selectors))) { @@ -1726,13 +1625,14 @@ Start <- function(..., # dim = indices/selectors, } else { file_path <- .ReplaceVariablesInString(dat[[i]][['path']], replace_values) -#NOTE: After replacing tags, there is still * if path_glob_permissive is not FALSE. + #NOTE: After replacing tags, there is still * if path_glob_permissive is not FALSE. + # Find the possible value to substitute *. if (grepl('\\*', file_path)) { found_files <- Sys.glob(file_path) file_path <- found_files[1] # choose only the first file. -#NOTE: Above line chooses only the first found file. Because * is not tags, which means -# it is not a dimension. So it cannot store more than one item. If use * to define -# the path, that * should only represent one possibility. + #NOTE: Above line chooses only the first found file. Because * is not tags, which means + # it is not a dimension. So it cannot store more than one item. If use * to define + # the path, that * should only represent one possibility. if (length(found_files) > 1) { .warning("Using glob expression * to define the path, but more ", "than one match is found. Choose the first match only.") @@ -1781,7 +1681,6 @@ Start <- function(..., # dim = indices/selectors, array_of_not_found_files <- .MergeArrays(array_of_not_found_files, sub_array_of_not_found_files, along = found_pattern_dim) } - dat[[i]][['selectors']] <- dat_selectors } if (all(sapply(indices_of_first_files_with_data, is.null))) { stop("No data files found for any of the specified datasets.") @@ -1805,6 +1704,7 @@ Start <- function(..., # dim = indices/selectors, # } #////////////////////////////////////////////// + # Separate 'return_vars' into 'common_return_vars' and 'return_vars' (those = 'dat'). common_return_vars <- NULL common_first_found_file <- NULL common_return_vars_pos <- NULL @@ -1817,6 +1717,9 @@ Start <- function(..., # dim = indices/selectors, common_first_found_file <- rep(FALSE, length(which(sapply(common_return_vars, length) == 0))) names(common_first_found_file) <- names(common_return_vars[which(sapply(common_return_vars, length) == 0)]) } + +#!!!!!!!Check here. return_vars has removed the common ones, and here remove 'dat' value???? +#It seems like it does some benefits to later parts return_vars <- lapply(return_vars, function(x) { if (found_pattern_dim %in% x) { @@ -1825,7 +1728,6 @@ Start <- function(..., # dim = indices/selectors, x } }) - #//////////////////////////////////////////// # Force return_vars = (time = NULL) to (time = 'sdate') if (1) selector = [sdate = 2, time = 4] or # (2) time_across = 'sdate'. @@ -1837,33 +1739,17 @@ Start <- function(..., # dim = indices/selectors, file_dim_as_selector_array_dim <- 1 if (any(found_file_dims[[i]] %in% names(dim(selector_array)))) { - file_dim_as_selector_array_dim <- found_file_dims[[i]][which(found_file_dims[[i]] %in% names(dim(selector_array)))] + file_dim_as_selector_array_dim <- + found_file_dims[[i]][which(found_file_dims[[i]] %in% names(dim(selector_array)))] } - - if (inner_dim %in% inner_dims_across_files | is.character(file_dim_as_selector_array_dim)) { #(2) or (1) + if (inner_dim %in% inner_dims_across_files | + is.character(file_dim_as_selector_array_dim)) { #(2) or (1) # inner_dim is not in return_vars or is NULL if (((!inner_dim %in% names(common_return_vars)) & (!inner_dim %in% names(return_vars))) | - (inner_dim %in% names(common_return_vars) & is.null(common_return_vars[[inner_dim]])) ) { - if (is.character(file_dim_as_selector_array_dim)) { #(1) - if (file_dim_as_selector_array_dim %in% found_pattern_dim) { - return_vars[[inner_dim]] <- file_dim_as_selector_array_dim - } else { - common_return_vars[[inner_dim]] <- file_dim_as_selector_array_dim - } - tmp <- file_dim_as_selector_array_dim - } else if (inner_dim %in% inner_dims_across_files) { #(2) - file_dim_name <- names(which(inner_dim == inner_dims_across_files)) - if (file_dim_name %in% found_pattern_dim) { - return_vars[[inner_dim]] <- file_dim_name - } else { - common_return_vars[[inner_dim]] <- file_dim_name - } - tmp <- file_dim_name - } - .warning(paste0("Found ", inner_dim, " dependency on file diemnsion '", tmp, - "', but '", inner_dim, "' is not in return_vars list or is NULL. ", - "To provide the correct metadata, the value of ", inner_dim, - " in 'return_vars' is specified as '", tmp, "'.")) + (inner_dim %in% names(common_return_vars) & is.null(common_return_vars[[inner_dim]]))) { + common_return_vars[[inner_dim]] <- correct_return_vars( + inner_dim, inner_dims_across_files, + found_pattern_dim, file_dim_as_selector_array_dim) } } } @@ -1879,6 +1765,26 @@ Start <- function(..., # dim = indices/selectors, } #//////////////////////////////////////////// + # Change the structure of 'dat'. If the selector is not list or it is list of 2 that represents + # range, make it as list. The dimensions that go across files will later be extended to have + # lists of lists/vectors of selectors. + for (i in 1:length(dat)) { + if (dataset_has_files[i]) { + for (inner_dim in expected_inner_dims[[i]]) { + if (!is.list(dat[[i]][['selectors']][[inner_dim]]) || # not list, or + (is.list(dat[[i]][['selectors']][[inner_dim]]) && # list of 2 that represents range + length(dat[[i]][['selectors']][[inner_dim]]) == 2 && + is.null(names(dat[[i]][['selectors']][[inner_dim]])))) { + dat[[i]][['selectors']][[inner_dim]] <- list(dat[[i]][['selectors']][[inner_dim]]) + } + } + } + } + + + # Use 'common_return_vars' and 'return_vars' to generate the initial picked(_common)_vars, + # picked(_common)_vars_ordered, and picked(_common)_vars_unorder_indices. + ## Create 'picked_common_vars' if (length(common_return_vars) > 0) { picked_common_vars <- vector('list', length = length(common_return_vars)) names(picked_common_vars) <- names(common_return_vars) @@ -1887,29 +1793,20 @@ Start <- function(..., # dim = indices/selectors, } picked_common_vars_ordered <- picked_common_vars picked_common_vars_unorder_indices <- picked_common_vars + + ## Create 'picked_vars' picked_vars <- vector('list', length = length(dat)) names(picked_vars) <- dat_names + if (length(return_vars) > 0) { + picked_vars <- lapply(picked_vars, function(x) { + x <- vector('list', length = length(return_vars))} ) + picked_vars <- lapply(picked_vars, setNames, names(return_vars)) + } picked_vars_ordered <- picked_vars picked_vars_unorder_indices <- picked_vars + for (i in 1:length(dat)) { if (dataset_has_files[i]) { - # Put all selectors in a list of a single list/vector of selectors. - # The dimensions that go across files will later be extended to have - # lists of lists/vectors of selectors. - for (inner_dim in expected_inner_dims[[i]]) { - if (!is.list(dat[[i]][['selectors']][[inner_dim]]) || - (is.list(dat[[i]][['selectors']][[inner_dim]]) && - length(dat[[i]][['selectors']][[inner_dim]]) == 2 && - is.null(names(dat[[i]][['selectors']][[inner_dim]])))) { - dat[[i]][['selectors']][[inner_dim]] <- list(dat[[i]][['selectors']][[inner_dim]]) - } - } - if (length(return_vars) > 0) { - picked_vars[[i]] <- vector('list', length = length(return_vars)) - names(picked_vars[[i]]) <- names(return_vars) - picked_vars_ordered[[i]] <- picked_vars[[i]] - picked_vars_unorder_indices[[i]] <- picked_vars[[i]] - } indices_of_first_file <- as.list(indices_of_first_files_with_data[[i]]) array_file_dims <- sapply(dat[[i]][['selectors']][found_file_dims[[i]]], function(x) length(x[[1]])) names(array_file_dims) <- found_file_dims[[i]] @@ -1919,35 +1816,30 @@ Start <- function(..., # dim = indices/selectors, array_of_var_files <- do.call('[', c(list(x = array_of_files_to_load), indices_of_first_file, list(drop = FALSE))) array_of_var_indices <- array(1:length(array_of_var_files), dim = dim(array_of_var_files)) array_of_not_found_var_files <- do.call('[', c(list(x = array_of_not_found_files), indices_of_first_file, list(drop = FALSE))) + # Create previous_indices. The initial value is -1 because there is no 'previous' before the + # 1st current_indices. previous_indices <- rep(-1, length(indices_of_first_file)) names(previous_indices) <- names(indices_of_first_file) + # Create first_found_file for vars_to_read defining. It is for the dim value in return_vars + # that is NULL or character(0). Because these dims only need to be read once, so + # first_found_file indicates if these dims have been read or not. + # If read, it turns to TRUE and won't be included in vars_to_read again in the next + # 'for j loop'. first_found_file <- NULL if (length(return_vars) > 0) { first_found_file <- rep(FALSE, length(which(sapply(return_vars, length) == 0))) names(first_found_file) <- names(return_vars[which(sapply(return_vars, length) == 0)]) } + for (j in 1:length(array_of_var_files)) { current_indices <- which(array_of_var_indices == j, arr.ind = TRUE)[1, ] names(current_indices) <- names(indices_of_first_file) if (!is.na(array_of_var_files[j]) && !array_of_not_found_var_files[j]) { changed_dims <- which(current_indices != previous_indices) - vars_to_read <- NULL - if (length(return_vars) > 0) { - vars_to_read <- names(return_vars)[sapply(return_vars, function(x) any(names(changed_dims) %in% x))] - } - if (!is.null(first_found_file)) { - if (any(!first_found_file)) { - vars_to_read <- c(vars_to_read, names(first_found_file[which(!first_found_file)])) - } - } - if ((i == 1) && (length(common_return_vars) > 0)) { - vars_to_read <- c(vars_to_read, names(common_return_vars)[sapply(common_return_vars, function(x) any(names(changed_dims) %in% x))]) - } - if (!is.null(common_first_found_file)) { - if (any(!common_first_found_file)) { - vars_to_read <- c(vars_to_read, names(common_first_found_file[which(!common_first_found_file)])) - } - } + # Prepare vars_to_read for this dataset (i loop) and this file (j loop) + vars_to_read <- generate_vars_to_read(return_vars, changed_dims, first_found_file, + common_return_vars, common_first_found_file, i) + file_object <- file_opener(array_of_var_files[j]) if (!is.null(file_object)) { for (var_to_read in vars_to_read) { @@ -1960,193 +1852,44 @@ Start <- function(..., # dim = indices/selectors, synonims) # file_dim_reader returns dimension names as found in the file. # Need to translate accoridng to synonims: - names(var_dims) <- sapply(names(var_dims), - function(x) { - which_entry <- which(sapply(synonims, function(y) x %in% y)) - if (length(which_entry) > 0) { - names(synonims)[which_entry] - } else { - x - } - }) + names(var_dims) <- replace_with_synonmins(var_dims, synonims) if (!is.null(var_dims)) { - var_file_dims <- NULL + + ## (1) common_return_vars if (var_to_read %in% names(common_return_vars)) { var_to_check <- common_return_vars[[var_to_read]] + list_picked_var_of_read <- generate_picked_var_of_read( + var_to_read, var_to_check, array_of_files_to_load, var_dims, + array_of_var_files = array_of_var_files[j], file_var_reader, + file_object, synonims, associated_dim_name, dim_reorder_params, + aiat, current_indices, var_params, + either_picked_vars = picked_common_vars[[var_to_read]], + either_picked_vars_ordered = picked_common_vars_ordered[[var_to_read]], + either_picked_vars_unorder_indices = picked_common_vars_unorder_indices[[var_to_read]] + ) + picked_common_vars[[var_to_read]] <- list_picked_var_of_read$either_picked_vars + picked_common_vars_ordered[[var_to_read]] <- + list_picked_var_of_read$either_picked_vars_ordered + picked_common_vars_unorder_indices[[var_to_read]] <- + list_picked_var_of_read$either_picked_vars_unorder_indices + + ## (2) return_vars } else { var_to_check <- return_vars[[var_to_read]] - } - if (any(names(dim(array_of_files_to_load)) %in% var_to_check)) { - var_file_dims <- dim(array_of_files_to_load)[which(names(dim(array_of_files_to_load)) %in% - var_to_check)] - } - if (((var_to_read %in% names(common_return_vars)) && - is.null(picked_common_vars[[var_to_read]])) || - ((var_to_read %in% names(return_vars)) && - is.null(picked_vars[[i]][[var_to_read]]))) { - if (any(names(var_file_dims) %in% names(var_dims))) { - stop("Found a requested var in 'return_var' requested for a ", - "file dimension which also appears in the dimensions of ", - "the variable inside the file.\n", array_of_var_files[j]) - } - special_types <- list('POSIXct' = as.POSIXct, 'POSIXlt' = as.POSIXlt, - 'Date' = as.Date) - first_sample <- file_var_reader(NULL, file_object, NULL, - var_to_read, synonims) - if (any(class(first_sample) %in% names(special_types))) { - array_size <- prod(c(var_file_dims, var_dims)) - new_array <- rep(special_types[[class(first_sample)[1]]](NA), array_size) - dim(new_array) <- c(var_file_dims, var_dims) - } else { - new_array <- array(dim = c(var_file_dims, var_dims)) - } - attr(new_array, 'variables') <- attr(first_sample, 'variables') - if (var_to_read %in% names(common_return_vars)) { - picked_common_vars[[var_to_read]] <- new_array - pick_ordered <- FALSE - if (var_to_read %in% unlist(var_params)) { - if (associated_dim_name %in% names(dim_reorder_params) && !aiat) { - picked_common_vars_ordered[[var_to_read]] <- new_array - pick_ordered <- TRUE - } - } - if (!pick_ordered) { - picked_common_vars_ordered[[var_to_read]] <- NULL - } - } else { - picked_vars[[i]][[var_to_read]] <- new_array - pick_ordered <- FALSE - if (var_to_read %in% unlist(var_params)) { - if (associated_dim_name %in% names(dim_reorder_params) && !aiat) { - picked_vars_ordered[[i]][[var_to_read]] <- new_array - pick_ordered <- TRUE - } - } - if (!pick_ordered) { - picked_vars_ordered[[i]][[var_to_read]] <- NULL - } - } - } else { - if (var_to_read %in% names(common_return_vars)) { - array_var_dims <- dim(picked_common_vars[[var_to_read]]) - } else { - array_var_dims <- dim(picked_vars[[i]][[var_to_read]]) - } - full_array_var_dims <- array_var_dims - if (any(names(array_var_dims) %in% names(var_file_dims))) { - array_var_dims <- array_var_dims[-which(names(array_var_dims) %in% names(var_file_dims))] - } - if (names(array_var_dims) != names(var_dims)) { - stop("Error while reading the variable '", var_to_read, "' from ", - "the file. Dimensions do not match.\nExpected ", - paste(paste0("'", names(array_var_dims), "'"), - collapse = ', '), " but found ", - paste(paste0("'", names(var_dims), "'"), - collapse = ', '), ".\n", array_of_var_files[j]) - } - if (any(var_dims > array_var_dims)) { - longer_dims <- which(var_dims > array_var_dims) - if (length(longer_dims) == 1) { - longer_dims_in_full_array <- longer_dims - if (any(names(full_array_var_dims) %in% names(var_file_dims))) { - candidates <- (1:length(full_array_var_dims))[-which(names(full_array_var_dims) %in% names(var_file_dims))] - longer_dims_in_full_array <- candidates[longer_dims] - } - padding_dims <- full_array_var_dims - padding_dims[longer_dims_in_full_array] <- var_dims[longer_dims] - - array_var_dims[longer_dims] - special_types <- list('POSIXct' = as.POSIXct, 'POSIXlt' = as.POSIXlt, - 'Date' = as.Date) - if (var_to_read %in% names(common_return_vars)) { - var_class <- class(picked_common_vars[[var_to_read]]) - } else { - var_class <- class(picked_vars[[i]][[var_to_read]]) - } - if (any(var_class %in% names(special_types))) { - padding_size <- prod(padding_dims) - padding <- rep(special_types[[var_class[1]]](NA), padding_size) - dim(padding) <- padding_dims - } else { - padding <- array(dim = padding_dims) - } - if (var_to_read %in% names(common_return_vars)) { - picked_common_vars[[var_to_read]] <- .abind2( - picked_common_vars[[var_to_read]], - padding, - names(full_array_var_dims)[longer_dims_in_full_array] - ) - } else { - picked_vars[[i]][[var_to_read]] <- .abind2( - picked_vars[[i]][[var_to_read]], - padding, - names(full_array_var_dims)[longer_dims_in_full_array] - ) - } - } else { - stop("Error while reading the variable '", var_to_read, "' from ", - "the file. Found size (", paste(var_dims, collapse = ' x '), - ") is greater than expected maximum size (", - array_var_dims, ").") - } - } - } - var_store_indices <- c(as.list(current_indices[names(var_file_dims)]), lapply(var_dims, function(x) 1:x)) - var_values <- file_var_reader(NULL, file_object, NULL, var_to_read, synonims) - if (var_to_read %in% unlist(var_params)) { - if ((associated_dim_name %in% names(dim_reorder_params)) && !aiat) { - ## Is this check really needed? - if (length(dim(var_values)) > 1) { - stop("Requested a '", associated_dim_name, "_reorder' for a dimension ", - "whose coordinate variable that has more than 1 dimension. This is ", - "not supported.") - } - ordered_var_values <- dim_reorder_params[[associated_dim_name]](var_values) - attr(ordered_var_values$x, 'variables') <- attr(var_values, 'variables') - if (!all(c('x', 'ix') %in% names(ordered_var_values))) { - stop("All the dimension reorder functions must return a list with the components 'x' and 'ix'.") - } - # Save the indices to reorder back the ordered variable values. - # This will be used to define the first round indices. - unorder <- sort(ordered_var_values$ix, index.return = TRUE)$ix - if (var_to_read %in% names(common_return_vars)) { - picked_common_vars_ordered[[var_to_read]] <- do.call('[<-', - c(list(x = picked_common_vars_ordered[[var_to_read]]), - var_store_indices, - list(value = ordered_var_values$x))) - picked_common_vars_unorder_indices[[var_to_read]] <- do.call('[<-', - c(list(x = picked_common_vars_unorder_indices[[var_to_read]]), - var_store_indices, - list(value = unorder))) - } else { - picked_vars_ordered[[i]][[var_to_read]] <- do.call('[<-', - c(list(x = picked_vars_ordered[[i]][[var_to_read]]), - var_store_indices, - list(value = ordered_var_values$x))) - picked_vars_unorder_indices[[i]][[var_to_read]] <- do.call('[<-', - c(list(x = picked_vars_unorder_indices[[i]][[var_to_read]]), - var_store_indices, - list(value = unorder))) - } - } - } - if (var_to_read %in% names(common_return_vars)) { - picked_common_vars[[var_to_read]] <- do.call('[<-', - c(list(x = picked_common_vars[[var_to_read]]), - var_store_indices, - list(value = var_values))) - # Turn time zone back to UTC if this var_to_read is 'time' - if (all(class(picked_common_vars[[var_to_read]]) == c('POSIXct', 'POSIXt'))) { - attr(picked_common_vars[[var_to_read]], "tzone") <- 'UTC' - } - } else { - picked_vars[[i]][[var_to_read]] <- do.call('[<-', - c(list(x = picked_vars[[i]][[var_to_read]]), - var_store_indices, - list(value = var_values))) - # Turn time zone back to UTC if this var_to_read is 'time' - if (all(class(picked_vars[[i]][[var_to_read]]) == c('POSIXct', 'POSIXt'))) { - attr(picked_vars[[i]][[var_to_read]], "tzone") <- 'UTC' - } + list_picked_var_of_read <- generate_picked_var_of_read( + var_to_read, var_to_check, array_of_files_to_load, var_dims, + array_of_var_files = array_of_var_files[j], file_var_reader, + file_object, synonims, associated_dim_name, dim_reorder_params, + aiat, current_indices, var_params, + either_picked_vars = picked_vars[[i]][[var_to_read]], + either_picked_vars_ordered = picked_vars_ordered[[i]][[var_to_read]], + either_picked_vars_unorder_indices = picked_vars_unorder_indices[[i]][[var_to_read]] + ) + picked_vars[[i]][[var_to_read]] <- list_picked_var_of_read$either_picked_vars + picked_vars_ordered[[i]][[var_to_read]] <- + list_picked_var_of_read$either_picked_vars_ordered + picked_vars_unorder_indices[[i]][[var_to_read]] <- + list_picked_var_of_read$either_picked_vars_unorder_indices } if (var_to_read %in% names(first_found_file)) { first_found_file[var_to_read] <- TRUE @@ -2155,7 +1898,7 @@ Start <- function(..., # dim = indices/selectors, common_first_found_file[var_to_read] <- TRUE } } else { - stop("Could not find variable '", var_to_read, + stop("Could not find variable '", var_to_read, "' in the file ", array_of_var_files[j]) } } @@ -2168,21 +1911,7 @@ Start <- function(..., # dim = indices/selectors, } # Once we have the variable values, we can work out the indices # for the implicitly defined selectors. - # - # Trnasforms a vector of indices v expressed in a world of - # length N from 1 to N, into a world of length M, from - # 1 to M. Repeated adjacent indices are collapsed. - transform_indices <- function(v, n, m) { - #unique2 turns e.g. 1 1 2 2 2 3 3 1 1 1 into 1 2 3 1 - unique2 <- function(v) { - if (length(v) < 2) { - v - } else { - v[c(1, v[2:length(v)] - v[1:(length(v) - 1)]) != 0] - } - } - unique2(round(((v - 1) / (n - 1)) * (m - 1))) + 1 # this rounding may generate 0s. what then? - } + beta <- transform_extra_cells dims_to_crop <- vector('list') transformed_vars <- vector('list', length = length(dat)) @@ -2197,7 +1926,10 @@ Start <- function(..., # dim = indices/selectors, if (dataset_has_files[i]) { indices <- indices_of_first_files_with_data[[i]] if (!is.null(indices)) { - if (largest_dims_length == FALSE | is.numeric(largest_dims_length)) { #old code. use the 1st valid file to determine the dims + #////////////////////////////////////////////////// + # Find data_dims + ## old code. use the 1st valid file to determine the dims + if (!largest_dims_length | is.numeric(largest_dims_length)) { file_path <- do.call("[", c(list(array_of_files_to_load), as.list(indices_of_first_files_with_data[[i]]))) # The following 5 lines should go several lines below, but were moved # here for better performance. @@ -2211,15 +1943,7 @@ Start <- function(..., # dim = indices/selectors, synonims) # file_dim_reader returns dimension names as found in the file. # Need to translate accoridng to synonims: - names(data_dims) <- sapply(names(data_dims), - function(x) { - which_entry <- which(sapply(synonims, function(y) x %in% y)) - if (length(which_entry) > 0) { - names(synonims)[which_entry] - } else { - x - } - }) + names(data_dims) <- replace_with_synonmins(data_dims, synonims) } if (is.numeric(largest_dims_length)) { # largest_dims_length is a named vector @@ -2233,98 +1957,35 @@ Start <- function(..., # dim = indices/selectors, } } - } else { # largest_dims_length == TRUE - # Open and get all the dim from all the files - data_dims_all_files <- vector('list', length = length(selectors_total_list[[i]])) - - for (selectors_kk in 1:length(data_dims_all_files)) { - file_path <- do.call("[", c(list(array_of_files_to_load), as.list(selector_indices_save[[i]][[selectors_kk]]))) - file_to_open <- file_path - - data_dims_all_files[[selectors_kk]] <- try(file_dim_reader(file_to_open, NULL, selectors_total_list[[i]][[selectors_kk]], - lapply(dat[[i]][['selectors']][expected_inner_dims[[i]]], '[[', 1), - synonims), silent = TRUE) - - } - - # Remove the missing files (i.e., fail try above) - if (!identical(which(substr(data_dims_all_files, 1, 5) == 'Error'), integer(0))) { - tmp <- which(substr(data_dims_all_files, 1, 5) == 'Error') - data_dims_all_files <- data_dims_all_files[-tmp] - } - - # Find the longest dimensions from all the files - largest_data_dims <- rep(0, length(data_dims_all_files[[1]])) - - # The inner dim order may differ among files. Need to align them before - # find out the largest dim length. - dim_names_first_file <- names(data_dims_all_files[[1]]) - same_dim_order <-lapply(lapply(data_dims_all_files, names), - identical, dim_names_first_file) - for (to_fix in which(!unlist(same_dim_order))) { - data_dims_all_files[[to_fix]] <- data_dims_all_files[[to_fix]][match(dim_names_first_file, - names(data_dims_all_files[[to_fix]]))] - } - - for (kk in 1:length(data_dims_all_files[[1]])) { - largest_data_dims[kk] <- max(sapply(data_dims_all_files, '[', kk)) - } - names(largest_data_dims) <- names(data_dims_all_files[[1]]) + ## largest_dims_length = TRUE + } else { + data_dims <- find_largest_dims_length( + selectors_total_list[[i]], array_of_files_to_load, + selector_indices_save[[i]], dat[[i]], expected_inner_dims[[i]], + synonims, file_dim_reader) # file_dim_reader returns dimension names as found in the file. # Need to translate accoridng to synonims: - names(largest_data_dims) <- sapply(names(largest_data_dims), - function(x) { - which_entry <- which(sapply(synonims, function(y) x %in% y)) - if (length(which_entry) > 0) { - names(synonims)[which_entry] - } else { - x - } - }) + names(data_dims) <- replace_with_synonmins(data_dims, synonims) + + } # end if (largest_dims_length == TRUE) + #////////////////////////////////////////////////// - # replace data_dims with largest_data_dims - data_dims <- largest_data_dims - } # end of if (largest_dims_length == TRUE) + #/////////////////////////////////////////////////////////////////// # Transform the variables if needed and keep them apart. if (!is.null(transform) && (length(transform_vars) > 0)) { if (!all(transform_vars %in% c(names(picked_vars[[i]]), names(picked_common_vars)))) { stop("Could not find all the required variables in 'transform_vars' ", "for the dataset '", dat[[i]][['name']], "'.") } + vars_to_transform <- NULL - picked_vars_to_transform <- which(names(picked_vars[[i]]) %in% transform_vars) - if (length(picked_vars_to_transform) > 0) { - picked_vars_to_transform <- names(picked_vars[[i]])[picked_vars_to_transform] - new_vars_to_transform <- picked_vars[[i]][picked_vars_to_transform] - which_are_ordered <- which(!sapply(picked_vars_ordered[[i]][picked_vars_to_transform], is.null)) - - ##NOTE: The following 'if' replaces the original with reordering vector - if (length(which_are_ordered) > 0) { - tmp <- which(!is.na(match(names(picked_vars_ordered[[i]]), names(which_are_ordered)))) - new_vars_to_transform[which_are_ordered] <- picked_vars_ordered[[i]][tmp] - - } - vars_to_transform <- c(vars_to_transform, new_vars_to_transform) - } - - ##NOTE: Above is non-common vars, here is common vars (ie, return_vars = NULL). - picked_common_vars_to_transform <- which(names(picked_common_vars) %in% transform_vars) - if (length(picked_common_vars_to_transform) > 0) { - picked_common_vars_to_transform <- names(picked_common_vars)[picked_common_vars_to_transform] - - new_vars_to_transform <- picked_common_vars[picked_common_vars_to_transform] - which_are_ordered <- which(!sapply(picked_common_vars_ordered[picked_common_vars_to_transform], is.null)) - - if (length(which_are_ordered) > 0) { - - tmp <- which(!is.na(match(names(picked_common_vars_ordered), names(which_are_ordered)))) - new_vars_to_transform[which_are_ordered] <- picked_common_vars_ordered[tmp] - } - vars_to_transform <- c(vars_to_transform, new_vars_to_transform) - } - + # picked_vars[[i]] + vars_to_transform <- generate_vars_to_transform(vars_to_transform, picked_vars[[i]], transform_vars, picked_vars_ordered[[i]]) + # picked_common_vars + vars_to_transform <- generate_vars_to_transform(vars_to_transform, picked_common_vars, transform_vars, picked_common_vars_ordered) + # Transform the variables transformed_data <- do.call(transform, c(list(data_array = NULL, variables = vars_to_transform, @@ -2345,7 +2006,7 @@ Start <- function(..., # dim = indices/selectors, for (var_to_read in names(transformed_data$variables)) { if (var_to_read %in% unlist(var_params)) { associated_dim_name <- names(var_params)[which(unlist(var_params) == var_to_read)] - if ((associated_dim_name %in% names(dim_reorder_params)) && aiat) { + if ((associated_dim_name %in% names(dim_reorder_params))) { ## Is this check really needed? if (length(dim(transformed_data$variables[[associated_dim_name]])) > 1) { stop("Requested a '", associated_dim_name, "_reorder' for a dimension ", @@ -2358,7 +2019,8 @@ Start <- function(..., # dim = indices/selectors, stop("All the dimension reorder functions must return a list with the components 'x' and 'ix'.") } # Save the indices to reorder back the ordered variable values. - # This will be used to define the first round indices. + # This will be used to define the first round indices (if aiat) or second round + # indices (if !aiat). unorder <- sort(ordered_var_values$ix, index.return = TRUE)$ix if (var_to_read %in% names(picked_common_vars)) { transformed_common_vars_ordered[[var_to_read]] <- ordered_var_values$x @@ -2370,16 +2032,16 @@ Start <- function(..., # dim = indices/selectors, } } } - transformed_picked_vars <- which(names(picked_vars[[i]]) %in% names(transformed_data$variables)) - if (length(transformed_picked_vars) > 0) { - transformed_picked_vars <- names(picked_vars[[i]])[transformed_picked_vars] - transformed_vars[[i]][transformed_picked_vars] <- transformed_data$variables[transformed_picked_vars] + transformed_picked_vars_names <- which(names(picked_vars[[i]]) %in% names(transformed_data$variables)) + if (length(transformed_picked_vars_names) > 0) { + transformed_picked_vars_names <- names(picked_vars[[i]])[transformed_picked_vars_names] + transformed_vars[[i]][transformed_picked_vars_names] <- transformed_data$variables[transformed_picked_vars_names] } if (is.null(transformed_common_vars)) { - transformed_picked_common_vars <- which(names(picked_common_vars) %in% names(transformed_data$variables)) - if (length(transformed_picked_common_vars) > 0) { - transformed_picked_common_vars <- names(picked_common_vars)[transformed_picked_common_vars] - transformed_common_vars <- transformed_data$variables[transformed_picked_common_vars] + transformed_picked_common_vars_names <- which(names(picked_common_vars) %in% names(transformed_data$variables)) + if (length(transformed_picked_common_vars_names) > 0) { + transformed_picked_common_vars_names <- names(picked_common_vars)[transformed_picked_common_vars_names] + transformed_common_vars <- transformed_data$variables[transformed_picked_common_vars_names] } } } @@ -2495,6 +2157,7 @@ Start <- function(..., # dim = indices/selectors, print(str(transform)) } } + # For fri if (var_with_selectors_name %in% names(picked_vars[[i]])) { var_with_selectors <- picked_vars[[i]][[var_with_selectors_name]] var_ordered <- picked_vars_ordered[[i]][[var_with_selectors_name]] @@ -2505,10 +2168,13 @@ Start <- function(..., # dim = indices/selectors, var_unorder_indices <- picked_common_vars_unorder_indices[[var_with_selectors_name]] } n <- prod(dim(var_with_selectors)) + # if no _reorder, var_unorder_indices is NULL if (is.null(var_unorder_indices)) { var_unorder_indices <- 1:n } + # For sri if (with_transform) { + ## var in 'dat' if (var_with_selectors_name %in% names(transformed_vars[[i]])) { m <- prod(dim(transformed_vars[[i]][[var_with_selectors_name]])) if (aiat) { @@ -2516,6 +2182,22 @@ Start <- function(..., # dim = indices/selectors, var_ordered <- transformed_vars_ordered[[i]][[var_with_selectors_name]] var_unorder_indices <- transformed_vars_unorder_indices[[i]][[var_with_selectors_name]] } + # For making sri ordered later + transformed_var_unordered_indices <- transformed_vars_unorder_indices[[i]][[var_with_selectors_name]] + if (is.null(transformed_var_unordered_indices)) { + transformed_var_unordered_indices <- 1:m + } + transformed_var_with_selectors <- transformed_vars[[i]][transformed_picked_vars_names][[var_with_selectors_name]][transformed_var_unordered_indices] + # Sorting the transformed variable and working out the indices again after transform. + if (!is.null(dim_reorder_params[[var_with_selectors_name]])) { + transformed_var_with_selectors_reorder <- dim_reorder_params[[var_with_selectors_name]](transformed_var_with_selectors) + transformed_var_with_selectors <- transformed_var_with_selectors_reorder$x + transformed_var_with_selectors_unorder <- transformed_var_with_selectors_reorder$ix + } else { + transformed_var_with_selectors_unorder <- 1:length(transformed_var_with_selectors) + } + + ## var in common } else if (var_with_selectors_name %in% names(transformed_common_vars)) { m <- prod(dim(transformed_common_vars[[var_with_selectors_name]])) if (aiat) { @@ -2523,6 +2205,20 @@ Start <- function(..., # dim = indices/selectors, var_ordered <- transformed_common_vars_ordered[[var_with_selectors_name]] var_unorder_indices <- transformed_common_vars_unorder_indices[[var_with_selectors_name]] } + # For making sri ordered later + transformed_var_unordered_indices <- transformed_common_vars_unorder_indices[[var_with_selectors_name]] + if (is.null(transformed_var_unordered_indices)) { + transformed_var_unordered_indices <- 1:m + } + transformed_var_with_selectors <- transformed_common_vars[[var_with_selectors_name]][transformed_var_unordered_indices] + # Sorting the transformed variable and working out the indices again after transform. + if (!is.null(dim_reorder_params[[var_with_selectors_name]])) { + transformed_var_with_selectors_reorder <- dim_reorder_params[[var_with_selectors_name]](transformed_var_with_selectors) + transformed_var_with_selectors <- transformed_var_with_selectors_reorder$x + transformed_var_with_selectors_unorder <- transformed_var_with_selectors_reorder$ix + } else { + transformed_var_with_selectors_unorder <- 1:length(transformed_var_with_selectors) + } } if (is.null(var_unorder_indices)) { var_unorder_indices <- 1:m @@ -2673,7 +2369,11 @@ Start <- function(..., # dim = indices/selectors, #sri <- NULL } else { ordered_sri[] <- replicate(prod(var_file_dims), list(1:m)) - sri[] <- replicate(prod(var_file_dims), list(1:m)) + if (inner_dim %in% names(dim_reorder_params)) { + sri[] <- replicate(prod(var_file_dims), list(transformed_var_unordered_indices[1:m])) + } else { + sri[] <- replicate(prod(var_file_dims), list(1:m)) + } ## var_file_dims instead?? #if (!aiat) { #fri[] <- replicate(prod(var_file_dims), list(1:n)) @@ -2834,6 +2534,7 @@ Start <- function(..., # dim = indices/selectors, print(file_dim) } } + #???????????????? if ((!is.null(file_dim) && (file_dim %in% names(selector_file_dims))) || is.null(file_dim)) { if (length(sub_array_of_selectors) > 0) { if (debug) { @@ -2857,46 +2558,59 @@ Start <- function(..., # dim = indices/selectors, # The selector_checker will return either a vector of indices or a list # with the first and last desired indices. + #NOTE: goes_across_prime_meridian may be TRUE only if the selector is list of values goes_across_prime_meridian <- FALSE + is_circular_dim <- FALSE + # If selectors are indices and _reorder = CircularSort() is used, change + # is_circular_dim to TRUE. + if (!is.null(var_ordered) & selectors_are_indices & + !is.null(dim_reorder_params[[inner_dim]])) { + if ('circular' %in% names(attributes(dim_reorder_params[[inner_dim]]))) { + is_circular_dim <- attr(dim_reorder_params[[inner_dim]], "circular") + if (is_circular_dim & is.list(sub_array_of_selectors)) { + tmp <- dim_reorder_params[[inner_dim]](unlist(sub_array_of_selectors))$ix + goes_across_prime_meridian <- tmp[1] > tmp[2] + } + } + } + + # If selectors are values and _reorder is defined. if (!is.null(var_ordered) && !selectors_are_indices) { if (!is.null(dim_reorder_params[[inner_dim]])) { + if ('circular' %in% names(attributes(dim_reorder_params[[inner_dim]]))) { + is_circular_dim <- attr(dim_reorder_params[[inner_dim]], "circular") + } if (is.list(sub_array_of_selectors)) { - ## NOTE: The check of 'goes_across_prime_meridian' is moved forward to here. - is_circular_dim <- attr(dim_reorder_params[[inner_dim]], "circular") - if (!is.null(is_circular_dim)) { - if (is_circular_dim) { - - # NOTE: Use CircularSort() to put the values in the assigned range, and get the order. - # For example, [-10, 20] in CircularSort(0, 360) is [350, 20]. The $ix list is [2, 1]. - # 'goes_across_prime_meridian' means the selector range across the border. For example, - # CircularSort(-180, 180) with selector [170, 190] -> goes_across_prime_meridian = TRUE. - tmp <- dim_reorder_params[[inner_dim]](unlist(sub_array_of_selectors))$ix - goes_across_prime_meridian <- tmp[1] > tmp[2] - } + if (is_circular_dim) { + # NOTE: Use CircularSort() to put the values in the assigned range, and get the order. + # For example, [-10, 20] in CircularSort(0, 360) is [350, 20]. The $ix list is [2, 1]. + # 'goes_across_prime_meridian' means the selector range across the border. For example, + # CircularSort(-180, 180) with selector [170, 190] -> goes_across_prime_meridian = TRUE. + # dim_reorder_params is a list of Reorder function, i.e., + # Sort() or CircularSort(). + tmp <- dim_reorder_params[[inner_dim]](unlist(sub_array_of_selectors))$ix + goes_across_prime_meridian <- tmp[1] > tmp[2] } - # HERE change to the same code as below (under 'else'). Not sure why originally - #it uses additional lines, which make reorder not work. + #NOTE: HERE change to the same code as below (under 'else'). Not sure why originally + # it uses additional lines, which make reorder not work. + # If "_reorder" is used, here 'sub_array_of_selectors' is adjusted to + # follow the reorder rule. E.g., if lat = values(list(-90, 90)) and + # lat_reorder = Sort(decreasing = T), 'sub_array_of_selectors' changes + # from list(-90, 90) to list(90, -90). sub_array_of_selectors <- as.list(dim_reorder_params[[inner_dim]](unlist(sub_array_of_selectors))$x) #sub_array_reordered <- dim_reorder_params[[inner_dim]](unlist(sub_array_of_selectors)) #sub_array_unorder <- sort(sub_array_reordered$ix, index.return = TRUE)$ix #sub_array_of_selectors <- as.list(sub_array_reordered$x[sub_array_unorder]) # Add warning if the boundary is out of range - if (sub_array_of_selectors[1] < range(var_ordered)[1] | sub_array_of_selectors[1] > range(var_ordered)[2]) { - .warning(paste0("The lower boundary of selector of ", - inner_dim, - " is out of range [", - min(var_ordered), ", ", max(var_ordered), "]. ", - "Check if the desired range is all included.")) + if (min(unlist(sub_array_of_selectors)) < range(var_ordered)[1]) { + show_out_of_range_warning(inner_dim, range = range(var_ordered), + bound = 'lower') } - if (sub_array_of_selectors[2] < range(var_ordered)[1] | sub_array_of_selectors[2] > range(var_ordered)[2]) { - .warning(paste0("The upper boundary of selector of ", - inner_dim, - " is out of range [", - min(var_ordered), ", ", max(var_ordered), "]. ", - "Check if the desired range is all included.")) + if (max(unlist(sub_array_of_selectors)) > range(var_ordered)[2]) { + show_out_of_range_warning(inner_dim, range = range(var_ordered), bound = 'upper') } @@ -2940,27 +2654,20 @@ Start <- function(..., # dim = indices/selectors, } else { # Add warning if the boundary is out of range - if (is.list(sub_array_of_selectors)) { - if (sub_array_of_selectors[1] < - min(sub_array_of_values) | sub_array_of_selectors[1] > - max(sub_array_of_values)) { - .warning(paste0("The lower boundary of selector of ", - inner_dim, " is out of range [", - min(sub_array_of_values), ", ", - max(sub_array_of_values), "]. ", - "Check if the desired range is all included.")) + if (is.list(sub_array_of_selectors) & !selectors_are_indices) { + if (min(unlist(sub_array_of_selectors)) < min(sub_array_of_values)) { + show_out_of_range_warning(inner_dim, range = range(sub_array_of_values), + bound = 'lower') } - if (sub_array_of_selectors[2] < - min(sub_array_of_values) | sub_array_of_selectors[2] > - max(sub_array_of_values)) { - .warning(paste0("The upper boundary of selector of ", - inner_dim, " is out of range [", - min(sub_array_of_values), ", ", - max(sub_array_of_values), "]. ", - "Check if the desired range is all included.")) + if (max(unlist(sub_array_of_selectors)) > max(sub_array_of_values)) { + show_out_of_range_warning(inner_dim, range = range(sub_array_of_values), + bound = 'upper') } } + # sub_array_of_values here is NULL if selectors are indices, and + # 'sub_array_of_indices' will be sub_array_of_selectors, i.e., the indices + # assigned (but rounded). sub_array_of_indices <- selector_checker(sub_array_of_selectors, sub_array_of_values, tolerance = if (aiat) { NULL @@ -2976,28 +2683,66 @@ Start <- function(..., # dim = indices/selectors, } } - ## This 'if' runs in both Start() and Compute(). In Start(), it doesn't have any effect (no chunk). - ## In Compute(), it creates the indices for each chunk. For example, if 'sub_array_of_indices' - ## is c(5:10) and chunked into 2, 'sub_array_of_indices' becomes c(5:7) for chunk = 1, c(8:10) - ## for chunk = 2. If 'sub_array_of_indices' is list(55, 62) and chunked into 2, it becomes - ## list(55, 58) for chunk = 1 and list(59, 62) for chunk = 2. - ## TODO: The list can be turned into vector here? So afterward no need to judge if it is list - ## or vector. - if (!is.list(sub_array_of_indices)) { - sub_array_of_indices <- sub_array_of_indices[chunk_indices(length(sub_array_of_indices), - chunks[[inner_dim]]["chunk"], - chunks[[inner_dim]]["n_chunks"], - inner_dim)] - } else { - tmp <- chunk_indices(length(sub_array_of_indices[[1]]:sub_array_of_indices[[2]]), - chunks[[inner_dim]]["chunk"], chunks[[inner_dim]]["n_chunks"], - inner_dim) - vect <- sub_array_of_indices[[1]]:sub_array_of_indices[[2]] - sub_array_of_indices[[1]] <- vect[tmp[1]] - sub_array_of_indices[[2]] <- vect[tmp[length(tmp)]] - } + # If chunking along this inner dim, this part creates the indices for each chunk. + + # For example, if 'sub_array_of_indices' is c(5:10) and chunked into 2, + # 'sub_array_of_indices' becomes c(5:7) for chunk = 1, c(8:10) for chunk = 2. + # If 'sub_array_of_indices' is list(55, 62) and chunked into 2, it becomes + # list(55, 58) for chunk = 1 and list(59, 62) for chunk = 2. + #TODO: The list can be turned into vector here? So afterward no need to judge if + # it is list or vector. + #NOTE: chunking cannot be done if goes_across_prime_meridian = TRUE. + #TODO: Change the algorithm to make chunking works for goes_across_prime_meridian = TRUE. + # If goes_across_prime_meridian = TRUE, "sub_array_of_indices" are not + # continuous numbers. For example, list(37, 1243) means sub_array_of_fri + # that will be generated based on sub_array_of_indices later is c(1:37, 1243:1296). + # the longitude are separated into 2 parts, therefore, cannot be chunked here. + if (chunks[[inner_dim]]["n_chunks"] > 1) { + if (goes_across_prime_meridian) { + stop(paste0("Chunking over ", inner_dim, " that goes across the circular border assigned by '", inner_dim, "_reorder' is not supported by startR now. Adjust the ", inner_dim, " selector to be within the border or change the borders." )) + } + if (!is.list(sub_array_of_indices)) { + sub_array_of_indices <- + sub_array_of_indices[chunk_indices(length(sub_array_of_indices), + chunks[[inner_dim]]["chunk"], + chunks[[inner_dim]]["n_chunks"], + inner_dim)] + } else { + tmp <- + chunk_indices(length(sub_array_of_indices[[1]]:sub_array_of_indices[[2]]), + chunks[[inner_dim]]["chunk"], chunks[[inner_dim]]["n_chunks"], + inner_dim) + vect <- sub_array_of_indices[[1]]:sub_array_of_indices[[2]] + sub_array_of_indices[[1]] <- vect[tmp[1]] + sub_array_of_indices[[2]] <- vect[tmp[length(tmp)]] + } + } # The sub_array_of_indices now contains numeric indices of the values to be taken by each chunk. - + + #---------------------------------------------------------- + # 'sub_sub_array_of_values' is for sri chunking. If this inner dim is chunked, + # the sri has to follow the chunking of fri. Therefore, we save the original + # value of this chunk here for later use. We'll find the corresponding + # transformed value within 'sub_sub_array_of_values' and chunk sri. + if (with_transform & chunks[[inner_dim]]["n_chunks"] > 1) { + if (!is.null(var_ordered)) { #var_ordered + input_array_of_values <- var_ordered + } else { + if (is.null(sub_array_of_values)) { # selectors are indices + #NOTE: Not sure if 'vars_to_transform' is the correct one to use. + input_array_of_values <- vars_to_transform[[var_with_selectors_name]] + } else { + input_array_of_values <- sub_array_of_values + } + } + tmp <- generate_sub_sub_array_of_values( + input_array_of_values, sub_array_of_indices, + number_of_chunk = chunks[[inner_dim]]["chunk"]) + sub_sub_array_of_values <- tmp$sub_sub_array_of_values + previous_sub_sub_array_of_values <- tmp$previous_sub_sub_array_of_values + } + #---------------------------------------------------------- + if (debug) { if (inner_dim %in% dims_to_check) { print("-> TRANSFORMATION REQUESTED?") @@ -3017,84 +2762,22 @@ Start <- function(..., # dim = indices/selectors, print("-> SELECTORS REQUESTED BEFORE TRANSFORM.") } } - - ###NOTE: Here, the transform, is different from the below part of non-transform. - # search 'if (goes_across_prime_meridian' to find the lines below. - if (goes_across_prime_meridian) { - # NOTE: before changing, the return is already correct. - - #NOTE: The fix below has the same explanation as no with_transform part below. - # Search the next next 'if (goes_across_prime_meridian) {'. - if (sub_array_of_indices[[1]] == sub_array_of_indices[[2]]) { - # global longitude - sub_array_of_fri <- 1:n - # Warning if transform_extra_cell != 0 - if (beta != 0) { - .warning(paste0("Adding parameter transform_extra_cells = ", - transform_extra_cells, " to the transformed index excesses ", - "the border. The border index is used for transformation.")) - } - - } else { - # normal case, i.e., not global - first_index <- min(unlist(sub_array_of_indices)) - last_index <- max(unlist(sub_array_of_indices)) - gap_width <- last_index - first_index - 1 - sub_array_of_fri <- c(1:(min(unlist(sub_array_of_indices)) + min(gap_width, beta)), - (max(unlist(sub_array_of_indices)) - min(gap_width, beta)):n) - - if (min(gap_width, beta) != beta) { - .warning(paste0("Adding parameter transform_extra_cells = ", - transform_extra_cells, " to the transformed index excesses ", - "the border. The border index is used for transformation.")) - } - } - - } else { - #NOTE: This if seems redundant. - if (is.list(sub_array_of_indices)) { - sub_array_of_indices <- sub_array_of_indices[[1]]:sub_array_of_indices[[2]] - } - first_index <- min(unlist(sub_array_of_indices)) - last_index <- max(unlist(sub_array_of_indices)) - - start_padding <- min(beta, first_index - 1) - end_padding <- min(beta, n - last_index) - - if (exists("is_circular_dim")) { - if (!is_circular_dim) { #latitude - sub_array_of_fri <- (first_index - start_padding):(last_index + end_padding) - if (start_padding != beta | end_padding != beta) { - .warning(paste0("Adding parameter transform_extra_cells = ", - transform_extra_cells, " to the transformed index excesses ", - "the border. The border index is used for transformation.")) - } - } else { #longitude - if ((last_index - first_index + 1 + beta * 2) >= n) { - sub_array_of_fri <- 1:n - } else if (start_padding < beta) { # left side too close to border, need to go to right side - sub_array_of_fri <- c((first_index - start_padding):(last_index + end_padding), (n - (beta - start_padding - 1)):n) - } else if (end_padding < beta) { # right side too close to border, need to go to left side - sub_array_of_fri <- c(1: (beta - end_padding), (first_index - start_padding):(last_index + end_padding)) - } else { #normal - sub_array_of_fri <- (first_index - start_padding):(last_index + end_padding) - } - } - } else { # when _reorder is not used - sub_array_of_fri <- (first_index - start_padding):(last_index + end_padding) - if (start_padding != beta | end_padding != beta) { - .warning(paste0("Adding parameter transform_extra_cells = ", - transform_extra_cells, " to the transformed index excesses ", - "the border. The border index is used for transformation.")) - } - } - - } + # Generate sub_array_of_fri + sub_array_of_fri <- generate_sub_array_of_fri( + with_transform, goes_across_prime_meridian, sub_array_of_indices, n, beta, + is_circular_dim) + + # May be useful for crop = T. 'subset_vars_to_transform' may not need + # to include extra cells, but currently it shows mistake if not include. + sub_array_of_fri_no_beta <- generate_sub_array_of_fri( + with_transform, goes_across_prime_meridian, sub_array_of_indices, n, beta, + is_circular_dim, add_beta = FALSE) + subset_vars_to_transform <- vars_to_transform if (!is.null(var_ordered)) { - ##NOTE: if var_ordered is common_vars, it doesn't have attributes and it is a vector. - ## Turn it into array and add dimension name. + #NOTE: If var_ordered is common_vars, it doesn't have attributes and it is a vector. + # Turn it into array and add dimension name. if (!is.array(var_ordered)) { var_ordered <- as.array(var_ordered) names(dim(var_ordered)) <- inner_dim @@ -3102,16 +2785,23 @@ Start <- function(..., # dim = indices/selectors, subset_vars_to_transform[[var_with_selectors_name]] <- Subset(var_ordered, inner_dim, sub_array_of_fri) } else { - ##NOTE: It should be redundant because without reordering the var should remain array + if (!selectors_are_indices) { # selectors are values + #NOTE: It should be redundant because without reordering the var should remain array ## But just stay same with above... if (!is.array(sub_array_of_values)) { sub_array_of_values <- as.array(sub_array_of_values) names(dim(sub_array_of_values)) <- inner_dim } - + subset_vars_to_transform[[var_with_selectors_name]] <- Subset(sub_array_of_values, inner_dim, sub_array_of_fri) + + } else { # selectors are indices + subset_vars_to_transform[[var_with_selectors_name]] <- + Subset(subset_vars_to_transform[[var_with_selectors_name]], + inner_dim, sub_array_of_fri) + } } - + # Change the order of longitude crop if no reorder + from big to small. # cdo -sellonlatbox, the lon is west, east (while lat can be north # to south or opposite) @@ -3149,12 +2839,36 @@ Start <- function(..., # dim = indices/selectors, } else { transformed_subset_var_unorder <- 1:length(transformed_subset_var) } - sub_array_of_sri <- selector_checker(sub_array_of_selectors, transformed_subset_var, - tolerance = if (aiat) { - tolerance_params[[inner_dim]] - } else { - NULL - }) + if (!selectors_are_indices) { # selectors are values + sub_array_of_sri <- selector_checker( + sub_array_of_selectors, transformed_subset_var, + tolerance = if (aiat) { + tolerance_params[[inner_dim]] + } else { + NULL + }) + if (!is.list(sub_array_of_sri)) { + sub_array_of_sri <- unique(sub_array_of_sri) + } + } else { # selectors are indices + # Need to transfer to values first, then use the values to get the new + # indices in transformed_subset_var. + if (is.list(sub_array_of_selectors)) { + ori_values <- vars_to_transform[[var_with_selectors_name]][sub_array_of_selectors[[1]]:sub_array_of_selectors[[2]]] + } else { + ori_values <- vars_to_transform[[var_with_selectors_name]][sub_array_of_selectors] + } + sub_array_of_sri <- selector_checker( + ori_values, transformed_subset_var, + tolerance = if (aiat) { + tolerance_params[[inner_dim]] + } else { + NULL + }) + # Here may need to further modify considering aiat. If aiat = FALSE, + # (i.e., indices are taken before transform), unique() is needed. + sub_array_of_sri <- unique(sub_array_of_sri) + } # Check if selectors fall out of the range of the transform grid # It may happen when original lon is [-180, 180] while want to regrid to @@ -3174,25 +2888,99 @@ Start <- function(..., # dim = indices/selectors, sub_array_of_sri <- c(1:length(transformed_subset_var)) } else { # the common case, i.e., non-global - # NOTE: Because sub_array_of_sri order is exchanged due to - # previous development, here [[1]] and [[2]] should exchange - sub_array_of_sri <- c(1:sub_array_of_sri[[1]], - sub_array_of_sri[[2]]:length(transformed_subset_var)) +# # NOTE: Because sub_array_of_sri order is exchanged due to +# # previous development, here [[1]] and [[2]] should exchange +# sub_array_of_sri <- c(1:sub_array_of_sri[[1]], +# sub_array_of_sri[[2]]:length(transformed_subset_var)) + #NOTE: the old code above is not suitable for all the possible cases. + # If sub_array_of_selectors is not exactly the value in transformed_subset_var, sub_array_of_sri[[1]] will be larger than sub_array_of_sri[[2]]. + # Though here is not global case, we already have transformed_subset_var cropped as the desired region, so it is okay to use the whole length. Not sure if it will cause other problems... + sub_array_of_sri <- 1:length(transformed_subset_var) } } else if (is.list(sub_array_of_sri)) { sub_array_of_sri <- sub_array_of_sri[[1]]:sub_array_of_sri[[2]] } + + # Chunk sub_array_of_sri if this inner_dim needs to be chunked + #TODO: Potential problem: the transformed_subset_var value falls between + # the end of sub_sub_array_of_values of the 1st chunk and the beginning + # of sub_sub_array_of_values of the 2nd chunk. Then, one sub_array_of_sri + # will miss. 'previous_sri' is checked and will be included if this + # situation happens, but don't know if the transformed result is + # correct or not. + if (chunks[[inner_dim]]["n_chunks"] > 1) { + if (is.list(sub_sub_array_of_values)) { # list + sub_array_of_sri <- + which(transformed_subset_var >= min(unlist(sub_sub_array_of_values)) & + transformed_subset_var <= max(unlist(sub_sub_array_of_values))) + # Check if sub_array_of_sri perfectly connects to the previous sri. + # If not, inlclude the previous sri. + #NOTE 1: don't know if the transform for the previous sri is + # correct or not. + #NOTE 2: If crop = T, sub_array_of_sri always starts from 1. + # Don't know if the cropping will miss some sri or not. + if (sub_array_of_sri[1] != 1) { + if (!is.null(previous_sub_sub_array_of_values)) { + previous_sri <- max(which(transformed_subset_var <= previous_sub_sub_array_of_values)) + if (previous_sri + 1 != sub_array_of_sri[1]) { + sub_array_of_sri <- (previous_sri + 1):sub_array_of_sri[length(sub_array_of_sri)] + } + } + } + + } else { # is vector + tmp <- which(transformed_subset_var >= min(sub_sub_array_of_values) & + transformed_subset_var <= max(sub_sub_array_of_values)) + # Include first or last sri if tmp doesn't have. It's only for + # ""vectors"" because vectors look for the closest value. + #NOTE: The condition here is not correct. The criteria should be + # 'vector' instead of indices. + if (chunks[[inner_dim]]["chunk"] == 1) { + sub_array_of_sri <- unique(c(sub_array_of_sri[1], tmp)) + } else if (chunks[[inner_dim]]["chunk"] == + chunks[[inner_dim]]["n_chunks"]) { # last chunk + sub_array_of_sri <- unique(c(tmp, sub_array_of_sri[length(sub_array_of_sri)])) + } else { + sub_array_of_sri <- tmp + } + # Check if sub_array_of_sri perfectly connects to the previous sri. + # If not, inlclude the previous sri. + #NOTE 1: don't know if the transform for the previous sri is + # correct or not. + #NOTE 2: If crop = T, sub_array_of_sri always starts from 1. + # Don't know if the cropping will miss some sri or not. + if (sub_array_of_sri[1] != 1) { + if (!is.null(previous_sub_sub_array_of_values)) { + previous_sri <- max(which(transformed_subset_var <= previous_sub_sub_array_of_values)) + if (previous_sri + 1 != sub_array_of_sri[1]) { + sub_array_of_sri <- (previous_sri + 1):sub_array_of_sri[length(sub_array_of_sri)] + } + } + } + } + } ordered_sri <- sub_array_of_sri sub_array_of_sri <- transformed_subset_var_unorder[sub_array_of_sri] + +###########################old################################## +# if (chunks[[inner_dim]]["n_chunks"] > 1) { +# tmp <- which(transformed_subset_var >= min(sub_sub_array_of_values) & +# transformed_subset_var <= max(sub_sub_array_of_values)) +# sub_array_of_sri <- sub_array_of_sri[tmp] +# } +################################################################ + # In this case, the tvi are not defined and the 'transformed_subset_var' # will be taken instead of the var transformed before in the code. if (debug) { if (inner_dim %in% dims_to_check) { print("-> FIRST INDEX:") - print(first_index) +# print(first_index) + print("NOTE: Check function generate_sub_array_of_fri() in zzz.R") print("-> LAST INDEX:") - print(last_index) +# print(last_index) + print("NOTE: Check function generate_sub_array_of_fri() in zzz.R") print("-> STRUCTURE OF FIRST ROUND INDICES:") print(str(sub_array_of_fri)) print("-> STRUCTURE OF SECOND ROUND INDICES:") @@ -3232,31 +3020,15 @@ Start <- function(..., # dim = indices/selectors, ### sub_array_of_sri <- sub_array_of_sri + n_of_extra_cells sri <- do.call('[[<-', c(list(x = sri), as.list(selector_store_position), list(value = sub_array_of_sri))) - } else { - if (goes_across_prime_meridian) { - #NOTE: The potential problem here is, if it is global longitude, - # and the indices overlap (e.g., lon = [0, 359.723] and - # CircularSort(-180, 180), then sub_array_of_indices = list(649, 649)). - # Therefore, sub_array_of_fri will be c(1:649, 649:1296). We'll - # get two 649. - # The fix below may not be the best solution, but it works for - # the example above. - - if (sub_array_of_indices[[1]] == sub_array_of_indices[[2]]) { - # global longitude - sub_array_of_fri <- c(1:n) - } else { - # the common case, i.e., non-global - sub_array_of_fri <- c(1:min(unlist(sub_array_of_indices)), - max(unlist(sub_array_of_indices)):n) - } - - } else if (is.list(sub_array_of_indices)) { - sub_array_of_fri <- sub_array_of_indices[[1]]:sub_array_of_indices[[2]] - } else { - sub_array_of_fri <- sub_array_of_indices - } + + } else { # !with_transform + sub_array_of_fri <- generate_sub_array_of_fri( + with_transform, goes_across_prime_meridian, sub_array_of_indices, n, beta, + is_circular_dim) } + + # Reorder sub_array_of_fri if reordering function is used. + # It was index in the assigned order (e.g., in [-180, 180] if CircularSort(-180, 180)), and here is changed to the index in the original order. if (!is.null(var_unorder_indices)) { if (is.null(ordered_fri)) { ordered_fri <- sub_array_of_fri @@ -3271,7 +3043,7 @@ Start <- function(..., # dim = indices/selectors, taken_chunks <- TRUE } } - } else { + } else { #???????????? if (debug) { if (inner_dim %in% dims_to_check) { print("-> THE INNER DIMENSION GOES ACROSS A FILE DIMENSION.") @@ -3478,6 +3250,8 @@ Start <- function(..., # dim = indices/selectors, vars_to_crop <- picked_vars_ordered[[i]] common_vars_to_crop <- picked_common_vars_ordered } else { + #TODO: If fri has different indices in each list, the crop_indices should be + # separated for each list. Otherwise, picked_common_vars later will be wrong. crop_indices <- unique(unlist(fri)) vars_to_crop <- picked_vars[[i]] common_vars_to_crop <- picked_common_vars @@ -3487,7 +3261,13 @@ Start <- function(..., # dim = indices/selectors, if (!is.null(crop_indices)) { if (type_of_var_to_crop == 'transformed') { if (!aiat) { - vars_to_crop[[var_to_crop]] <- Subset(transformed_subset_var, inner_dim, crop_indices) + if (!(length(selector_array) == 1 & + selector_array %in% c('all', 'first', 'last'))) { + vars_to_crop[[var_to_crop]] <- Subset(transformed_subset_var, inner_dim, crop_indices) + } else { + vars_to_crop[[var_to_crop]] <- + Subset(transformed_var_with_selectors, inner_dim, crop_indices) + } } else { vars_to_crop[[var_to_crop]] <- Subset(vars_to_crop[[var_to_crop]], inner_dim, crop_indices) } @@ -3502,7 +3282,14 @@ Start <- function(..., # dim = indices/selectors, if (inner_dim %in% names(dim(common_vars_to_crop[[common_var_to_crop]]))) { if (type_of_var_to_crop == 'transformed' & !aiat) { - common_vars_to_crop[[common_var_to_crop]] <- Subset(transformed_subset_var, inner_dim, crop_indices) + if (!(length(selector_array) == 1 & + selector_array %in% c('all', 'first', 'last'))) { + common_vars_to_crop[[common_var_to_crop]] <- + Subset(transformed_subset_var, inner_dim, crop_indices) + } else { + common_vars_to_crop[[common_var_to_crop]] <- + Subset(transformed_var_with_selectors, inner_dim, crop_indices) + } } else { #old code common_vars_to_crop[[common_var_to_crop]] <- Subset(common_vars_to_crop[[common_var_to_crop]], inner_dim, crop_indices) } @@ -3636,95 +3423,37 @@ Start <- function(..., # dim = indices/selectors, # final_dims will be used for collocation of data, whereas final_dims_fake # will be used for shaping the final array to be returned to the user. final_dims_fake <- final_dims - if (merge_across_dims) { - if (!is.null(inner_dims_across_files)) { - for (file_dim_across in names(inner_dims_across_files)) { - inner_dim_pos <- which(names(final_dims_fake) == inner_dims_across_files[[file_dim_across]]) - new_dims <- c() - if (inner_dim_pos > 1) { - new_dims <- c(new_dims, final_dims_fake[1:(inner_dim_pos - 1)]) - } - new_dims <- c(new_dims, setNames(prod(final_dims_fake[c(inner_dim_pos, inner_dim_pos + 1)]), - inner_dims_across_files[[file_dim_across]])) - if (inner_dim_pos + 1 < length(final_dims_fake)) { - new_dims <- c(new_dims, final_dims_fake[(inner_dim_pos + 2):length(final_dims_fake)]) - } - final_dims_fake <- new_dims - } - } + final_dims_fake <- dims_merge(inner_dims_across_files, final_dims_fake) } #========================================================================= # Find the dimension to split if split_multiselected_dims = TRUE. # If there is no dimension able to be split, change split_multiselected_dims to FALSE. all_split_dims <- NULL if (split_multiselected_dims) { - for (dim_param in 1:length(dim_params)) { - if (!is.null(dim(dim_params[[dim_param]]))) { - if (length(dim(dim_params[[dim_param]])) > 1) { - split_dims <- dim(dim_params[[dim_param]]) - all_split_dims <- c(all_split_dims, setNames(list(split_dims), - names(dim_params)[dim_param])) - if (is.null(names(split_dims))) { - names(split_dims) <- paste0(names(dim_params)[dim_param], - 1:length(split_dims)) - } - old_dim_pos <- which(names(final_dims_fake) == names(dim_params)[dim_param]) + tmp <- dims_split(dim_params, final_dims_fake) + final_dims_fake <- tmp[[1]] + # all_split_dims is a list containing all the split dims + all_split_dims <- tmp[[2]] - # If merge_across_dims and split_multiselected_dims are both used, - # on one file dim, and this file dim is multi-dim, it doesn't work. - if (identical(old_dim_pos, integer(0))) { - stop(paste0("The dimension '", names(dim_params)[dim_param], - "' to be split cannot be found after 'merge_across_dims' ", - "is used. Check if the reshape parameters are used appropriately.")) - } - - # NOTE: Three steps to create new dims. - # 1st: Put in the dims before split_dim. - # 2nd: Replace the old_dim with split_dims. - # 3rd: Put in the dims after split_dim. - new_dims <- c() - if (old_dim_pos > 1) { - new_dims <- c(new_dims, final_dims_fake[1:(old_dim_pos - 1)]) - } - new_dims <- c(new_dims, split_dims) - if (old_dim_pos < length(final_dims_fake)) { - new_dims <- c(new_dims, final_dims_fake[(old_dim_pos + 1):length(final_dims_fake)]) - } - final_dims_fake <- new_dims - } - } - } - if (is.null(all_split_dims)) { - split_multiselected_dims <- FALSE - .warning(paste0("Not found any dimensions able to be split. The parameter ", - "'split_multiselected_dims' is changed to FALSE.")) - } + if (is.null(all_split_dims)) { + split_multiselected_dims <- FALSE + .warning(paste0("Not found any dimensions able to be split. The parameter ", + "'split_multiselected_dims' is changed to FALSE.")) + } } #====================================================================== + # If only merge_across_dims and merge_across_dims_narm and no split_multiselected_dims, + # the length of inner across dim (e.g., time) needs to be adjusted. Sum up the actual length + # without potential NAs. if (merge_across_dims) { - # only merge_across_dims -> the 'time' dim length needs to be adjusted + # Prepare the arguments for later use across_inner_dim <- inner_dims_across_files[[1]] #TODO: more than one? # Get the length of each inner_dim ('time') along each file_dim ('file_date') length_inner_across_dim <- lapply(dat[[i]][['selectors']][[across_inner_dim]][['fri']], length) - if (merge_across_dims_narm) { - across_file_dim <- names(inner_dims_across_files) #TODO: more than one? - - if (!split_multiselected_dims) { - final_dims_fake_name <- names(final_dims_fake) - pos_across_inner_dim <- which(final_dims_fake_name == across_inner_dim) - new_length_inner_dim <- sum(unlist(length_inner_across_dim)) - if (pos_across_inner_dim != length(final_dims_fake)) { - final_dims_fake <- c(final_dims_fake[1:(pos_across_inner_dim - 1)], - new_length_inner_dim, - final_dims_fake[(pos_across_inner_dim + 1):length(final_dims_fake)]) - } else { - final_dims_fake <- c(final_dims_fake[1:(pos_across_inner_dim - 1)], - new_length_inner_dim) - } - names(final_dims_fake) <- final_dims_fake_name - } + if (merge_across_dims_narm & !split_multiselected_dims) { + final_dims_fake <- merge_narm_dims(final_dims_fake, across_inner_dim, length_inner_across_dim) } } @@ -3752,7 +3481,7 @@ Start <- function(..., # dim = indices/selectors, # NOTE: If split_multiselected_dims + merge_across_dims, the dim order may need to be changed. # The inner_dim needs to be the first dim among split dims. - # Cannot control the rest dims are in the same order or not... + # TODO: Cannot control the rest dims are in the same order or not... # Suppose users put the same order of across inner and file dims. if (split_multiselected_dims & merge_across_dims) { # TODO: More than one split? @@ -3760,24 +3489,15 @@ Start <- function(..., # dim = indices/selectors, # if inner_dim is not the first, change! if (inner_dim_pos_in_split_dims != 1) { - split_dims <- c(split_dims[inner_dim_pos_in_split_dims], - split_dims[1:length(split_dims)][-inner_dim_pos_in_split_dims]) - split_dims_pos <- which(!is.na(match(names(final_dims_fake), names(split_dims)))) - # Save the current final_dims_fake for later reorder back + # Save the current final_dims_fake for reordering it back later final_dims_fake_output <- final_dims_fake - new_dims <- c() - if (split_dims_pos[1] != 1) { - new_dims <- c(new_dims, final_dims_fake[1:(split_dims_pos[1] - 1)]) - } - new_dims <- c(new_dims, split_dims) - if (split_dims_pos[length(split_dims_pos)] < length(final_dims_fake)) { - new_dims <- c(new_dims, final_dims_fake[(split_dims_pos[length(split_dims_pos)] + 1):length(final_dims_fake)]) - } - final_dims_fake <- new_dims + tmp <- reorder_split_dims(all_split_dims[[1]], inner_dim_pos_in_split_dims, final_dims_fake) + final_dims_fake <- tmp[[1]] + all_split_dims[[1]] <- tmp[[2]] } } - # The following several lines will only be run if retrieve = TRUE + # The following several lines will only run if retrieve = TRUE if (retrieve) { ########## CREATING THE SHARED MATRIX AND DISPATCHING WORK PIECES ########### @@ -3826,124 +3546,23 @@ Start <- function(..., # dim = indices/selectors, work_pieces <- list() for (i in 1:length(dat)) { if (dataset_has_files[i]) { - selectors <- dat[[i]][['selectors']] - file_dims <- found_file_dims[[i]] - inner_dims <- expected_inner_dims[[i]] - sub_array_dims <- final_dims[file_dims] - sub_array_dims[found_pattern_dim] <- 1 - sub_array_of_files_to_load <- array(1:prod(sub_array_dims), - dim = sub_array_dims) - names(dim(sub_array_of_files_to_load)) <- names(sub_array_dims) - # Detect which of the dimensions of the dataset go across files. - file_dim_across_files <- lapply(inner_dims, - function(x) { - dim_across <- sapply(inner_dims_across_files, function(y) x %in% y) - if (any(dim_across)) { - names(inner_dims_across_files)[which(dim_across)[1]] - } else { - NULL - } - }) - names(file_dim_across_files) <- inner_dims - j <- 1 - while (j <= prod(sub_array_dims)) { - # Work out file path. - file_to_load_sub_indices <- which(sub_array_of_files_to_load == j, arr.ind = TRUE)[1, ] - names(file_to_load_sub_indices) <- names(sub_array_dims) - file_to_load_sub_indices[found_pattern_dim] <- i - big_dims <- rep(1, length(dim(array_of_files_to_load))) - names(big_dims) <- names(dim(array_of_files_to_load)) - file_to_load_indices <- .MergeArrayDims(file_to_load_sub_indices, big_dims)[[1]] - file_to_load <- do.call('[[', c(list(array_of_files_to_load), - as.list(file_to_load_indices))) - not_found_file <- do.call('[[', c(list(array_of_not_found_files), - as.list(file_to_load_indices))) - load_file_metadata <- do.call('[', c(list(array_of_metadata_flags), - as.list(file_to_load_indices))) - if (load_file_metadata) { - metadata_file_counter <- metadata_file_counter + 1 - } - if (!is.na(file_to_load) && !not_found_file) { - # Work out indices to take - first_round_indices <- lapply(inner_dims, - function (x) { - if (is.null(file_dim_across_files[[x]])) { - selectors[[x]][['fri']][[1]] - } else { - which_chunk <- file_to_load_sub_indices[file_dim_across_files[[x]]] - selectors[[x]][['fri']][[which_chunk]] - } - }) - names(first_round_indices) <- inner_dims - second_round_indices <- lapply(inner_dims, - function (x) { - if (is.null(file_dim_across_files[[x]])) { - selectors[[x]][['sri']][[1]] - } else { - which_chunk <- file_to_load_sub_indices[file_dim_across_files[[x]]] - selectors[[x]][['sri']][[which_chunk]] - } - }) - if (debug) { - print("-> BUILDING A WORK PIECE") - #print(str(selectors)) - } - names(second_round_indices) <- inner_dims - if (!any(sapply(first_round_indices, length) == 0)) { - work_piece <- list() - work_piece[['first_round_indices']] <- first_round_indices - work_piece[['second_round_indices']] <- second_round_indices - work_piece[['file_indices_in_array_of_files']] <- file_to_load_indices - work_piece[['file_path']] <- file_to_load - work_piece[['store_dims']] <- final_dims - # Work out store position - store_position <- final_dims - store_position[names(file_to_load_indices)] <- file_to_load_indices - store_position[inner_dims] <- rep(1, length(inner_dims)) - work_piece[['store_position']] <- store_position - # Work out file selectors - file_selectors <- sapply(file_dims, - function (x) { - vector_to_pick <- 1 - if (x %in% names(depending_file_dims)) { - vector_to_pick <- file_to_load_indices[depending_file_dims[[x]]] - } - selectors[file_dims][[x]][[vector_to_pick]][file_to_load_indices[x]] - }) - names(file_selectors) <- file_dims - work_piece[['file_selectors']] <- file_selectors - # Send variables for transformation - if (!is.null(transform) && (length(transform_vars) > 0)) { - vars_to_transform <- NULL - picked_vars_to_transform <- which(names(picked_vars[[i]]) %in% transform_vars) - if (length(picked_vars_to_transform) > 0) { - picked_vars_to_transform <- names(picked_vars[[i]])[picked_vars_to_transform] - vars_to_transform <- c(vars_to_transform, picked_vars[[i]][picked_vars_to_transform]) - if (any(picked_vars_to_transform %in% names(picked_vars_ordered[[i]]))) { - picked_vars_ordered_to_transform <- picked_vars_to_transform[which(picked_vars_to_transform %in% names(picked_vars_ordered[[i]]))] - vars_to_transform[picked_vars_ordered_to_transform] <- picked_vars_ordered[[i]][picked_vars_ordered_to_transform] - } - } - picked_common_vars_to_transform <- which(names(picked_common_vars) %in% transform_vars) - if (length(picked_common_vars_to_transform) > 0) { - picked_common_vars_to_transform <- names(picked_common_vars)[picked_common_vars_to_transform] - vars_to_transform <- c(vars_to_transform, picked_common_vars[picked_common_vars_to_transform]) - if (any(picked_common_vars_to_transform %in% names(picked_common_vars_ordered))) { - picked_common_vars_ordered_to_transform <- picked_common_vars_to_transform[which(picked_common_vars_to_transform %in% names(picked_common_vars_ordered))] - vars_to_transform[picked_common_vars_ordered_to_transform] <- picked_common_vars_ordered[picked_common_vars_ordered_to_transform] - } - } - work_piece[['vars_to_transform']] <- vars_to_transform - } - # Send flag to load metadata - if (load_file_metadata) { - work_piece[['save_metadata_in']] <- paste0(metadata_folder, '/', metadata_file_counter) - } - work_pieces <- c(work_pieces, list(work_piece)) - } - } - j <- j + 1 - } + # metadata_file_counter may be changed by the following function + work_pieces <- build_work_pieces( + work_pieces = work_pieces, i = i, selectors = dat[[i]][['selectors']], + file_dims = found_file_dims[[i]], + inner_dims = expected_inner_dims[[i]], final_dims = final_dims, + found_pattern_dim = found_pattern_dim, + inner_dims_across_files = inner_dims_across_files, + array_of_files_to_load = array_of_files_to_load, + array_of_not_found_files = array_of_not_found_files, + array_of_metadata_flags = array_of_metadata_flags, + metadata_file_counter = metadata_file_counter, + depending_file_dims = depending_file_dims, transform = transform, + transform_vars = transform_vars, picked_vars = picked_vars[[i]], + picked_vars_ordered = picked_vars_ordered[[i]], + picked_common_vars = picked_common_vars, + picked_common_vars_ordered = picked_common_vars_ordered, + metadata_folder = metadata_folder, debug = debug) } } #print("N") @@ -3953,68 +3572,10 @@ Start <- function(..., # dim = indices/selectors, # Calculate the progress %s that will be displayed and assign them to # the appropriate work pieces. - if (length(work_pieces) / num_procs >= 2 && !silent) { - if (length(work_pieces) / num_procs < 10) { - amount <- 100 / ceiling(length(work_pieces) / num_procs) - reps <- ceiling(length(work_pieces) / num_procs) - } else { - amount <- 10 - reps <- 10 - } - progress_steps <- rep(amount, reps) - if (length(work_pieces) < (reps + 1)) { - selected_pieces <- length(work_pieces) - progress_steps <- c(sum(head(progress_steps, reps)), - tail(progress_steps, reps)) - } else { - selected_pieces <- round(seq(1, length(work_pieces), - length.out = reps + 1))[-1] - } - progress_steps <- paste0(' + ', round(progress_steps, 2), '%') - progress_message <- 'Progress: 0%' - } else { - progress_message <- '' - selected_pieces <- NULL - } - piece_counter <- 1 - step_counter <- 1 - work_pieces <- lapply(work_pieces, - function (x) { - if (piece_counter %in% selected_pieces) { - wp <- c(x, list(progress_amount = progress_steps[step_counter])) - step_counter <<- step_counter + 1 - } else { - wp <- x - } - piece_counter <<- piece_counter + 1 - wp - }) - if (!silent) { - .message("If the size of the requested data is close to or above the free shared RAM memory, R may crash.") - .message("If the size of the requested data is close to or above the half of the free RAM memory, R may crash.") - .message(paste0("Will now proceed to read and process ", length(work_pieces), " data files:")) - if (length(work_pieces) < 30) { - lapply(work_pieces, function (x) .message(x[['file_path']], indent = 2)) - } else { - .message("The list of files is long. You can check it after Start() finishes in the output '$Files'.", indent = 2, exdent = 5) - } - } - - # Build the cluster of processes that will do the work and dispatch work pieces. - # The function .LoadDataFile is applied to each work piece. This function will - # open the data file, regrid if needed, subset, apply the mask, - # compute and apply the weights if needed, - # disable extreme values and store in the shared memory matrix. - #print("O") - if (!silent) { - .message("Loading... This may take several minutes...") - if (progress_message != '') { - .message(progress_message, appendLF = FALSE) - } - } + work_pieces <- retrieve_progress_message(work_pieces, num_procs, silent) -# NOTE: In .LoadDataFile(), metadata is saved in metadata_folder/1 or /2 etc. Before here, -# the path name is created in work_pieces but the path hasn't been built yet. + # NOTE: In .LoadDataFile(), metadata is saved in metadata_folder/1 or /2 etc. Before here, + # the path name is created in work_pieces but the path hasn't been built yet. if (num_procs == 1) { found_files <- lapply(work_pieces, .LoadDataFile, shared_matrix_pointer = shared_matrix_pointer, @@ -4039,7 +3600,8 @@ Start <- function(..., # dim = indices/selectors, } if (!silent) { - if (progress_message != '') { + # if (progress_message != '') + if (length(work_pieces) / num_procs >= 2 && !silent) { .message("\n", tag = '') } } @@ -4053,38 +3615,9 @@ Start <- function(..., # dim = indices/selectors, if (!merge_across_dims_narm) { data_array_tmp <- array(bigmemory::as.matrix(data_array), dim = final_dims) } else { - # Get the length of these two dimensions in final_dims - length_inner_across_store_dims <- final_dims[across_inner_dim] - length_file_across_store_dims <- final_dims[across_file_dim] - - # Create a logical array for merge_across_dims - logi_array <- array(rep(FALSE, - length_file_across_store_dims * length_inner_across_store_dims), - dim = c(length_inner_across_store_dims, length_file_across_store_dims)) - for (i in 1:length_file_across_store_dims) { #1:4 - logi_array[1:length_inner_across_dim[[i]], i] <- TRUE - } - - # First, get the data array with final_dims dimension - data_array_final_dims <- array(bigmemory::as.matrix(data_array), dim = final_dims) - - # Change the NA derived from additional spaces to -9999, then remove these -9999 - func_remove_blank <- function(data_array, logi_array) { - # dim(data_array) = [time, file_date] - # dim(logi_array) = [time, file_date] - # Change the blank spaces from NA to -9999 - data_array[which(!logi_array)] <- -9999 - return(data_array) - } - data_array_final_dims <- multiApply::Apply(data_array_final_dims, - target_dims = c(across_inner_dim, across_file_dim), #c('time', 'file_date') - output_dims = c(across_inner_dim, across_file_dim), - fun = func_remove_blank, - logi_array = logi_array)$output1 - ## reorder back to the correct dim - tmp <- match(names(final_dims), names(dim(data_array_final_dims))) - data_array_final_dims <- .aperm2(data_array_final_dims, tmp) - data_array_tmp <- data_array_final_dims[data_array_final_dims != -9999] # become a vector + data_array_tmp <- remove_additional_na_from_merge( + inner_dims_across_files, final_dims, across_inner_dim, + length_inner_across_dim, data_array) } if (length(data_array_tmp) != prod(final_dims_fake)) { @@ -4095,70 +3628,9 @@ Start <- function(..., # dim = indices/selectors, #NOTE: When one file contains values for dicrete dimensions, rearrange the # chunks (i.e., work_piece) is necessary. if (split_multiselected_dims) { - - # generate the correct order list from indices_chunk - final_order_list <- list() - i <- 1 - j <- 1 - a <- indices_chunk[i] - while (i <= length(indices_chunk)) { - while (indices_chunk[i+1] == indices_chunk[i] & i < length(indices_chunk)) { - a <- c(a, indices_chunk[i+1]) - i <- i + 1 - } - final_order_list[[j]] <- a - a <- indices_chunk[i+1] - i <- i + 1 - j <- j + 1 - } - names(final_order_list) <- sapply(final_order_list, '[[', 1) - final_order_list <- lapply(final_order_list, length) - - if (!all(diff(as.numeric(names(final_order_list))) > 0)) { - # shape the vector into the array without split_dims - split_dims_pos <- match(split_dims, final_dims_fake) - new_dims <- c() - if (split_dims_pos[1] > 1) { - new_dims <- c(new_dims, final_dims_fake[1:(split_dims_pos[1] - 1)]) - } - new_dims <- c(new_dims, prod(split_dims)) - names(new_dims)[split_dims_pos[1]] <- across_inner_dim - if (split_dims_pos[length(split_dims_pos)] < length(final_dims_fake)) { - new_dims <- c(new_dims, final_dims_fake[(split_dims_pos[length(split_dims_pos)] + 1):length(final_dims_fake)]) - } - final_dims_fake_no_split <- new_dims - data_array_no_split <- array(data_array_tmp, dim = final_dims_fake_no_split) - # seperate 'time' dim into each work_piece length - data_array_seperate <- list() - tmp <- cumsum(unlist(length_inner_across_dim)) - tmp <- c(0, tmp) - for (i in 1:length(length_inner_across_dim)) { - data_array_seperate[[i]] <- Subset(data_array_no_split, across_inner_dim, - (tmp[i] + 1):tmp[i + 1]) - } - - # re-build the array: chunk - which_chunk <- as.numeric(names(final_order_list)) - how_many_indices <- unlist(final_order_list) - array_piece <- list() - ind_in_array_seperate <- as.list(rep(1, length(data_array_seperate))) - for (i in 1:length(final_order_list)) { - array_piece[[i]] <- Subset(data_array_seperate[[which_chunk[i]]], - across_inner_dim, - ind_in_array_seperate[[which_chunk[i]]]:(ind_in_array_seperate[[which_chunk[i]]] + how_many_indices[i] - 1)) - ind_in_array_seperate[[which_chunk[i]]] <- ind_in_array_seperate[[which_chunk[i]]] + how_many_indices[i] - } - - # re-build the array: paste - data_array_tmp <- array_piece[[1]] - along_pos <- which(names(dim(data_array_tmp)) == across_inner_dim) - if (length(array_piece) > 1) { - for (i in 2:length(array_piece)) { - data_array_tmp <- abind::abind(data_array_tmp, array_piece[[i]], - along = along_pos) - } - } - } + data_array_tmp <- rebuild_array_merge_split( + data_array_tmp, indices_chunk, all_split_dims, final_dims_fake, + across_inner_dim, length_inner_across_dim) } data_array <- array(data_array_tmp, dim = final_dims_fake) @@ -4190,45 +3662,10 @@ Start <- function(..., # dim = indices/selectors, unlink(metadata_folder, recursive = TRUE) -#NOTE: Here, metadata can be saved in one of two ways: one for $common and the other for $dat -# for $common, it is a list of metadata length. For $dat, it is a list of dat length, -# and each sublist has the metadata for each dat. - dim_of_metadata <- dim(array_of_metadata_flags)[metadata_dims] - if (!any(names(dim_of_metadata) == pattern_dims) | - (any(names(dim_of_metadata) == pattern_dims) & - dim_of_metadata[pattern_dims] == 1)) { # put under $common; old code - return_metadata <- vector('list', - length = prod(dim(array_of_metadata_flags)[metadata_dims])) - return_metadata[as.numeric(loaded_metadata_files)] <- loaded_metadata - dim(return_metadata) <- dim(array_of_metadata_flags[metadata_dims]) - - } else { # put under $dat. metadata_dims has 'dat' and dat length > 1 - return_metadata <- vector('list', - length = dim_of_metadata[pattern_dims]) - names(return_metadata) <- dat_names - for (kk in 1:length(return_metadata)) { - return_metadata[[kk]] <- vector('list', length = prod(dim_of_metadata[-1])) # 1 is dat - } - loaded_metadata_count <- 1 - for (kk in 1:length(return_metadata)) { - for (jj in 1:length(return_metadata[[kk]])) { - - if (dataset_has_files[kk]) { - if (loaded_metadata_count %in% loaded_metadata_files) { - return_metadata[[kk]][jj] <- loaded_metadata[[loaded_metadata_count]] - names(return_metadata[[kk]])[jj] <- names(loaded_metadata[[loaded_metadata_count]]) - } else { - return_metadata[[kk]][jj] <- NULL - } - loaded_metadata_count <- loaded_metadata_count + 1 - } else { - return_metadata[[kk]][jj] <- NULL - } - - } - } - } - attr(data_array, 'Variables') <- return_metadata + # Create a list of metadata of the variable (e.g., tas) + return_metadata <- create_metadata_list(array_of_metadata_flags, metadata_dims, pattern_dims, + loaded_metadata_files, loaded_metadata, dat_names, + dataset_has_files) # TODO: Try to infer data type from loaded_metadata # as.integer(data_array) } @@ -4287,65 +3724,30 @@ Start <- function(..., # dim = indices/selectors, for (i in 1:length(dat)) { file_selectors[[dat[[i]][['name']]]] <- dat[[i]][['selectors']][which(names(dat[[i]][['selectors']]) %in% found_file_dims[[i]])] } + if (retrieve) { if (!silent) { .message("Successfully retrieved data.") } - if (all(sapply(attr(data_array, 'Variables'), is.null))) { - var_backup <- NULL + if (all(sapply(return_metadata, is.null))) { + # We don't have metadata of the variable (e.g., tas). The returned metadata list only + # contains those are specified in argument "return_vars". + Variables_list <- c(list(common = picked_common_vars), picked_vars) .warning(paste0("Metadata cannot be retrieved. The reason may be the ", "non-existence of the first file. Use parameter 'metadata_dims'", " to assign to file dimensions along which to return metadata, ", "or check the existence of the first file.")) } else { - -#NOTE: The metadata of variables can be saved in one of the two different structures. -# (1) metadata_dims != 'dat', or (metadata_dims == 'dat' & length(dat) == 1): -# put under $common -# (2) (metadata_dims == 'dat' & length(dat) > 1): -# put under $dat1, $dat2, .... Put it in picked_vars list -#TODO: The current (2) uses the inefficient method. Should define the list structure first -# then fill the list, rather than expand it in the for loop. - if (any(metadata_dims == pattern_dims) & length(dat) > 1) { # (2) - var_backup <- attr(data_array, 'Variables') - for (kk in 1:length(var_backup)) { - sublist_names <- lapply(var_backup, names)[[kk]] - if (!is.null(sublist_names)) { - for (jj in 1:length(sublist_names)) { - picked_vars[[kk]][[sublist_names[jj]]] <- var_backup[[kk]][[jj]] - } - } - } - var_backup <- NULL - - } else { #(1) - var_backup <- attr(data_array, 'Variables') - len <- unlist(lapply(var_backup, length)) - len <- sum(len) + length(which(len == 0)) #0 means NULL - name_list <- lapply(var_backup, names) - new_list <- vector('list', length = len) - count <- 1 - - for (kk in 1:length(var_backup)) { - if (length(var_backup[[kk]]) == 0) { #NULL - count <- count + 1 - } else { - for (jj in 1:length(var_backup[[kk]])) { - new_list[[count]] <- var_backup[[kk]][[jj]] - names(new_list)[count] <- name_list[[kk]][jj] - count <- count + 1 - } - } - } - var_backup <- new_list + # Add the metadata of the variable (e.g., tas) into the list of picked_vars or + # picked_common_vars. + Variables_list <- combine_metadata_picked_vars( + return_metadata, picked_vars, picked_common_vars, + metadata_dims, pattern_dims, length(dat)) } -} - attr(data_array, 'Variables') <- NULL attributes(data_array) <- c(attributes(data_array), - list(Variables = c(list(common = c(picked_common_vars, var_backup)), - picked_vars), + list(Variables = Variables_list, Files = array_of_files_to_load, NotFoundFiles = array_of_not_found_files, FileSelectors = file_selectors, @@ -4354,7 +3756,8 @@ Start <- function(..., # dim = indices/selectors, ) attr(data_array, 'class') <- c('startR_array', attr(data_array, 'class')) data_array - } else { + + } else { # retrieve = FALSE if (!silent) { .message("Successfully discovered data dimensions.") } diff --git a/R/zzz.R b/R/zzz.R index af04e6e2c60fc8e5a8c4d60d1d19a3afbfd547ab..3eeed1a5c667e6deb88d861f5e100fd6593fa4e4 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -182,3 +182,1178 @@ look_for_chunks <- function(dim_params, dim_names) { array(indices, dim = setNames(length(indices), dim_name)) } +# Check pattern_dims +# Function found_pattern_dims may change pattern_dims in the parent.env +found_pattern_dims <- function(pattern_dims, dim_names, var_params, + dim_params, dim_reorder_params) { + if (is.null(pattern_dims)) { + .warning(paste0("Parameter 'pattern_dims' not specified. Taking the first dimension, '", + dim_names[1], "' as 'pattern_dims'.")) + assign('pattern_dims', dim_names[1], envir = parent.frame()) + pattern_dims <- dim_names[1] + } else if (is.character(pattern_dims) && (length(pattern_dims) > 0)) { + assign('pattern_dims', unique(pattern_dims), envir = parent.frame()) + pattern_dims <- unique(pattern_dims) + } else { + stop("Parameter 'pattern_dims' must be a vector of character strings.") + } + if (any(names(var_params) %in% pattern_dims)) { + stop("'*_var' parameters specified for pattern dimensions. Remove or fix them.") + } + # Find the pattern dimension with the pattern specifications + found_pattern_dim <- NULL + for (pattern_dim in pattern_dims) { + # Check all specifications in pattern_dim are valid +# dat <- datasets <- dim_params[[pattern_dim]] + dat <- dim_params[[pattern_dim]] + if (is.null(dat) || !(is.character(dat) && all(nchar(dat) > 0)) && !is.list(dat)) { + stop(paste0("Parameter '", pattern_dim, + "' must be a list of lists with pattern specifications or a vector of character strings.")) + } + if (!is.null(dim_reorder_params[[pattern_dim]])) { + .warning(paste0("A reorder for the selectors of '", pattern_dim, + "' has been specified, but it is a pattern dimension and the reorder will be ignored.")) + } + if (is.list(dat) || any(sapply(dat, is.list))) { + if (is.null(found_pattern_dim)) { + found_pattern_dim <- pattern_dim + } else { + stop("Found more than one pattern dim with pattern specifications (list of lists). One and only one pattern dim must contain pattern specifications.") + } + } + } + if (is.null(found_pattern_dim)) { + .warning(paste0("Could not find any pattern dim with explicit data set descriptions (in the form of list of lists). Taking the first pattern dim, '", pattern_dims[1], "', as dimension with pattern specifications.")) + found_pattern_dim <- pattern_dims[1] + } + return(found_pattern_dim) +} + + +# The variable 'dat' is mounted with the information (name, path) of each dataset. +# NOTE: This function creates the object 'dat_names' in the parent env. +mount_dat <- function(dat, pattern_dims, found_pattern_dim, dat_names) { + +# dat_info_names <- c('name', 'path')#, 'nc_var_name', 'suffix', 'var_min', 'var_max', 'dimnames') + dat_to_fetch <- c() +# dat_names <- c() + if (!is.list(dat)) { + dat <- as.list(dat) + } else { + if (!any(sapply(dat, is.list))) { + dat <- list(dat) + } + } + for (i in 1:length(dat)) { + if (is.character(dat[[i]]) && length(dat[[i]]) == 1 && nchar(dat[[i]]) > 0) { + if (grepl('^(\\./|\\.\\./|/.*/|~/)', dat[[i]])) { + dat[[i]] <- list(path = dat[[i]]) + } else { + dat[[i]] <- list(name = dat[[i]]) + } + } else if (!is.list(dat[[i]])) { + stop(paste0("Parameter '", pattern_dims, + "' is incorrect. It must be a list of lists or character strings.")) + } + #if (!(all(names(dat[[i]]) %in% dat_info_names))) { + # stop("Error: parameter 'dat' is incorrect. There are unrecognized components in the information of some of the datasets. Check 'dat' in ?Load for details.") + #} + if (!('name' %in% names(dat[[i]]))) { + dat[[i]][['name']] <- paste0('dat', i) + if (!('path' %in% names(dat[[i]]))) { + stop(paste0("Parameter '", found_pattern_dim, + "' is incorrect. A 'path' should be provided for each dataset if no 'name' is provided.")) + } + } else if (!('path' %in% names(dat[[i]]))) { + dat_to_fetch <- c(dat_to_fetch, i) + } + #if ('path' %in% names(dat[[i]])) { + # if (!('nc_var_name' %in% names(dat[[i]]))) { + # dat[[i]][['nc_var_name']] <- '$var_name$' + # } + # if (!('suffix' %in% names(dat[[i]]))) { + # dat[[i]][['suffix']] <- '' + # } + # if (!('var_min' %in% names(dat[[i]]))) { + # dat[[i]][['var_min']] <- '' + # } + # if (!('var_max' %in% names(dat[[i]]))) { + # dat[[i]][['var_max']] <- '' + # } + #} + dat_names <- c(dat_names, dat[[i]][['name']]) + } + if ((length(dat_to_fetch) > 0) && (length(dat_to_fetch) < length(dat))) { + .warning("'path' has been provided for some datasets. Any information in the configuration file related to these will be ignored.") + } + if (length(dat_to_fetch) > 0) { + stop("Specified only the name for some data sets, but not the path ", + "pattern. This option has not been yet implemented.") + } + + assign('dat_names', dat_names, envir = parent.frame()) + return(dat) +} + +# Add attributes indicating whether this dimension selector is value or indice +add_value_indices_flag <- function(x) { + if (is.null(attr(x, 'values')) || is.null(attr(x, 'indices'))) { + flag <- (any(x %in% c('all', 'first', 'last')) || is.numeric(unlist(x))) + attr(x, 'values') <- !flag + attr(x, 'indices') <- flag + } + return(x) +} + + +# Find the value for the undefined selector (i.e., indices()). Use the value from the first +# found file. +# Note that "dat[[i]][['path']]" in parent env. is changed in this function. +find_ufd_value <- function(undefined_file_dims, dat, i, replace_values, + first_file, file_dims, path_glob_permissive, + depending_file_dims, dat_selectors, selector_checker, chunks) { + first_values <- vector('list', length = length(undefined_file_dims)) + names(first_values) <- undefined_file_dims + found_values <- 0 + stop <- FALSE + try_dim <- 1 + last_success <- 1 + while ((found_values < length(undefined_file_dims)) && !stop) { + u_file_dim <- undefined_file_dims[try_dim] + if (is.null(first_values[[u_file_dim]])) { + path_with_globs_and_tag <- .ReplaceVariablesInString(dat[[i]][['path']], + replace_values[-which(file_dims == u_file_dim)], + allow_undefined_key_vars = TRUE) + found_value <- .FindTagValue(path_with_globs_and_tag, + first_file, u_file_dim) + if (!is.null(found_value)) { + found_values <- found_values + 1 + last_success <- try_dim + first_values[[u_file_dim]] <- found_value + replace_values[[u_file_dim]] <- found_value + } + } + try_dim <- (try_dim %% length(undefined_file_dims)) + 1 + if (try_dim == last_success) { + stop <- TRUE + } + } + if (found_values < length(undefined_file_dims)) { + stop(paste0("Path pattern of dataset '", dat[[i]][['name']], + "' is too complex. Could not automatically ", + "detect values for all non-explicitly defined ", + "indices. Check its pattern: ", dat[[i]][['path']])) + } + ## TODO: Replace ReplaceGlobExpressions by looped call to FindTagValue? As done above + ## Maybe it can solve more cases actually. I got warnings in ReplGlobExp with a typical + ## cmor case, requesting all members and chunks for fixed var and sdate. Not fixing + ## sdate raised 'too complex' error. + # Replace shell globs in path pattern and keep the file_dims as tags + dat[[i]][['path']] <- .ReplaceGlobExpressions(dat[[i]][['path']], first_file, replace_values, + file_dims, dat[[i]][['name']], path_glob_permissive) + + # Now time to look for the available values for the non + # explicitly defined selectors for the file dimensions. + #print("H") + # Check first the ones that do not depend on others. + ufd <- c(undefined_file_dims[which(!(undefined_file_dims %in% names(depending_file_dims)))], + undefined_file_dims[which(undefined_file_dims %in% names(depending_file_dims))]) + + for (u_file_dim in ufd) { + replace_values[undefined_file_dims] <- first_values + replace_values[[u_file_dim]] <- '*' + depended_dim <- NULL + depended_dim_values <- NA + + #NOTE: Here 'selectors' is always 1. Is it supposed to be like this? + selectors <- dat_selectors[[u_file_dim]][[1]] + if (u_file_dim %in% names(depending_file_dims)) { + depended_dim <- depending_file_dims[[u_file_dim]] + depended_dim_values <- dat_selectors[[depended_dim]][[1]] + dat_selectors[[u_file_dim]] <- vector('list', length = length(depended_dim_values)) + names(dat_selectors[[u_file_dim]]) <- depended_dim_values + } else { + dat_selectors[[u_file_dim]] <- list() + } + if (u_file_dim %in% unlist(depending_file_dims)) { + depending_dims <- names(depending_file_dims)[which(sapply(depending_file_dims, function(x) u_file_dim %in% x))] + replace_values[depending_dims] <- rep('*', length(depending_dims)) + } + for (j in 1:length(depended_dim_values)) { + parsed_values <- c() + if (!is.null(depended_dim)) { + replace_values[[depended_dim]] <- depended_dim_values[j] + } + path_with_globs <- .ReplaceVariablesInString(dat[[i]][['path']], replace_values) + found_files <- Sys.glob(path_with_globs) + ## TODO: Enhance this error message, or change by warning. + ## Raises if a wrong sdate is specified, for example. + if (length(found_files) == 0) { + .warning(paste0("Could not find files for any '", u_file_dim, + "' for '", depended_dim, "' = '", + depended_dim_values[j], "'.")) + dat_selectors[[u_file_dim]][[j]] <- NA + } else { + for (found_file in found_files) { + path_with_globs_and_tag <- .ReplaceVariablesInString(dat[[i]][['path']], + replace_values[-which(file_dims == u_file_dim)], + allow_undefined_key_vars = TRUE) + parsed_values <- c(parsed_values, + .FindTagValue(path_with_globs_and_tag, found_file, + u_file_dim)) + } + #TODO: selector_checker() doesn't allow selectors to be characters. For selectors + # like "member = 'r7i1p1f1", it cannot be defined with values. + dat_selectors[[u_file_dim]][[j]] <- selector_checker(selectors = selectors, + var = unique(parsed_values), + return_indices = FALSE) + # Take chunk if needed + dat_selectors[[u_file_dim]][[j]] <- dat_selectors[[u_file_dim]][[j]][chunk_indices(length(dat_selectors[[u_file_dim]][[j]]), + chunks[[u_file_dim]]['chunk'], + chunks[[u_file_dim]]['n_chunks'], + u_file_dim)] + } + } + } + #NOTE: change 'dat' in parent env. because "dat[[i]][['path']]" is changed. + assign('dat', dat, envir = parent.frame()) + return(dat_selectors) +} + + +# Adjust the argument 'return_vars' if users don't assign them properly. +# Force return_vars = (time = NULL) to (time = 'sdate') if one of the situations: +# (1) selector = [sdate = 2, time = 4], or +# (2) time_across = 'sdate'. +correct_return_vars <- function(inner_dim, inner_dims_across_files, found_pattern_dim, + file_dim_as_selector_array_dim) { + # inner_dim is not in return_vars or is NULL + if (is.character(file_dim_as_selector_array_dim)) { #(1) + if (file_dim_as_selector_array_dim %in% found_pattern_dim) { + stop(paste0("Found '", inner_dim, "' selector has dimension of the pattern dim '", + found_pattern_dim, + "', which is not allowed. To assign the dependency on the pattern dim, ", + "use 'return_vars = list(", inner_dim, " = 'dat')' instead.")) + } else { + corrected_value <- file_dim_as_selector_array_dim + } + } else if (inner_dim %in% inner_dims_across_files) { #(2) + file_dim_name <- names(which(inner_dim == inner_dims_across_files)) + if (file_dim_name %in% found_pattern_dim) { + stop(paste0("Found '", inner_dim, "' has across dependency on the pattern dim '", + found_pattern_dim, "', which is not allowed.")) + } else { + corrected_value <- file_dim_name + } + } + .warning(paste0("Found ", inner_dim, " dependency on file diemnsion '", corrected_value, + "', but '", inner_dim, "' is not in return_vars list or is NULL. ", + "To provide the correct metadata, the value of ", inner_dim, + " in 'return_vars' is specified as '", corrected_value, "'.")) + return(corrected_value) +} + +# The time classes that are needed to adjust time zone back to UTC. +time_special_types <- function() { + list('POSIXct' = as.POSIXct, 'POSIXlt' = as.POSIXlt, 'Date' = as.Date) +} + +# Replace the dim names read from netCDF file with the user-specified synonims. +replace_with_synonmins <- function(read_dims, synonims) { + corrected_dim_name <- sapply(names(read_dims), + function(x) { + which_entry <- which(sapply(synonims, function(y) x %in% y)) + if (length(which_entry) > 0) { + names(synonims)[which_entry] + } else { + x + } + }) + return(corrected_dim_name) +} + + +# Prepare vars_to_read for this dataset (i loop) and this file (j loop) +generate_vars_to_read <- function(return_vars, changed_dims, first_found_file, common_return_vars, + common_first_found_file, i) { + vars_to_read <- NULL + if (length(return_vars) > 0) { + #NOTE: because return_vars has changed 'dat' to character(0) above (line 1775), + # 'dat' won't be included in vars_to_read here. + vars_to_read <- names(return_vars)[sapply(return_vars, function(x) any(names(changed_dims) %in% x))] + } + if (!is.null(first_found_file)) { + if (any(!first_found_file)) { + vars_to_read <- c(vars_to_read, names(first_found_file[which(!first_found_file)])) + } + } + if ((i == 1) && (length(common_return_vars) > 0)) { + vars_to_read <- c(vars_to_read, names(common_return_vars)[sapply(common_return_vars, function(x) any(names(changed_dims) %in% x))]) + } + if (!is.null(common_first_found_file)) { + if (any(!common_first_found_file)) { + vars_to_read <- c(vars_to_read, names(common_first_found_file[which(!common_first_found_file)])) + } + } + return(vars_to_read) +} + +# Find the largest dims length within one dataset. +find_largest_dims_length <- function(selectors_total_list, array_of_files_to_load, + selector_indices_save, dat, expected_inner_dims, + synonims, file_dim_reader) { + # Open and get all the dims from all the files + data_dims_all_files <- vector('list', length = length(selectors_total_list)) + + for (selectors_kk in 1:length(data_dims_all_files)) { + file_to_open <- do.call("[", c(list(array_of_files_to_load), + as.list(selector_indices_save[[selectors_kk]]))) + data_dims_all_files[[selectors_kk]] <- try( + file_dim_reader(file_to_open, NULL, selectors_total_list[[selectors_kk]], + lapply(dat[['selectors']][expected_inner_dims], '[[', 1), + synonims), silent = TRUE) + + } + + # Remove the missing files (i.e., fail try above) + if (!identical(which(substr(data_dims_all_files, 1, 5) == 'Error'), integer(0))) { + tmp <- which(substr(data_dims_all_files, 1, 5) == 'Error') + data_dims_all_files <- data_dims_all_files[-tmp] + } + + # Find the longest dimensions from all the files + largest_data_dims <- rep(0, length(data_dims_all_files[[1]])) + + # The inner dim order may differ among files. Need to align them before + # find out the largest dim length. + dim_names_first_file <- names(data_dims_all_files[[1]]) + same_dim_order <-lapply(lapply(data_dims_all_files, names), + identical, dim_names_first_file) + for (to_fix in which(!unlist(same_dim_order))) { + data_dims_all_files[[to_fix]] <- data_dims_all_files[[to_fix]][match(dim_names_first_file, + names(data_dims_all_files[[to_fix]]))] + } + + for (kk in 1:length(data_dims_all_files[[1]])) { + largest_data_dims[kk] <- max(sapply(data_dims_all_files, '[', kk)) + } + names(largest_data_dims) <- names(data_dims_all_files[[1]]) + return(largest_data_dims) +} + +# Gererate vars_to_transform from picked_vars[[i]] and picked_common_vars +generate_vars_to_transform <- function(vars_to_transform, picked_vars, transform_vars, + picked_vars_ordered) { + # In Start(), picked_vars can be picked_vars[[i]] or picked_common_vars + picked_vars_to_transform <- which(names(picked_vars) %in% transform_vars) + if (length(picked_vars_to_transform) > 0) { + picked_vars_to_transform <- names(picked_vars)[picked_vars_to_transform] + new_vars_to_transform <- picked_vars[picked_vars_to_transform] + which_are_ordered <- which(!sapply(picked_vars_ordered[picked_vars_to_transform], is.null)) + + if (length(which_are_ordered) > 0) { + tmp <- which(!is.na(match(names(picked_vars_ordered), names(which_are_ordered)))) + new_vars_to_transform[which_are_ordered] <- picked_vars_ordered[tmp] + } + vars_to_transform <- c(vars_to_transform, new_vars_to_transform) + } + return(vars_to_transform) +} + +# Out-of-range warning +show_out_of_range_warning <- function(inner_dim, range, bound) { + # bound: 'lower' or 'upper' + .warning(paste0("The ", bound, " boundary of selector of ", inner_dim, + " is out of range [", min(range), ", ", max(range), "]. ", + "Check if the desired range is all included.")) +} + +# 'sub_sub_array_of_values' is for sri chunking. If this inner dim is chunked, +# the sri has to follow the chunking of fri. Therefore, we save the original +# value of this chunk here for later use. We'll find the corresponding +# transformed value within 'sub_sub_array_of_values' and chunk sri. This +# function also returns 'previous_sub_subarray_of_values', which is used for +# checking if there is sri being skipped. +generate_sub_sub_array_of_values <- function(input_array_of_values, sub_array_of_indices, + number_of_chunk) { + previous_sub_sub_array_of_values <- NULL + + if (is.list(sub_array_of_indices)) { + sub_sub_array_of_values <- list(input_array_of_values[sub_array_of_indices[[1]]], + input_array_of_values[sub_array_of_indices[[2]]]) + if (number_of_chunk > 1) { + previous_sub_sub_array_of_values <- input_array_of_values[sub_array_of_indices[[1]] - 1] + } + } else { # is vector + sub_sub_array_of_values <- input_array_of_values[sub_array_of_indices] + if (number_of_chunk > 1) { + previous_sub_sub_array_of_values <- input_array_of_values[sub_array_of_indices[1] - 1] + } + } + + return(list(sub_sub_array_of_values = sub_sub_array_of_values, + previous_sub_sub_array_of_values = previous_sub_sub_array_of_values)) +} + + +# Generate sub_array_of_fri +generate_sub_array_of_fri <- function(with_transform, goes_across_prime_meridian, sub_array_of_indices, n, beta, + is_circular_dim, add_beta = TRUE) { + print_warning <- FALSE + if (goes_across_prime_meridian) { + #NOTE: The potential problem here is, if it is global longitude, + # and the indices overlap (e.g., lon = [0, 359.723] and + # CircularSort(-180, 180), then sub_array_of_indices = list(649, 649)). + # Therefore, sub_array_of_fri will be c(1:649, 649:1296). We'll get two 649. + # The fix below may not be the best solution, but it works for the example above. + + if (sub_array_of_indices[[1]] == sub_array_of_indices[[2]]) { + # global longitude + sub_array_of_fri <- 1:n # n = prod(dim(var_with_selectors)) + + if (with_transform & beta != 0 & add_beta) { + # Warning if transform_extra_cell != 0 + print_warning <- TRUE + } + + } else { + # normal case, i.e., not global + first_index <- min(unlist(sub_array_of_indices)) + last_index <- max(unlist(sub_array_of_indices)) + if (with_transform & add_beta) { + gap_width <- last_index - first_index - 1 + actual_beta <- min(gap_width, beta) + sub_array_of_fri <- c(1:(first_index + actual_beta), + (last_index - actual_beta):n) + if (actual_beta != beta) { + print_warning <- TRUE + } + } else { + sub_array_of_fri <- c(1:first_index, last_index:n) + } + } + + } else { + #NOTE: This if seems redundant. +# if (is.list(sub_array_of_indices)) { +# sub_array_of_indices <- sub_array_of_indices[[1]]:sub_array_of_indices[[2]] +# } + #NOTE: sub_array_of_indices may be vector or list + if (with_transform & add_beta) { + first_index <- min(unlist(sub_array_of_indices)) + last_index <- max(unlist(sub_array_of_indices)) + start_padding <- min(beta, first_index - 1) + end_padding <- min(beta, n - last_index) + + if (!is_circular_dim) { #latitude or when _reorder is not used + sub_array_of_fri <- (first_index - start_padding):(last_index + end_padding) + if (start_padding != beta | end_padding != beta) { + print_warning <- TRUE + } + } else { #longitude + if (start_padding == beta & end_padding == beta) { + # normal regional situation + sub_array_of_fri <- (first_index - start_padding):(last_index + end_padding) + } else if (start_padding < beta & end_padding < beta) { + # global + sub_array_of_fri <- 1:n + } else if (start_padding < beta) { + # left side too close to border, need to go to right side + sub_array_of_fri <- c((first_index - start_padding):(last_index + end_padding), (n - (beta - start_padding - 1)):n) + } else if (end_padding < beta) { + # right side too close to border, need to go to left side + sub_array_of_fri <- c(1: (beta - end_padding), (first_index - start_padding):(last_index + end_padding)) + } + } + + } else { + if (is.list(sub_array_of_indices)) { + sub_array_of_fri <- sub_array_of_indices[[1]]:sub_array_of_indices[[2]] + } else { + sub_array_of_fri <- sub_array_of_indices + } + } + } + if (print_warning) { + .warning(paste0("Adding parameter transform_extra_cells = ", beta, + " to the transformed index excesses ", + "the border. The border index is used for transformation.")) + } + + return(sub_array_of_fri) +} + +# This function merges two dimensions (e.g., time and sdate if "time_across = 'sdate'") into one. +# The two dimensions have to be next to each other. In Start(), it is used to reshape +# final_dims_fake if merge_across_dims = TRUE +dims_merge <- function(inner_dims_across_files, final_dims_fake) { + # inner_dims_across_files would be like: $sdate: "time" + for (file_dim_across in names(inner_dims_across_files)) { + inner_dim_pos <- which(names(final_dims_fake) == inner_dims_across_files[[file_dim_across]]) + new_dims <- c() + # part 1: Put the dims before 'time' in new_dims + if (inner_dim_pos > 1) { + new_dims <- c(new_dims, final_dims_fake[1:(inner_dim_pos - 1)]) + } + # part 2: Merge time and sdate together, and name this dim as 'time' + # The cross and being crossed dims are next to each other, e.g., [time, sdate] + new_dims <- c(new_dims, setNames(prod(final_dims_fake[c(inner_dim_pos, inner_dim_pos + 1)]), + inner_dims_across_files[[file_dim_across]])) + # part 3: Put the dimes after 'sdate' in new_dims + if (inner_dim_pos + 1 < length(final_dims_fake)) { + new_dims <- c(new_dims, final_dims_fake[(inner_dim_pos + 2):length(final_dims_fake)]) + } + final_dims_fake <- new_dims + } + return(final_dims_fake) +} + +# This function splits one dimension into two. In Start(), it is used to reshape final_dims_fake +# if split_multiselected_dims = TRUE. +dims_split <- function(dim_params, final_dims_fake) { + all_split_dims <- NULL + for (dim_param in 1:length(dim_params)) { + split_dims <- dim(dim_params[[dim_param]]) + if (!is.null(split_dims)) { + if (length(split_dims) > 1) { + all_split_dims <- c(all_split_dims, setNames(list(split_dims), + names(dim_params)[dim_param])) + if (is.null(names(split_dims))) { + names(split_dims) <- paste0(names(dim_params)[dim_param], + 1:length(split_dims)) + } + old_dim_pos <- which(names(final_dims_fake) == names(dim_params)[dim_param]) + + # If merge_across_dims and split_multiselected_dims are both used, + # on one file dim, and this file dim is multi-dim, it doesn't work. + if (identical(old_dim_pos, integer(0))) { + stop(paste0("The dimension '", names(dim_params)[dim_param], + "' to be split cannot be found after 'merge_across_dims' ", + "is used. Check if the reshape parameters are used appropriately.")) + } + + # NOTE: Three steps to create new dims. + # 1st: Put in the dims before split_dim. + # 2nd: Replace the old_dim with split_dims. + # 3rd: Put in the dims after split_dim. + new_dims <- c() + if (old_dim_pos > 1) { + new_dims <- c(new_dims, final_dims_fake[1:(old_dim_pos - 1)]) + } + new_dims <- c(new_dims, split_dims) + if (old_dim_pos < length(final_dims_fake)) { + new_dims <- c(new_dims, final_dims_fake[(old_dim_pos + 1):length(final_dims_fake)]) + } + final_dims_fake <- new_dims + } + } + } + return(list(final_dims_fake, all_split_dims)) +} + + +# This function sums up the length of all the inner across dim (e.g., time: list(31, 29, 31, 30)) +# and use it to replace the value of that inner dim. That is, it returns the actual length of +# time rather than using the one including NAs. In Start(), it is used to reshape final_dims_fake +# if merge_across_dims = TRUE, merge_across_dims_narm = TRUE, and split_multiselected_dims = FALSE. +merge_narm_dims <- function(final_dims_fake, across_inner_dim, length_inner_across_dim) { + final_dims_fake_name <- names(final_dims_fake) + pos_across_inner_dim <- which(final_dims_fake_name == across_inner_dim) + new_length_inner_dim <- sum(unlist(length_inner_across_dim)) + if (pos_across_inner_dim != length(final_dims_fake)) { + final_dims_fake <- c(final_dims_fake[1:(pos_across_inner_dim - 1)], + new_length_inner_dim, + final_dims_fake[(pos_across_inner_dim + 1):length(final_dims_fake)]) + } else { + final_dims_fake <- c(final_dims_fake[1:(pos_across_inner_dim - 1)], + new_length_inner_dim) + } + names(final_dims_fake) <- final_dims_fake_name + return(final_dims_fake) +} + + + +# Adjust the dim order. If split_multiselected_dims + merge_across_dims, the dim order may +# need to be changed. The inner_dim needs to be the first dim among split dims. +reorder_split_dims <- function(all_split_dims, inner_dim_pos_in_split_dims, final_dims_fake) { + all_split_dims <- c(all_split_dims[inner_dim_pos_in_split_dims], + all_split_dims[1:length(all_split_dims)][-inner_dim_pos_in_split_dims]) + split_dims_pos <- which(!is.na(match(names(final_dims_fake), names(all_split_dims)))) + new_dims <- c() + if (split_dims_pos[1] != 1) { + new_dims <- c(new_dims, final_dims_fake[1:(split_dims_pos[1] - 1)]) + } + new_dims <- c(new_dims, all_split_dims) + if (split_dims_pos[length(split_dims_pos)] < length(final_dims_fake)) { + new_dims <- c(new_dims, final_dims_fake[(split_dims_pos[length(split_dims_pos)] + 1):length(final_dims_fake)]) + } + final_dims_fake <- new_dims + + return(list(final_dims_fake, all_split_dims)) +} + + +# Build the work pieces. +build_work_pieces <- function(work_pieces, i, selectors, file_dims, inner_dims, final_dims, + found_pattern_dim, inner_dims_across_files, array_of_files_to_load, + array_of_not_found_files, array_of_metadata_flags, + metadata_file_counter, depending_file_dims, transform, + transform_vars, picked_vars, picked_vars_ordered, picked_common_vars, + picked_common_vars_ordered, metadata_folder, debug = debug) { + sub_array_dims <- final_dims[file_dims] + sub_array_dims[found_pattern_dim] <- 1 + sub_array_of_files_to_load <- array(1:prod(sub_array_dims), + dim = sub_array_dims) + names(dim(sub_array_of_files_to_load)) <- names(sub_array_dims) + # Detect which of the dimensions of the dataset go across files. + file_dim_across_files <- lapply(inner_dims, + function(x) { + dim_across <- sapply(inner_dims_across_files, function(y) x %in% y) + if (any(dim_across)) { + names(inner_dims_across_files)[which(dim_across)[1]] + } else { + NULL + } + }) + names(file_dim_across_files) <- inner_dims + j <- 1 + while (j <= prod(sub_array_dims)) { + # Work out file path. + file_to_load_sub_indices <- which(sub_array_of_files_to_load == j, arr.ind = TRUE)[1, ] + names(file_to_load_sub_indices) <- names(sub_array_dims) + file_to_load_sub_indices[found_pattern_dim] <- i + big_dims <- rep(1, length(dim(array_of_files_to_load))) + names(big_dims) <- names(dim(array_of_files_to_load)) + file_to_load_indices <- .MergeArrayDims(file_to_load_sub_indices, big_dims)[[1]] + file_to_load <- do.call('[[', c(list(array_of_files_to_load), + as.list(file_to_load_indices))) + not_found_file <- do.call('[[', c(list(array_of_not_found_files), + as.list(file_to_load_indices))) + load_file_metadata <- do.call('[', c(list(array_of_metadata_flags), + as.list(file_to_load_indices))) + if (load_file_metadata) { + metadata_file_counter <- metadata_file_counter + 1 + assign('metadata_file_counter', metadata_file_counter, envir = parent.frame()) + } + if (!is.na(file_to_load) && !not_found_file) { + # Work out indices to take + first_round_indices <- lapply(inner_dims, + function (x) { + if (is.null(file_dim_across_files[[x]])) { + x_dim_name <- attr(attr(selectors[[x]][['fri']], "dim"), "names") + if (!is.null(x_dim_name)) { + which_chunk <- file_to_load_sub_indices[x_dim_name] + selectors[[x]][['fri']][[which_chunk]] + } else { + selectors[[x]][['fri']][[1]] + } + } else { + which_chunk <- file_to_load_sub_indices[file_dim_across_files[[x]]] + selectors[[x]][['fri']][[which_chunk]] + } + }) + names(first_round_indices) <- inner_dims + second_round_indices <- lapply(inner_dims, + function (x) { + if (is.null(file_dim_across_files[[x]])) { + x_dim_name <- attr(attr(selectors[[x]][['sri']], "dim"), "names") + if (!is.null(x_dim_name)) { + which_chunk <- file_to_load_sub_indices[x_dim_name] + selectors[[x]][['sri']][[which_chunk]] + } else { + selectors[[x]][['sri']][[1]] + } + } else { + which_chunk <- file_to_load_sub_indices[file_dim_across_files[[x]]] + selectors[[x]][['sri']][[which_chunk]] + } + }) + if (debug) { + print("-> BUILDING A WORK PIECE") + #print(str(selectors)) + } + names(second_round_indices) <- inner_dims + if (!any(sapply(first_round_indices, length) == 0)) { + work_piece <- list() + work_piece[['first_round_indices']] <- first_round_indices + work_piece[['second_round_indices']] <- second_round_indices + work_piece[['file_indices_in_array_of_files']] <- file_to_load_indices + work_piece[['file_path']] <- file_to_load + work_piece[['store_dims']] <- final_dims + # Work out store position + store_position <- final_dims + store_position[names(file_to_load_indices)] <- file_to_load_indices + store_position[inner_dims] <- rep(1, length(inner_dims)) + work_piece[['store_position']] <- store_position + # Work out file selectors + file_selectors <- sapply(file_dims, + function (x) { + vector_to_pick <- 1 + if (x %in% names(depending_file_dims)) { + vector_to_pick <- file_to_load_indices[depending_file_dims[[x]]] + } + selectors[file_dims][[x]][[vector_to_pick]][file_to_load_indices[x]] + }) + names(file_selectors) <- file_dims + work_piece[['file_selectors']] <- file_selectors + # Send variables for transformation + if (!is.null(transform) && (length(transform_vars) > 0)) { + vars_to_transform <- NULL + picked_vars_to_transform <- which(names(picked_vars) %in% transform_vars) + if (length(picked_vars_to_transform) > 0) { + picked_vars_to_transform <- names(picked_vars)[picked_vars_to_transform] + vars_to_transform <- c(vars_to_transform, picked_vars[picked_vars_to_transform]) + if (any(picked_vars_to_transform %in% names(picked_vars_ordered))) { + picked_vars_ordered_to_transform <- picked_vars_to_transform[which(picked_vars_to_transform %in% names(picked_vars_ordered))] + vars_to_transform[picked_vars_ordered_to_transform] <- picked_vars_ordered[picked_vars_ordered_to_transform] + } + } + picked_common_vars_to_transform <- which(names(picked_common_vars) %in% transform_vars) + if (length(picked_common_vars_to_transform) > 0) { + picked_common_vars_to_transform <- names(picked_common_vars)[picked_common_vars_to_transform] + vars_to_transform <- c(vars_to_transform, picked_common_vars[picked_common_vars_to_transform]) + if (any(picked_common_vars_to_transform %in% names(picked_common_vars_ordered))) { + picked_common_vars_ordered_to_transform <- picked_common_vars_to_transform[which(picked_common_vars_to_transform %in% names(picked_common_vars_ordered))] + vars_to_transform[picked_common_vars_ordered_to_transform] <- picked_common_vars_ordered[picked_common_vars_ordered_to_transform] + } + } + work_piece[['vars_to_transform']] <- vars_to_transform + } + # Send flag to load metadata + if (load_file_metadata) { + work_piece[['save_metadata_in']] <- paste0(metadata_folder, '/', metadata_file_counter) + } + work_pieces <- c(work_pieces, list(work_piece)) + } + } + j <- j + 1 + } + + return(work_pieces) +} + +# Calculate the progress %s that will be displayed and assign them to the appropriate work pieces. +retrieve_progress_message <- function(work_pieces, num_procs, silent) { + if (length(work_pieces) / num_procs >= 2 && !silent) { + if (length(work_pieces) / num_procs < 10) { + amount <- 100 / ceiling(length(work_pieces) / num_procs) + reps <- ceiling(length(work_pieces) / num_procs) + } else { + amount <- 10 + reps <- 10 + } + progress_steps <- rep(amount, reps) + if (length(work_pieces) < (reps + 1)) { + selected_pieces <- length(work_pieces) + progress_steps <- c(sum(head(progress_steps, reps)), + tail(progress_steps, reps)) + } else { + selected_pieces <- round(seq(1, length(work_pieces), + length.out = reps + 1))[-1] + } + progress_steps <- paste0(' + ', round(progress_steps, 2), '%') + progress_message <- 'Progress: 0%' + } else { + progress_message <- '' + selected_pieces <- NULL + } + piece_counter <- 1 + step_counter <- 1 + work_pieces <- lapply(work_pieces, + function (x) { + if (piece_counter %in% selected_pieces) { + wp <- c(x, list(progress_amount = progress_steps[step_counter])) + step_counter <<- step_counter + 1 + } else { + wp <- x + } + piece_counter <<- piece_counter + 1 + wp + }) + if (!silent) { + .message("If the size of the requested data is close to or above the free shared RAM memory, R may crash.") + .message("If the size of the requested data is close to or above the half of the free RAM memory, R may crash.") + .message(paste0("Will now proceed to read and process ", length(work_pieces), " data files:")) + if (length(work_pieces) < 30) { + lapply(work_pieces, function (x) .message(x[['file_path']], indent = 2)) + } else { + .message("The list of files is long. You can check it after Start() finishes in the output '$Files'.", indent = 2, exdent = 5) + } + } + + # Build the cluster of processes that will do the work and dispatch work pieces. + # The function .LoadDataFile is applied to each work piece. This function will + # open the data file, regrid if needed, subset, apply the mask, + # compute and apply the weights if needed, + # disable extreme values and store in the shared memory matrix. + #print("O") + if (!silent) { + .message("Loading... This may take several minutes...") + if (progress_message != '') { + .message(progress_message, appendLF = FALSE) + } + } + return(work_pieces) +} + +# If merge_across_dims = TRUE and merge_across_dims_narm = TRUE, remove the additional NAs +# due to unequal inner_dim ('time') length across file_dim ('sdate'). +remove_additional_na_from_merge <- function(inner_dims_across_files, final_dims, across_inner_dim, + length_inner_across_dim, data_array) { + across_file_dim <- names(inner_dims_across_files) #TODO: more than one? + # Get the length of these two dimensions in final_dims + length_inner_across_store_dims <- final_dims[across_inner_dim] + length_file_across_store_dims <- final_dims[across_file_dim] + + # Create a logical array for merge_across_dims + logi_array <- array(rep(FALSE, + length_file_across_store_dims * length_inner_across_store_dims), + dim = c(length_inner_across_store_dims, length_file_across_store_dims)) + for (i in 1:length_file_across_store_dims) { #1:4 + logi_array[1:length_inner_across_dim[[i]], i] <- TRUE + } + + # First, get the data array with final_dims dimension + data_array_final_dims <- array(bigmemory::as.matrix(data_array), dim = final_dims) + + # Change the NA derived from additional spaces to -9999, then remove these -9999 + func_remove_blank <- function(data_array, logi_array) { + # dim(data_array) = [time, file_date] + # dim(logi_array) = [time, file_date] + # Change the blank spaces from NA to -9999 + data_array[which(!logi_array)] <- -9999 + return(data_array) + } + data_array_final_dims <- multiApply::Apply(data_array_final_dims, + target_dims = c(across_inner_dim, across_file_dim), #c('time', 'file_date') + output_dims = c(across_inner_dim, across_file_dim), + fun = func_remove_blank, + logi_array = logi_array)$output1 + ## reorder back to the correct dim + tmp <- match(names(final_dims), names(dim(data_array_final_dims))) + data_array_final_dims <- .aperm2(data_array_final_dims, tmp) + data_array_tmp <- data_array_final_dims[data_array_final_dims != -9999] # become a vector + + return(data_array_tmp) +} + + + +# When merge_across_dims = TRUE and split_multiselected_dims = TRUE, rearrange the chunks +# (i.e., work_piece) is necessary if one file contains values for discrete dimensions +rebuild_array_merge_split <- function(data_array_tmp, indices_chunk, all_split_dims, + final_dims_fake, across_inner_dim, length_inner_across_dim) { + # generate the correct order list from indices_chunk + final_order_list <- list() + i <- 1 + j <- 1 + a <- indices_chunk[i] + while (i <= length(indices_chunk)) { + while (indices_chunk[i+1] == indices_chunk[i] & i < length(indices_chunk)) { + a <- c(a, indices_chunk[i+1]) + i <- i + 1 + } + final_order_list[[j]] <- a + a <- indices_chunk[i+1] + i <- i + 1 + j <- j + 1 + } + names(final_order_list) <- sapply(final_order_list, '[[', 1) + final_order_list <- lapply(final_order_list, length) + + if (!all(diff(as.numeric(names(final_order_list))) > 0)) { + # shape the vector into the array without split_dims + split_dims_pos <- match(all_split_dims[[1]], final_dims_fake) + new_dims <- c() + if (split_dims_pos[1] > 1) { + new_dims <- c(new_dims, final_dims_fake[1:(split_dims_pos[1] - 1)]) + } + new_dims <- c(new_dims, prod(all_split_dims[[1]])) + names(new_dims)[split_dims_pos[1]] <- across_inner_dim + if (split_dims_pos[length(split_dims_pos)] < length(final_dims_fake)) { + new_dims <- c(new_dims, final_dims_fake[(split_dims_pos[length(split_dims_pos)] + 1):length(final_dims_fake)]) + } + data_array_no_split <- array(data_array_tmp, dim = new_dims) + # seperate 'time' dim into each work_piece length + data_array_seperate <- list() + tmp <- cumsum(unlist(length_inner_across_dim)) + tmp <- c(0, tmp) + for (i in 1:length(length_inner_across_dim)) { + data_array_seperate[[i]] <- Subset(data_array_no_split, across_inner_dim, + (tmp[i] + 1):tmp[i + 1]) + } + # re-build the array: chunk + which_chunk <- as.numeric(names(final_order_list)) + how_many_indices <- unlist(final_order_list) + array_piece <- list() + ind_in_array_seperate <- as.list(rep(1, length(data_array_seperate))) + for (i in 1:length(final_order_list)) { + array_piece[[i]] <- Subset(data_array_seperate[[which_chunk[i]]], + across_inner_dim, + ind_in_array_seperate[[which_chunk[i]]]:(ind_in_array_seperate[[which_chunk[i]]] + how_many_indices[i] - 1)) + ind_in_array_seperate[[which_chunk[i]]] <- ind_in_array_seperate[[which_chunk[i]]] + how_many_indices[i] + } + + # re-build the array: paste + data_array_tmp <- array_piece[[1]] + along_pos <- which(names(dim(data_array_tmp)) == across_inner_dim) + if (length(array_piece) > 1) { + for (i in 2:length(array_piece)) { + data_array_tmp <- abind::abind(data_array_tmp, array_piece[[i]], + along = along_pos) + } + } + } + + return(data_array_tmp) +} + + +# Create a list of metadata of the variable (e.g., tas) +create_metadata_list <- function(array_of_metadata_flags, metadata_dims, pattern_dims, + loaded_metadata_files, loaded_metadata, dat_names, + dataset_has_files) { + #NOTE: Here, metadata can be saved in one of two ways: one for $common and the other for $dat + # for $common, it is a list of metadata length. For $dat, it is a list of dat length, + # and each sublist has the metadata for each dat. + dim_of_metadata <- dim(array_of_metadata_flags)[metadata_dims] + if (!any(names(dim_of_metadata) == pattern_dims) | + (any(names(dim_of_metadata) == pattern_dims) & + dim_of_metadata[pattern_dims] == 1)) { # put under $common; old code + return_metadata <- vector('list', + length = prod(dim_of_metadata)) + return_metadata[as.numeric(loaded_metadata_files)] <- loaded_metadata + dim(return_metadata) <- dim_of_metadata + + } else { # put under $dat. metadata_dims has 'dat' and dat length > 1 + return_metadata <- vector('list', + length = dim_of_metadata[pattern_dims]) + names(return_metadata) <- dat_names + for (kk in 1:length(return_metadata)) { + return_metadata[[kk]] <- vector('list', length = prod(dim_of_metadata[-1])) # 1 is dat + } + loaded_metadata_count <- 1 + for (kk in 1:length(return_metadata)) { + for (jj in 1:length(return_metadata[[kk]])) { + if (dataset_has_files[kk]) { + if (loaded_metadata_count %in% loaded_metadata_files) { + return_metadata[[kk]][jj] <- loaded_metadata[[which(loaded_metadata_files == loaded_metadata_count)]] + names(return_metadata[[kk]])[jj] <- names(loaded_metadata[[which(loaded_metadata_files == loaded_metadata_count)]]) + + } else { + return_metadata[[kk]][jj] <- NULL + } + loaded_metadata_count <- loaded_metadata_count + 1 + } else { + return_metadata[[kk]][jj] <- NULL + } + + } + } + } + + return(return_metadata) +} + +# This function adds the metadata of the variable (e.g., tas) into the list of picked_vars or +# picked_common_vars. The metadata is only retrieved when 'retrieve = TRUE'. +combine_metadata_picked_vars <- function(return_metadata, picked_vars, picked_common_vars, + metadata_dims, pattern_dims, length_dat) { +#NOTE: The metadata of variables can be saved in one of the two different structures. +# (1) metadata_dims != 'dat', or (metadata_dims == 'dat' & length(dat) == 1): +# put under $common +# (2) (metadata_dims == 'dat' & length(dat) > 1): +# put under $dat1, $dat2, .... Put it in picked_vars list +#TODO: The current (2) uses the inefficient method. Should define the list structure first +# then fill the list, rather than expand it in the for loop. + + if (any(metadata_dims == pattern_dims) & length_dat > 1) { # (2) + for (kk in 1:length(return_metadata)) { + sublist_names <- lapply(return_metadata, names)[[kk]] + if (!is.null(sublist_names)) { + for (jj in 1:length(sublist_names)) { + picked_vars[[kk]][[sublist_names[jj]]] <- return_metadata[[kk]][[jj]] + } + } + } + Variables_list <- c(list(common = picked_common_vars), picked_vars) + + } else { #(1) + len <- unlist(lapply(return_metadata, length)) + len <- sum(len) + length(which(len == 0)) #0 means NULL + name_list <- lapply(return_metadata, names) + new_list <- vector('list', length = len) + count <- 1 + + for (kk in 1:length(return_metadata)) { + if (length(return_metadata[[kk]]) == 0) { #NULL + count <- count + 1 + } else { + for (jj in 1:length(return_metadata[[kk]])) { + new_list[[count]] <- return_metadata[[kk]][[jj]] + names(new_list)[count] <- name_list[[kk]][jj] + count <- count + 1 + } + } + } + Variables_list <- c(list(common = c(picked_common_vars, new_list)), picked_vars) + } + + return(Variables_list) +} + +# This function generates a list of 3, containing picked(_common)_vars, +# picked(_common)_vars_ordered, and picked(_common)_vars_unorder_indices for the 'var_to_read' +# of this dataset (i) and file (j). +generate_picked_var_of_read <- function(var_to_read, var_to_check, array_of_files_to_load, + var_dims, array_of_var_files, file_var_reader, + file_object, synonims, associated_dim_name, + dim_reorder_params, aiat, current_indices, var_params, + either_picked_vars, + either_picked_vars_ordered, + either_picked_vars_unorder_indices) { + var_file_dims <- NULL + + if (any(names(dim(array_of_files_to_load)) %in% var_to_check)) { + var_file_dims <- dim(array_of_files_to_load)[which(names(dim(array_of_files_to_load)) %in% + var_to_check)] + } + if (is.null(either_picked_vars)) { + + if (any(names(var_file_dims) %in% names(var_dims))) { + stop("Found a requested var in 'return_var' requested for a ", + "file dimension which also appears in the dimensions of ", + "the variable inside the file.\n", array_of_var_files) + } + first_sample <- file_var_reader(NULL, file_object, NULL, + var_to_read, synonims) + if (any(class(first_sample) %in% names(time_special_types()))) { + array_size <- prod(c(var_file_dims, var_dims)) + new_array <- rep(time_special_types()[[class(first_sample)[1]]](NA), array_size) + dim(new_array) <- c(var_file_dims, var_dims) + } else { + new_array <- array(dim = c(var_file_dims, var_dims)) + } + attr(new_array, 'variables') <- attr(first_sample, 'variables') + + either_picked_vars <- new_array + pick_ordered <- FALSE + if (var_to_read %in% unlist(var_params)) { + if (associated_dim_name %in% names(dim_reorder_params) && !aiat) { + either_picked_vars_ordered <- new_array + pick_ordered <- TRUE + } + } + if (!pick_ordered) { + either_picked_vars_ordered <- NULL + } + + } else { + array_var_dims <- dim(either_picked_vars) + full_array_var_dims <- array_var_dims + if (any(names(array_var_dims) %in% names(var_file_dims))) { + array_var_dims <- array_var_dims[-which(names(array_var_dims) %in% names(var_file_dims))] + } + if (names(array_var_dims) != names(var_dims)) { + stop("Error while reading the variable '", var_to_read, "' from ", + "the file. Dimensions do not match.\nExpected ", + paste(paste0("'", names(array_var_dims), "'"), collapse = ', '), + " but found ", + paste(paste0("'", names(var_dims), "'"), collapse = ', '), + ".\n", array_of_var_files) + } + if (any(var_dims > array_var_dims)) { + longer_dims <- which(var_dims > array_var_dims) + if (length(longer_dims) == 1) { + longer_dims_in_full_array <- longer_dims + if (any(names(full_array_var_dims) %in% names(var_file_dims))) { + candidates <- (1:length(full_array_var_dims))[-which(names(full_array_var_dims) %in% names(var_file_dims))] + longer_dims_in_full_array <- candidates[longer_dims] + } + padding_dims <- full_array_var_dims + padding_dims[longer_dims_in_full_array] <- + var_dims[longer_dims] - array_var_dims[longer_dims] + + var_class <- class(either_picked_vars) + if (any(var_class %in% names(time_special_types()))) { + padding_size <- prod(padding_dims) + padding <- rep(time_special_types()[[var_class[1]]](NA), padding_size) + dim(padding) <- padding_dims + } else { + padding <- array(dim = padding_dims) + } + either_picked_vars <- .abind2(either_picked_vars, padding, + names(full_array_var_dims)[longer_dims_in_full_array]) + } else { + stop("Error while reading the variable '", var_to_read, "' from ", + "the file. Found size (", paste(var_dims, collapse = ' x '), + ") is greater than expected maximum size (", array_var_dims, ").") + } + } + } + + var_store_indices <- c(as.list(current_indices[names(var_file_dims)]), + lapply(var_dims, function(x) 1:x)) + var_values <- file_var_reader(NULL, file_object, NULL, var_to_read, synonims) + if (var_to_read %in% unlist(var_params)) { + if ((associated_dim_name %in% names(dim_reorder_params)) && !aiat) { + ## Is this check really needed? + if (length(dim(var_values)) > 1) { + stop("Requested a '", associated_dim_name, "_reorder' for a dimension ", + "whose coordinate variable that has more than 1 dimension. This is ", + "not supported.") + } + ordered_var_values <- dim_reorder_params[[associated_dim_name]](var_values) + attr(ordered_var_values$x, 'variables') <- attr(var_values, 'variables') + if (!all(c('x', 'ix') %in% names(ordered_var_values))) { + stop("All the dimension reorder functions must return a list with the components 'x' and 'ix'.") + } + # Save the indices to reorder the ordered variable values back to original order. + # 'unorder' refers to the indices of 'ordered_var_values' if it is unordered. + # This will be used to define the first round indices. + unorder <- sort(ordered_var_values$ix, index.return = TRUE)$ix + either_picked_vars_ordered <- do.call('[<-', + c(list(x = either_picked_vars_ordered), + var_store_indices, + list(value = ordered_var_values$x))) + either_picked_vars_unorder_indices <- do.call('[<-', + c(list(x = either_picked_vars_unorder_indices), + var_store_indices, + list(value = unorder))) + + + } + } + + either_picked_vars <- do.call('[<-', + c(list(x = either_picked_vars), + var_store_indices, + list(value = var_values))) + # Turn time zone back to UTC if this var_to_read is 'time' + if (all(class(either_picked_vars) == names(time_special_types))) { + attr(either_picked_vars, "tzone") <- 'UTC' + } + + + return(list(either_picked_vars = either_picked_vars, + either_picked_vars_ordered = either_picked_vars_ordered, + either_picked_vars_unorder_indices = either_picked_vars_unorder_indices)) +} + + +# Trnasforms a vector of indices v expressed in a world of +# length N from 1 to N, into a world of length M, from +# 1 to M. Repeated adjacent indices are collapsed. +transform_indices <- function(v, n, m) { + #unique2 turns e.g. 1 1 2 2 2 3 3 1 1 1 into 1 2 3 1 + unique2 <- function(v) { + if (length(v) < 2) { + v + } else { + v[c(1, v[2:length(v)] - v[1:(length(v) - 1)]) != 0] + } + } + unique2(round(((v - 1) / (n - 1)) * (m - 1))) + 1 # this rounding may generate 0s. what then? +} + diff --git a/inst/doc/data_check.md b/inst/doc/data_check.md index ae73f50ea2e665f11ebbaf4152f4024c2475e859..156a2531ce091bac515310c240e297c282b7619f 100644 --- a/inst/doc/data_check.md +++ b/inst/doc/data_check.md @@ -21,6 +21,7 @@ Here we list some tips recommended to pay attention, and some tools for data com - Extra examination (5) [Compute()](inst/doc/data_check.md#5-compute) + (6) [Regridding](inst/doc/data_check.md#6-regridding) ## Tips @@ -383,5 +384,35 @@ res[1:3, 1, 1, 1, 1, 1:2] ``` +### (5) Regridding +If `transform = CDORemapper` is used in Start(), you can use other regridding tool to +verify the result, like cdo or s2dv::CDORemap. Here is an example using easyNCDF and +CDORemap() to get the transformed data of file "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc". +```r +library(easyNCDF) +file <- NcOpen("/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc") +arr <- NcToArray(file, + dim_indices = list(time = 1, ensemble = 1, + latitude = 1:640, longitude = 1:1296), + vars_to_read = 'tas') +lats <- NcToArray(file, + dim_indices = list(latitude = 1:640), vars_to_read = 'latitude') +lons <- NcToArray(file, + dim_indices = list(longitude = 1:1296), vars_to_read = 'longitude') +NcClose(file) + +res <- s2dv::CDORemap(arr, lons = as.vector(lons), lats = as.vector(lats), + grid = 'r100x50', method = 'con', crop = FALSE) +dim(res$data_array) +# var time ensemble latitude longitude +# 1 1 1 50 100 + +head(res$lons) +#[1] 0.0 3.6 7.2 10.8 14.4 18.0 + +head(res$lats) +#[1] -88.2 -84.6 -81.0 -77.4 -73.8 -70.2 + +``` diff --git a/inst/doc/faq.md b/inst/doc/faq.md index 83676f37b3c0cc0c2f810bc2614ee2c0af0f2a3e..fbf2efbc098210a04abd1d5a35cd207638e8521c 100644 --- a/inst/doc/faq.md +++ b/inst/doc/faq.md @@ -24,7 +24,10 @@ This document intends to be the first reference for any doubts that you may have 18. [Use glob expression '*' to define the file path](#18-use-glob-expression-to-define-the-file-path) 19. [Get metadata when the first file does not exist](#19-get-metadata-when-the-first-file-does-not-exist) 20. [Use 'metadata_dims' to retrieve variable metadata](#20-use-metadata_dims-to-retrieve-variable-metadata) - 21. [Retrieve the complete data when the dimension length varies among files](#21-retrieve-the-complete-data-when-the-dimension-length-varies-among-files) + 21. [Retrieve the complete data when the dimension length varies among files](#21-retrieve-the-complete-data-when-the-dimension-length-varies-among-files) + 22. [Define the selector when the indices in the files are not aligned](#22-define-the-selector-when-the-indices-in-the-files-are-not-aligned) + 23. [The best practice of using vector and list for selectors](#23-the-best-practice-of-using-vector-and-list-for-selectors) + 24. [Do both interpolation and chunking on spatial dimensions](#24-do-both-interpolation-and-chunking-on-spatial-dimensions) 2. **Something goes wrong...** @@ -321,7 +324,7 @@ If you want to do the interpolation within Start(), you can use the following fo 4. **`transform_extra_cells`**: A numeric indicating the number of grid cell to extend from the borders if the interpolating region is a subset of the whole region. 2 as default, which is consistent with the method in s2dverification::Load(). You can find an example script here [ex1_1_tranform.R](/inst/doc/usecase/ex1_1_tranform.R) -You can see more information in s2dverification::CDORemap documentation [here](https://earth.bsc.es/gitlab/es/s2dverification/blob/master/man/CDORemap.Rd). +You can see more information in s2dverification::CDORemap documentation [here](https://earth.bsc.es/gitlab/es/s2dverification/blob/master/man/CDORemap.Rd). ### 6. Get data attributes without retrieving data to workstation @@ -855,6 +858,111 @@ adopt the provided ones and use the first valid file to decide the rest of dimen By this means, the efficiency can be similar to `largest_dims_length = FALSE`. +### 22. Define the selector when the indices in the files are not aligned +When the data structure between the requested files is not identical, we need to give different +selectors to each file. We can do this by using arrays as the selector and with the parameter +'return_vars' being well-defined. There are two scenarios: (1) different between datasets (2) different along certain file dim. + +(1) Different between datasets +We don't need (and can't) to define the selectors with pattern dim as the dimension. We can use +the value as the selector and specify `return_vars = list( = 'dat')`. By 'return_vars', +Start() knows that this inner_dim differs among the datasets so it examines all the files to get +the correct values. See more details of 'return_vars' at [How-to-16](#16-use-parameter-return_vars-in-start). + +For example, the two datasets, Hadgem3 and NorCPM1, have different initial dates. Hadgem3 initiates +in November while NorCPM1 in October. To retrieve them aligned, we can define the time selector +with the value "2000-11-16 UTC" and define 'return_vars' properly. + +```r +# HadGEM3 (initialised in November) +# NorCPM1 (initialised in October) + +data <- Start(dat = list(list(name = 'hadgem3', path = path_hadgem3), + list(name = 'norcpm1', path = path_norcpm1)), + var = 'tas', + sdate = '2000', + time = as.POSIXct("2000-11-16", tz = 'UTC'), + lat = 'all', + lon = 'all', + synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + return_vars = list(lat = 'dat', lon = 'dat', + time = 'dat'), + retrieve = TRUE) + +``` + +(2) Different along certain file dim +If the difference of indices is among the files in the same dataset, we can use the array with +named dimensions +to define the selector, and define 'return_vars' with the file dim along which the indices differ. + +For example, the 'region' number in the earlier experiments (sdate < 2013) is less than the later experiments (sdate = 2013), +making some regions have different indices between the experiments. The region selector array +should be two-dimensional, with one dimension 'sdate' and the other 'region'. The value of the +array can be either the character string of the region name or the indices in each sdate. +Besides, the dependency should be specified by `return_vars = list(region = 'sdate')`. + +```r +# 'Nino3' in 1st sdate file is index 9 while in 2nd sdate file is index 11 +# Either define with 'Nino3' or the corresponding index works +region <- array('Nino3', dim = c(sdate = 2, region = 1)) +region <- array(c(indices(9), indices(11)), dim = c(sdate = 2, region = 1)) + +data <- Start(dat = path, + var = 'tosmean', + sdate = c('1993', '2013'), + chunk = 'all', + chunk_depends = 'sdate', + region = region, + time = 'all', + time_across = 'chunk', + merge_across_dims = TRUE, + return_vars = list(time = c('sdate', 'chunk'), + region = 'sdate'), + retrieve = T) +``` + +### 23. The best practice of using vector and list for selectors +There are three ways to define the selectors in Start(): `indices()`, `values()`, and character string +like 'all', 'first', and 'last'. For `indices()` and `values()`, we can put either a vector or a list +in them (here we talk about the common cases, not including the dependency case mentioned in how-to-22 above.) + +For file dimensions, it is common to simply define the selectors by a vector of character string +(which belongs to `values()` but `values()` can be ommitted), e.g., `sdate = c('200001', '200002')`; `var = 'tas'`. +You can also use a vector of indices, but you cannot gurantee the files you get is the desired one +since the file order in the repository may change. + +For inner dimensions, it is recommended using "list of 2 values" or "vector of indices". +The main difference between vector and list is that the vector looks for the exact or closest +(could be larger or smaller) value in the data while the list looks for the data falling between the two numbers in the list. +You can assign all the indices needed by a vector, e.g., `time = indices(1:12)`, or give a range +that covers all the data needed by a list of 2, e.g., `lon = values(list(0, 30))`. +Note that `lon = values(list(0, 30))` means the data between 0 degE and 30 degE is taken; on the +other hand, `lon = indices(list(0, 30))` means that index 0 to index 30 of lon is taken (and it +will return an error in this case because there is no index 0.) + +In conclusion, if you know the exact values or indices of the selector, you can use vector of values or indices; if not, usually for longitude and latitude, it is better to use list of 2 values instead. + + +### 24. Do both interpolation and chunking on spatial dimensions +If all other dimensions are used as target dimensions in the operation, it would be necessary to +to chunk the spatial dimensions. The chunking can be done even if regridding is also required in +Start() (See those transform arguments at [how-to-5](#5-do-interpolation-in-start-using-parameter-transform), and the script has no difference with chunking other dimensions. +However, there are some things you need to bear in mind when using startR in this way. + +The regridding function provided by startR is CDORemapper(), which is a wrapper function of s2dv::CDORemap; +and CDORemap() uses cdo inside. Therefore, the regridding of startR has the same performance as cdo. +The errors due to transformation at borders may increase by chunking because it produces more +borders. For example, if `longitude = indices(1:20)` is chunked by 2, the first chunk will be indices(1:10) and the second chunk will be indices(11:20). Therefore, we have borders at 0, 10, 11, and 20. +In most cases, the border errors can be eliminated by increasing the number of extra cells (argument `transform_extra_cells` in Start()). With enough extra cells, the result will be identical as +global regridding. + +However, there are many factors that may impact the results of regridding, like the `crop` option, +the way to define the longitude/latitude selectors, etc. It is important to know how CDO works and +the usage of those parameters to avoid unecessary errors. +We provide some [use cases](inst/doc/usecase/ex2_12_transform_and_chunk.R) showing the secure ways of transformation + chunking. + + # Something goes wrong... ### 1. No space left on device diff --git a/inst/doc/usecase.md b/inst/doc/usecase.md index 06f2c044eb64673cedaf1141a00c0cc69bc2b5b5..013b47a3c159be2931b3b2c24b47857f2e254525 100644 --- a/inst/doc/usecase.md +++ b/inst/doc/usecase.md @@ -12,13 +12,14 @@ In this document, you can link to the example scripts for various demands. For t data is one file per year, each file contains 12 months (time = 12). However, observational data is one file per month, each file contains only one time step. You can learn how to select all the required year and month for observation, and - tweak the dimension to make it consistent with experiment. + twist the dimensions to make them consistent with experiment. The highlight paramters used in this usecase are: **'*_across'**, **'merge_across_dims'**, and **'split_multiselected_dims'**. 3. [Use experimental data attribute to load in oberservational data](inst/doc/usecase/ex1_3_attr_loadin.R) Like ex1_2, it shows how to retrieve the experimental data and observational data in a comparable structure. It also shows how to use parameters `xxx_tolerance`, `xxx_across`, `merge_across_dims`, `merge_across_dims_narm`, and `split_multiselected_dims`. +It is recommended reading ex1_2 first since there is more explanation. 4. [Checking impact of start date order in the number of members](inst/doc/usecase/ex1_4_variable_nmember.R) Mixing start dates of different months can lead to load different number of members, check the code provided and the [FAQ 10](/inst/doc/faq.md). @@ -54,6 +55,16 @@ You can find more explanation in FAQ [How-to-20](inst/doc/faq.md#20-use-metadata This script shows how to load and plot data in rotated coordinates using **Monarch-dust** simulations. + 13. [Use value array as selector to express dependency](inst/doc/usecase/ex1_13_implicit_dependency.R) + This script shows how to use a value array as the inner dimension selector to express +dependency on a file dimension. By this means, we do not need to specify the *_across +parameter and Start() can recognize this dependecy relationship. + + 14. [Specify the dependency between file dimensions](inst/doc/usecase/ex1_14_file_dependency.R) + This script shows how to define the dependency between file dimensions. Note that ex1_13 is for +the dependency between one inner dimension and one file dimension (i.e., the usage of *_across), while +this use case is for two file dimensions (i.e., the usage of *_depends). + 2. **Execute computation (use `Compute()`)** 1. [Function working on time dimension](inst/doc/usecase/ex2_1_timedim.R) 2. [Function using attributes of the data](inst/doc/usecase/ex2_2_attr.R) @@ -72,8 +83,9 @@ You can find more explanation in FAQ [How-to-20](inst/doc/faq.md#20-use-metadata 10. [Apply an existing mask on data](inst/doc/usecase/ex2_10_existing_mask.R) This use case shows you how to apply the existing mask file on your data. If you need to create the mask file on your own, go to ex2_9_mask.R. - - - + 11. [Two datasets with different length of target dimensions](inst/doc/usecase/ex2_11_two_dat_inconsistent_target_dim.R) + This use case uses experimental and the corresponding observational data to calculate +the temporal mean and spatial weighted mean. Notice that the spatial resolutions of the two +datasets are different, but it still works because lat and lon are target dimensions. diff --git a/inst/doc/usecase/ex1_13_implicit_dependency.R b/inst/doc/usecase/ex1_13_implicit_dependency.R new file mode 100644 index 0000000000000000000000000000000000000000..1ea9381e53a225612e295b526656910702456503 --- /dev/null +++ b/inst/doc/usecase/ex1_13_implicit_dependency.R @@ -0,0 +1,88 @@ +# Author: An-Chi Ho +# Date: 13th July 2021 +#--------------------------------------------------------------------- +# This script shows how to use a value array as the inner dimension selector to express +# dependency on a file dimension. By this means, we don't need to specify the *_across +# parameter and Start() can recognize this dependecy relationship. +# In the first case, 'time' is dependent on 'sdate'. We create the actual time values +# for each sdate beforehand. The time array is two-dimensional with the names 'time' +# and 'sdate'. +# In the second case, 'region' is dependent on 'sdate'. The two files have different +# index for Nino3. sdate 1993 has 'Nino3' at index 9 while sdate 2013 has 'Nino3' at +# index 11. Create a value array for region selector so Start() can look for 'Nino3' in +# each file. +#--------------------------------------------------------------------- + +library(startR) +library(lubridate) + +# Case 1: 'time' depends on 'sdate' +repos <- '/esarchive/exp/ecmwf/system4_m1/daily_mean/$var$_f24h/$var$_$sdate$.nc' + +sdates <- ymd("20010501") + rep(years(0:2), each = 1) +times <- array(ymd("20010501") + days(0:30) + rep(years(0:2), each = 31), + dim = c(time = 31, sdate = 3)) +times <- as.POSIXct(times * 86400, tz = 'UTC', origin = '1970-01-01') + +exp <- Start(dat = repos, + var = 'tos', + sdate = format(sdates, "%Y%m%d"), + time = times, #dim: [time = 31, sdate = 3]. time is corresponding to each sdate + ensemble = indices(1:5), + lat = 'all', + lon = 'all', + synonims = list(lat = c('lat', 'latitude'), + lon = c('lon', 'longitude')), + return_vars = list(lon = NULL, lat = NULL, time = 'sdate'), + retrieve = T) + +dim(exp) +# dat var sdate time ensemble lat lon +# 1 1 3 31 5 256 512 + +exp[1, 1, 2, 1:10, 1, 100, 100] +# [1] 302.1276 302.1346 302.2003 302.2121 302.2552 302.3312 302.3184 302.3507 +# [9] 302.3665 302.3865 + +summary(exp) +# Min. 1st Qu. Median Mean 3rd Qu. Max. NA's +# 271 274 287 287 299 305 19757385 + +#============================================================================= + +# Case 2: 'region' depends on 'sdate' +path <- paste0('/esarchive/exp/ecearth/a35b/diags/DCPP/EC-Earth-Consortium/', + 'EC-Earth3-HR/dcppA-hindcast/r1i1p1f1/Omon/$var$_mixed/gn/v20201107/', + '$var$_Omon_EC-Earth3-HR_dcppA-hindcast_s$sdate$-r1i1p1f1_gn_$chunk$.nc') + +region <- array('Nino3', dim = c(sdate = 2, region = 1)) + +data <- Start(dat = path, + var = 'tosmean', + sdate = c('1993', '2013'), + chunk = indices(1:2), + chunk_depends = 'sdate', + region = region, + time = 'all', + time_across = 'chunk', + merge_across_dims = TRUE, + return_vars = list(time = c('sdate', 'chunk'), + region = 'sdate'), + retrieve = T) + +dim(data) +# dat var sdate region time +# 1 1 2 1 2 + +data[1, 1, , 1, ] +# [,1] [,2] +#[1,] 24.98788 24.46488 # --> region index 9 in original file +#[2,] 24.47482 24.75953 # --> region index 11 in orginal file + + + + + + + + diff --git a/inst/doc/usecase/ex1_14_file_dependency.R b/inst/doc/usecase/ex1_14_file_dependency.R new file mode 100644 index 0000000000000000000000000000000000000000..95cc3daa50bdd9ee03f09fb8c0e8e880f6669664 --- /dev/null +++ b/inst/doc/usecase/ex1_14_file_dependency.R @@ -0,0 +1,80 @@ +# Author: An-Chi Ho +# Date: 13th July 2021 +#-------------------------------------------------------------------------------- +# This script shows how to define the dependency between file dimensions. +# Note that ex1_13 is for the dependency between one inner dimension and one file +# dimension (i.e., the usage of *_across), while this use case is for two file +# dimensions (i.e., the usage of *_depends). + +# The first case simply use indices() or 'all' to define the depending file dimension. +# In the second case, we use values() to define both the depended and depending +# dimensions. The depending dimension should be a list with names that are the values +# of depended dimensions. +#-------------------------------------------------------------------------------- + +library(startR) + +path <- paste0('/esarchive/exp/CMIP6/dcppA-hindcast/hadgem3-gc31-mm/', + 'cmip6-dcppA-hindcast_i1p1/DCPP/MOHC/HadGEM3-GC31-MM/dcppA-hindcast/', + 'r1i1p1f2/Omon/tos/gn/v20200417/', + '$var$_Omon_HadGEM3-GC31-MM_dcppA-hindcast_s$sdate$-r1i1p1f2_gn_$chunk$.nc') + +sdates <- c('2016', '2017', '2018') + +# Case 1: Define the depending dimension ('chunk') by indices or 'all' + +data1 <- Start(dat = path, + var = 'tos', + sdate = sdates, + chunk = indices(2:4), # 'all' if you want to read all the files + chunk_depends = 'sdate', + time = 'all', + i = indices(450:500), + j = indices(650:700), + time_across = 'chunk', + merge_across_dims = TRUE, + return_vars = list(time = 'sdate'), + retrieve = TRUE) + + +dim(data1) +# dat var sdate time i j +# 1 1 3 36 51 51 +data1[1, 1, 1:3, 1:5, 1, 1] +# [,1] [,2] [,3] [,4] [,5] +#[1,] 29.26021 29.73614 29.67156 29.61240 29.59503 +#[2,] 29.37948 29.38624 29.73120 29.97264 29.89160 +#[3,] 30.43721 30.58396 30.06479 30.51131 29.81269 + +#===================================================================== + +# Case 2: Define the depended ('sdate') and depending ('chunk') dimensions by values +sdates <- c('2016', '2017', '2018') +chunks <- array(dim = c(chunk = 3, sdate = 3)) +chunks[, 1] <- c("201701-201712", "201801-201812", "201901-201912") +chunks[, 2] <- c("201801-201812", "201901-201912", "202001-202012") +chunks[, 3] <- c("201901-201912", "202001-202012", "202101-202112") + + +data2 <- Start(dat = path, + var = 'tos', + sdate = sdates, + # the names should be the values of the depended dimension + chunk = list('2016' = chunks[, 1], '2017' = chunks[, 2], '2018' = chunks[ ,3]), + chunk_depends = 'sdate', + time = 'all', + i = indices(450:500), + j = indices(650:700), + time_across = 'chunk', + merge_across_dims = TRUE, + return_vars = list(time = 'sdate'), + retrieve = TRUE) + +dim(data2) +# dat var sdate time i j +# 1 1 3 36 51 51 + +all.equal(as.vector(data1), as.vector(data2)) +#[1] TRUE + + diff --git a/inst/doc/usecase/ex1_2_exp_obs_attr.R b/inst/doc/usecase/ex1_2_exp_obs_attr.R index 2e4b5da965ba642081bf0e362c7b873004f9d9e7..fa2323d6aaa5ace57195ea52e127a8ad1fa1b3c7 100644 --- a/inst/doc/usecase/ex1_2_exp_obs_attr.R +++ b/inst/doc/usecase/ex1_2_exp_obs_attr.R @@ -1,14 +1,24 @@ #--------------------------------------------------------------------- # This script tells you how to load experimental and observational data in a -# consistent way, facilating the following comparison. - -# First, we load the experimental data. Because the latitude order of observation -# is opposite with experiment, and the sdate/time dimension is also different, we -# use the attributes (sdate and latitude) of experimental data to define the -# selectors for observation. - -# You can see how to use parameter '*_across', 'merge_across_dims', and -# 'split_multiselected_dims' to create the consistent dimension as experiment. +# consistent way, facilating the following comparison. We use the attributes of +# the experimental data to define the selectors of obs Start() call, so they +# can have the same dimension structure. + +# Spatial dimensions: +# The exp and obs data happen to have the same spatial resolution (256x512) and +# the grids are not shifted, so we don't need to regrid them. However, their latitude +# orders are opposite. exp has ascending order while obs has descending order. +# To make them consistent, we cannot simply use 'all' as the selector of obs because +# for now, the reordering parameter '*_Sort' is only functional when the dimension is +# defined by values(). We can use either `indices(256:1)` or the exp attributes (`values()`) +# to define the latitude of obs. + +# Temporal dimensions: +# The exp and obs files have different date/time structure. exp has one file per year and +# each file has 12 time steps. obs has one file per month and each file has 1 time step. +# To shape the obs array as exp, we need to use the time attribute of exp to define +# the date/time selector of obs. You can see how to use parameter '*_across', 'merge_across_dims', +# and 'split_multiselected_dims' to achieve the goal. #--------------------------------------------------------------------- library(startR) @@ -31,30 +41,41 @@ exp <- Start(dat = repos_exp, time = 'sdate'), retrieve = FALSE) -# Retrieve attributes for the following observation. -# Because latitude order in experiment is [-90, 90] but in observation is [90, -90], -# latitude values need to be retrieved and used below. +attr(exp, 'Dimensions') +# dat var sdate time lat lon +# 1 1 4 3 256 512 + +# Retrieve attributes for observational data retrieval. +## Because latitude order in experiment is [-90, 90] but in observation is [90, -90], +## latitude values need to be retrieved and used below. lats <- attr(exp, 'Variables')$common$lat -# The 'time' attribute is dependent on 'sdate'. You can see the dimension below. +lons <- attr(exp, 'Variables')$common$lon +## The 'time' attribute is a two-dim array dates <- attr(exp, 'Variables')$common$time -# dim(dates) +dim(dates) #sdate time # 4 3 +dates +# [1] "2005-01-16 12:00:00 UTC" "2006-01-16 12:00:00 UTC" +# [3] "2007-01-16 12:00:00 UTC" "2008-01-16 12:00:00 UTC" +# [5] "2005-02-15 00:00:00 UTC" "2006-02-15 00:00:00 UTC" +# [7] "2007-02-15 00:00:00 UTC" "2008-02-15 12:00:00 UTC" +# [9] "2005-03-16 12:00:00 UTC" "2006-03-16 12:00:00 UTC" +#[11] "2007-03-16 12:00:00 UTC" "2008-03-16 12:00:00 UTC" #------------------------------------------- # obs -# 1. For lat, use experiment attribute. For lon, it is not necessary because they have -# same values. -# 2. For dimension 'date', it is a vector involving the first 3 months (ftime) of the four years (sdate). -# 3. Dimension 'time' is assigned by the matrix, so we can seperate 'sdate' and 'time' -# using 'split_multiselected_dims' later. -# 4. Because the 'time' is actually across all the files, so we need to specify -# 'time_across'. Then, use 'merge_across_dims' to make dimension 'date' disappears. +# 1. For lat, use the experiment attribute or reversed indices. For lon, it is not necessary +# because their lons are identical, but either way works. +# 2. For dimension 'date', it is a vector involving the 3 months (ftime) of the four years (sdate). +# 3. Dimension 'time' is assigned by the matrix, so we can split it into 'sdate' and 'time' +# by 'split_multiselected_dims'. +# 4. Because 'time' is actually across all the files, so we need to specify 'time_across'. +# Then, use 'merge_across_dims' to make dimension 'date' disappears. # At this moment, the dimension is 'time = 12'. # 5. However, we want to seperate year and month (which are 'sdate' and 'ftime' in -# experimental data). So we use 'split_multiselected_dims' to split the two dimensions -# of dimension 'time'. +# experimental data). So we use 'split_multiselected_dims' to split 'time' into the two dimensions. repos_obs <- '/esarchive/recon/ecmwf/erainterim/monthly_mean/$var$_f6h/$var$_$date$.nc' @@ -62,8 +83,8 @@ obs <- Start(dat = repos_obs, var = 'tas', date = unique(format(dates, '%Y%m')), time = values(dates), #dim: [sdate = 4, time = 3] - lat = values(lats), - lon = 'all', + lat = values(lats), # indices(256:1), + lon = values(lons), # 'all', time_across = 'date', merge_across_dims = TRUE, split_multiselected_dims = TRUE, @@ -74,9 +95,13 @@ obs <- Start(dat = repos_obs, time = 'date'), retrieve = FALSE) -#========================== -# Check attributes -#========================== +attr(obs, 'Dimensions') +# dat var sdate time lat lon +# 1 1 4 3 256 512 + +#==================================================== +# Check the attributes. They should be all identical. +#==================================================== ##-----dimension----- print(attr(exp, 'Dimensions')) @@ -87,7 +112,8 @@ print(attr(obs, 'Dimensions')) # dat var sdate time lat lon # 1 1 4 3 256 512 -##-----time----- +##-----time----- +## They're not identical but the years and months are. See below for more details. print(attr(exp, 'Variables')$common$time) # [1] "2005-01-16 12:00:00 UTC" "2006-01-16 12:00:00 UTC" # [3] "2007-01-16 12:00:00 UTC" "2008-01-16 12:00:00 UTC" @@ -114,3 +140,92 @@ print(attr(obs, 'Variables')$common$lat[1:3]) print(attr(obs, 'Variables')$common$lat[256]) #[1] 89.46282 +##-----lon----- +print(attr(exp, 'Variables')$common$lon[1:3]) +#[1] 0.000000 0.703125 1.406250 +print(attr(obs, 'Variables')$common$lon[1:3]) +#[1] 0.000000 0.703125 1.406250 + + +#======================= +# About time attributes +#======================= +# You may notice that the date and time of exp and obs are not the same. +# In this case, the data are monthly data, so only the years and months matter. +# The thing worth noticing is that the actual time values of obs are half month different +# from the values we assigned. For example, the first time from exp is "2005-01-16 12:00:00 UTC", +# and the obs time we get is "2005-01-31 18:00:00 UTC". +# If the provided selector is value, Start() looks for the closest value in the data. +# So for "2005-01-16 12:00:00 UTC", the two closest obs values are "2004-12-31 18:00:00 UTC" and +# "2005-01-31 18:00:00 UTC", and the later one is the closest and happen to be the desired one. +# It's fortunate that in this case, all the provided values are closer to the values we want. + +#----- 1. Manually adjust the values ----- +# It is always necessary to check the data attributes before and after data retrieval. +# If the provided exp values are quite in the middle of two values in obs, we can adjust a bit to +# make exp values closer to the desired obs values. +dates_adjust <- dates + 86400*15 +dates_adjust +# [1] "2005-01-31 12:00:00 UTC" "2006-01-31 12:00:00 UTC" +# [3] "2007-01-31 12:00:00 UTC" "2008-01-31 12:00:00 UTC" +# [5] "2005-03-02 00:00:00 UTC" "2006-03-02 00:00:00 UTC" +# [7] "2007-03-02 00:00:00 UTC" "2008-03-01 12:00:00 UTC" +# [9] "2005-03-31 12:00:00 UTC" "2006-03-31 12:00:00 UTC" +#[11] "2007-03-31 12:00:00 UTC" "2008-03-31 12:00:00 UTC" + +obs2 <- Start(dat = repos_obs, + var = 'tas', + date = unique(format(dates, '%Y%m')), + time = values(dates_adjust), # use the adjust ones + lat = values(lats), + lon = values(lons), + time_across = 'date', + merge_across_dims = TRUE, + split_multiselected_dims = TRUE, + synonims = list(lat = c('lat', 'latitude'), + lon = c('lon', 'longitude')), + return_vars = list(lon = NULL, + lat = NULL, + time = 'date'), + retrieve = FALSE) + +# The time should be the same as obs above. +print(attr(obs2, 'Variables')$common$time) +# [1] "2005-01-31 18:00:00 UTC" "2006-01-31 18:00:00 UTC" +# [3] "2007-01-31 18:00:00 UTC" "2008-01-31 18:00:00 UTC" +# [5] "2005-02-28 18:00:00 UTC" "2006-02-28 18:00:00 UTC" +# [7] "2007-02-28 18:00:00 UTC" "2008-02-29 18:00:00 UTC" +# [9] "2005-03-31 18:00:00 UTC" "2006-03-31 18:00:00 UTC" +#[11] "2007-03-31 18:00:00 UTC" "2008-03-31 18:00:00 UTC" + +#----- 2. Set the tolerance ----- +# Sometimes, it may be useful to set the tolerance. If the provided values are too much different +# from the values in obs, Start() returns an error directly (if none of the data found) or returns +# incorrect time attributes. + +obs3 <- Start(dat = repos_obs, + var = 'tas', + date = unique(format(dates, '%Y%m')), + time = values(dates), + lat = values(lats), + lon = values(lons), + time_across = 'date', + time_tolerance = as.difftime(15, units = 'days'), + merge_across_dims = TRUE, + split_multiselected_dims = TRUE, + synonims = list(lat = c('lat', 'latitude'), + lon = c('lon', 'longitude')), + return_vars = list(lon = NULL, + lat = NULL, + time = 'date'), + retrieve = FALSE) + +# We lose many data because there are no data within 15 days from the provided time values. +print(attr(obs3, 'Variables')$common$time) +[1] "2005-02-28 18:00:00 UTC" "2006-02-28 18:00:00 UTC" +[3] "2007-02-28 18:00:00 UTC" "2008-02-29 18:00:00 UTC" + +# If 'time_tolerance' is changed to "as.difftime(1, units = 'days')", an error shows: +# Selectors do not match any of the possible values for the dimension 'time'. + + diff --git a/inst/doc/usecase/ex1_3_attr_loadin.R b/inst/doc/usecase/ex1_3_attr_loadin.R index e2c821117a82612e842d29d3a90cdf3869f5c2cd..427b12cb53dbce815ba57b950283bcb4a2e19c4c 100644 --- a/inst/doc/usecase/ex1_3_attr_loadin.R +++ b/inst/doc/usecase/ex1_3_attr_loadin.R @@ -2,11 +2,16 @@ # This usecase shows you how to load experimental and observational data in a # consistent way. -# First, load the experimental data. Then, use the time attributes of experimental data to define the selectors for observational data. +# First, load the experimental data. Then, use the time attributes of experimental data to +# define the selectors for observational data. # You can see how to use parameter '*_across', 'merge_across_dims', 'merge_across_dims_narm', # and 'split_multiselected_dims' to create the same dimension structure. + +# If you haven't read ex1_2, it is recommended reading it first since there is more explanation. #--------------------------------------------------------------------- +library(startR) +library(easyNCDF) # experimental data # May to December 1994, monthly file with 6-hourly frequency @@ -25,17 +30,12 @@ longitude = NULL, time = c('sdate'))) -#-------- Check exp data ----------- - attr(system4, 'Dimensions') -# dat var sdate time ensemble latitude longitude -# 1 1 8 31 51 10 10 -#----------------------------------- -# ------- retrieve the attributes for obs load-in ---------- - dates <- attr(system4, 'Variables')$common$time -# dim(dates) -#sdate time -# 8 31 +# retrieve the attributes for obs load-in +dates <- attr(system4, 'Variables')$common$time +dim(dates) +# sdate time +# 8 31 # NOTE: Even though June, September, and November only have 30 days, it reads # 31 days for each month. Therefore, the last day of these months is the @@ -46,6 +46,7 @@ substr, 1, 7)))) # dates_file #[1] "199405" "199406" "199407" "199408" "199409" "199410" "199411" "199412" + # ----------------------------------------------------------- # observational data @@ -79,36 +80,27 @@ # If the NAs are not removed, unwanted NAs will exist and make the # values misplaced in the array. -#------- Check erai ----------- + +#-------------------------------------------------------- +# Check data +#-------------------------------------------------------- + +# (0) +attr(system4, 'Dimensions') +# dat var sdate time ensemble latitude longitude +# 1 1 8 31 51 10 10 dim(erai) # dat var sdate time latitude longitude # 1 1 8 31 10 10 -erai[1, 1, 1, , 1, 1] -# [1] 255.0120 256.8095 254.3654 254.6059 257.0551 255.5087 256.8167 257.9717 -# [9] 258.7491 259.2942 259.6682 260.7215 260.0988 261.2605 263.3590 265.6683 -#[17] 262.4813 262.6136 263.0591 262.8377 261.7276 263.9910 264.7755 266.0213 -#[25] 268.5927 267.8699 268.9210 269.4702 267.6735 267.9255 268.2216 - -erai[1, 1, , 1, 2, 2] -#[1] 254.5793 269.6221 274.5021 274.0269 269.5855 253.7458 243.9750 244.2415 - -# NOTE: You will see that the observation array is the same as experiment one -# that the last day in 30-day months are the first day of the following -# month. -erai[1, 1, 3, 1, 1, 1] # 1st March -#[1] 274.6019 -erai[1, 1, 2, 31, 1, 1] # 1st March also, since June only has 30 days -#[1] 274.6019 -#------------------------------ - -# The experimental and observational data are comparable with same structure. +# --> The experimental and observational data are comparable with same structure. -#---------Check time attributes-------- dim(attr(erai, 'Variables')$common$time) #file_date time # 8 31 -attr(erai, 'Variables')$common$time[1, ] + +# (1) +dates[1, ] # [1] "1994-05-01 UTC" "1994-05-02 UTC" "1994-05-03 UTC" "1994-05-04 UTC" # [5] "1994-05-05 UTC" "1994-05-06 UTC" "1994-05-07 UTC" "1994-05-08 UTC" # [9] "1994-05-09 UTC" "1994-05-10 UTC" "1994-05-11 UTC" "1994-05-12 UTC" @@ -117,7 +109,29 @@ attr(erai, 'Variables')$common$time[1, ] #[21] "1994-05-21 UTC" "1994-05-22 UTC" "1994-05-23 UTC" "1994-05-24 UTC" #[25] "1994-05-25 UTC" "1994-05-26 UTC" "1994-05-27 UTC" "1994-05-28 UTC" #[29] "1994-05-29 UTC" "1994-05-30 UTC" "1994-05-31 UTC" -attr(erai, 'Variables')$common$time[2, ] + +# The following values should belong to the above times. +erai[1, 1, 1, , 1, 1] +# [1] 255.0120 256.8095 254.3654 254.6059 257.0551 255.5087 256.8167 257.9717 +# [9] 258.7491 259.2942 259.6682 260.7215 260.0988 261.2605 263.3590 265.6683 +#[17] 262.4813 262.6136 263.0591 262.8377 261.7276 263.9910 264.7755 266.0213 +#[25] 268.5927 267.8699 268.9210 269.4702 267.6735 267.9255 268.2216 + +# Use easyNCDF to read netCDF files and compare to erai. +file199405 <- NcOpen('/esarchive/recon/ecmwf/erainterim/6hourly/tas/tas_199405.nc') +obs199405 <- NcToArray(file199405, vars_to_read = 'tas', + dim_indices = list(longitude = 1, latitude = 1, time = seq(1, 4*31, 4))) +NcClose(file199405) +obs199405[1, 1, 1, ] +# [1] 255.0120 256.8095 254.3654 254.6059 257.0551 255.5087 256.8167 257.9717 +# [9] 258.7491 259.2942 259.6682 260.7215 260.0988 261.2605 263.3590 265.6683 +#[17] 262.4813 262.6136 263.0591 262.8377 261.7276 263.9910 264.7755 266.0213 +#[25] 268.5927 267.8699 268.9210 269.4702 267.6735 267.9255 268.2216 + +# --> CORRECT. + +# (2) +dates[2, ] # [1] "1994-06-01 UTC" "1994-06-02 UTC" "1994-06-03 UTC" "1994-06-04 UTC" # [5] "1994-06-05 UTC" "1994-06-06 UTC" "1994-06-07 UTC" "1994-06-08 UTC" # [9] "1994-06-09 UTC" "1994-06-10 UTC" "1994-06-11 UTC" "1994-06-12 UTC" @@ -125,7 +139,33 @@ attr(erai, 'Variables')$common$time[2, ] #[17] "1994-06-17 UTC" "1994-06-18 UTC" "1994-06-19 UTC" "1994-06-20 UTC" #[21] "1994-06-21 UTC" "1994-06-22 UTC" "1994-06-23 UTC" "1994-06-24 UTC" #[25] "1994-06-25 UTC" "1994-06-26 UTC" "1994-06-27 UTC" "1994-06-28 UTC" -#[29] "1994-06-29 UTC" "1994-06-30 UTC" NA - - +#[29] "1994-06-29 UTC" "1994-06-30 UTC" "1994-07-01 UTC" + +# The following values should belong to the above times. +erai[1, 1, 2, , 1, 1] +# [1] 269.9410 269.6855 268.7380 268.5008 270.3236 271.5151 270.5046 270.1686 +# [9] 270.5395 272.0379 272.5489 271.1494 270.7764 270.5678 272.0331 273.7856 +#[17] 273.9849 274.5904 273.4369 273.8404 274.4068 274.2292 274.7375 275.5104 +#[25] 275.4324 274.9408 274.8679 276.5602 275.0995 274.6409 274.6019 + +# Use easyNCDF to read netCDF files and compare to erai. +file199406 <- NcOpen('/esarchive/recon/ecmwf/erainterim/6hourly/tas/tas_199406.nc') +obs199406 <- NcToArray(file199406, vars_to_read = 'tas', + dim_indices = list(longitude = 1, latitude = 1, time = seq(1, 4*31, 4))) +NcClose(file199405) +obs199406[1, 1, 1, ] +# [1] 269.9410 269.6855 268.7380 268.5008 270.3236 271.5151 270.5046 270.1686 +# [9] 270.5395 272.0379 272.5489 271.1494 270.7764 270.5678 272.0331 273.7856 +#[17] 273.9849 274.5904 273.4369 273.8404 274.4068 274.2292 274.7375 275.5104 +#[25] 275.4324 274.9408 274.8679 276.5602 275.0995 274.6409 + +# --> CORRECT. + +# (3) +# NOTE that the observation array is the same as the experiment one that the +# last day in those 30-day months is the first day of the following month. +erai[1, 1, 3, 1, 1, 1] # 1st July +#[1] 274.6019 +erai[1, 1, 2, 31, 1, 1] # same as 1st July, since June only has 30 days +#[1] 274.6019 diff --git a/inst/doc/usecase/ex1_7_split_merge.R b/inst/doc/usecase/ex1_7_split_merge.R index 539a24d8051f796dff317d45b7630c926f8e3ec3..258be3398407ef854aac5971c9a4b7f730dfeb86 100644 --- a/inst/doc/usecase/ex1_7_split_merge.R +++ b/inst/doc/usecase/ex1_7_split_merge.R @@ -49,9 +49,9 @@ dim(dates) #----------------------------------------------------------------------- # If you need to reorder the dimensions of the 'time' selector, you can use -# s2dv::Reorder function. These two lines are not used in the following example. -library(s2dv) -dates <- Reorder(dates, c('syear', 'sdate', 'time')) +# s2dv::Reorder function. This line is not used in the following example. +# +# dates <- s2dv::Reorder(dates, c('syear', 'sdate', 'time')) #----------------------------------------------------------------------- #----------------------------------------------------------------------- @@ -84,30 +84,46 @@ obs <- Start(dat = path.obs, time = 'file_date'), retrieve = T) -# check obs data +#----------- Check data ---------------- +attr(hcst, 'Dimensions') +# dat var sdate syear time latitude longitude ensemble +# 1 1 2 3 12 10 10 11 dim(obs) # dat var latitude longitude sdate syear time # 1 1 10 10 2 3 12 -obs[1, 1, 1, 1, 2, 1:2, ] -# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] -#[1,] 4.402223 2.657466 7.296539 10.263944 6.367464 5.433421 3.021327 7.498292 -#[2,] 6.802123 7.110264 7.584915 4.255134 2.047740 3.619044 5.648496 8.322672 -# [,9] [,10] [,11] [,12] -#[1,] 15.321060 1.131008 6.326981 5.301850 -#[2,] 7.942419 7.594263 6.189313 7.627579 - -# check with ncdf4 + +# The dimension structure is the same as experimental one. + +#------------ Check if the data are placed correctly----------------- +# For example, [sdate = 2, syear = 1, time = 1:12] +dates[2, 1, ] +# [1] "1996-12-22 UTC" "1996-12-23 UTC" "1996-12-24 UTC" "1996-12-25 UTC" +# [5] "1996-12-26 UTC" "1996-12-27 UTC" "1996-12-28 UTC" "1996-12-29 UTC" +# [9] "1996-12-30 UTC" "1996-12-31 UTC" "1997-01-01 UTC" "1997-01-02 UTC" + +# obs at [sdate = 2, syear = 1, time = 1:12] should have data for the corresponding times. +# Use ncdf4 package to read the netCDF files and compare. + +obs[1, 1, 2, 3, 2, 1, ] +# [1] 4.565837 3.254213 5.710205 10.255745 5.809094 5.477635 3.184075 +# [8] 7.230077 14.662762 2.256792 6.470966 5.574388 + + +# NOTE: The following lines require much memory scpace. Run them on interactive session +# rather than workstation. library(ncdf4) file199612 <- nc_open('/esarchive/recon/ecmwf/era5/1hourly/sfcWind/sfcWind_199612.nc') wind199612 <- ncvar_get(file199612, 'sfcWind') file199701 <- nc_open('/esarchive/recon/ecmwf/era5/1hourly/sfcWind/sfcWind_199701.nc') wind199701 <- ncvar_get(file199701, 'sfcWind') -data_wanted_199612 <- seq(506, 722, 24) -wind199612[1, 1, data_wanted_199612] -# [1] 4.402223 2.657466 7.296539 10.263944 6.367464 5.433421 3.021327 -# [8] 7.498292 15.321060 1.131008 -data_wanted_199701 <- seq(2, 26, 24) -wind199701[1, 1, data_wanted_199701] -#[1] 6.326981 5.301850 +# The file has 1hr frequency and the dimensions are [lon, lat, time] +# 505 is 1996-12-22 0; 721 is 1996-12-31 0; etc. +wind199612[3, 2, seq(505, 721, by = 24)] +# [1] 4.565837 3.254213 5.710205 10.255745 5.809094 5.477635 3.184075 +# [8] 7.230077 14.662762 2.256792 + +wind199701[3, 2, c(1, 25)] +#[1] 6.470966 5.574388 +# The data of retrieved obs and netCDF are identical. diff --git a/inst/doc/usecase/ex1_8_tasandtos.R b/inst/doc/usecase/ex1_8_tasandtos.R index 38fdf956dfaf61618b04ab46fe9e7c2ccca95e0b..2c9e75e33fcfd9bd4aff9f1e8b56a33fb0c168d1 100644 --- a/inst/doc/usecase/ex1_8_tasandtos.R +++ b/inst/doc/usecase/ex1_8_tasandtos.R @@ -1,6 +1,7 @@ # ----------------------------------------------------- # Loading tas and tos for EC-Earth decadal predictions: # Authors: Carlos Delgado and Núria Pérez-Zanón +# Revised by An-Chi Ho on 4th Aug. 2021 # ------------------------------------------------------ # Three ways to load the same data are provided: @@ -9,97 +10,138 @@ # 3) two Start call (one for each path and variable) -# Case 1) returns dimensions 'dataset' and 'var' with length 2 , but only the positions of the diagonal are filled: -# tas is stored in {dataset = 1, var = 1} -# tos is stored in {dataset = 2, var = 2} -# NOTE!!! check {datastet = 1, var = 2} because an issue in ESMValTool:https://earth.bsc.es/gitlab/es/auto-ecearth3/issues/1258 +# Case 1: +# Return dimensions 'dataset' and 'var' with length 2, but only the positions of the diagonal +# are filled: +# = Amon/tas is stored in {dataset = 1, var = 1} +# = Omon/tos is stored in {dataset = 2, var = 2} +# We choose an ocean region (lon = 150:170; lat = 10:20) so 'tos' will have values. + +## NOTE!!! [dataset = 1, var = 2] has values because an issue in ESMValTool:https://earth.bsc.es/gitlab/es/auto-ecearth3/issues/1258. +## However, the file seems incorrect. tos shouldn't have values on land. But it is a file issue +## rather than Start()'s problem. library(startR) -paths = list(list(path = '/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consortium/EC-Earth3/dcppA-hindcast/$member$/Amon/$var$/gr/v20190713/$var$_Amon_EC-Earth3_dcppA-hindcast_s$sdate$-$member$_gr_$fyear$.nc'), - list(path = '/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consortium/EC-Earth3/dcppA-hindcast/$member$/Omon/$var$/gr/v20190713/$var$_Omon_EC-Earth3_dcppA-hindcast_s$sdate$-$member$_gr_$fyear$.nc')) -data1 <- Start(dataset = paths, - var = c('tas','tos'), +path_tas <- paste0('/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consortium/EC-Earth3/', + 'dcppA-hindcast/$member$/Amon/$var$/gr/v20190713/', + '$var$_Amon_EC-Earth3_dcppA-hindcast_s$sdate$-$member$_gr_$fyear$.nc') +path_tos <- paste0('/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consortium/EC-Earth3/', + 'dcppA-hindcast/$member$/Omon/$var$/gr/v20190713/', + '$var$_Omon_EC-Earth3_dcppA-hindcast_s$sdate$-$member$_gr_$fyear$.nc') + +data1 <- Start(dataset = list(list(path = path_tas), + list(path = path_tos)), + var = c('tas', 'tos'), sdate = paste0(1960:1962), fmonth = 1, - lat = values(list(0, 10)), - lon = values(list(0, 10)), + lat = values(list(10, 20)), + lat_reorder = Sort(), + lon = values(list(150, 170)), + lon_reorder = CircularSort(0, 360), fyear = 'all', member = indices(1), fyear_depends = 'sdate', fmonth_across = 'fyear', merge_across_dims = TRUE, - synonims = list(fmonth = c('fmonth','time'), + synonims = list(fmonth = c('fmonth', 'time'), lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + metadata_dims = c('dataset', 'var'), return_vars = list(lat = 'dataset', lon = 'dataset'), num_procs = 1, retrieve = TRUE) dim(data1) #dataset var sdate fmonth lat lon member -# 2 2 3 12 14 15 1 +# 2 2 3 1 15 28 1 # Check empty and filled dimensions: -sum(is.na(data1[1,1,,,,,])) == (3*12*14*15) -#[1] FALSE -sum(is.na(data1[1,2,,,,,])) == (3*12*14*15) -#[1] TRUE -sum(is.na(data1[2,2,,,,,])) == (3*12*14*15) -#[1] FALSE -sum(is.na(data1[2,1,,,,,])) == (3*12*14*15) -#[1] TRUE +sum(is.na(data1[1, 1, , , , , ])) +#[1] 0 +sum(is.na(data1[1, 2, , , , , ])) # It should be 1260 if Amon/tos doesn't exist +#[1] 0 +sum(is.na(data1[2, 1, , , , , ])) +#[1] 1260 +sum(is.na(data1[2, 2, , , , , ])) +#[1] 0 lat1 <- as.vector(attributes(data1)$Variables$dat1$lat) lon1 <- as.vector(attributes(data1)$Variables$dat1$lon) +# Check metadata. 'dat1' has 'tas' and 'tos'; 'dat2' has 'tos' +names(attr(data1, 'Variables')$common) +#[1] "fmonth" +names(attr(data1, 'Variables')$dat1) +#[1] "lat" "lon" "tas" "tos" +names(attr(data1, 'Variables')$dat2) +#[1] "lat" "lon" "tos" + # --------------------------------------------------------------- -# Case 2) using a single path, {dataset = 1, var = 2, type = 1} -# 'type' dimension is necessary to distinguish between 'Amon' and 'Omon'. +# Case 2: +# Use a single path, {dataset = 1, var = 2, type = 1}. +# 'type' dimension is necessary to distinguish between 'Amon' and 'Omon', and the dependency +# needs to be specified. library(startR) -path = '/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consortium/EC-Earth3/dcppA-hindcast/$member$/$type$/$var$/gr/v20190713/$var$_$type$_EC-Earth3_dcppA-hindcast_s$sdate$-$member$_gr_$fyear$.nc' +path <- paste0('/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consortium/EC-Earth3/', + 'dcppA-hindcast/$member$/$type$/$var$/gr/v20190713/', + '$var$_$type$_EC-Earth3_dcppA-hindcast_s$sdate$-$member$_gr_$fyear$.nc') data2 <- Start(dataset = path, var = c('tas', 'tos'), - type = 'all', + type = list('tas' = 'Amon', 'tos' = 'Omon'), type_depends = 'var', sdate = paste0(1960:1962), fmonth = 1, - lat = values(list(0, 10)), - lon = values(list(0, 10)), + lat = values(list(10, 20)), + lat_reorder = Sort(), + lon = values(list(150, 170)), + lon_reorder = CircularSort(0, 360), fyear = indices(1), member = indices(1), fyear_depends = 'sdate', fmonth_across = 'fyear', merge_across_dims = TRUE, - synonims = list(fmonth = c('fmonth','time'), + synonims = list(fmonth = c('fmonth', 'time'), lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + metadata_dims = 'var', return_vars = list(lat = 'dataset', lon = 'dataset'), num_procs = 1, retrieve = TRUE) dim(data2) -# dataset var type sdate fmonth lat lon member -# 1 2 1 3 1 14 15 1 +#dataset var type sdate fmonth lat lon member +# 1 2 1 3 1 15 28 1 +# Compare data1 and data2 +identical(as.vector(data1[1, 1, , 1, , , 1]), as.vector(data2[1, 1, 1, , 1, , , 1])) +#[1] TRUE +identical(as.vector(data1[2, 2, , 1, , , 1]), as.vector(data2[1, 2, 1, , 1, , , 1])) +#[1] TRUE # --------------------------------------------------------------- -# Case 3) Two different Start calls can save data_tas and data_tos both with {dataset = 1 and var = 1} dimensions and avoiding extra dimensions like 'type'. +# Case 3: +# Two different Start calls can save data_tas and data_tos both with {dataset = 1 and var = 1} +# dimensions and avoid extra dimensions like 'type'. -path = '/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consortium/EC-Earth3/dcppA-hindcast/$member$/Amon/$var$/gr/v20190713/$var$_Amon_EC-Earth3_dcppA-hindcast_s$sdate$-$member$_gr_$fyear$.nc' +path <- paste0('/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consortium/EC-Earth3/', + 'dcppA-hindcast/$member$/Amon/$var$/gr/v20190713/', + '$var$_Amon_EC-Earth3_dcppA-hindcast_s$sdate$-$member$_gr_$fyear$.nc') data_tas <- Start(dataset = path, var = 'tas', sdate = paste0(1960:1962), fmonth = 1, - lat = values(list(0, 10)), - lon = values(list(0, 10)), + lat = values(list(10, 20)), + lat_reorder = Sort(), + lon = values(list(150, 170)), + lon_reorder = CircularSort(0, 360), fyear = indices(1), member = indices(1), fyear_depends = 'sdate', fmonth_across = 'fyear', merge_across_dims = TRUE, - synonims = list(fmonth = c('fmonth','time'), + synonims = list(fmonth = c('fmonth', 'time'), lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), return_vars = list(lat = 'dataset', lon = 'dataset'), @@ -107,21 +149,25 @@ data_tas <- Start(dataset = path, dim(data_tas) #dataset var sdate fmonth lat lon member -# 1 1 3 1 14 15 1 +# 1 1 3 1 15 28 1 -path = '/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consortium/EC-Earth3/dcppA-hindcast/$member$/Omon/$var$/gr/v20190713/$var$_Omon_EC-Earth3_dcppA-hindcast_s$sdate$-$member$_gr_$fyear$.nc' +path <- paste0('/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consortium/EC-Earth3/', + 'dcppA-hindcast/$member$/Omon/$var$/gr/v20190713/', + '$var$_Omon_EC-Earth3_dcppA-hindcast_s$sdate$-$member$_gr_$fyear$.nc') data_tos <- Start(dataset = path, var = 'tos', sdate = paste0(1960:1962), fmonth = 1, - lat = values(list(0, 10)), - lon = values(list(0, 10)), + lat = values(list(10, 20)), + lat_reorder = Sort(), + lon = values(list(150, 170)), + lon_reorder = CircularSort(0, 360), fyear = indices(1), member = indices(1), fyear_depends = 'sdate', fmonth_across = 'fyear', merge_across_dims = TRUE, - synonims = list(fmonth = c('fmonth','time'), + synonims = list(fmonth = c('fmonth', 'time'), lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), return_vars = list(lat = 'dataset', lon = 'dataset'), @@ -129,15 +175,11 @@ data_tos <- Start(dataset = path, dim(data_tos) #dataset var sdate fmonth lat lon member -# 1 1 3 1 14 15 1 - -# --------------------------------------------------------------------- - -# Comparison cases 1) to 3): -#---------------------------------------------------------------------- +# 1 1 3 1 15 28 1 -all(data1[1, 1, , , , , ] == data_tas[1, 1, , , , , ]) -all((data1[2, 2, , , , , ]) == data_tos[1, 1, , , , , ], na.rm = TRUE) -all(data2[1, 1, 1, , , , , ] == data_tas[1, 1, , , , ,]) -all((data2[1, 2, 1, , , , , ]) == data_tos[1, 1, , , , , ], na.rm = TRUE) +# Compare with previous results +identical(as.vector(data2[1, 1, 1, , 1, , , 1]), as.vector(data_tas)) +#[1] TRUE +identical(as.vector(data2[1, 2, 1, , 1, , , 1]), as.vector(data_tos)) +#[1] TRUE diff --git a/inst/doc/usecase/ex2_11_two_dat_inconsistent_target_dim.R b/inst/doc/usecase/ex2_11_two_dat_inconsistent_target_dim.R new file mode 100644 index 0000000000000000000000000000000000000000..69267b06c60749b88c4ae0f1514ef0255e162955 --- /dev/null +++ b/inst/doc/usecase/ex2_11_two_dat_inconsistent_target_dim.R @@ -0,0 +1,125 @@ +# Author: Chihchung Chou, An-Chi Ho +# Date: 1st July 2021 +# ------------------------------------------------------------------ +# This use case uses experimental and the corresponding observational data to calculate +# the temporal mean and spatial weighted mean. Notice that the spatial resolutions of the +# two datasets are different, but it still works because lat and lon are target dimensions. +# ------------------------------------------------------------------ +library(startR) + + +# exp +repos_exp <- paste0('/esarchive/exp/ecearth/a1tr/cmorfiles/CMIP/EC-Earth-Consortium/', + 'EC-Earth3/historical/r24i1p1f1/Amon/$var$/gr/v20190312/', + '$var$_Amon_EC-Earth3_historical_r24i1p1f1_gr_$sdate$01-$sdate$12.nc') + +exp <- Start(dat = repos_exp, + var = 'tas', + sdate = as.character(c(2005:2008)), + time = indices(1:3), + lat = 'all', + lon = 'all', + synonims = list(lat = c('lat', 'latitude'), + lon = c('lon', 'longitude')), + return_vars = list(lon = NULL, + lat = NULL, + time = 'sdate'), + retrieve = FALSE) + +lons_exp <- as.vector(attr(exp, 'Variables')$common$lon) +lats_exp <- as.vector(attr(exp, 'Variables')$common$lat) +dates_exp <- attr(exp, 'Variables')$common$time + +attr(exp, 'Dimensions') +# dat var sdate time lat lon +# 1 1 4 3 256 512 +dates_exp +# [1] "2005-01-16 12:00:00 UTC" "2006-01-16 12:00:00 UTC" +# [3] "2007-01-16 12:00:00 UTC" "2008-01-16 12:00:00 UTC" +# [5] "2005-02-15 00:00:00 UTC" "2006-02-15 00:00:00 UTC" +# [7] "2007-02-15 00:00:00 UTC" "2008-02-15 12:00:00 UTC" +# [9] "2005-03-16 12:00:00 UTC" "2006-03-16 12:00:00 UTC" +#[11] "2007-03-16 12:00:00 UTC" "2008-03-16 12:00:00 UTC" + + +# obs + path.obs <- '/esarchive/recon/ecmwf/era5/monthly_mean/$var$_f1h-r1440x721cds/$var$_$date$.nc' + obs <- Start(dat = path.obs, + var = 'tas', + date = unique(format(dates_exp, '%Y%m')), + time = values(dates_exp), + time_across = 'date', + merge_across_dims = TRUE, + split_multiselected_dims = TRUE, + lat = 'all', + lon = 'all', + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude')), + return_vars = list(lon = NULL, + lat = NULL, + time = 'date'), + retrieve = FALSE) + +lons_obs <- as.vector(attr(obs, 'Variables')$common$lon) +lats_obs <- as.vector(attr(obs, 'Variables')$common$lat) +dates_obs <- attr(obs, 'Variables')$common$time + + +attr(obs, 'Dimensions') +# data var sdate time lat lon +# 1 1 4 3 721 1440 +dates_obs +# [1] "2005-01-16 11:30:00 UTC" "2006-01-16 11:30:00 UTC" +# [3] "2007-01-16 11:30:00 UTC" "2008-01-16 11:30:00 UTC" +# [5] "2005-02-14 23:30:00 UTC" "2006-02-14 23:30:00 UTC" +# [7] "2007-02-14 23:30:00 UTC" "2008-02-15 11:30:00 UTC" +# [9] "2005-03-16 11:30:00 UTC" "2006-03-16 11:30:00 UTC" +#[11] "2007-03-16 11:30:00 UTC" "2008-03-16 11:30:00 UTC" + + +fun <- function(exp, obs, + lons_exp = lons_exp, lats_exp = lats_exp, + lons_obs = lons_obs, lats_obs = lats_obs) { + # exp + e <- s2dv::MeanDims(drop(exp), 'time') + sst.e <- ClimProjDiags::WeightedMean(e, lons_exp, lats_exp, + londim = which(names(dim(e)) == 'lon'), + latdim = which(names(dim(e)) == 'lat')) + index.exp <- (sst.e - mean(sst.e))/sd(sst.e) + + # obs + o <- s2dv::MeanDims(drop(obs), 'time') + sst.o <- ClimProjDiags::WeightedMean(o, lons_obs, lats_obs, + londim = which(names(dim(o)) == 'lon'), + latdim = which(names(dim(o)) == 'lat')) + index.obs <- (sst.o - mean(sst.o))/sd(sst.o) + + # give dim name + dim(index.exp) <- c(sdate = length(index.exp)) + dim(index.obs) <- c(sdate = length(index.obs)) + + return(list(ind_exp = index.exp, ind_obs = index.obs)) + +} + +# If ClimProjDiags::WeightedMean accepts two-dim input, 'sdate' can be margin dimension. +step <- Step(fun, + target_dims = list(exp = c('sdate', 'time', 'lat', 'lon'), + obs = c('sdate', 'time', 'lat', 'lon')), + output_dims = list(ind_exp = 'sdate', ind_obs = 'sdate')) + +workflow <- AddStep(list(exp = exp, obs = obs), step, + lons_exp = lons_exp, lats_exp = lats_exp, + lons_obs = lons_obs, lats_obs = lats_obs) + +res <- Compute(workflow$ind_exp, + chunks = list(var = 1)) + +str(res) +#List of 2 +# $ ind_exp: num [1:4, 1, 1] 1.195 0.422 -0.6 -1.017 +# $ ind_obs: num [1:4, 1, 1] 0.4642 0.0206 0.9123 -1.3971 +# ... +# ... + + diff --git a/inst/doc/usecase/ex2_12_transform_and_chunk.R b/inst/doc/usecase/ex2_12_transform_and_chunk.R new file mode 100644 index 0000000000000000000000000000000000000000..8b2eb831878c0844b5262a3c501c7f8ccdbb5882 --- /dev/null +++ b/inst/doc/usecase/ex2_12_transform_and_chunk.R @@ -0,0 +1,163 @@ +# Author: An-Chi Ho +# Date: 10th September 2021 +# ------------------------------------------------------------------ +# This use case provides an example of transforming and chunking latitude and longitude +# dimensions. If all other dimensions are used as target dimensions in the operation, +# it would be good to have the option of chunking the spatial dimensions. However, the +# errors due to transformation at borders may increase because chunking produces more +# borders. There are many factors may impact the results of transformation or +# transformation + chunking. See FAQ How-to-24 for related information(https://earth.bsc.es/gitlab/es/startR/-/blob/master/inst/doc/faq.md#24-do-both-interpolation-and-chunking-on-spatial-dimensions) +# Here we provide some scripts that are more common and less error-prone. +# Common things to notice: +# 1. 'transform_extra_cells' is increased to 8 to avoid errors at borders. +# Fewer cells may be enough, depending on cases. +# 2. The 'crop' argument in 'transform_params' is defined by the borders of the region or FALSE. +# TRUE may return wrong values, depending on cases. +# 3. CircularSort() is required to use even if the longitude fully falls in the range because +# it tells startR that longitude dimension is circular and the extra cells should be got from +# the other side if the border is reached. In the scripts below, CircularSort(0, 360) is used, +# but it can also be replaced by CircularSort(-180, 180). +# ------------------------------------------------------------------ + +library(startR) + +lons.min <- 0 +lons.max <- 359.9 +lats.min <- -90 +lats.max <- 90 +sdates <- paste0(1981:2011, '0101') + +#--------------------------------- +# Method 1: +# - Use list of 2 values to define longitude and latitude. +#--------------------------------- + +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = sdates, + ensemble = 'all', + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('latitude', 'lat'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = F) + +func <- function(x) { + # x: [sdate, ensemble] + ensemble_mean <- s2dv::MeanDims(x, 2) + trend <- s2dv:::.Trend(ensemble_mean)$trend + return(trend) +} +step <- Step(func, + target_dims = c('sdate', 'ensemble'), output_dims = 'stats') +wf <- AddStep(exp, step) + +res1 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 + +dim(res1) +# stats dat var time latitude longitude +# 2 1 1 1 50 100 +summary(res1) +# Min. 1st Qu. Median Mean 3rd Qu. Max. +# -0.09884 0.00879 117.19019 138.18788 279.98564 305.25010 + + + +#--------------------------------- +# Method 2: +# - Use vector of indices to define longitude and latitude. +# - The 'crop' argument in 'transform_params' is FALSE (but it can also be defined by the borders +# of the region.) +#--------------------------------- + +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = sdates, + ensemble = 'all', + time = indices(1), + latitude = indices(1:640), + latitude_reorder = Sort(), + longitude = indices(1:1296), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('latitude', 'lat'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = F) + +func <- function(x) { + # x: [sdate, ensemble] + ensemble_mean <- s2dv::MeanDims(x, 2) + trend <- s2dv:::.Trend(ensemble_mean)$trend + return(trend) +} +step <- Step(func, + target_dims = c('sdate', 'ensemble'), output_dims = 'stats') +wf <- AddStep(exp, step) + +res2 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 + +identical(res1, res2) +#[1] TRUE + +#--------------------------------- +# Method 3: +# - Use 'all' to define longitude and latitude. +# - The 'crop' argument in 'transform_params' is FALSE (but it can also be defined by the borders +# of the region.) +#--------------------------------- +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = sdates, + ensemble = 'all', + time = indices(1), + latitude = 'all', + latitude_reorder = Sort(), + longitude = 'all', + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('latitude', 'lat'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = F) + +func <- function(x) { + # x: [sdate, ensemble] + ensemble_mean <- s2dv::MeanDims(x, 2) + trend <- s2dv:::.Trend(ensemble_mean)$trend + return(trend) +} +step <- Step(func, + target_dims = c('sdate', 'ensemble'), output_dims = 'stats') +wf <- AddStep(exp, step) + +res3 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 + +identical(res2, res3) +#[1] TRUE diff --git a/inst/doc/usecase/ex2_4_two_func.R b/inst/doc/usecase/ex2_4_two_func.R index 4f3da94e554a396c29aa6f7a84646787ac103934..d4d1b5f14a6f1eb2a162f2becd80f50c06b1a559 100644 --- a/inst/doc/usecase/ex2_4_two_func.R +++ b/inst/doc/usecase/ex2_4_two_func.R @@ -14,38 +14,35 @@ library(startR) retrieve = FALSE) fun_deb3 <- function(x) { - source("/esarchive/scratch/nperez/Season_v2.R") lons_data = as.vector(attr(x, 'Variables')$dat1$longitude) lats_data = as.vector(attr(x, 'Variables')$dat1$latitude) - resgrid = "r360x180" # prlr - y = Season_v2(x, posdim = 'time', monini = 1, moninf = 1, monsup = 3) - r <- s2dverification::CDORemap(y, lons_data, lats_data, resgrid, - 'bil', crop = FALSE, force_remap = TRUE)[[1]] + resgrid = "r360x180" +# y <- s2dv::Season(x, time_dim = 'time', monini = 1, moninf = 1, monsup = 3) + y <- apply(x, c(1, 2), s2dv:::.Season, monini = 1, moninf = 1, monsup = 3) + r <- s2dv::CDORemap(y, lons_data, lats_data, resgrid, + 'bil', crop = FALSE, force_remap = TRUE)[[1]] return(r) } step4 <- Step(fun = fun_deb3, target_dims = c('latitude','longitude', 'time'), - output_dims = c('latitude', 'longitude', 'time'), + output_dims = c('latitude', 'longitude'), use_attributes = list(data = "Variables")) - wf4 <- AddStep(data, step4) + wf4 <- AddStep(list(data = data), step4) ## locally res4 <- Compute(workflow = wf4, chunks = list(ensemble = 2, sdate = 2)) - dim(res4$output1) - head(res4$output1) - summary(res4$output1) # ------------------------------------------------------------------ # Output: -#> dim(res4$output1) -# latitude longitude time dat var sdate ensemble -# 180 360 1 1 1 2 2 -#> head(res4$output1) +dim(res4$output1) +# latitude longitude dat var sdate ensemble +# 180 360 1 1 2 2 +head(res4$output1) #[1] 237.1389 237.2601 238.0882 238.0312 237.7883 238.4835 -#> summary(res4$output1) +summary(res4$output1) # Min. 1st Qu. Median Mean 3rd Qu. Max. # 227.3 259.6 280.8 277.1 296.2 306.7 # ------------------------------------------------------------------ diff --git a/inst/doc/usecase/ex2_6_ext_param_func.R b/inst/doc/usecase/ex2_6_ext_param_func.R index 302b52a8697d7aaf394b2554fe89819941cb9732..8bd128fa6e1465cbb247bb093ad89b82ca2e9363 100644 --- a/inst/doc/usecase/ex2_6_ext_param_func.R +++ b/inst/doc/usecase/ex2_6_ext_param_func.R @@ -88,15 +88,15 @@ # Notice that the function uses rnorm() inside. So the results will be different. # ----------------------------------------------------------- -#names(res) +names(res) #[1] "strat" "t_test" -#> dim(res$strat) +dim(res$strat) # phase longitude latitude # 8 30 20 -#> summary(res$strat) +summary(res$strat) # Min. 1st Qu. Median Mean 3rd Qu. Max. #-0.133300 -0.032530 -0.001822 -0.005715 0.031700 0.094220 -#> res$strat[1:5, 1:2, 1] +res$strat[1:5, 1:2, 1] # [,1] [,2] #[1,] -0.04661354 -0.04661539 #[2,] -0.01058483 -0.01053589 diff --git a/inst/doc/usecase/ex2_7_seasonal_forecast_verification.R b/inst/doc/usecase/ex2_7_seasonal_forecast_verification.R index f24fa42a45b4f2a4fad8505bdd74b6019608557c..8b746071ecff79ef898695fffb2c499ac4fa948d 100644 --- a/inst/doc/usecase/ex2_7_seasonal_forecast_verification.R +++ b/inst/doc/usecase/ex2_7_seasonal_forecast_verification.R @@ -33,7 +33,7 @@ func <- function(x, y) { - crps <- mean(SpecsVerification::EnsCrps(x, y, R.new = Inf)) + crps <- mean(SpecsVerification::EnsCrps(x, y, R.new = Inf), na.rm = T) return(crps) } step <- Step(func, target_dims = list(c('sdate', 'ensemble'), c('sdate')), @@ -100,7 +100,7 @@ # 1 1 1 256 512 summary(res$output1) # Min. 1st Qu. Median Mean 3rd Qu. Max. -#0.09941 0.37760 0.71640 0.83570 1.20300 6.23400 +#0.09882 0.37815 0.71648 0.83638 1.20353 6.23452 # Plotting diff --git a/inst/doc/usecase/ex2_8_calibration.R b/inst/doc/usecase/ex2_8_calibration.R index d02afc1d63452bf2aa04105c38dc0c19c147fa4a..23ab3b01d89d0f7f8e651bbc753e4e1056af4a19 100644 --- a/inst/doc/usecase/ex2_8_calibration.R +++ b/inst/doc/usecase/ex2_8_calibration.R @@ -16,6 +16,8 @@ exp <- Start(dat = '/esarchive/exp/ecmwf/system4_m1/monthly_mean/$var$_f6h/$var$ latitude = values(list(lats.min, lats.max)), latitude_reorder = Sort(), longitude = values(list(lons.min, lons.max)), + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('lon', 'longitude')), return_vars = list(latitude = 'dat', longitude = 'dat', time = c('sdate')), @@ -28,31 +30,30 @@ obs <- Start(dat = '/esarchive/recon/ecmwf/erainterim/monthly_mean/$var$_f6h/$va latitude = values(list(lats.min, lats.max)), latitude_reorder = Sort(), longitude = values(list(lons.min, lons.max)), + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('lon', 'longitude')), return_vars = list(latitude = 'dat', longitude = 'dat', time = c('sdate')), - split_multiselected_dims = TRUE, - merge_across_dims = TRUE, retrieve = FALSE) # Define of the workflow # Function wrap_cal <- function(obs, exp) { - obs <- s2dverification::InsertDim(obs, 1, 1) - names(dim(obs))<- c('member', 'sdate') - exp <- t(exp) - names(dim(exp))<- c('member', 'sdate') + obs <- s2dv::InsertDim(obs, 1, 1, name = 'ensemble') #calibrated <- CSTools:::.cal(obs = obs, var_exp = exp) # CSTools version 1.0.1 or earlier calibrated <- CSTools:::.cal(exp = exp, obs = obs, cal.method = "mse_min", eval.method = "leave-one-out", - multi.model = FALSE) + multi.model = FALSE, + na.fill = TRUE, na.rm = TRUE, + apply_to = 'sign', alpha = 0.1) return(calibrated) } step <- Step(wrap_cal, - target_dims = list(obs = c('sdate'), exp = c('sdate', 'ensemble')), + target_dims = list(obs = c('sdate'), exp = c('ensemble', 'sdate')), output_dims = c('ensemble', 'sdate')) # workflow of operations @@ -92,10 +93,10 @@ res_nord3 <- Compute(wf, ecflow_suite_dir = "/esarchive/scratch/nperez/ecflow") # your path! # Results - dim(res$output1) +dim(res$output1) # ensemble sdate dat var time latitude longitude # 15 11 1 1 1 14 15 - summary(res$output1) +summary(res$output1) # Min. 1st Qu. Median Mean 3rd Qu. Max. -# 292.7 300.6 301.1 301.1 301.6 306.8 +# 293.1 300.6 301.1 301.1 301.6 306.8 diff --git a/inst/doc/usecase/ex2_9_mask.R b/inst/doc/usecase/ex2_9_mask.R index 13be87888875d37d123b26d81af25da4b9dc13d5..aca6162a34e01c400fd5c40f3d6731f64fa56539 100644 --- a/inst/doc/usecase/ex2_9_mask.R +++ b/inst/doc/usecase/ex2_9_mask.R @@ -107,15 +107,20 @@ wf_mask <- AddStep(list(data, mask), stepMask) res <- Compute(workflow = wf_mask, chunks = list(latitude = 2, longitude = 2)) + ##################################################################### # -------------------------------------------------------------------------------- ##################################################################### # Extra lines for output verification: # Output verification: - -summary(res$output1) dim(res$output1) +# var latitude longitude +# 1 42 40 +summary(res$output1) +# Min. 1st Qu. Median Mean 3rd Qu. Max. NA's +# 295.4 300.0 300.2 300.0 300.5 301.0 840 head(res$output1) +#[1] 300.0644 NA NA NA NA NA mask_loaded <- Start(dat = path, var = 'mask', @@ -125,8 +130,13 @@ mask_loaded <- Start(dat = path, longitude = 'dat'), retrieve = TRUE) summary(res$output1[mask_loaded == 0]) # All are NA's: correct +# Min. 1st Qu. Median Mean 3rd Qu. Max. NA's +# NA NA NA NaN NA NA 840 summary(res$output1[mask_loaded == 1]) # There is no NA's: correct +# Min. 1st Qu. Median Mean 3rd Qu. Max. +# 295.4 300.0 300.2 300.0 300.5 301.0 sum(mask_loaded == 0) # The number of NA's are 840: correct +#[1] 840 # compare values: data_loaded <- Start(dat = repos, @@ -141,9 +151,13 @@ data_loaded <- Start(dat = repos, time = 'sdate'), retrieve = TRUE) mean(data_loaded[1,1, , , ,1,1]) +#[1] 300.0644 res$output1[1,1,1] +#[1] 300.0644 mean(data_loaded[1,1, , , ,1,2]) +#[1] 300.3169 res$output1[1,1,2] +#[1] 300.3169 out <- mask_loaded for (i in 1:(dim(data_loaded)['latitude'])) { diff --git a/man/Start.Rd b/man/Start.Rd index efd258f3079af64f00b94262fcbd10da4f4cb0b9..3bdae42cdd792b32c68cd45656ab47e1f20c2120 100644 --- a/man/Start.Rd +++ b/man/Start.Rd @@ -174,6 +174,10 @@ Start() aware that the item names vary in function of the section, i.e. section 'electronics' has items 'a', 'b' and 'c' but section 'clothing' has items 'd', 'e', 'f'. Otherwise Start() would expect to find the same item names in all the sections. +If values() is used to define dimensions, it is possible to provide different +values of the depending dimension for each depended dimension values. For +example, if \code{section = c('electronics', 'clothing')}, we can use +\code{item = list(electronics = c('a', 'b', 'c'), clothing = c('d', 'e', 'f'))}. \cr\cr The \bold{name of another dimension} to be specified in '_across', only available for inner dimensions, must be a character string with the name diff --git a/tests/testthat.R b/tests/testthat.R index d424073d93d066a0a8c2bf330e87c67a34fbf0c8..04a698ce3550b762582b7442237b9f3721350fb7 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,5 +1,10 @@ library(testthat) library(startR) +library(SpecsVerification) +library(plyr) +library(dplyr) +library(easyNCDF) +library(s2dv) test_check("startR") diff --git a/tests/testthat/test-AddStep-DimNames.R b/tests/testthat/test-AddStep-DimNames.R index 5577ff5dd68e4e6b78f3e4af0431eaf0ece0a7ed..2fe6b3976c570c71356c459d3c3a6ec505ac296b 100644 --- a/tests/testthat/test-AddStep-DimNames.R +++ b/tests/testthat/test-AddStep-DimNames.R @@ -2,7 +2,7 @@ context("Error with bad dimensions tests.") test_that("Single File - Local execution", { -skip_on_cran() +suppressWarnings( data <- Start(dataset = '/esarchive/recon/jma/jra55/monthly_mean/$var$_f6h/$var$_$sdate$$month$.nc', var = 'tas', sdate = '2000', @@ -15,6 +15,7 @@ skip_on_cran() lon = c('lon','longitude')), return_vars = list(lat = 'dataset', lon = 'dataset'), num_procs = 1, retrieve = FALSE) +) fun <- function(x) { return(x) diff --git a/tests/testthat/test-Compute-CDORemap.R b/tests/testthat/test-Compute-CDORemap.R new file mode 100644 index 0000000000000000000000000000000000000000..991e7e1e12d308fb75be27863a4b274ce6c7ba40 --- /dev/null +++ b/tests/testthat/test-Compute-CDORemap.R @@ -0,0 +1,57 @@ +context("Compute use CDORemap") + +test_that("ex2_3", { + + repos <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' + +suppressWarnings( + data <- Start(dat = repos, + var = 'tas', + sdate = c('20170101'), + ensemble = indices(1), + time = indices(1), + latitude = 'all', + longitude = 'all', + return_vars = list(latitude = 'dat', longitude = 'dat', time = 'sdate'), + retrieve = FALSE) +) + + fun <- function(x) { + lons_data <- as.vector(attr(x, 'Variables')$dat1$longitude) + lats_data <- as.vector(attr(x, 'Variables')$dat1$latitude) + r <- s2dverification::CDORemap(x, lons_data, lats_data, "r360x181", + 'bil', crop = FALSE, force_remap = TRUE)[[1]] + return(r) + } + + step3 <- Step(fun = fun, + target_dims = c('latitude','longitude'), + output_dims = c('latitude', 'longitude'), + use_attributes = list(data = "Variables")) + wf3 <- AddStep(list(data = data), step3) + +suppressWarnings( + res3 <- Compute(workflow = wf3, + chunks = list(ensemble = 1)) + ) + +expect_equal( +attr(data, 'Dimensions'), +c(dat = 1, var = 1, sdate = 1, ensemble = 1, time = 1, latitude = 640, longitude = 1296) +) +expect_equal( +dim(res3$output), +c(latitude = 181, longitude = 360, dat = 1, var = 1, sdate = 1, ensemble = 1, time = 1) +) +expect_equal( +mean(res3$output), +277.0346, +tolerance = 0.0001 +) +expect_equal( +res3$output[20,11,1,,1,1,1], +c(265.5362), +tolerance = 0.0001 +) + +}) diff --git a/tests/testthat/test-Compute-NumChunks.R b/tests/testthat/test-Compute-NumChunks.R index 319a18b65c6f8afda3c124e2908a98d413d2384b..9e626e44fdac8790aecda70c00071fc25f17ab38 100644 --- a/tests/testthat/test-Compute-NumChunks.R +++ b/tests/testthat/test-Compute-NumChunks.R @@ -2,7 +2,8 @@ context("Number of chunks tests.") test_that("Single File - Local execution", { -skip_on_cran() + +suppressWarnings( data <- Start(dataset = '/esarchive/recon/jma/jra55/monthly_mean/$var$_f6h/$var$_$sdate$$month$.nc', var = 'tas', sdate = '2000', @@ -16,6 +17,7 @@ data <- Start(dataset = '/esarchive/recon/jma/jra55/monthly_mean/$var$_f6h/$var$ return_vars = list(lat = 'dataset', lon = 'dataset'), num_procs = 1, retrieve = FALSE) +) fun <- function(x) { return(x) @@ -24,18 +26,26 @@ step <- Step(fun = fun, target_dims = c('month'), output_dims = c('month')) -wf = AddStep(inputs = data, +wf <- AddStep(inputs = data, step_fun = step) -expect_equal(Compute(workflow = wf, - chunks = list(lat = 2, lon = 2), - threads_load = 1, - threads_compute = 2), +suppressWarnings( +res1 <- Compute(workflow = wf, + chunks = list(lat = 2, lon = 2), + threads_load = 1, + threads_compute = 2) +) +suppressWarnings( +res2 <- Compute(workflow = wf, + chunks = list(lat = 3, lon = 3), + threads_load = 1, + threads_compute = 2) +) - Compute(workflow = wf, - chunks = list(lat = 3, lon = 3), - threads_load = 1, - threads_compute = 2), - check.attributes = FALSE) +expect_equal( +res1, +res2, +check.attributes = FALSE +) }) diff --git a/tests/testthat/test-Compute-chunk_depend_dim.R b/tests/testthat/test-Compute-chunk_depend_dim.R new file mode 100644 index 0000000000000000000000000000000000000000..a08b1e53926dba2e470c756283ebd43d288b2bc3 --- /dev/null +++ b/tests/testthat/test-Compute-chunk_depend_dim.R @@ -0,0 +1,219 @@ +# This unit test tests the chunking over depended and depending dimension. +# ex1_14 +# 1. depending dim is values() +# 2. depending dim is indices() +# a. depended dim is indices() +# b. depended dim is list of values +# Note that 2.b. doesn't work. + +context("Chunk over dimensions that have dependency relationship") + +path <- paste0('/esarchive/exp/CMIP6/dcppA-hindcast/hadgem3-gc31-mm/', + 'cmip6-dcppA-hindcast_i1p1/DCPP/MOHC/HadGEM3-GC31-MM/dcppA-hindcast/', + 'r1i1p1f2/Omon/tos/gn/v20200417/', + '$var$_Omon_HadGEM3-GC31-MM_dcppA-hindcast_s$sdate$-r1i1p1f2_gn_$chunk$.nc') +sdates <- c('2016', '2017', '2018') + +# retrieve = T for verification +suppressWarnings( +data_T <- Start(dat = path, + var = 'tos', + sdate = sdates, + chunk = indices(2:4), + chunk_depends = 'sdate', + time = 'all', + i = indices(450:452), + j = indices(650:651), + time_across = 'chunk', + return_vars = list(time = 'sdate'), + retrieve = T, silent = T) +) + +test_that("1.a. depending dim is values(); depended dim is indices()", { + +suppressWarnings( +data <- Start(dat = path, + var = 'tos', + sdate = sdates, + chunk = indices(2:4), + chunk_depends = 'sdate', + time = 'all', + i = indices(450:452), + j = indices(650:651), + time_across = 'chunk', + return_vars = list(time = 'sdate'), + retrieve = F) +) +fun <- function(x) { +return(x) +} +step <- Step(fun = fun, + target_dims = 'dat', output_dims = 'dat') +wf <- AddStep(inputs = data, step_fun = step) +suppressWarnings( +res1 <- Compute(workflow = wf, chunks = list(chunk = 2))$output1 +) +suppressWarnings( +res2 <- Compute(workflow = wf, chunks = list(sdate = 2))$output1 +) +suppressWarnings( +res3 <- Compute(workflow = wf, chunks = list(chunk = 2, sdate = 2))$output1 +) + +expect_equal( +as.vector(data_T), +as.vector(res1) +) +expect_equal( +res1, +res2 +) +expect_equal( +res1, +res3 +) + +expect_equal( +as.vector(drop(res1)[, , 1, 1, 1]), +c(29.26021, 29.37948, 30.43721, 30.66117, 30.09621, 30.14460, 30.19445, 30.93453, 30.50104), +tolerance = 0.0001 +) +expect_equal( +as.vector(drop(res1)[, , 2, 1, 1]), +c(29.73614, 29.38624, 30.58396, 30.66175, 30.09205, 30.11643, 29.82516, 30.57528, 30.12949), +tolerance = 0.0001 +) + +}) + +################################################################# +################################################################# +################################################################# + +test_that("1.b. depending dim is values(); depended dim is list of values", { + +chunks <- list('2016' = c("201701-201712","201801-201812","201901-201912"), + '2017' = c("201801-201812","201901-201912","202001-202012"), + '2018' = c("201901-201912","202001-202012","202101-202112")) +suppressWarnings( +data <- Start(dat = path, + var = 'tos', + sdate = sdates, + chunk = chunks, + chunk_depends = 'sdate', + time = 'all', + i = indices(450:452), + j = indices(650:651), + time_across = 'chunk', + return_vars = list(time = 'sdate'), + retrieve = F) +) +fun <- function(x) { +return(x) +} +step <- Step(fun = fun, + target_dims = 'dat', output_dims = 'dat') +wf <- AddStep(inputs = data, step_fun = step) + +suppressWarnings( +res1 <- Compute(workflow = wf, chunks = list(chunk = 2))$output1 +) +suppressWarnings( +res2 <- Compute(workflow = wf, chunks = list(sdate = 2))$output1 +) +suppressWarnings( +res3 <- Compute(workflow = wf, chunks = list(chunk = 2, sdate = 2))$output1 +) + +expect_equal( +as.vector(data_T), +as.vector(res1) +) +expect_equal( +res1, +res2 +) +expect_equal( +res1, +res3 +) + +}) + +################################################################# +################################################################# +################################################################# + +test_that("2.a. depending dim is indices(); depended dim is indices()", { + +suppressWarnings( +data <- Start(dat = path, + var = 'tos', + sdate = indices(57:59), # 2016, 2017, 2018 + chunk = indices(2:4), + chunk_depends = 'sdate', + time = 'all', + i = indices(450:452), + j = indices(650:651), + time_across = 'chunk', + return_vars = list(time = 'sdate'), + retrieve = F) +) +fun <- function(x) { +return(x) +} +step <- Step(fun = fun, + target_dims = 'dat', output_dims = 'dat') +wf <- AddStep(inputs = data, step_fun = step) + +suppressWarnings( +res1 <- Compute(workflow = wf, chunks = list(chunk = 2))$output1 +) +suppressWarnings( +res2 <- Compute(workflow = wf, chunks = list(sdate = 2))$output1 +) +suppressWarnings( +res3 <- Compute(workflow = wf, chunks = list(chunk = 2, sdate = 2))$output1 +) + +expect_equal( +as.vector(data_T), +as.vector(res1) +) +expect_equal( +res1, +res2 +) +expect_equal( +res1, +res3 +) + +}) + +################################################################# +################################################################# +################################################################# + +test_that("2.b. depending dim is indices(); depended dim is list of values", { + +chunks <- list('2016' = c("201701-201712","201801-201812","201901-201912"), + '2017' = c("201801-201812","201901-201912","202001-202012"), + '2018' = c("201901-201912","202001-202012","202101-202112")) +expect_error( +suppressWarnings( +Start(dat = path, + var = 'tos', + sdate = indices(57:59), # 2016, 2017, 2018 + chunk = chunks, + chunk_depends = 'sdate', + time = 'all', + i = indices(450:452), + j = indices(650:651), + time_across = 'chunk', + return_vars = list(time = 'sdate'), + retrieve = F)), +"The depended dimension, chunk, is explictly defined by a list of values, while the depending dimension, sdate, is not explictly defined. Specify sdate by characters." +) + +}) diff --git a/tests/testthat/test-Compute-extra_params.R b/tests/testthat/test-Compute-extra_params.R new file mode 100644 index 0000000000000000000000000000000000000000..9b42e43c126fe53e0f3f015c9247a724ba1a02d8 --- /dev/null +++ b/tests/testthat/test-Compute-extra_params.R @@ -0,0 +1,126 @@ +context("Compute, extra function arguments") + +test_that("ex2_6", { + + +#========================= +# Prepare sdates and paths +#========================= + dataset <- "/esarchive/recon/ecmwf/era5/daily_mean/$var$_f1h/$var$_$sdate$.nc" + sdates <- paste0(1981:1982, rep(10:12, 2)) +#=================== +# Get daily winds +#=================== +suppressWarnings( + wind <- Start(dataset = dataset, + var = "sfcWind", + sdate = sdates, + time = 'all', + longitude = indices(1:3), + latitude = indices(1:2), + return_vars = list(time = NULL, latitude = NULL, longitude = NULL), + retrieve = FALSE, + synonims = list(longitude = c('lon', 'longitude'), + latitude = c('lat', 'latitude'))) +) + + # Synthetic MJO for 'season = OND': + set.seed(1) + MJO <- data.frame(vdate = 1:(30 * 2 + 31 * 4), + phase = c(rep(1:8, 23)), + amplitude = 10 * rnorm(31 * 4 + 30 * 2)) + + stratify_atomic <- function(field, MJO, season = c("JFM", "OND"), + lag = 0, ampl = 2, relative = TRUE, signif = 0.05) { + # Arrange wind in form (days) to match MJO + nmonths <- dim(field)[3] + field <- aperm(field, c(1, 2, 4, 3)) + dim(field) <- c(31 * nmonths) + if(season == "JFM") { + daysok <- rep(c(rep(TRUE, 31), rep(TRUE, 28), + rep(FALSE, 3), rep(TRUE, 31)), nmonths / 3) + } else if (season == "OND") { + daysok <- rep(c(rep(TRUE, 31), rep(TRUE, 30), + rep(FALSE, 1), rep(TRUE, 31)), nmonths / 3) + } + field <- field[daysok] + dim(field) <- c(days = length(field)) + + if(dim(field)[1] != dim(MJO)[1]) { + stop("MJO indices and wind data have different number of days") + } + + idx <- function(MJO, phase, ampl, lag){ + if(lag == 0) { + return(MJO$phase == phase & MJO$amplitude > ampl) + } + if(lag > 0) { + return(dplyr::lag(MJO$phase == phase & MJO$amplitude > ampl, + lag, default = FALSE)) + } + if(lag < 0) { + return(dplyr::lead(MJO$phase == phase & MJO$amplitude > ampl, + - 1 * lag, default = FALSE)) + } + } + strat <- plyr::laply(1:8, function(i) { + idx2 <- idx(MJO, i, ampl, lag) + if (relative) { + return(mean(field[idx2]) / mean(field) - 1) + } else { + return(mean(field[idx2]) - mean(field)) + }}) + strat.t.test <- plyr::laply(1:8, function(i) { + idx2 <- idx(MJO, i, ampl, lag) + return(t.test(field[idx2], field)$p.value)}) + return(list(strat = strat, t_test = strat.t.test)) + } + + step <- Step(stratify_atomic, + target_dims = list(field = c('dataset', 'var', 'sdate', 'time')), + output_dims = list(strat = c('phase'), t_test = c('phase'))) + workflow <- AddStep(wind, step, MJO = MJO, season = "OND", lag = "0", amp = 0) + +suppressWarnings( + res <- Compute(workflow$strat, + chunks = list(latitude = 2)) +) + +expect_equal( +attr(wind, 'Dimensions'), +c(dataset = 1, var = 1, sdate = 6, time = 31, longitude = 3, latitude = 2) +) +expect_equal( +names(res), +c('strat', 't_test') +) +expect_equal( +dim(res$strat), +c(phase = 8, longitude = 3, latitude = 2) +) +expect_equal( +dim(res$t_test), +c(phase = 8, longitude = 3, latitude = 2) +) +expect_equal( +mean(res$strat), +-0.01373227, +tolerance = 0.0001 +) +expect_equal( +res$strat[1:6,2,1], +c(-0.002499522, 0.125437301, -0.044554040, -0.034862961, 0.019349007, -0.143963809), +tolerance = 0.0001 +) +expect_equal( +res$t_test[1:6,2,1], +c(0.9808923, 0.3378701, 0.6251017, 0.7305827, 0.8573760, 0.2473257), +tolerance = 0.0001 +) +expect_equal( +mean(res$t_test), +0.6419336, +tolerance = 0.0001 +) + +}) diff --git a/tests/testthat/test-Compute-inconsistent_target_dim.R b/tests/testthat/test-Compute-inconsistent_target_dim.R new file mode 100644 index 0000000000000000000000000000000000000000..fa4992afe565d5e28b501c8b2e3e488bce886261 --- /dev/null +++ b/tests/testthat/test-Compute-inconsistent_target_dim.R @@ -0,0 +1,141 @@ +context("Compute()/ByChunks(): dimension consistence check") +# If dataset are more than 1 (e.g., exp and obs), ByChunks() checks if +# they have consistent dimensions in favor of Apply() computation. However, +# only margin dimensions need to be identical. Target dimensions can have +# different lengths. + +test_that("ex2_11", { +path.exp <- '/esarchive/exp/ecmwf/system5c3s/monthly_mean/$var$_f6h/$var$_$sdate$.nc' +path.obs <- '/esarchive/recon/ecmwf/era5/monthly_mean/$var$_f1h-r1440x721cds/$var$_$date$.nc' + +var <- 'tos' +y1 <- 1981 +y2 <- 1983 + +lons.min <- 220 +lons.max <- 240 +lats.min <- -5 +lats.max <- 5 + +sdate <- paste0(y1:y2, '1201') + +suppressWarnings( +exp <- Start(data = path.exp, + var = var, + member = indices(1:2), + sdate = sdate, + time = 1:3, + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(decreasing = TRUE), + longitude = values(list(lons.min, lons.max)), + synonims = list(longitude = c('lon', 'longitude'), + latitude = c('lat', 'latitude'), + member = c('member', 'ensemble')), + return_vars = list(longitude = NULL, + latitude = NULL, + time = 'sdate'), + retrieve = FALSE) +) +lons.exp <- attr(exp, 'Variables')$common$longitude +lats.exp <- attr(exp, 'Variables')$common$latitude +dates.exp <- attr(exp, 'Variables')$common$time + +# Manually create date/ime +dates.obs <- c(paste0(y1:y2, '1201'), + paste0((y1 + 1):(y2 + 1), '01', '01'), + paste0((y1 + 1):(y2 + 1), '02', '01')) +time.obs <- as.POSIXct(dates.obs, "%Y%m%d", + origin = "1981-12", tz = 'UTC') +dim(time.obs) <- c(dim(dates.exp)['sdate'], dim(dates.exp)['time']) + +suppressWarnings( +obs <- Start(data = path.obs, + var = var, + date = unique(format(time.obs, '%Y%m')), + time = values(time.obs), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(decreasing = TRUE), + longitude = values(list(lons.min, lons.max)), + time_across = 'date', + merge_across_dims = TRUE, + split_multiselected_dims = TRUE, + synonims = list(longitude = c('lon', 'longitude'), + latitude = c('lat', 'latitude')), + return_vars = list(longitude = NULL, + latitude = NULL, + time = 'date'), + retrieve = FALSE) +) + +lons.obs <- attr(obs, 'Variables')$common$longitude +lats.obs <- attr(obs, 'Variables')$common$latitude +dates.obs <- attr(obs, 'Variables')$common$time + +lons_exp <- as.vector(lons.exp) +lats_exp <- as.vector(lats.exp) +lons_obs <- as.vector(lons.obs) +lats_obs <- as.vector(lats.obs) + + +fun <- function(exp, obs, path.output, + lons_exp = lons_exp, lats_exp = lats_exp, + lons_obs = lons_obs, lats_obs = lats_obs) { + + e <- s2dv::MeanDims(drop(exp), c('member', 'time')) + sst.e <- ClimProjDiags::WeightedMean(e, lons_exp, lats_exp, + londim = which(names(dim(e)) == 'longitude'), + latdim = which(names(dim(e)) == 'latitude')) + index.exp <- (sst.e - mean(sst.e))/sd(sst.e) + + o <- s2dv::MeanDims(drop(obs), 'time') + sst.o <- ClimProjDiags::WeightedMean(o, lons_obs, lats_obs, + londim = which(names(dim(o)) == 'longitude'), + latdim = which(names(dim(o)) == 'latitude')) + index.obs <- (sst.o - mean(sst.o))/sd(sst.o) + + # give dim name + dim(index.exp) <- c(sdate = length(index.exp)) + dim(index.obs) <- c(sdate = length(index.obs)) + + return(list(ind_exp = index.exp, ind_obs = index.obs)) + +} + +step <- Step(fun, + target_dims = list(exp = c('member', 'sdate', 'time', 'latitude', 'longitude'), + obs = c('sdate', 'time', 'latitude', 'longitude')), + output_dims = list(ind_exp = 'sdate', ind_obs = 'sdate')) + +workflow <- AddStep(list(exp = exp, obs = obs), step, + lons_exp = lons_exp, lats_exp = lats_exp, + lons_obs = lons_obs, lats_obs = lats_obs) + +suppressWarnings( +res <- Compute(workflow$ind_exp, + chunks = list(var = 1)) +) + +expect_equal( +attr(exp, 'Dimensions'), +c(data = 1, var = 1, member = 2, sdate = 3, time = 3, latitude = 11, longitude = 21) +) +expect_equal( +attr(obs, 'Dimensions'), +c(data = 1, var = 1, sdate = 3, time = 3, latitude = 41, longitude = 81) +) +expect_equal( +names(res), +c('ind_exp', 'ind_obs') +) +expect_equal( +mean(res$ind_exp)*10^18, +-9.251859, +tolerance = 0.00001 +) +expect_equal( +mean(res$ind_obs)*10^15, +-9.584944, +tolerance = 0.00001 +) + +}) diff --git a/tests/testthat/test-Compute-timedim.R b/tests/testthat/test-Compute-timedim.R new file mode 100644 index 0000000000000000000000000000000000000000..80d96ff0bf2ade58ae1b30c9f2cadd1c6e6e8e36 --- /dev/null +++ b/tests/testthat/test-Compute-timedim.R @@ -0,0 +1,57 @@ +context("Compute on time dimension") + +test_that("ex2_1", { + + repos <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' + +suppressWarnings( + data <- Start(dat = repos, + var = 'tas', + sdate = c('20170101', '20180101'), + ensemble = indices(1:2), + time = 'all', + latitude = indices(1:10), + longitude = indices(1:15), + return_vars = list(latitude = 'dat', longitude = 'dat', time = 'sdate'), + retrieve = FALSE) +) + + fun_spring <- function(x) { + y <- s2dv::Season(x, time_dim = 'time', monini = 1, moninf = 3, monsup = 5) + return(y) + } + + step1 <- Step(fun = fun_spring, + target_dims = c('var', 'time'), + output_dims = c('var', 'time')) + + wf1 <- AddStep(data, step1) + +suppressWarnings( + res1 <- Compute(wf1, + chunks = list(ensemble = 2)) +) + +expect_equal( +attr(data, 'Dimensions'), +c(dat = 1, var = 1, sdate = 2, ensemble = 2, time = 7, latitude = 10, longitude = 15) +) +expect_equal( +dim(res1$output), +c(var = 1, time = 1, dat = 1, sdate = 2, ensemble = 2, latitude = 10, longitude = 15) +) +expect_equal( +mean(res1$output), +258.3792, +tolerance = 0.0001 +) +expect_equal( +res1$output[1,1,1,,2,10,2], +c(256.4469, 260.3636), +tolerance = 0.0001 +) + + + + +}) diff --git a/tests/testthat/test-Compute-transform_all.R b/tests/testthat/test-Compute-transform_all.R new file mode 100644 index 0000000000000000000000000000000000000000..46430d7a2736f1946d6e369d32c4037179494aa8 --- /dev/null +++ b/tests/testthat/test-Compute-transform_all.R @@ -0,0 +1,126 @@ +context("Transform with 'all'") + +test_that("1. Chunk along non-lat/lon dim", { +skip_on_cran() + +path <- '/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consortium/EC-Earth3/dcppA-hindcast/$member$/Amon/$var$/gr/v20190713/$var$_Amon_*_s$sdate$-$member$_gr_$fyear$.nc' +suppressWarnings( +data <- Start(dat = path, + var = 'tos', + sdate = paste0(1960), + time = indices(1:2), #'all', + lat = 'all', + lon = 'all', + fyear = indices(1), + member = indices(1:2), + transform = CDORemapper, + transform_extra_cells = 2, + transform_params = list(grid = 'r100x50', method = 'conservative', crop = FALSE), + transform_vars = c('lat','lon'), + synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), + retrieve = FALSE) +) + + func <- function(x) { + a <- mean(x, na.rm = TRUE) + return(a) + } + step <- Step(func, target_dims = c('time'), + output_dims = NULL) + wf <- AddStep(data, step) +suppressWarnings( + res <- Compute(wf, + chunks = list(member = 2)) +) + +expect_equal( +dim(res$output1), +c(dat = 1, var = 1, sdate = 1, lat = 50, lon = 100, fyear = 1, member = 2) +) +expect_equal( +res$output1[1, 1, 1, 10:12, 20, 1, 1], +c(274.2808, 275.8509, 277.7623), +tolerance = 0.0001 +) + +}) + +test_that("2. chunk along lon", { +skip_on_cran() + +#!!!!!!!!!!!!!!!!!!!NOTE: the results are not identical when exp has extra cells = 2!!!!!!!!!!!!!!!!!! +# But exp2 (retrieve = T) has the same results with extra_cells = 2 and 8. + +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 'all', + latitude_reorder = Sort(), + longitude = 'all', + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat',#NULL, + longitude = 'dat',#NULL, + time = 'sdate'), + retrieve = F) +) + + func <- function(x) { + return(x) + } + step <- Step(func, target_dims = 'time', output_dims = 'time') + wf <- AddStep(exp, step) +suppressWarnings( + res <- Compute(wf, chunks = list(longitude = 2)) +) +suppressWarnings( + res2 <- Compute(wf, chunks = list(ensemble = 1)) +) + +expect_equal( +res$output1, +res2$output1 +) + +# Check with retrieve = TRUE +suppressWarnings( +exp2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 'all', + latitude_reorder = Sort(), + longitude = 'all', + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat',#NULL, + longitude = 'dat',#NULL, + time = 'sdate'), + retrieve = T) +) + +expect_equal( +as.vector(res$output1), +as.vector(exp2) +) + +}) diff --git a/tests/testthat/test-Compute-transform_indices.R b/tests/testthat/test-Compute-transform_indices.R new file mode 100644 index 0000000000000000000000000000000000000000..d9d65cb8ede93b2b55859db60bca3036805c4008 --- /dev/null +++ b/tests/testthat/test-Compute-transform_indices.R @@ -0,0 +1,650 @@ +context("Transform with indices") +# Using indinces() to assign lat and lon, and transform the data. +# Also test transform + chunk along lat/lon. + +#---------------------------------------------------------- +# cdo result +#library(easyNCDF) +#pathh <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc" +#file <- NcOpen(pathh) +#arr <- NcToArray(file, +# dim_indices = list(time = 1, ensemble = 1, +# latitude = 1:640, longitude = 1:1296), +# vars_to_read = 'tas') +#lats <- NcToArray(file, +# dim_indices = list(latitude = 1:640), vars_to_read = 'latitude') +#lons <- NcToArray(file, +# dim_indices = list(longitude = 1:1296), vars_to_read = 'longitude') +#NcClose(file) +# +#arr2 <- s2dv::CDORemap(arr, lons = as.vector(lons), lats = as.vector(lats), +# grid = 'r100x50', method = 'con', crop = FALSE) + + +test_that("1. global", { +skip_on_cran() + +path <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' + +#----------------------------------- +# crop = region +suppressWarnings( +exp <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + lat = indices(1:640), + lon = indices(1:1296), + lat_reorder = Sort(), + lon_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_extra_cells = 8, + transform_params = list(grid = 'r100x50', method = 'conservative', + crop = c(0, 360, -90, 90)), + transform_vars = c('lat','lon'), + synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), + retrieve = F) +) +func <- function(x) { + return(x) +} +step <- Step(func, target_dims = 'time', output_dims = 'time') +wf <- AddStep(exp, step) + +suppressWarnings( +res1 <- Compute(wf, chunks = list(lon = 2)) +) +suppressWarnings( +res2 <- Compute(wf, chunks = list(ensemble = 1)) +) +suppressWarnings( +res3 <- Compute(wf, chunks = list(lon = 3)) +) + + +expect_equal( +res1$output1, +res2$output1 +) +expect_equal( +res1$output1, +res3$output1 +) + +#----------------------------------- + +# crop = region, selector is indices(list(, )) +suppressWarnings( +exp <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + lat = indices(list(1, 640)), + lon = indices(list(1, 1296)), + lat_reorder = Sort(), + lon_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_extra_cells = 8, + transform_params = list(grid = 'r100x50', method = 'conservative', + crop = c(0, 360, -90, 90)), + transform_vars = c('lat','lon'), + synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), + retrieve = F) +) +func <- function(x) { + return(x) +} +step <- Step(func, target_dims = 'time', output_dims = 'time') +wf <- AddStep(exp, step) + +suppressWarnings( +res1_list <- Compute(wf, chunks = list(lon = 2)) +) +expect_equal( +res1$output1, +res1_list$output1 +) + +#----------------------------------- +# crop = FALSE +suppressWarnings( +exp <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + lat = indices(1:640), + lon = indices(1:1296), + lat_reorder = Sort(), + lon_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_extra_cells = 8, + transform_params = list(grid = 'r100x50', method = 'conservative', + crop = FALSE), + transform_vars = c('lat','lon'), + synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), + retrieve = F) +) +func <- function(x) { + return(x) +} +step <- Step(func, target_dims = 'time', output_dims = 'time') +wf <- AddStep(exp, step) + +suppressWarnings( +res_crop_F_1 <- Compute(wf, chunks = list(lon = 2)) +) +suppressWarnings( +res_crop_F_2 <- Compute(wf, chunks = list(ensemble = 1)) +) +suppressWarnings( +res_crop_F_3 <- Compute(wf, chunks = list(lon = 3)) +) + +expect_equal( +res1$output1, +res_crop_F_1$output1 +) +expect_equal( +res_crop_F_1$output1, +res_crop_F_2$output1 +) +expect_equal( +res_crop_F_1$output1, +res_crop_F_3$output1 +) + +#--------------------------------------------- +#!!!!!!!!!!!!!!!!!!!!Problem when global + crop = T + chunk along lon!!!!!!!!!!!!!!!! +# crop = TRUE +suppressWarnings( +exp <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + lat = indices(1:640), + lon = indices(1:1296), + lat_reorder = Sort(), + lon_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_extra_cells = 8, + transform_params = list(grid = 'r100x50', method = 'conservative', + crop = TRUE), + transform_vars = c('lat','lon'), + synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), + retrieve = F) +) +func <- function(x) { + return(x) +} +step <- Step(func, target_dims = 'time', output_dims = 'time') +wf <- AddStep(exp, step) + +#WRONG!!!!!!!!!! +#suppressWarnings( +#res_crop_T_1 <- Compute(wf, chunks = list(lon = 2)) +#) +suppressWarnings( +res_crop_T_2 <- Compute(wf, chunks = list(ensemble = 1)) +) +#WRONG!!!!!!!!!! +#suppressWarnings( +#res_crop_T_3 <- Compute(wf, chunks = list(lon = 3)) +#) +suppressWarnings( +res_crop_T_4 <- Compute(wf, chunks = list(lat = 2)) +) + +#expect_equal( +#res1$output1, +#res_crop_T_1$output1 +#) +expect_equal( +res1$output1, +res_crop_T_2$output1 +) +#expect_equal( +#res1$output1, +#res_crop_T_3$output1 +#) +expect_equal( +res1$output1, +res_crop_T_4$output1 +) + +}) + + +##################################################################### +##################################################################### +##################################################################### + +#NOTE: The numbers in the unit test are testified by the following code. First, we subset +# the desired region plus the extra cells (that is, the desired lon is (19:65), so we +# subset (19-8:65+8)); then, we use CDORemap() to transform and crop like the Start() +# call. Actually, the crop region is not correct. The lat region should be (-90, 67) +# rather than (-90, -60). It causes wrong values at the end of lat because the selected +# region is not big enough to do the interpolation at -60. But anyway, the startR +# result is identical to arr2, and that's what we expect. + +#pathh <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc" +#file <- NcOpen(pathh) +#arr <- NcToArray(file, +# dim_indices = list(time = 1, ensemble = 1, +# latitude = 553:640, longitude = 11:83), +# vars_to_read = 'tas') +#lats <- NcToArray(file, +# dim_indices = list(latitude = 553:640), vars_to_read = 'latitude') +#lons <- NcToArray(file, +# dim_indices = list(longitude = 11:83), vars_to_read = 'longitude') +#NcClose(file) +# +#arr2 <- s2dv::CDORemap(arr, lons = as.vector(lons), lats = as.vector(lats), +# grid = 'r100x50', method = 'con', crop = c(0, 22, -90, -60)) + + +test_that("2. regional, no border", { +skip_on_cran() + +path <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' + +# crop = region +suppressWarnings( +exp <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + lat = indices(1:80), # 1:80 = -89.78488:-67.58778 + lon = indices(19:65), # 19:65 = 5.00000:17.7777778 + lat_reorder = Sort(), + lon_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_extra_cells = 8, + transform_params = list(grid = 'r100x50', + method = 'conservative', + crop = c(0, 22, -90, -60)), + transform_vars = c('lat','lon'), + synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), + retrieve = F) +) +func <- function(x) { + return(x) +} +step <- Step(func, target_dims = 'time', output_dims = 'time') +wf <- AddStep(exp, step) + +suppressWarnings( +res <- Compute(wf, chunks = list(lon = 2)) +) +suppressWarnings( +res2 <- Compute(wf, chunks = list(ensemble = 1)) +) +suppressWarnings( +res3 <- Compute(wf, chunks = list(lon = 3)) +) + + +expect_equal( +res$output1, +res2$output1 +) +expect_equal( +res$output1, +res3$output1 +) + +expect_equal( +drop(res$output1)[, 1], +c(241.5952, 243.0271, 247.6998, 246.7727, 248.7175, 267.7744, 273.2705), +tolerance = 0.001 +) +expect_equal( +drop(res$output1)[, 2], +c(241.4042, 242.5804, 246.8507, 245.8008, 246.4318, 267.0983, 272.9651), +tolerance = 0.001 +) +expect_equal( +drop(res$output1)[, 3], +c(241.2223, 242.2564, 245.9863, 244.5377, 244.8937, 266.5749, 272.5154), +tolerance = 0.001 +) +expect_equal( +drop(res$output1)[, 4], +c(241.0894, 242.1896, 245.3183, 243.1169, 243.9446, 266.4386, 272.4731), +tolerance = 0.001 +) +expect_equal( +drop(res$output1)[, 5], +c(241.0217, 242.3326, 244.6789, 241.6538, 244.3845, 266.6960, 272.4390), +tolerance = 0.001 +) + +#------------------------------------------------------ +# crop = FALSE +suppressWarnings( +exp <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + lat = indices(1:80), # 1:80 = -89.78488:-67.58778 + lon = indices(19:65), # 19:65 = 5.00000:17.7777778 + lat_reorder = Sort(), + lon_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_extra_cells = 8, + transform_params = list(grid = 'r100x50', + method = 'conservative', + crop = FALSE), + transform_vars = c('lat','lon'), + synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), + retrieve = F) +) + +func <- function(x) { + return(x) +} +step <- Step(func, target_dims = 'time', output_dims = 'time') +wf <- AddStep(exp, step) + +suppressWarnings( +res_crop_F_1 <- Compute(wf, chunks = list(lon = 2)) +) +suppressWarnings( +res_crop_F_2 <- Compute(wf, chunks = list(ensemble = 1)) +) +suppressWarnings( +res_crop_F_3 <- Compute(wf, chunks = list(lon = 3)) +) + +expect_equal( +res$output1, +res_crop_F_1$output1 +) +expect_equal( +res$output1, +res_crop_F_2$output1 +) +expect_equal( +res$output1, +res_crop_F_3$output1 +) + + + +#------------------------------------------------------ +# crop = TRUE +suppressWarnings( +exp <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + lat = indices(1:80), # 1:80 = -89.78488:-67.58778 + lon = indices(19:65), # 19:65 = 5.00000:17.7777778 + lat_reorder = Sort(), + lon_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_extra_cells = 8, + transform_params = list(grid = 'r100x50', + method = 'conservative', + crop = T), + transform_vars = c('lat','lon'), + synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), + retrieve = F) +) + +func <- function(x) { + return(x) +} +step <- Step(func, target_dims = 'time', output_dims = 'time') +wf <- AddStep(exp, step) + +suppressWarnings( +res_crop_T_1 <- Compute(wf, chunks = list(lat = 2, lon = 2)) +) +suppressWarnings( +res_crop_T_2 <- Compute(wf, chunks = list(ensemble = 1)) +) +suppressWarnings( +res_crop_T_3 <- Compute(wf, chunks = list(lon = 3)) +) + + +expect_equal( +res$output1, +res_crop_T_1$output1 +) +expect_equal( +res$output1, +res_crop_T_2$output1 +) +expect_equal( +res$output1, +res_crop_T_3$output1 +) + + +}) + +##################################################################### +##################################################################### +##################################################################### + +#NOTE: The numbers in the unit test below is identical to the result from the following +# code. Unlike unit test 2 above, we need to retrieve the global grids for +# transformation here because lon is at the border and the extra cells at the other +# side (i.e., 360, 359, etc.) are needed. + +#library(easyNCDF) +#pathh <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc" +#file <- NcOpen(pathh) +#arr <- NcToArray(file, +# dim_indices = list(time = 1, ensemble = 1, +# latitude = 1:640, longitude = 1:1296), +# vars_to_read = 'tas') +#lats <- NcToArray(file, +# dim_indices = list(latitude = 1:640), vars_to_read = 'latitude') +#lons <- NcToArray(file, +# dim_indices = list(longitude = 1:1296), vars_to_read = 'longitude') +#NcClose(file) +# +#arr2 <- s2dv::CDORemap(arr, lons = as.vector(lons), lats = as.vector(lats), +# grid = 'r100x50', method = 'con', crop = c(0, 18, -90, -67)) + + +test_that("3. regional, at lon border", { +skip_on_cran() + +path <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' + +# crop = region +suppressWarnings( +exp <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + lat = indices(1:80), # 1:80 = -89.78488:-67.58778 + lon = indices(1:65),# 1:65 = 0.00000:17.7777778 + lat_reorder = Sort(), + lon_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_extra_cells = 8, + transform_params = list(grid = 'r100x50', method = 'conservative', + crop = c(0, 18, -90, -67)), + transform_vars = c('lat','lon'), + synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), + retrieve = F) +) + +func <- function(x) { + return(x) +} +step <- Step(func, target_dims = 'time', output_dims = 'time') +wf <- AddStep(exp, step) + +suppressWarnings( +res1 <- Compute(wf, chunks = list(lon = 2)) +) +suppressWarnings( +res2 <- Compute(wf, chunks = list(ensemble = 1)) +) +suppressWarnings( +res3 <- Compute(wf, chunks = list(lon = 3)) +) + +expect_equal( +res1$output1, +res2$output1 +) +expect_equal( +res1$output1, +res3$output1 +) +expect_equal( +drop(res1$output1)[, 1], +c(241.8592, 243.7243, 248.7337, 247.9308, 252.0744, 268.5533), +tolerance = 0.001 +) +expect_equal( +drop(res1$output1)[, 2], +c(241.6231, 243.0969, 247.8179, 246.8879, 249.1226, 267.8804), +tolerance = 0.001 +) +expect_equal( +drop(res1$output1)[, 3], +c(241.4042, 242.5804, 246.8507, 245.8008, 246.4318, 267.0983), +tolerance = 0.001 +) +expect_equal( +drop(res1$output1)[, 4], +c(241.2223, 242.2564, 245.9863, 244.5377, 244.8937, 266.5749), +tolerance = 0.001 +) +expect_equal( +drop(res1$output1)[, 5], +c(241.0894, 242.1896, 245.3183, 243.1169, 243.9446, 266.4386), +tolerance = 0.001 +) +expect_equal( +drop(res1$output1)[, 6], +c(241.0217, 242.3326, 244.6789, 241.6538, 244.3845, 266.6960), +tolerance = 0.001 +) + +#------------------------------------------------------ +# crop = FALSE +suppressWarnings( +exp <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + lat = indices(1:80), # 1:80 = -89.78488:-67.58778 + lon = indices(1:65),# 1:65 = 0.00000:17.7777778 + lat_reorder = Sort(), + lon_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_extra_cells = 8, + transform_params = list(grid = 'r100x50', method = 'conservative', + crop = F), + transform_vars = c('lat','lon'), + synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), + retrieve = F) +) + +func <- function(x) { + return(x) +} +step <- Step(func, target_dims = 'time', output_dims = 'time') +wf <- AddStep(exp, step) + +suppressWarnings( +res_crop_F_1 <- Compute(wf, chunks = list(lon = 2)) +) +suppressWarnings( +res_crop_F_2 <- Compute(wf, chunks = list(ensemble = 1)) +) +suppressWarnings( +res_crop_F_3 <- Compute(wf, chunks = list(lon = 3)) +) + +expect_equal( +as.vector(res1$output1), +as.vector(drop(res_crop_F_1$output1)[1:6, ]) +) +expect_equal( +res_crop_F_1$output1, +res_crop_F_2$output1 +) +expect_equal( +res_crop_F_1$output1, +res_crop_F_3$output1 +) + +#---------------------------------------------- +# crop = TRUE +suppressWarnings( +exp <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + lat = indices(1:80), # 1:80 = -89.78488:-67.58778 + lon = indices(1:65),# 1:65 = 0.00000:17.7777778 + lat_reorder = Sort(), + lon_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_extra_cells = 8, + transform_params = list(grid = 'r100x50', method = 'conservative', + crop = T), + transform_vars = c('lat','lon'), + synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), + return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), + retrieve = F) +) + +func <- function(x) { + return(x) +} +step <- Step(func, target_dims = 'time', output_dims = 'time') +wf <- AddStep(exp, step) + +suppressWarnings( +res_crop_T_1 <- Compute(wf, chunks = list(lon = 2)) +) +suppressWarnings( +res_crop_T_2 <- Compute(wf, chunks = list(ensemble = 1)) +) +suppressWarnings( +res_crop_T_3 <- Compute(wf, chunks = list(lon = 3)) +) + +expect_equal( +res_crop_F_1$output1, +res_crop_T_1$output1 +) +expect_equal( +res_crop_T_1$output1, +res_crop_T_2$output1 +) +expect_equal( +res_crop_T_1$output1, +res_crop_T_3$output1 +) + +}) diff --git a/tests/testthat/test-Compute-transform_values.R b/tests/testthat/test-Compute-transform_values.R new file mode 100644 index 0000000000000000000000000000000000000000..74975f7ca0904b46da0ec1608462894e9268cef2 --- /dev/null +++ b/tests/testthat/test-Compute-transform_values.R @@ -0,0 +1,924 @@ +context("Compute: Transform and chunk values()") +# Using values() to assign lat and lon, and transform the data. +# Also test transform + chunk along lat/lon. + +##################################################################### +##################################################################### +##################################################################### + +test_that("1. Global", { +skip_on_cran() + +lons.min <- 0 +lons.max <- 359.9 +lats.min <- -90 +lats.max <- 90 + +# crop = region +#NOTE: res1 and res3 differ if extra_cells = 2. But if retrieve = T, extra_cells = 2 or 8 is equal. + +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +suppressWarnings( +res1 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +) +suppressWarnings( +res2 <- Compute(wf, chunks = list(ensemble = 1))$output1 +) +suppressWarnings( +res3 <- Compute(wf, chunks = list(longitude = 3))$output1 +) + +expect_equal( +dim(res1), +c(sdate = 1, dat = 1, var = 1, ensemble = 1, time = 1, latitude = 50, longitude = 100) +) +expect_equal( +res1, +res2 +) +expect_equal( +res1, +res3 +) + +expect_equal( +drop(res1)[1:5, 1], +c(241.8592, 243.7243, 248.7337, 247.9308, 252.0744), +tolerance = 0.001 +) +expect_equal( +drop(res1)[23:28, 2], +c(298.0772, 299.4716, 299.7746, 300.2744, 300.3914, 299.5223), +tolerance = 0.001 +) +expect_equal( +mean(res1), +276.3901, +tolerance = 0.001 +) +#-------------------------------------------------- + +# crop = region, selector is values(c()) +library(easyNCDF) +pathh <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc" +file <- NcOpen(pathh) +arr <- NcToArray(file, + dim_indices = list(time = 1, ensemble = 1, + latitude = 1:640, longitude = 1:1296), + vars_to_read = 'tas') +lats <- NcToArray(file, + dim_indices = list(latitude = 1:640), vars_to_read = 'latitude') +lons <- NcToArray(file, + dim_indices = list(longitude = 1:1296), vars_to_read = 'longitude') +NcClose(file) + +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(as.vector(lats)), + latitude_reorder = Sort(), + longitude = values(as.vector(lons)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +suppressWarnings( +res1_vector <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +) +expect_equal( +res1, +res1_vector +) + +#----------------------------------------------------------------- + +# crop = region, CircularSort(-180, 180) +lons.min <- -180 +lons.max <- 179.9 +lats.min <- -90 +lats.max <- 90 +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(-180, 180), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +suppressWarnings( +res1_180 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +) +suppressWarnings( +res2_180 <- Compute(wf, chunks = list(ensemble = 1))$output1 +) +suppressWarnings( +res3_180 <- Compute(wf, chunks = list(longitude = 3))$output1 +) + +expect_equal( +as.vector(drop(res1)[, c(51:100, 1:50)]), +as.vector(res1_180), +tolerance = 0.0001 +) +expect_equal( +res1_180, +res2_180 +) +expect_equal( +res1_180, +res3_180 +) + +#============================================================ + +# crop = FALSE +lons.min <- 0 +lons.max <- 359.9 +lats.min <- -90 +lats.max <- 90 + +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +suppressWarnings( +res_crop_F_1 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +) +suppressWarnings( +res_crop_F_2 <- Compute(wf, chunks = list(ensemble = 1))$output1 +) +suppressWarnings( +res_crop_F_3 <- Compute(wf, chunks = list(longitude = 3))$output1 +) + +expect_equal( +res1, +res_crop_F_1 +) +expect_equal( +res_crop_F_1, +res_crop_F_2 +) +expect_equal( +res_crop_F_1, +res_crop_F_3 +) + +#------------------------------------------------------- +#!!!!!!!!!!!!!!!!!!!!Problem when global + crop = T + chunk along lon!!!!!!!!!!!!!!!! + +# crop = TRUE +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = TRUE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +#WRONG +#suppressWarnings( +#res_crop_T_1 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +#) +suppressWarnings( +res_crop_T_2 <- Compute(wf, chunks = list(ensemble = 1))$output1 +) +#WRONG +#suppressWarnings( +#res_crop_T_3 <- Compute(wf, chunks = list(longitude = 3))$output1 +#) +suppressWarnings( +res_crop_T_4 <- Compute(wf, chunks = list(latitude = 3))$output1 +) + +#expect_equal( +#res1, +#res_crop_T_1 +#) +expect_equal( +res1, +res_crop_T_2 +) +#expect_equal( +#res1, +#res_crop_T_3 +#) +expect_equal( +res1, +res_crop_T_4 +) + +}) + +############################################################################ +############################################################################ +############################################################################ + +# The numbers below are consistent with the result of this script. +#pathh <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc" +#file <- NcOpen(pathh) +#arr <- NcToArray(file, +# dim_indices = list(time = 1, ensemble = 1, +# latitude = 171:257, longitude = 30:81), +# vars_to_read = 'tas') +#lats <- NcToArray(file, +# dim_indices = list(latitude = 171:257), vars_to_read = 'latitude') +#lons <- NcToArray(file, +# dim_indices = list(longitude = 30:81), vars_to_read = 'longitude') +#NcClose(file) +# +#arr2 <- s2dv::CDORemap(arr, lons = as.vector(lons), lats = as.vector(lats), +# grid = 'r100x50', method = 'con', crop = c(10, 20, 20, 40)) + +test_that("2. Regional, no border", { + +skip_on_cran() + +lons.min <- 10 +lons.max <- 20 +lats.min <- 20 +lats.max <- 40 + +# crop = region +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', #paste0(2000:2001, '0101'), + ensemble = indices(1), #'all', + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, #'dat', + longitude = NULL, #'dat', + time = 'sdate'), + retrieve= F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +suppressWarnings( +res1 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +) +suppressWarnings( +res2 <- Compute(wf, chunks = list(ensemble = 1))$output1 +) +suppressWarnings( +res3 <- Compute(wf, chunks = list(longitude = 3))$output1 +) + +expect_equal( +dim(res1), +c(sdate = 1, dat = 1, var = 1, ensemble = 1, time = 1, latitude = 5, longitude = 3) +) +expect_equal( +res1, +res2 +) +expect_equal( +res1, +res3 +) + +expect_equal( +drop(res1)[, 1], +c(284.9907, 282.9883, 281.2574, 284.1387, 285.6547), +tolerance = 0.0001 +) +expect_equal( +drop(res1)[, 2], +c(285.4820, 282.9362, 282.6088, 287.3716, 285.0194), +tolerance = 0.0001 +) +expect_equal( +drop(res1)[, 3], +c(286.1208, 284.3523, 285.9198, 287.7389, 286.1099), +tolerance = 0.0001 +) + +#------------------------------------------------------- + +# crop = FALSE +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +suppressWarnings( +res_crop_F_1 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +) +suppressWarnings( +res_crop_F_2 <- Compute(wf, chunks = list(ensemble = 1))$output1 +) +suppressWarnings( +res_crop_F_3 <- Compute(wf, chunks = list(longitude = 3))$output1 +) + +expect_equal( +res1, +res_crop_F_1 +) +expect_equal( +res_crop_F_1, +res_crop_F_2 +) +expect_equal( +res_crop_F_1, +res_crop_F_3 +) + +#------------------------------------------------------- + +# crop = TRUE +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = TRUE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +suppressWarnings( +res_crop_T_1 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +) +suppressWarnings( +res_crop_T_2 <- Compute(wf, chunks = list(ensemble = 1))$output1 +) +suppressWarnings( +res_crop_T_3 <- Compute(wf, chunks = list(longitude = 3))$output1 +) + +expect_equal( +res1, +res_crop_T_1 +) +expect_equal( +res_crop_T_1, +res_crop_T_2 +) +expect_equal( +res_crop_T_1, +res_crop_T_3 +) + +}) + +############################################################################ +############################################################################ +############################################################################ + +# The numbers below are consistent with the result of this script. +#pathh <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc" +#file <- NcOpen(pathh) +#arr <- NcToArray(file, +# dim_indices = list(time = 1, ensemble = 1, +# latitude = 171:257, longitude = c(1:81, 1289:1296)), +# vars_to_read = 'tas') +#lats <- NcToArray(file, +# dim_indices = list(latitude = 171:257), vars_to_read = 'latitude') +#lons <- NcToArray(file, +# dim_indices = list(longitude = c(1:81, 1289:1296)), vars_to_read = 'longitude') +#NcClose(file) +# +#arr2 <- s2dv::CDORemap(arr, lons = as.vector(lons), lats = as.vector(lats), +# grid = 'r100x50', method = 'con', crop = c(0, 20, 20, 40)) + + +test_that("3. Regional, at lon border", { +skip_on_cran() + +lons.min <- 0 +lons.max <- 20 +lats.min <- 20 +lats.max <- 40 + +# crop = region +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +suppressWarnings( +res1 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +) +suppressWarnings( +res2 <- Compute(wf, chunks = list(ensemble = 1))$output1 +) +suppressWarnings( +res3 <- Compute(wf, chunks = list(longitude = 3))$output1 +) + +expect_equal( +dim(res1), +c(sdate = 1, dat = 1, var = 1, ensemble = 1, time = 1, latitude = 5, longitude = 6) +) +expect_equal( +res1, +res2 +) +expect_equal( +res1, +res3 +) + +expect_equal( +drop(res1)[, 1], +c(286.4231, 283.8847, 280.4234, 277.7688, 284.3575), +tolerance = 0.001 +) +expect_equal( +drop(res1)[, 2], +c(288.0916, 283.9386, 280.9974, 278.4432, 284.8728), +tolerance = 0.001 +) +expect_equal( +drop(res1)[, 3], +c(285.7436, 283.1867, 281.7465, 280.2615, 284.6408), +tolerance = 0.001 +) +expect_equal( +drop(res1)[, 4], +c(284.9907, 282.9883, 281.2574, 284.1387, 285.6547), +tolerance = 0.001 +) +expect_equal( +drop(res1)[, 5], +c(285.4820, 282.9362, 282.6088, 287.3716, 285.0194), +tolerance = 0.001 +) +expect_equal( +drop(res1)[, 6], +c(286.1208, 284.3523, 285.9198, 287.7389, 286.1099), +tolerance = 0.001 +) + + +#-------------------------------------------------------------- + +# crop = region, CircularSort(-180, 180) +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(-180, 180), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +suppressWarnings( +res1_180 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +) +suppressWarnings( +res2_180 <- Compute(wf, chunks = list(ensemble = 1))$output1 +) +suppressWarnings( +res3_180 <- Compute(wf, chunks = list(longitude = 3))$output1 +) + +expect_equal( +res1, +res1_180 +) +expect_equal( +res1_180, +res2_180 +) +expect_equal( +res1_180, +res3_180 +) + +#================================================================ + +# crop = FALSE +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +suppressWarnings( +res_crop_F_1 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +) +suppressWarnings( +res_crop_F_2 <- Compute(wf, chunks = list(ensemble = 1))$output1 +) +suppressWarnings( +res_crop_F_3 <- Compute(wf, chunks = list(longitude = 3))$output1 +) + +expect_equal( +res1, +res_crop_F_1 +) +expect_equal( +res_crop_F_1, +res_crop_F_2 +) +expect_equal( +res_crop_F_1, +res_crop_F_3 +) + +#------------------------------------------------------- + +# crop = FALSE, CircularSort(-180, 180) +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(-180, 180), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +suppressWarnings( +res_crop_F_1_180 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +) +suppressWarnings( +res_crop_F_2_180 <- Compute(wf, chunks = list(ensemble = 1))$output1 +) +suppressWarnings( +res_crop_F_3_180 <- Compute(wf, chunks = list(longitude = 3))$output1 +) + +expect_equal( +res1, +res_crop_F_1_180 +) +expect_equal( +res_crop_F_1, +res_crop_F_2_180 +) +expect_equal( +res_crop_F_1, +res_crop_F_3_180 +) + +#=========================================================== + +# crop = TRUE +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = TRUE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +suppressWarnings( +res_crop_T_1 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +) +suppressWarnings( +res_crop_T_2 <- Compute(wf, chunks = list(ensemble = 1))$output1 +) +suppressWarnings( +res_crop_T_3 <- Compute(wf, chunks = list(longitude = 3))$output1 +) + +expect_equal( +res1, +res_crop_T_1 +) +expect_equal( +res_crop_T_1, +res_crop_T_2 +) +expect_equal( +res_crop_T_1, +res_crop_T_3 +) +#-------------------------------------------------- +# crop = TRUE, CircularSort(-180, 180) +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(-180, 180), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = TRUE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = F) +) +func <- function(exp) { + return(exp) +} +step <- Step(func, + target_dims = 'sdate', output_dims = 'sdate') +wf <- AddStep(exp, step) +suppressWarnings( +res_crop_T_1_180 <- Compute(wf, chunks = list(latitude = 2, longitude = 2))$output1 +) +suppressWarnings( +res_crop_T_2_180 <- Compute(wf, chunks = list(ensemble = 1))$output1 +) +suppressWarnings( +res_crop_T_3_180 <- Compute(wf, chunks = list(longitude = 3))$output1 +) + +expect_equal( +res1, +res_crop_T_1_180 +) +expect_equal( +res_crop_T_1, +res_crop_T_2_180 +) +expect_equal( +res_crop_T_1, +res_crop_T_3_180 +) + +}) diff --git a/tests/testthat/test-Compute-two_data.R b/tests/testthat/test-Compute-two_data.R new file mode 100644 index 0000000000000000000000000000000000000000..9cb7145dc05c5c41b7935342c5b84a5d88147391 --- /dev/null +++ b/tests/testthat/test-Compute-two_data.R @@ -0,0 +1,81 @@ +context("Compute with two datasets") + +test_that("ex2_7", { + +# exp data + repos <- paste0('/esarchive/exp/ecmwf/system4_m1/monthly_mean/', + '$var$_f6h/$var$_$sdate$.nc') + sdates <- sapply(2013:2014, function(x) paste0(x, sprintf('%02d', 1:12), '01')) + +suppressWarnings( + exp <- Start(dat = repos, + var = 'tas', + sdate = sdates, + time = indices(1), + ensemble = indices(1:2), + latitude = values(list(10, 12)), + latitude_reorder = Sort(), + longitude = values(list(0, 2)), + longitude_reorder = CircularSort(0, 360), + synonims = list(longitude = c('lon', 'longitude'), + latitude = c('lat', 'latitude')), + retrieve = F) +) +# obs data + repos_obs <- paste0('/esarchive/recon/ecmwf/erainterim/monthly_mean/', + '$var$_f6h/$var$_$sdate$.nc') + sdates_obs <- (sapply(2012:2013, function(x) paste0(x, sprintf('%02d', 1:12)))) +suppressWarnings( + obs <- Start(dat = repos_obs, + var = 'tas', + sdate = sdates_obs, + time = indices(1), + latitude = values(list(10, 12)), + latitude_reorder = Sort(), + longitude = values(list(0, 2)), + longitude_reorder = CircularSort(0, 360), + synonims = list(longitude = c('lon', 'longitude'), + latitude = c('lat', 'latitude')), + retrieve = F) +) + + func <- function(x, y) { + crps <- mean(SpecsVerification::EnsCrps(x, y, R.new = Inf)) + return(crps) + } + step <- Step(func, target_dims = list(c('sdate', 'ensemble'), c('sdate')), + output_dims = NULL) + wf <- AddStep(list(exp, obs), step) + + +# Compute() on fatnodes +suppressWarnings( + res <- Compute(wf, + chunks = list(latitude = 2)) +) + +expect_equal( +attr(exp, 'Dimensions'), +c(dat = 1, var = 1, sdate = 24, time = 1, ensemble = 2, latitude = 3, longitude = 3) +) +expect_equal( +attr(obs, 'Dimensions'), +c(dat = 1, var = 1, sdate = 24, time = 1, latitude = 3, longitude = 3) +) +expect_equal( +dim(res$output), +c(dat = 1, var = 1, time = 1, latitude = 3, longitude = 3) +) +expect_equal( +mean(res$output), +0.8646249, +tolerance = 0.0001 +) +expect_equal( +res$output[1,1,1,2,1], +0.7980703, +tolerance = 0.0001 +) + + +}) diff --git a/tests/testthat/test-Compute-use_attribute.R b/tests/testthat/test-Compute-use_attribute.R new file mode 100644 index 0000000000000000000000000000000000000000..2ca73a770f040f19c650960e1be8e8c97b6e294e --- /dev/null +++ b/tests/testthat/test-Compute-use_attribute.R @@ -0,0 +1,56 @@ +context("Compute use attributes") + +test_that("ex2_2", { + + repos <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' + +suppressWarnings( + data <- Start(dat = repos, + var = 'tas', + sdate = c('20170101', '20180101'), + ensemble = indices(1:2), + time = 'all', + latitude = indices(1:10), + longitude = indices(1:15), + return_vars = list(latitude = 'dat', longitude = 'dat', time = 'sdate'), + retrieve = FALSE) +) + funp <- function(x) { + lat <- attributes(x)$Variables$dat1$latitude + weight <- sqrt(cos(lat * pi / 180)) + corrected <- Apply(list(x), target_dims = "latitude", + fun = function(x) {x * weight}) + } + + + step2 <- Step(fun = funp, + target_dims = 'latitude', + output_dims = 'latitude', + use_attributes = list(data = "Variables")) + wf2 <- AddStep(list(data = data), step2) + +suppressWarnings( + res2 <- Compute(workflow = wf2, + chunks = list(sdate = 2)) +) + +expect_equal( +attr(data, 'Dimensions'), +c(dat = 1, var = 1, sdate = 2, ensemble = 2, time = 7, latitude = 10, longitude = 15) +) +expect_equal( +dim(res2$output), +c(latitude = 10, dat = 1, var = 1, sdate = 2, ensemble = 2, time = 7, longitude = 15) +) +expect_equal( +mean(res2$output), +39.84091, +tolerance = 0.0001 +) +expect_equal( +res2$output[2,1,1,,1,7,2], +c(25.40159, 25.40265), +tolerance = 0.0001 +) + +}) diff --git a/tests/testthat/test-Start-DCPP-across-depends.R b/tests/testthat/test-Start-DCPP-across-depends.R index f5a5dc6f7ee8dbbc535dabf813825b3cbada3747..452a2306f7415d936719f03041c43bcb89769d2a 100644 --- a/tests/testthat/test-Start-DCPP-across-depends.R +++ b/tests/testthat/test-Start-DCPP-across-depends.R @@ -4,6 +4,7 @@ test_that("Chunks of DCPP files- Local execution", { path <- '/esarchive/exp/CMIP6/dcppA-hindcast/hadgem3-gc31-mm/cmip6-dcppA-hindcast_i1p1/DCPP/MOHC/HadGEM3-GC31-MM/dcppA-hindcast/r1i1p1f2/Omon/tos/gn/v20200417/$var$_Omon_HadGEM3-GC31-MM_dcppA-hindcast_s$sdate$-r1i1p1f2_gn_$chunk$.nc' sdates <- c('2017', '2018') +suppressWarnings( dat <- Start(dat = path, var = 'tos', sdate = sdates, @@ -16,25 +17,30 @@ test_that("Chunks of DCPP files- Local execution", { merge_across_dims = TRUE, retrieve = TRUE, return_vars = list(time = 'sdate')) +) # [sdate = 2, chunk = 3] +suppressWarnings( dat_2018_chunk3 <- Start(dat = '/esarchive/exp/CMIP6/dcppA-hindcast/hadgem3-gc31-mm/cmip6-dcppA-hindcast_i1p1/DCPP/MOHC/HadGEM3-GC31-MM/dcppA-hindcast/r1i1p1f2/Omon/tos/gn/v20200417/$var$_Omon_HadGEM3-GC31-MM_dcppA-hindcast_s2018-r1i1p1f2_gn_202201-202212.nc', var = 'tos', time = 'all', i = indices(1:10), j = indices(1:10), retrieve = TRUE) - +) expect_equal(dat[1,1,2,25:36,,], dat_2018_chunk3[1,1,,,]) # [sdate = 1, chunk = 2] +suppressWarnings( dat_2017_chunk2 <- Start(dat = '/esarchive/exp/CMIP6/dcppA-hindcast/hadgem3-gc31-mm/cmip6-dcppA-hindcast_i1p1/DCPP/MOHC/HadGEM3-GC31-MM/dcppA-hindcast/r1i1p1f2/Omon/tos/gn/v20200417/$var$_Omon_HadGEM3-GC31-MM_dcppA-hindcast_s2017-r1i1p1f2_gn_202001-202012.nc', var = 'tos', time = 'all', i = indices(1:10), j = indices(1:10), retrieve = TRUE) - +) expect_equal(dat[1,1,1,13:24,,], dat_2017_chunk2[1,1,,,]) # [sdate = 2, chunk = 1] +suppressWarnings( dat_2018_chunk1 <- Start(dat = '/esarchive/exp/CMIP6/dcppA-hindcast/hadgem3-gc31-mm/cmip6-dcppA-hindcast_i1p1/DCPP/MOHC/HadGEM3-GC31-MM/dcppA-hindcast/r1i1p1f2/Omon/tos/gn/v20200417/$var$_Omon_HadGEM3-GC31-MM_dcppA-hindcast_s2018-r1i1p1f2_gn_202001-202012.nc', var = 'tos', time = 'all', i = indices(1:10), j = indices(1:10), retrieve = TRUE) +) expect_equal(dat[1,1,2,1:12,,], dat_2018_chunk1[1,1,,,]) diff --git a/tests/testthat/test-Start-calendar.R b/tests/testthat/test-Start-calendar.R index 328aa0e1fe611e4f98b39c161b7d4fff4516265b..8ac0760502fe1924b109f00d14616145606bf2b0 100644 --- a/tests/testthat/test-Start-calendar.R +++ b/tests/testthat/test-Start-calendar.R @@ -50,6 +50,7 @@ expect_equal( test_that("2. 365_day, daily, unit = 'days since 1984-01-01'", { path_bcc_csm2 <- '/esarchive/exp/CMIP6/dcppA-hindcast/bcc-csm2-mr/cmip6-dcppA-hindcast_i1p1/DCPP/BCC/BCC-CSM2-MR/dcppA-hindcast/r1i1p1f1/day/$var$/gn/v20200408/$var$_day_BCC-CSM2-MR_dcppA-hindcast_s$sdate$-r1i1p1f1_gn_19800101-19891231.nc' +suppressWarnings( data <- Start(dat = path_bcc_csm2, var = 'tasmax', sdate = '1980', @@ -58,6 +59,7 @@ path_bcc_csm2 <- '/esarchive/exp/CMIP6/dcppA-hindcast/bcc-csm2-mr/cmip6-dcppA-hi lon = indices(1), return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), retrieve = FALSE) +) expect_equal( dim(attr(data, 'Variables')$common$time), @@ -87,6 +89,7 @@ test_that("3. standard, daily, unit = 'days since 1850-1-1 00:00:00'", { sdate <- '2000' fyear_mpi_esm <- paste0(sdate, '1101-', as.numeric(sdate) + 10, '1231') +suppressWarnings( data <- Start(dat = path_mpi_esm, var = var, sdate = sdate, @@ -97,6 +100,7 @@ test_that("3. standard, daily, unit = 'days since 1850-1-1 00:00:00'", { lon = indices(1), return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), retrieve = FALSE) +) expect_equal( dim(attr(data, 'Variables')$common$time), @@ -123,6 +127,7 @@ test_that("4. standard, monthly, unit = 'days since 1850-1-1 00:00:00'", { sdate <- '2000' fyear_mpi_esm <- paste0(sdate, '1101-', as.numeric(sdate) + 10, '1231') +suppressWarnings( data <- Start(dat = path_mpi_esm, var = 'tasmax', sdate = '2000', @@ -131,6 +136,7 @@ test_that("4. standard, monthly, unit = 'days since 1850-1-1 00:00:00'", { lon = indices(1), return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), retrieve = FALSE) +) expect_equal( dim(attr(data, 'Variables')$common$time), @@ -153,6 +159,8 @@ test_that("5. proleptic_gregorian, 6hrly, unit = 'hours since 2000-11-01 00:00:0 date <- paste0('1994-05-', sprintf('%02d', 1:31), ' 00:00:00') date <- as.POSIXct(date, tz = 'UTC') # attr(date, 'tzone') <- 'UTC' + +suppressWarnings( data <- Start(dat = repos_obs, var = 'tas', time = date, @@ -162,6 +170,7 @@ test_that("5. proleptic_gregorian, 6hrly, unit = 'hours since 2000-11-01 00:00:0 longitude = NULL, time = NULL), retrieve = TRUE) +) expect_equal( as.vector(attr(data, 'Variables')$common$time[1:31]), @@ -182,6 +191,7 @@ expect_equal( test_that("6. standard, monthly, unit = 'months since 1870-01-16 12:00:00'", { repos_obs <- '/esarchive/obs/ukmo/hadisst_v1.1/monthly_mean/$var$/$var$_$date$.nc' +suppressWarnings( obs <- Start(dat = repos_obs, var = 'tos', date = '200505', #dates_file, @@ -199,6 +209,7 @@ test_that("6. standard, monthly, unit = 'months since 1870-01-16 12:00:00'", { lon = 'dat', time = 'date'), retrieve = FALSE) +) expect_equal( attr(obs, 'Variables')$common$time[1, 1], @@ -210,6 +221,7 @@ expect_equal( test_that("7. proleptic_gregorian, monthly, unit = 'days since 1850-1-1 00:00:00'", { repos <- '/esarchive/exp/mpi-esm-lr/cmip5-historical_i0p1/monthly_mean/$var$/$var$_$sdate$.nc' +suppressWarnings( data <- Start(dat = repos, var = 'tas', sdate = '20000101', @@ -218,7 +230,7 @@ test_that("7. proleptic_gregorian, monthly, unit = 'days since 1850-1-1 00:00:00 latitude = indices(1:4), longitude = indices(1:3), return_vars = list(time = NULL)) - +) time <- c(as.POSIXct('2000-01-16 12:00:00', tz = 'UTC'), as.POSIXct('2000-02-15 12:00:00', tz = 'UTC'), as.POSIXct('2000-03-16 12:00:00', tz = 'UTC')) @@ -241,14 +253,15 @@ test_that("7. proleptic_gregorian, monthly, unit = 'days since 1850-1-1 00:00:00 test_that("8. gregorian, 3hrly, unit = 'days since 1850-1-1'", { repos <- '/esarchive/exp/CMIP5/historical/ecearth/cmip5-historical_i0p1/$var$_3hr_EC-EARTH_historical_r6i1p1_$period$.nc' - data <- Start(dat = repos, + suppressWarnings( + data <- Start(dat = repos, var = 'vas', period = '200501010300-200601010000', time = indices(1:3), lat = indices(1:4), lon = indices(1:3), return_vars = list(time = NULL)) - +) time <- c(as.POSIXct('2005-01-01 03:00:00', tz = 'UTC'), as.POSIXct('2005-01-01 06:00:00', tz = 'UTC'), as.POSIXct('2005-01-01 09:00:00', tz = 'UTC')) diff --git a/tests/testthat/test-Start-depends_values.R b/tests/testthat/test-Start-depends_values.R new file mode 100644 index 0000000000000000000000000000000000000000..49114e7bd15cee0d0a77d480a5cfc90ed8328c0b --- /dev/null +++ b/tests/testthat/test-Start-depends_values.R @@ -0,0 +1,84 @@ +# This unit test tests the case that using values() to define the depended +# and depending dimensions. The depending dimension should be a list with +# names that are the values of depended dimensions. + +context("Start() using values() to define dependency relations") + + +path <- '/esarchive/exp/CMIP6/dcppA-hindcast/hadgem3-gc31-mm/cmip6-dcppA-hindcast_i1p1/DCPP/MOHC/HadGEM3-GC31-MM/dcppA-hindcast/r1i1p1f2/Omon/tos/gn/v20200417/$var$_Omon_HadGEM3-GC31-MM_dcppA-hindcast_s$sdate$-r1i1p1f2_gn_$chunk$.nc' + +sdates <- c('2016', '2017', '2018') +chunks <- array(dim = c(chunk = 3, sdate = 3)) +chunks[ , 1] <- c("201701-201712", "201801-201812", "201901-201912") +chunks[ , 2] <- c("201801-201812", "201901-201912", "202001-202012") +chunks[ , 3] <- c("201901-201912", "202001-202012", "202101-202112") + +test_that("1. ", { +suppressWarnings( +dat1 <- Start(dat = path, + var = 'tos', + sdate = sdates[1:2], + chunk = list('2016' = chunks[, 1], '2017' = chunks[, 2]), + chunk_depends = 'sdate', + time = 'all', + i = indices(450:460), + j = indices(685:700), + time_across = 'chunk', + merge_across_dims = TRUE, + return_vars = list(time = 'sdate'), + retrieve = TRUE) +) + +suppressWarnings( +dat2 <- Start(dat = path, + var = 'tos', + sdate = sdates, + chunk = list('2016' = chunks[, 1], '2017' = chunks[, 2], '2018' = chunks[ ,3]), + chunk_depends = 'sdate', + time = 'all', + i = indices(450:460), + j = indices(685:700), + time_across = 'chunk', + merge_across_dims = TRUE, + return_vars = list(time = 'sdate'), + retrieve = TRUE) +) +suppressWarnings( + dat3 <- Start(dat = path, + var = 'tos', + sdate = sdates, + chunk = list(chunks[, 1], chunks[, 2], chunks[ ,3]), + chunk_depends = 'sdate', + time = 'all', + i = indices(450:460), + j = indices(685:700), + time_across = 'chunk', + merge_across_dims = TRUE, + return_vars = list(time = 'sdate'), + retrieve = TRUE) +) + expect_equal( + dat1[1,1,1:2,,,], + dat2[1,1,1:2,,,] + ) + expect_equal( + mean(dat2, na.rm = T), + 29.11137, + tolerance = 0.0001 + ) + expect_equal( + mean(dat1, na.rm = T), + 29.07394, + tolerance = 0.0001 + ) + expect_equal( + dat2[1, 1, 2, 2, 1:3, 10], + c(28.38624, 28.19837, 28.08603), + tolerance = 0.0001 + ) + expect_equal( + as.vector(dat2), + as.vector(dat3) + ) +}) + diff --git a/tests/testthat/test-Start-first_file_missing.R b/tests/testthat/test-Start-first_file_missing.R index 25f4d0241cea4b25d642db5863f79fd8df08e0f6..392841aa0a44121807d74d27df6456615f252f97 100644 --- a/tests/testthat/test-Start-first_file_missing.R +++ b/tests/testthat/test-Start-first_file_missing.R @@ -16,6 +16,7 @@ sdates5 <- c("20130611", "20130612") #both exist test_that("1. first file missing, no assign parameter 'metadata_dims'", { +suppressWarnings( data <- Start(dat = file, var = var, file_date = sdates4, @@ -32,6 +33,7 @@ data <- Start(dat = file, time = 'file_date'), #metadata_dims = c('file_date'), retrieve = T) +) expect_equal( dim(data), @@ -54,7 +56,7 @@ data <- Start(dat = file, }) test_that("2. Use parameter 'metadata_dims'", { - +suppressWarnings( data <- Start(dat = file, var = var, file_date = sdates4, @@ -71,6 +73,7 @@ data <- Start(dat = file, time = 'file_date'), metadata_dims = c('file_date'), retrieve = T) +) expect_equal( dim(data), @@ -92,7 +95,7 @@ data <- Start(dat = file, }) test_that("3. Use parameter 'metadata_dims', all common attributes, 1st file missing", { - +suppressWarnings( data <- Start(dat = file, var = var, file_date = sdates4, @@ -109,7 +112,7 @@ data <- Start(dat = file, time = 'file_date'), metadata_dims = c('file_date'), retrieve = T) - +) expect_equal( names(attr(data, 'Variables')$common), c('latitude', 'longitude', 'time', NA, 'tas') @@ -122,7 +125,7 @@ data <- Start(dat = file, }) test_that("4. Use parameter 'metadata_dims', all common attributes, 2nd file missing", { - +suppressWarnings( data <- Start(dat = file, var = var, file_date = sdates3, @@ -139,7 +142,7 @@ data <- Start(dat = file, time = 'file_date'), metadata_dims = c('file_date'), retrieve = T) - +) expect_equal( names(attr(data, 'Variables')$common), c('latitude', 'longitude', 'time', 'tas', NA) @@ -152,7 +155,7 @@ data <- Start(dat = file, }) test_that("5. Use parameter 'metadata_dims', all common attributes, no file missing", { - +suppressWarnings( data <- Start(dat = file, var = var, file_date = sdates5, @@ -169,7 +172,7 @@ data <- Start(dat = file, time = 'file_date'), metadata_dims = c('file_date'), retrieve = T) - +) expect_equal( names(attr(data, 'Variables')$common), c('latitude', 'longitude', 'time', 'tas', 'tas') diff --git a/tests/testthat/test-Start-global-lon-across_meridian.R b/tests/testthat/test-Start-global-lon-across_meridian.R index 16507033c30bb95c0009b92b99794dcb6adbad91..34c861f1cb568d9254e582c9a796d50a85dc0d94 100644 --- a/tests/testthat/test-Start-global-lon-across_meridian.R +++ b/tests/testthat/test-Start-global-lon-across_meridian.R @@ -3,7 +3,6 @@ context("Start() across_meridia global lon length check") test_that("first test", { -skip_on_cran() repos <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/$var$_$sdate$.nc" var <- 'tas' @@ -12,6 +11,7 @@ skip_on_cran() lat.min <- -90 lat.max <- 90 +suppressWarnings( data <- Start(dat = repos, var = var, sdate = c('20170101'), @@ -26,7 +26,8 @@ skip_on_cran() latitude = 'dat'), retrieve = FALSE ) - +) +suppressWarnings( data2 <- Start(dat = repos, var = var, sdate = c('20170101'), @@ -41,6 +42,7 @@ skip_on_cran() latitude = 'dat'), retrieve = FALSE ) +) expect_equal( attr(data, 'Dimensions'), diff --git a/tests/testthat/test-Start-implicit_dependency_by_selector.R b/tests/testthat/test-Start-implicit_dependency_by_selector.R new file mode 100644 index 0000000000000000000000000000000000000000..5c2f050ed90bbf23199a6e13f1ae40adae9375b3 --- /dev/null +++ b/tests/testthat/test-Start-implicit_dependency_by_selector.R @@ -0,0 +1,118 @@ +# Similar as usecase ex1_13. +# Use a value array as the inner dimension selector to express dependency on a +# file dimension. By this means, we don't need to specify the *_across parameter +# and Start() can recognize this dependecy relationship. +#--------------------------------------------------- +# If assign a selector with an array that has file dim as dimension, Start() read +# the values depending on the the file dim. +#--------------------------------------------------- +context("Start() implicit dependency by selector dimension") + + +test_that("1. region with different index between files", { + +path <- paste0('/esarchive/exp/ecearth/a35b/diags/DCPP/EC-Earth-Consortium/', + 'EC-Earth3-HR/dcppA-hindcast/r1i1p1f1/Omon/$var$_mixed/gn/v20201107/', + '$var$_Omon_EC-Earth3-HR_dcppA-hindcast_s$sdate$-r1i1p1f1_gn_$chunk$.nc') + +# two sdates have different index for Nino3. +region <- array('Nino3', dim = c(sdate = 2, region = 1)) + +suppressWarnings( +data <- Start(dat = path, + var = 'tosmean', + sdate = c('1993', '2013'), + chunk = indices(1:2), + chunk_depends = 'sdate', + region = region, + time = 'all', + time_across = 'chunk', + merge_across_dims = TRUE, + return_vars = list(time = c('sdate', 'chunk'), + region = 'sdate'), + retrieve = T) +) +suppressWarnings( +data1 <- Start(dat = path, + var = 'tosmean', + sdate = c('1993'), + chunk = indices(1:2), + chunk_depends = 'sdate', + region = 'Nino3', + time = 'all', #c(1:length(forecast_month)), + time_across = 'chunk', + merge_across_dims = TRUE, + return_vars = list(time = c('sdate', 'chunk'), + region = NULL), + retrieve = T) +) +suppressWarnings( +data2 <- Start(dat = path, + var = 'tosmean', + sdate = c('2013'), + chunk = indices(1:2), + chunk_depends = 'sdate', + region = 'Nino3', + time = 'all', #c(1:length(forecast_month)), + time_across = 'chunk', + merge_across_dims = TRUE, + return_vars = list(time = c('sdate', 'chunk'), + region = NULL), + retrieve = T) +) + +expect_equal( +dim(data), +c(dat = 1, var = 1, sdate = 2, region = 1, time = 2) +) +expect_equal( +data[1, 1, 1, 1, ], +data1[1, 1, 1, 1, ] +) +expect_equal( +data[1, 1, 2, 1, ], +data2[1, 1, 1, 1, ] +) + + +}) + +test_that("2. time depends on sdate", { + +repos <- '/esarchive/exp/ecmwf/system4_m1/daily_mean/$var$_f24h/$var$_$sdate$.nc' +sdates <- paste0(2001:2003, '0501') +tmp <- as.POSIXct(sapply(2001:2003, function(x) paste0(x, '-05-', sprintf('%02d', 1:31))), tz = 'UTC') +tmp <- array(tmp, dim = c(time = 31, sdate = 3)) +times <- as.POSIXct(tmp, tz = 'UTC', origin = '1970-01-01') + +suppressWarnings( +exp <- Start(dat = repos, + var = 'tos', + sdate = sdates, + time = times, #dim: [time = 31, sdate = 3]. time is corresponding to each sdate + ensemble = indices(1:2), + lat = indices(1:3), + lon = indices(1:6), + synonims = list(lat = c('lat', 'latitude'), + lon = c('lon', 'longitude')), + return_vars = list(lon = NULL, lat = NULL, time = 'sdate'), + retrieve = T) +) + +expect_equal( +dim(exp), +c(dat = 1, var = 1, sdate = 3, time = 31, ensemble = 2, lat = 3, lon = 6) +) +expect_equal( +mean(exp, na.rm = T), +271.4913, +tolerance = 0.0001 +) +expect_equal( +exp[1, 1, 3, 28:30, 1, 3, 2], +c(272.4185, 272.6533, 272.6494), +tolerance = 0.0001 +) + + +}) diff --git a/tests/testthat/test-Start-implicit_inner_dim.R b/tests/testthat/test-Start-implicit_inner_dim.R index 26e3ce71796aebabea10a0da9220444e340e815f..6a3262a6fe17373fb0d7df8469f593b545e76744 100644 --- a/tests/testthat/test-Start-implicit_inner_dim.R +++ b/tests/testthat/test-Start-implicit_inner_dim.R @@ -37,7 +37,7 @@ c(file_date = 2, time = 1) ) expect_equal( attr(obs, 'Variables')$common$time[1, 1], -as.POSIXct('2013-11-15 23:30:00', tz = 'UTC') +as.POSIXct('2013-11-15', tz = 'UTC') ) }) diff --git a/tests/testthat/test-Start-indices_list_vector.R b/tests/testthat/test-Start-indices_list_vector.R new file mode 100644 index 0000000000000000000000000000000000000000..39ecb24f15edde38460a02d06095e59f612dae19 --- /dev/null +++ b/tests/testthat/test-Start-indices_list_vector.R @@ -0,0 +1,241 @@ +# This unit test tests the consistence between list of indices and vector of indices. +# 1. transform +# 2. no transform +# 3. transform, indices reversed +# 4. no transform, indices reversed + +context("List of indices and vector of indices") + + +test_that("1. transform", { + +# lat and lon are lists of indices +suppressWarnings( +exp1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = indices(list(1, 30)), + latitude_reorder = Sort(), + longitude = indices(list(1, 40)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(0, 11, -90, -81)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +# lat and lon are vectors of indices +suppressWarnings( +exp2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 1:30, + latitude_reorder = Sort(), + longitude = 1:40, + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(0, 11, -90, -81)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +expect_equal( +as.vector(exp1), +as.vector(exp2) +) + +}) + +############################################################# +############################################################# +############################################################# + +test_that("2. no transform", { + +# lat and lon are lists of indices +suppressWarnings( +exp1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = indices(list(1, 30)), + latitude_reorder = Sort(), + longitude = indices(list(1, 40)), + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +# lat and lon are vectors of indices +suppressWarnings( +exp2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 1:30, + latitude_reorder = Sort(), + longitude = 1:40, + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +expect_equal( +as.vector(exp1), +as.vector(exp2) +) + +}) + + +############################################################# +############################################################# +############################################################# +# PROBLEM: +# latitude is -81 to -88.2 now, but it should be 81 to 88.2 because the indices is retrieved first then do the transform (aiat = F); and it should be ascending. + +# .. ..$ latitude : num [1:3(1d)] -81 -84.6 -88.2 + +test_that("3. transform, indices reverse", { + +# lat and lon are lists of indices +suppressWarnings( +exp1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = indices(list(30, 1)), + latitude_reorder = Sort(), + longitude = indices(list(1, 40)), # can't reverse. Different meaning + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(0, 11, -90, -81)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +# lat and lon are vectors of indices +suppressWarnings( +exp2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 30:1, + latitude_reorder = Sort(), + longitude = 40:1, + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(0, 11, -90, -81)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +expect_equal( +as.vector(drop(exp1)[, 4:1]), +as.vector(exp2) +) + +}) + +################################################################ +################################################################ +################################################################ + +test_that("4. no transform, indices reverse", { + +# lat and lon are lists of indices +suppressWarnings( +exp1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = indices(list(30, 1)), + latitude_var = 'latitude', + latitude_reorder = Sort(), + longitude = indices(list(1, 40)), # can't reverse. different meaning + longitude_var = 'longitude', + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +# lat and lon are vectors of indices +suppressWarnings( +exp2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 30:1, + latitude_var = 'latitude', + latitude_reorder = Sort(), + longitude = 40:1, + longitude_var = 'longitude', + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +expect_equal( +as.vector(drop(exp1)[, 40:1]), +as.vector(exp2) +) + +}) diff --git a/tests/testthat/test-Start-largest_dims_length.R b/tests/testthat/test-Start-largest_dims_length.R index fe0899e8d19d46ff5372f2d1ee2796f15974b27f..59b73e89c4a8987d99524d4714e139e98f31cbfc 100644 --- a/tests/testthat/test-Start-largest_dims_length.R +++ b/tests/testthat/test-Start-largest_dims_length.R @@ -12,6 +12,7 @@ repos <- list(list(name = 'system5c3s', path = "/esarchive/exp/cmcc/system3_m1-c3s/monthly_mean/g500_f12h/$var$_$sdate$.nc")) # largest_dims_length = FALSE +suppressWarnings( dat1 <- Start(dataset = repos, var = "g500", sdate = c("19931101","20200901"), @@ -28,7 +29,7 @@ dat1 <- Start(dataset = repos, latitude = 'dataset', longitude = 'dataset'), retrieve = T) - +) expect_equal( dim(dat1), c(dataset = 2, var = 1, sdate = 2, time = 6, ensemble = 40, latitude = 3, longitude = 2) @@ -47,6 +48,7 @@ dat1 <- Start(dataset = repos, ) # largest_dims_length = TRUE +suppressWarnings( dat2 <- Start(dataset = repos, var = "g500", sdate = c("19931101","20200901"), @@ -63,7 +65,7 @@ dat2 <- Start(dataset = repos, latitude = 'dataset', longitude = 'dataset'), retrieve = T) - +) expect_equal( dim(dat2), c(dataset = 2, var = 1, sdate = 2, time = 6, ensemble = 51, latitude = 3, longitude = 2) @@ -82,6 +84,7 @@ dat2 <- Start(dataset = repos, ) # largest_dims_length = c(ensemble = 51) +suppressWarnings( dat3 <- Start(dataset = repos, var = "g500", sdate = c("19931101","20200901"), @@ -98,7 +101,7 @@ dat3 <- Start(dataset = repos, latitude = 'dataset', longitude = 'dataset'), retrieve = T) - +) expect_equal( dim(dat3), c(dataset = 2, var = 1, sdate = 2, time = 6, ensemble = 51, latitude = 3, longitude = 2) diff --git a/tests/testthat/test-Start-line_order-consistency.R b/tests/testthat/test-Start-line_order-consistency.R index 74ffae2ad7cb4abd91710d9e6be0a8b69bc97fa9..6b797a89ead97863062c2fec52e7e8fce9f4930d 100644 --- a/tests/testthat/test-Start-line_order-consistency.R +++ b/tests/testthat/test-Start-line_order-consistency.R @@ -12,7 +12,7 @@ context("Start() line order consistency check") lons.max <- 360 test_that("1. lon and lat order", { -skip_on_cran() +suppressWarnings( dat1 <- Start(dat = obs.path, var = variable, file_date = dates_file, @@ -31,7 +31,8 @@ skip_on_cran() longitude = 'dat', time = 'file_date'), retrieve = T) - +) +suppressWarnings( dat2 <- Start(dat = obs.path, var = variable, file_date = dates_file, @@ -50,7 +51,7 @@ skip_on_cran() longitude = 'dat', time = 'file_date'), retrieve = T) - +) expect_equal( length(attr(dat1, 'Variables')$dat1$latitude), length(attr(dat2, 'Variables')$dat1$latitude) @@ -63,8 +64,7 @@ skip_on_cran() test_that("2. dim length check: with/out reorder", { -skip_on_cran() - +suppressWarnings( dat1 <- Start(dat = obs.path, var = variable, file_date = dates_file, @@ -83,7 +83,8 @@ skip_on_cran() longitude = 'dat', time = 'file_date'), retrieve = T) - +) +suppressWarnings( dat2 <- Start(dat = obs.path, var = variable, file_date = dates_file, @@ -104,7 +105,8 @@ skip_on_cran() longitude = 'dat', time = 'file_date'), retrieve = T) - +) +suppressWarnings( dat3 <- Start(dat = obs.path, var = variable, file_date = dates_file, @@ -124,7 +126,7 @@ skip_on_cran() longitude = 'dat', time = 'file_date'), retrieve = T) - +) expect_equal( length(attr(dat1, 'Variables')$dat1$latitude), length(attr(dat2, 'Variables')$dat1$latitude) diff --git a/tests/testthat/test-Start-metadata_dims.R b/tests/testthat/test-Start-metadata_dims.R index b446d1c29692b405aa3f71fe5a0ff9a6d1fcfdd3..3239e7de37b878030d776ea5019d15ceacf43fe6 100644 --- a/tests/testthat/test-Start-metadata_dims.R +++ b/tests/testthat/test-Start-metadata_dims.R @@ -2,13 +2,14 @@ context("Start() metadata_dims check") test_that("1. One data set, one var", { repos <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc" +suppressWarnings( data <- Start(dat = list(list(name = 'system5_m1', path = repos)), var = 'tas', sdate = '20170101', ensemble = indices(1), time = indices(1), - lat = indices(1:10), - lon = indices(1:10), + lat = indices(1:2), + lon = indices(2:3), synonims = list(lat = c('lat', 'latitude'), lon = c('lon', 'longitude')), return_vars = list(time = 'sdate', @@ -17,7 +18,7 @@ test_that("1. One data set, one var", { metadata_dims = 'dat', # it can be omitted since it is automatically specified as 'dat' retrieve = T ) - +) expect_equal( length(attr(data, 'Variables')), 2 @@ -38,6 +39,11 @@ test_that("1. One data set, one var", { length(attr(data, 'Variables')$common$tas), 12 ) + expect_equal( + data[1, 1, 1, 1, 1, , 1], + c(248.5012, 248.7815), + tolerance = 0.0001 + ) }) @@ -45,15 +51,15 @@ test_that("1. One data set, one var", { test_that("2. Two data sets, one var", { repos <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc" repos2 <- "/esarchive/exp/ecmwf/system4_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc" - +suppressWarnings( data <- Start(dat = list(list(name = 'system4_m1', path = repos2), list(name = 'system5_m1', path = repos)), var = 'tas', sdate = '20170101', ensemble = indices(1), time = indices(1), - lat = indices(1:10), - lon = indices(1:10), + lat = indices(1:2), + lon = indices(2:3), synonims = list(lat = c('lat', 'latitude'), lon = c('lon', 'longitude')), return_vars = list(time = 'sdate', @@ -62,7 +68,7 @@ test_that("2. Two data sets, one var", { metadata_dims = 'dat', # it can be omitted since it is automatically specified as 'dat' retrieve = T ) - +) expect_equal( length(attr(data, 'Variables')), 3 @@ -91,7 +97,16 @@ test_that("2. Two data sets, one var", { length(attr(data, 'Variables')$system4_m1$tas), 11 ) - + expect_equal( + data[, 1, 1, 1, 1, 1, 1], + c(247.2570, 248.5012), + tolerance = 0.0001 + ) + expect_equal( + data[, 1, 1, 1, 1, 1, 2], + c(247.2570, 248.5016), + tolerance = 0.0001 + ) }) test_that("3. One data set, two vars", { @@ -99,20 +114,19 @@ test_that("3. One data set, two vars", { 'EC-Earth3/historical/r24i1p1f1/Amon/$var$/gr/v20190312/', '$var$_Amon_EC-Earth3_historical_r24i1p1f1_gr_185001-185012.nc') var <- c('tas', 'clt') - sdate <- '20170101' - +suppressWarnings( data <- Start(dat = repos, var = var, time = indices(1), - lat = indices(1:10), - lon = indices(10:19), + lat = indices(9:10), + lon = indices(10:11), return_vars = list(lat = NULL, lon = NULL), metadata_dims = 'var', synonims = list(lat = c('lat', 'latitude'), lon = c('lon', 'longitude')), retrieve = TRUE ) - +) expect_equal( length(attr(data, 'Variables')), 2 @@ -137,21 +151,30 @@ test_that("3. One data set, two vars", { length(attr(data, 'Variables')$common$clt), 16 ) - + expect_equal( + data[1, , 1, 1, 1], + c(249.42436, 32.45226), + tolerance = 0.0001 + ) + expect_equal( + data[1, , 1, 2, 1], + c(250.00110, 25.04345), + tolerance = 0.0001 + ) }) test_that("4. Two data sets, two vars", { repos <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc" repos2 <- "/esarchive/exp/ecmwf/system4_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc" - +suppressWarnings( data <- Start(dat = list(list(name = 'system4_m1', path = repos2), list(name = 'system5_m1', path = repos)), var = c('tas', 'sfcWind'), sdate = '20170101', ensemble = indices(1), time = indices(1), - lat = indices(1:10), - lon = indices(1:10), + lat = indices(1:2), + lon = indices(1:2), synonims = list(lat = c('lat', 'latitude'), lon = c('lon', 'longitude')), return_vars = list(time = 'sdate', @@ -160,7 +183,7 @@ test_that("4. Two data sets, two vars", { metadata_dims = 'dat', retrieve = T ) - +) expect_equal( length(attr(data, 'Variables')), 3 @@ -189,16 +212,27 @@ test_that("4. Two data sets, two vars", { length(attr(data, 'Variables')$system4_m1$tas), 11 ) + expect_equal( + data[1, , 1, 1, 1, 2, 2], + c(247.227219, 6.370782), + tolerance = 0.0001 + ) + expect_equal( + data[2, , 1, 1, 1, 2, 2], + c(248.781540, 5.794801), + tolerance = 0.0001 + ) - +#------------------------------------------------------------- +suppressWarnings( data <- Start(dat = list(list(name = 'system4_m1', path = repos2), list(name = 'system5_m1', path = repos)), var = c('tas', 'sfcWind'), sdate = '20170101', ensemble = indices(1), time = indices(1), - lat = indices(1:10), - lon = indices(1:10), + lat = indices(1:2), + lon = indices(1:2), synonims = list(lat = c('lat', 'latitude'), lon = c('lon', 'longitude')), return_vars = list(time = 'sdate', @@ -207,6 +241,8 @@ test_that("4. Two data sets, two vars", { metadata_dims = c('dat', 'var'), retrieve = T ) +) + expect_equal( length(attr(data, 'Variables')), 3 @@ -243,13 +279,22 @@ test_that("4. Two data sets, two vars", { length(attr(data, 'Variables')$system4_m1$sfcWind), 11 ) - + expect_equal( + data[1, , 1, 1, 1, 2, 2], + c(247.227219, 6.370782), + tolerance = 0.0001 + ) + expect_equal( + data[2, , 1, 1, 1, 2, 2], + c(248.781540, 5.794801), + tolerance = 0.0001 + ) }) test_that("5. Specify metadata_dims with another file dimension", { repos <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc" repos2 <- "/esarchive/exp/ecmwf/system4_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc" - +suppressWarnings( data <- Start(dat = list(list(name = 'system4_m1', path = repos2), list(name = 'system5_m1', path = repos)), var = c('tas', 'sfcWind'), @@ -266,6 +311,8 @@ test_that("5. Specify metadata_dims with another file dimension", { metadata_dims = 'sdate', retrieve = T ) +) + expect_equal( length(attr(data, 'Variables')), 3 @@ -296,7 +343,7 @@ test_that("5. Specify metadata_dims with another file dimension", { test_that("6. One data set, two vars from one file", { mask_path <- '/esarchive/autosubmit/con_files/mask.regions.Ec3.0_O1L46.nc' - +suppressWarnings( data <- Start(repos = mask_path, var = c('nav_lon', 'nav_lat'), t = 'first', @@ -306,7 +353,7 @@ data <- Start(repos = mask_path, return_vars = list(var_names = NULL), var_var = 'var_names', retrieve = T) - +) expect_equal( length(attr(data, 'Variables')), 2 @@ -335,7 +382,8 @@ test_that("7. Two data sets, while one is missing", { # incorrect path. Therefore repos2 doesn't have any valid files repos2 <- "/esarchive/exp/ecmwf/system4_m1/monthly_mean/$var$_f2h/$var$_$sdate$.nc" # correct one is _f6h var <- 'tas' - data <- Start(dat = list(list(name = 'system4_m1', path = repos2), +suppressWarnings( + data <- Start(dat = list(list(name = 'system4_m1', path = repos2), list(name = 'system5_m1', path = repos)), var = var, sdate = '20170101', @@ -351,14 +399,14 @@ test_that("7. Two data sets, while one is missing", { metadata_dims = 'dat', # it can be omitted since it is automatically specified as 'dat' retrieve = T ) - +) expect_equal( length(data[is.na(data)]), 829440 ) expect_equal( attr(data, "Variables")$system4_m1, - NULL + list(lon = NULL, lat = NULL) ) expect_equal( length(attr(data, "Variables")$system5_m1$lon), @@ -387,7 +435,7 @@ path_list <- list( 'cmip6-dcppA-hindcast_i1p1/DCPP/MOHC/HadGEM3-GC31-MM/', 'dcppA-hindcast/$member$/day/$var$/gn/v20200101/', '$var$_day_HadGEM3-GC31-MM_dcppA-hindcast_s$sdate$-$member$_gn_$chunk$.nc'))) - +suppressWarnings( data <- Start(dataset = path_list, var = 'tasmin', member = list(c('r1i1p1f1', 'r2i1p1f2')), @@ -403,7 +451,7 @@ data <- Start(dataset = path_list, lat_reorder = Sort(), num_procs = 1, retrieve = T) - +) expect_equal( length(data[is.na(data)]), 5500 diff --git a/tests/testthat/test-Start-multiple-sdates.R b/tests/testthat/test-Start-multiple-sdates.R index 832205ae2e8bfd9e8abc4ef776f840b0564dda05..d0c4bd38b55050d51b0c2f25487ed7a168ce5529 100644 --- a/tests/testthat/test-Start-multiple-sdates.R +++ b/tests/testthat/test-Start-multiple-sdates.R @@ -16,24 +16,25 @@ var100_name <- 'windagl100' sdates.seq <- c("20161222","20161229","20170105","20170112") test_that("1. ", { -skip_on_cran() -hcst<-Start(dat = ecmwf_path_hc, - var = var_name, - sdate = sdates.seq, - syear = 'all', - time = 'all', - latitude = indices(1), - longitude = indices(1), - ensemble = 'all', - syear_depends = 'sdate', - return_vars = list(latitude = 'dat', +suppressWarnings( +hcst <- Start(dat = ecmwf_path_hc, + var = var_name, + sdate = sdates.seq, + syear = 'all', + time = 'all', + latitude = indices(1), + longitude = indices(1), + ensemble = 'all', + syear_depends = 'sdate', + return_vars = list(latitude = 'dat', longitude = 'dat', time = c('sdate','syear') ), - retrieve = F) + retrieve = F) +) dates <- attr(hcst, 'Variables')$common$time file_date <- unique(sapply(dates, format, '%Y%m')) - +suppressWarnings( obs <- Start(dat = obs_path, var = var100_name, latitude = indices(1), @@ -51,7 +52,7 @@ obs <- Start(dat = obs_path, longitude = 'dat',# time = c('file_date')), retrieve = T) - +) expect_equal( dim(obs), c(dat = 1, var = 1, latitude = 1, longitude = 1, sdate = 4, syear = 20, time = 47) @@ -88,8 +89,8 @@ obs <- Start(dat = obs_path, }) test_that("2. change the file_date order", { -skip_on_cran() - hcst<-Start(dat = ecmwf_path_hc, +suppressWarnings( +hcst <- Start(dat = ecmwf_path_hc, var = var_name, sdate = sdates.seq, syear = indices(1:20), @@ -103,10 +104,12 @@ skip_on_cran() time = c('sdate','syear') ), retrieve = F) +) + dates <- attr(hcst, 'Variables')$common$time file_date <- sort(unique(sapply(dates, format, '%Y%m'))) - +suppressWarnings( obs <- Start(dat = obs_path, var = var100_name, latitude = indices(1), @@ -124,6 +127,7 @@ obs <- Start(dat = obs_path, longitude = 'dat',# time = c('file_date')), retrieve = T) +) expect_equal( dim(obs), diff --git a/tests/testthat/test-Start-path_glob_permissive.R b/tests/testthat/test-Start-path_glob_permissive.R index 2809d73585a4364fc06db41afb76a802e05a4244..ddd69be18d24b30380ecfd161bb3a7c63d78aa8d 100644 --- a/tests/testthat/test-Start-path_glob_permissive.R +++ b/tests/testthat/test-Start-path_glob_permissive.R @@ -8,7 +8,7 @@ years <- paste0(c(1960:1961), '01-', c(1960:1961), '12') repos <- paste0('/esarchive/exp/ecearth/$expid$/diags/CMIP/EC-Earth-Consortium/', 'EC-Earth3/historical/*/Omon/$var$/gn/v*/', '$var$_Omon_EC-Earth3_historical_*_gn_$year$.nc') - +suppressWarnings( data <- Start(dat = repos, var = 'tosmean', expid = c('a1st', 'a1sx'), @@ -18,7 +18,7 @@ data <- Start(dat = repos, path_glob_permissive = 6, #TRUE, return_vars = list(time = NULL, region = NULL), retrieve = T) - +) expect_equal( dim(data), @@ -48,7 +48,7 @@ data <- Start(dat = repos, repos <- paste0('/esarchive/exp/ecearth/$expid$/diags/CMIP/EC-Earth-Consortium/', 'EC-Earth3/historical/$member$/Omon/$var$/gn/v*/', '$var$_Omon_EC-Earth3_historical_*_gn_$year$.nc') - +suppressWarnings( data <- Start(dat = repos, var = 'tosmean', expid = c('a1st', 'a1sx'), @@ -60,7 +60,7 @@ data <- Start(dat = repos, path_glob_permissive = 2, #TRUE, return_vars = list(time = NULL, region = NULL), retrieve = T) - +) expect_equal( dim(data), @@ -96,44 +96,65 @@ test_that("2. tag at the end", { # Without the layer that path_glob_permissive allows to contain *, the last item in the path is tag. In the example below, the path without path_glob_permissive layer is # "/esarchive/oper/S2S4E-data/weekly_statistics/S2S/$var$/$sdate$/". The last item is "$sdate$" -sdates.seq.thu <- format(seq(as.Date(paste(2020, 06, 11, sep = '-')), as.Date(paste(2020, 09, 17, sep = '-')), - by = 'weeks'), format='%Y%m%d') -path <- "/esarchive/oper/S2S4E-data/weekly_statistics/S2S/$var$/$sdate$/$var$_$sdate$_*.nc" - -exp <- Start(dat = path, - var = "tas", - sdate = sdates.seq.thu, - time = 'all', - ensemble = "all", - latitude = indices(1:2), - longitude = indices(1:2), - path_glob_permissive = 1, - retrieve = F) - - asd <- as.list(attr(exp, 'ExpectedFiles')) - qwe <- sapply(sapply(asd, strsplit, '/'), '[[', 9) - files <- paste0('tas_', sdates.seq.thu, '_', 24:38, '.nc') - expect_equal( - qwe, files - ) - -exp <- Start(dat = path, - var = "tas", - sdate = sdates.seq.thu, - time = 'all', - ensemble = "all", - latitude = indices(1:2), - longitude = indices(1:2), - path_glob_permissive = FALSE, - retrieve = F) - - asd <- as.list(attr(exp, 'ExpectedFiles')) - qwe <- sapply(sapply(asd, strsplit, '/'), '[[', 9) - files <- paste0('tas_', sdates.seq.thu, '_', 24, '.nc') - expect_equal( - qwe, files - ) - +#!!!!!!!!!!This data has been removed!!!!!!!!!!!!! +#sdates.seq.thu <- format(seq(as.Date(paste(2020, 06, 11, sep = '-')), as.Date(paste(2020, 09, 17, sep = '-')), +# by = 'weeks'), format='%Y%m%d') +#path <- "/esarchive/oper/S2S4E-data/weekly_statistics/S2S/$var$/$sdate$/$var$_$sdate$_*.nc" +#suppressWarnings( +#exp <- Start(dat = path, +# var = "tas", +# sdate = sdates.seq.thu, +# time = 'all', +# ensemble = "all", +# latitude = indices(1:2), +# longitude = indices(1:2), +# path_glob_permissive = 1, +# retrieve = F) +#) +# asd <- as.list(attr(exp, 'ExpectedFiles')) +# qwe <- sapply(sapply(asd, strsplit, '/'), '[[', 9) +# files <- paste0('tas_', sdates.seq.thu, '_', 24:38, '.nc') +# expect_equal( +# qwe, files +# ) +# +#suppressWarnings( +#exp <- Start(dat = path, +# var = "tas", +# sdate = sdates.seq.thu, +# time = 'all', +# ensemble = "all", +# latitude = indices(1:2), +# longitude = indices(1:2), +# path_glob_permissive = FALSE, +# retrieve = F) +#) +# asd <- as.list(attr(exp, 'ExpectedFiles')) +# qwe <- sapply(sapply(asd, strsplit, '/'), '[[', 9) +# files <- paste0('tas_', sdates.seq.thu, '_', 24, '.nc') +# expect_equal( +# qwe, files +# ) + + +path <- "/esarchive/exp/ecmwf/system4_m1/6hourly/$var$/$var$_$year$0*.nc" +suppressWarnings( +data <- Start(dat = path, + var = "tas", + year = c('1994', '1995'), + time = indices(1:2), + ensemble = indices(1), + latitude = indices(1:2), + longitude = indices(1:2), + path_glob_permissive = 1, + retrieve = F) +) + +expect_equal( +as.list(attr(data, 'ExpectedFiles')), +list("/esarchive/exp/ecmwf/system4_m1/6hourly/tas/tas_19940501.nc", + "/esarchive/exp/ecmwf/system4_m1/6hourly/tas/tas_19950101.nc") +) }) diff --git a/tests/testthat/test-Start-reorder-lat.R b/tests/testthat/test-Start-reorder-lat.R index 9c2729a930041831e13c707f75dfe41d5bea77da..4133cf01e4b357350bb85dfc58212c472afc8060 100644 --- a/tests/testthat/test-Start-reorder-lat.R +++ b/tests/testthat/test-Start-reorder-lat.R @@ -18,12 +18,11 @@ path_exp <- '/esarchive/exp/ecmwf/system5_m1/daily_mean/$var$_f6h/$var$_$sdate$. ############################################## test_that("1-1-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -38,7 +37,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -81,12 +80,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-2-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 20 lats.max <- 10 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -101,7 +99,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -125,12 +123,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-3-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- -10 lats.max <- -20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -145,7 +142,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -167,12 +164,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-4-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- -20 lats.max <- -10 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -187,7 +183,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -210,12 +206,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("2-1-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -230,7 +225,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -273,12 +268,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("2-2-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 20 lats.max <- 10 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -293,7 +287,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -315,12 +309,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("2-3-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- -10 lats.max <- -20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -335,6 +328,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -356,12 +350,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("2-4-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- -20 lats.max <- -10 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -376,6 +369,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -397,12 +391,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-1-2-3-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -417,6 +410,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = NULL, time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$common$latitude)), @@ -439,12 +433,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("2-1-2-3-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -459,6 +452,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = NULL, time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$common$latitude)), @@ -481,12 +475,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## ############################################## test_that("1-1-2-2-2-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -502,6 +495,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -543,12 +537,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-2-2-2-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 20 lats.max <- 10 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -564,6 +557,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -585,12 +579,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-1-2-2-2-3-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -606,6 +599,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -627,12 +621,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("2-1-2-2-2-3-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -648,6 +641,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -682,12 +676,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-1-2-2-1-1-2-3", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -709,6 +702,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -731,12 +725,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-1-2-2-3-1-2-3", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -759,6 +752,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -780,12 +774,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-1-2-2-3-2-2-3", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -809,6 +802,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -830,12 +824,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-1-2-2-3-1-2-1", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -857,6 +850,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -886,7 +880,175 @@ test_that("1-4. Selector type: indices(vector)", { }) ############################################## -test_that("1-4. Selector type: indices(vector)", { +test_that("4-x-2-12-123-2-1-x", { -}) +# 1-1. no Sort(), NULL +## lat should be descending +suppressWarnings( +exp1_1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 'all', +# latitude_reorder = Sort(), + longitude = 'all', + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('latitude', 'lat'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = T) +) +# 1-2. Sort(), NULL +## lat should be ascending +suppressWarnings( +exp1_2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 'all', + latitude_reorder = Sort(), + longitude = 'all', + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('latitude', 'lat'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = T) +) +# 1-3. Sort(drcreasing = T), NULL +## lat should be descending +suppressWarnings( +exp1_3 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 'all', + latitude_reorder = Sort(decreasing = T), + longitude = 'all', + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('latitude', 'lat'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = T) +) +expect_equal( +drop(exp1_1)[1:5, 2], +c(250.8470, 251.0054, 251.1874, 251.3769, 251.5602), +tolerance = 0.0001 +) +expect_equal( +as.vector(drop(exp1_1)), +as.vector(drop(exp1_2)[640:1, ]) +) +expect_equal( +as.vector(drop(exp1_1)), +as.vector(drop(exp1_3)) +) +expect_equal( +as.vector(attr(exp1_1, 'Variables')$common$latitude)[1:5], +c(89.78488, 89.50620, 89.22588, 88.94519, 88.66436), +tolerance = 0.0001 +) +expect_equal( +as.vector(attr(exp1_2, 'Variables')$common$latitude)[1:5], +c(-89.78488, -89.50620, -89.22588, -88.94519, -88.66436), +tolerance = 0.0001 +) +expect_equal( +as.vector(attr(exp1_1, 'Variables')$common$latitude), +as.vector(attr(exp1_3, 'Variables')$common$latitude) +) + + +# 2-1. no Sort(), 'dat' +## lat should be descending +suppressWarnings( +exp2_1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 'all', +# latitude_reorder = Sort(), + longitude = 'all', + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('latitude', 'lat'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) +# 2-2. Sort(), 'dat' +## lat should be ascending +suppressWarnings( +exp2_2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 'all', + latitude_reorder = Sort(), + longitude = 'all', + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('latitude', 'lat'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) +# 2-3. Sort(drcreasing = T), NULL +## lat should be descending +suppressWarnings( +exp2_3 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 'all', + latitude_reorder = Sort(decreasing = T), + longitude = 'all', + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('latitude', 'lat'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) +expect_equal( +as.vector(drop(exp1_1)), +as.vector(drop(exp2_1)) +) +expect_equal( +as.vector(drop(exp1_2)), +as.vector(drop(exp2_2)) +) +expect_equal( +as.vector(drop(exp1_3)), +as.vector(drop(exp2_3)) +) +expect_equal( +as.vector(attr(exp2_1, 'Variables')$dat1$latitude), +as.vector(attr(exp1_1, 'Variables')$common$latitude) +) +expect_equal( +as.vector(attr(exp2_2, 'Variables')$dat1$latitude), +as.vector(attr(exp1_2, 'Variables')$common$latitude) +) +expect_equal( +as.vector(attr(exp2_3, 'Variables')$dat1$latitude), +as.vector(attr(exp1_3, 'Variables')$common$latitude) +) +}) +############################################## diff --git a/tests/testthat/test-Start-reorder-latCoarse.R b/tests/testthat/test-Start-reorder-latCoarse.R index 4229b06a09944b87d06fcf2060360fefd39ecf1c..4fc62ad03dbadae5c758a1012eac6e7593f8b8ce 100644 --- a/tests/testthat/test-Start-reorder-latCoarse.R +++ b/tests/testthat/test-Start-reorder-latCoarse.R @@ -20,12 +20,11 @@ path_exp <- '/esarchive/exp/ncar/cesm-dple/monthly_mean/$var$/$var$_$sdate$.nc' ## latitude: -90 o 90 {-90, -89.05759 ...} #192 values ############################################## test_that("1-1-4-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path = path_exp)), var = 'psl', member = 'all', @@ -40,7 +39,7 @@ res <- Start(dat = list(list(path = path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -83,12 +82,11 @@ res <- Start(dat = list(list(path = path_exp)), ############################################## test_that("1-2-4-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 20 lats.max <- 10 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -103,7 +101,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -127,12 +125,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-3-4-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- -10 lats.max <- -20 - +suppressWarnings( res <- Start(dat = list(list(path = path_exp)), var = 'psl', member = 'all', @@ -147,7 +144,7 @@ res <- Start(dat = list(list(path = path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -169,12 +166,11 @@ res <- Start(dat = list(list(path = path_exp)), }) ############################################## test_that("1-4-4-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- -20 lats.max <- -10 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -189,7 +185,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -212,12 +208,12 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("2-1-4-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -232,7 +228,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -275,12 +271,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("2-2-4-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 20 lats.max <- 10 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -295,7 +290,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -317,12 +312,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("2-3-4-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- -10 lats.max <- -20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -337,6 +331,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -358,12 +353,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("2-4-4-2-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- -20 lats.max <- -10 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -378,6 +372,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -399,12 +394,12 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-1-4-3-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -419,6 +414,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = NULL, time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$common$latitude)), @@ -441,12 +437,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("2-1-4-3-1-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -461,6 +456,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = NULL, time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$common$latitude)), @@ -483,12 +479,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## ############################################## test_that("1-1-4-2-2-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -504,6 +499,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -545,12 +541,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-4-2-2-1-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 20 lats.max <- 10 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -566,6 +561,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -587,12 +583,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-1-4-2-2-3-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -608,6 +603,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -629,12 +625,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("2-1-4-2-2-3-1-x", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -650,6 +645,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -684,12 +680,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-1-4-2-1-1-2-3", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -711,6 +706,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -733,12 +729,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-1-4-2-3-1-2-3", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -761,6 +756,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -782,12 +778,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-1-4-2-3-2-2-3", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -811,6 +806,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -832,12 +828,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-1-4-2-3-1-2-1", { -skip_on_cran() lons.min <- 40 lons.max <- 45 lats.min <- 10 lats.max <- 20 - +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -859,6 +854,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), diff --git a/tests/testthat/test-Start-reorder-lon_-180to180.R b/tests/testthat/test-Start-reorder-lon-180to180.R similarity index 98% rename from tests/testthat/test-Start-reorder-lon_-180to180.R rename to tests/testthat/test-Start-reorder-lon-180to180.R index bdfc1da5343c95597e6ef76224d7ae781c0744be..aa209b8353300d849203c37594e5671fec76b1e9 100644 --- a/tests/testthat/test-Start-reorder-lon_-180to180.R +++ b/tests/testthat/test-Start-reorder-lon-180to180.R @@ -20,11 +20,11 @@ sdate <- '199212' ############################################## test_that("1-1-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -37,7 +37,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lon expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -60,11 +60,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-2-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -77,6 +77,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10.12500, 19.96875), @@ -90,11 +91,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-3-2-2-1-1-1-x", { -skip_on_cran() lons.min <- -10 lons.max <- -20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -107,7 +108,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-19.96875, -10.12500), @@ -121,11 +122,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-4-2-2-1-1-1-x", { -skip_on_cran() lons.min <- -20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -138,7 +139,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-19.96875, -10.12500), @@ -152,11 +153,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-5-2-2-1-1-1-x", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -169,6 +170,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-9.84375,9.84375), @@ -183,11 +185,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-6-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 10 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -200,6 +202,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c( -9.84375, 9.84375), @@ -213,11 +216,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-8-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 170 lons.max <- 190 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -230,6 +233,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(170.1562, 180), @@ -244,11 +248,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## ############################################## test_that("1-1-2-2-2-2-1-x", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -263,6 +267,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10.12500, 19.96875), @@ -283,11 +288,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-1-2-2-2-3-1-x", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -302,6 +307,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10.12500, 19.96875), @@ -318,11 +324,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-2-2-2-2-1-x", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -337,6 +343,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), 1244 @@ -353,11 +360,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-2-2-2-3-1-x", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -372,6 +379,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), 1244 @@ -389,11 +397,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-3-2-2-2-2-1-x", { -skip_on_cran() lons.min <- -10 lons.max <- -20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -408,6 +416,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), 1244 @@ -425,11 +434,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-3-2-2-2-3-1-x", { -skip_on_cran() lons.min <- -10 lons.max <- -20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -444,6 +453,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), 1244 @@ -456,11 +466,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-4-2-2-2-2-1-x", { -skip_on_cran() lons.min <- -20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -475,6 +485,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(340.0312, 349.8750), @@ -487,11 +498,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-4-2-2-2-3-1-x", { -skip_on_cran() lons.min <- -20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -506,6 +517,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-19.96875, -10.12500), @@ -518,11 +530,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-5-2-2-2-2-1-x", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -537,6 +549,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 359.7188), @@ -559,11 +572,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-5-2-2-2-3-1-x", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -578,6 +591,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-9.84375, 9.84375), @@ -590,11 +604,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-6-2-2-2-2-1-x", { -skip_on_cran() lons.min <- 20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -609,6 +623,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(20.2500, 349.8750), @@ -626,11 +641,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-6-2-2-2-3-1-x", { -skip_on_cran() lons.min <- 20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -645,6 +660,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-180, 179.7188), @@ -666,11 +682,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-7-2-2-2-2-1-x", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -685,6 +701,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(330.1875, 349.8750), @@ -698,11 +715,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-7-2-2-2-3-1-x", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -717,6 +734,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-29.8125, -10.1250), @@ -735,11 +753,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-8-2-2-2-2-1-x", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -754,6 +772,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), 71, @@ -767,11 +786,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-8-2-2-2-3-1-x", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -786,6 +805,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), 71, diff --git a/tests/testthat/test-Start-reorder-lon-transform_-180to180.R b/tests/testthat/test-Start-reorder-lon-transform_-180to180.R index efbe178401b929b11df534a8dcf16f2da6b72cbb..d8b43ee9f59e8a2c500b4841fc67d6993db2b442 100644 --- a/tests/testthat/test-Start-reorder-lon-transform_-180to180.R +++ b/tests/testthat/test-Start-reorder-lon-transform_-180to180.R @@ -19,11 +19,11 @@ sdate <- '199212' ############################################## test_that("1-1-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -32,7 +32,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = F), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -41,6 +41,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -62,11 +63,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-2-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -75,7 +76,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = F), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -84,6 +85,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -101,11 +103,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-5-2-2-1-1-2-4", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -114,7 +116,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -123,6 +125,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-10, 10), @@ -140,11 +143,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-6-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 10 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -153,7 +156,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -162,6 +165,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-10, 10), @@ -178,11 +182,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-8-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 170 lons.max <- 190 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -191,7 +195,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -200,6 +204,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(170, 180), @@ -218,11 +223,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## ############################################## test_that("1-1-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -244,6 +249,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -265,11 +271,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -291,7 +297,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 359), @@ -313,11 +319,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-3-2-2-2-2-2-3", { -skip_on_cran() lons.min <- -10 lons.max <- -20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -339,7 +345,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 359), @@ -361,11 +367,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-4-2-2-2-2-2-3", { -skip_on_cran() lons.min <- -20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -387,6 +393,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(340, 350), @@ -403,11 +410,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-5-2-2-2-2-2-3", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -429,7 +436,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 359), @@ -451,11 +458,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-6-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -477,7 +484,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(20, 350), @@ -494,11 +501,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-7-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -520,6 +527,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(330, 350), @@ -536,11 +544,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-8-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -562,6 +570,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -586,11 +595,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## ############################################## test_that("1-1-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -612,6 +621,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -632,11 +642,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -658,6 +668,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-180, 179), @@ -679,11 +690,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-3-2-2-2-3-2-3", { -skip_on_cran() lons.min <- -10 lons.max <- -20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -705,6 +716,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-180, 179), @@ -726,11 +738,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-4-2-2-2-3-2-3", { -skip_on_cran() lons.min <- -20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -752,6 +764,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-20, -10), @@ -769,11 +782,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-5-2-2-2-3-2-3", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -795,6 +808,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-10, 10), @@ -811,11 +825,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-6-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -837,6 +851,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-180, 179), @@ -858,11 +873,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-7-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -884,6 +899,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-30, -10), @@ -900,11 +916,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-8-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, sdate = sdate, @@ -926,6 +942,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-10, 10), diff --git a/tests/testthat/test-Start-reorder-lon-transform_0to360.R b/tests/testthat/test-Start-reorder-lon-transform_0to360.R index 0a973bcfcd04eaad0e634fda06dff7da9ed57f10..a722bea88af4600845894914bea273a630de9b17 100644 --- a/tests/testthat/test-Start-reorder-lon-transform_0to360.R +++ b/tests/testthat/test-Start-reorder-lon-transform_0to360.R @@ -19,11 +19,11 @@ sdate <- '19821201' ############################################## test_that("1-1-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -33,7 +33,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -43,6 +43,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -64,11 +65,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-2-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -78,7 +79,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -88,6 +89,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -104,11 +106,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-5-2-2-1-1-2-4", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -118,7 +120,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -128,6 +130,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 10), @@ -145,11 +148,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-6-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 10 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -159,7 +162,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -169,6 +172,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 10), @@ -185,11 +189,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-7-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -199,7 +203,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -209,6 +213,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(330, 350), @@ -225,11 +230,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-8-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -239,7 +244,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -249,6 +254,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(350, 359), @@ -267,11 +273,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## ############################################## test_that("1-1-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -295,7 +301,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -316,11 +322,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -344,7 +350,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 359), @@ -366,11 +372,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-3-2-2-2-2-2-3", { -skip_on_cran() lons.min <- -10 lons.max <- -20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -394,7 +400,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 359), @@ -416,11 +422,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-4-2-2-2-2-2-3", { -skip_on_cran() lons.min <- -20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -444,6 +450,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(340, 350), @@ -460,11 +467,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-5-2-2-2-2-2-3", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -488,7 +495,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 359), @@ -510,11 +517,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-6-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -538,7 +545,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(20, 350), @@ -555,11 +562,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-7-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -583,6 +590,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(330, 350), @@ -599,11 +607,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-8-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -627,7 +635,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 359), @@ -651,11 +659,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## ############################################## test_that("1-1-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -679,6 +687,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -699,11 +708,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -727,6 +736,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-180, 179), @@ -748,11 +758,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-3-2-2-2-3-2-3", { -skip_on_cran() lons.min <- -10 lons.max <- -20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -776,6 +786,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-180, 179), @@ -797,11 +808,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-4-2-2-2-3-2-3", { -skip_on_cran() lons.min <- -20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -825,6 +836,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-20, -10), @@ -842,11 +854,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-5-2-2-2-3-2-3", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -870,6 +882,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-10, 10), @@ -886,11 +899,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-6-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -914,6 +927,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-180, 179), @@ -935,11 +949,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-7-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -963,6 +977,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-30, -10), @@ -979,11 +994,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-8-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -1007,6 +1022,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-10, 10), diff --git a/tests/testthat/test-Start-reorder-lon-transform_0to360Coarse.R b/tests/testthat/test-Start-reorder-lon-transform_0to360Coarse.R index 01b5d68919b98c0d7f9886064e7680d18c459dd9..2a4f2ca6cd01fb6f464c6d05683d57e3b58eb09d 100644 --- a/tests/testthat/test-Start-reorder-lon-transform_0to360Coarse.R +++ b/tests/testthat/test-Start-reorder-lon-transform_0to360Coarse.R @@ -23,11 +23,11 @@ sdate <- '20001101' ############################################## test_that("1-1-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -37,7 +37,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -47,6 +47,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -68,11 +69,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-2-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -82,7 +83,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -92,6 +93,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -108,11 +110,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-5-2-2-1-1-2-4", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -122,7 +124,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -132,6 +134,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 10), @@ -149,11 +152,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-6-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 10 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -163,7 +166,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -173,6 +176,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 10), @@ -189,11 +193,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-7-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -203,7 +207,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -213,6 +217,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(330, 350), @@ -229,11 +234,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-8-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -243,7 +248,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = values(list(lons.min, lons.max)), transform = CDORemapper, transform_params = list(grid ='r360x181', - method = 'con'), + method = 'con', crop = T), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -253,6 +258,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(350, 359), @@ -271,11 +277,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## ############################################## test_that("1-1-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -299,6 +305,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -320,11 +327,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -348,7 +355,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 359), @@ -370,11 +377,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-3-2-2-2-2-2-3", { -skip_on_cran() lons.min <- -10 lons.max <- -20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -398,7 +405,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 359), @@ -420,11 +427,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-4-2-2-2-2-2-3", { -skip_on_cran() lons.min <- -20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -448,6 +455,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(340, 350), @@ -464,11 +472,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-5-2-2-2-2-2-3", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -492,6 +500,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -514,11 +523,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-6-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -542,6 +551,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -559,11 +569,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-7-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -587,6 +597,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(330, 350), @@ -603,11 +614,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-8-2-2-2-2-2-3", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -631,7 +642,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 359), @@ -655,11 +666,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## ############################################## test_that("1-1-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -683,6 +694,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -703,11 +715,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -731,6 +743,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-180, 179), @@ -752,11 +765,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-3-2-2-2-3-2-3", { -skip_on_cran() lons.min <- -10 lons.max <- -20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -780,6 +793,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-180, 179), @@ -801,11 +815,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-4-2-2-2-3-2-3", { -skip_on_cran() lons.min <- -20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -829,6 +843,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-20, -10), @@ -846,11 +861,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-5-2-2-2-3-2-3", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -874,6 +889,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-10, 10), @@ -890,11 +906,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-6-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -918,6 +934,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-180, 179), @@ -939,11 +956,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-7-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -967,6 +984,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-30, -10), @@ -983,11 +1001,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-8-2-2-2-3-2-3", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = variable, member = indices(1), @@ -1011,6 +1029,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-10, 10), diff --git a/tests/testthat/test-Start-reorder-lon_0to360.R b/tests/testthat/test-Start-reorder-lon0to360.R similarity index 98% rename from tests/testthat/test-Start-reorder-lon_0to360.R rename to tests/testthat/test-Start-reorder-lon0to360.R index 5faf713a849260765a1cc52adb14bd13b967eddc..340860aa8f3a9d47fbbb974a741eb368aa2cdd9c 100644 --- a/tests/testthat/test-Start-reorder-lon_0to360.R +++ b/tests/testthat/test-Start-reorder-lon0to360.R @@ -18,11 +18,11 @@ path_exp <- '/esarchive/exp/ecmwf/system5_m1/daily_mean/$var$_f6h/$var$_$sdate$. ############################################## test_that("1-1-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -37,7 +37,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lon expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -60,11 +60,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-2-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -79,6 +79,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -91,11 +92,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-5-2-2-1-1-1-x", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -110,6 +111,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 10), @@ -124,11 +126,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-6-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 10 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -143,6 +145,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 10), @@ -156,11 +159,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-7-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -175,6 +178,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(330, 350), @@ -187,11 +191,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-8-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -206,6 +210,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(350, 359.7222222), @@ -220,11 +225,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## ############################################## test_that("1-1-2-2-2-2-1-x", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -241,6 +246,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -261,11 +267,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-1-2-2-2-3-1-x", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -282,6 +288,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -298,11 +305,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-2-2-2-2-1-x", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -319,6 +326,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), c(1261) @@ -335,11 +343,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-2-2-2-3-1-x", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -356,6 +364,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), c(1261) @@ -373,11 +382,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-3-2-2-2-2-1-x", { -skip_on_cran() lons.min <- -10 lons.max <- -20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -394,6 +403,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), c(1261) @@ -411,11 +421,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-3-2-2-2-3-1-x", { -skip_on_cran() lons.min <- -10 lons.max <- -20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -432,6 +442,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), c(1261) @@ -444,11 +455,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-4-2-2-2-2-1-x", { -skip_on_cran() lons.min <- -20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -465,6 +476,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(340, 350), @@ -477,11 +489,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-4-2-2-2-3-1-x", { -skip_on_cran() lons.min <- -20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -498,6 +510,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-20, -10), @@ -511,11 +524,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-5-2-2-2-2-1-x", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -532,6 +545,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(330, 350), @@ -540,11 +554,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-5-2-2-2-3-1-x", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -561,6 +575,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-30, -10), @@ -574,11 +589,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-6-2-2-2-2-1-x", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -595,6 +610,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), c(73), @@ -608,11 +624,12 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-6-2-2-2-3-1-x", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 + +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -629,6 +646,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), c(73), diff --git a/tests/testthat/test-Start-reorder-lon0to360Coarse.R b/tests/testthat/test-Start-reorder-lon0to360Coarse.R index cb7649a82b11e0fa797bb002e2a47f94526ee44e..e093a8870cd2640057c2cb025d730488cc9295af 100644 --- a/tests/testthat/test-Start-reorder-lon0to360Coarse.R +++ b/tests/testthat/test-Start-reorder-lon0to360Coarse.R @@ -18,11 +18,12 @@ path_exp <- '/esarchive/exp/ncar/cesm-dple/monthly_mean/$var$/$var$_$sdate$.nc' ## latitude: -90 o 90 {-90, -89.05759 ...} #192 values ############################################## test_that("1-1-4-2-1-1-1-x", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 + +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -37,7 +38,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lon expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -60,11 +61,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-2-4-2-1-1-1-x", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -79,6 +80,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -91,11 +93,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-5-4-2-1-1-1-x", { -skip_on_cran() lons.min <- -10 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -110,6 +112,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 10), @@ -124,11 +127,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-6-4-2-1-1-1-x", { -skip_on_cran() lons.min <- 10 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -143,6 +146,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(0, 10), @@ -156,11 +160,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-7-4-2-1-1-1-x", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -175,6 +179,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(330, 350), @@ -187,11 +192,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-8-4-2-1-1-1-x", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -206,6 +211,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(350, 358.75), @@ -220,11 +226,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## ############################################## test_that("1-1-4-2-2-2-1-x", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -241,6 +247,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -261,11 +268,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-1-4-2-2-3-1-x", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -282,6 +289,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(10, 20), @@ -298,11 +306,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-4-2-2-2-1-x", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -319,6 +327,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), c(281) @@ -335,11 +344,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-2-4-2-2-3-1-x", { -skip_on_cran() lons.min <- 20 lons.max <- 10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -356,6 +365,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), c(281) @@ -373,11 +383,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-3-4-2-2-2-1-x", { -skip_on_cran() lons.min <- -10 lons.max <- -20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -394,6 +404,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), c(281) @@ -411,11 +422,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-3-4-2-2-3-1-x", { -skip_on_cran() lons.min <- -10 lons.max <- -20 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -432,6 +443,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), c(281) @@ -444,11 +456,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-4-4-2-2-2-1-x", { -skip_on_cran() lons.min <- -20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -465,6 +477,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(340, 350), @@ -477,11 +490,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-4-4-2-2-3-1-x", { -skip_on_cran() lons.min <- -20 lons.max <- -10 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -498,6 +511,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-20, -10), @@ -511,11 +525,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-5-4-2-2-2-1-x", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -532,6 +546,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(330, 350), @@ -540,11 +555,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-5-4-2-2-3-1-x", { -skip_on_cran() lons.min <- 330 lons.max <- 350 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -561,6 +576,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), c(-30, -10), @@ -574,11 +590,11 @@ res <- Start(dat = list(list(path=path_exp)), ############################################## test_that("1-6-4-2-2-2-1-x", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -595,6 +611,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), c(17), @@ -608,11 +625,11 @@ res <- Start(dat = list(list(path=path_exp)), }) ############################################## test_that("1-6-4-2-2-3-1-x", { -skip_on_cran() lons.min <- 350 lons.max <- 370 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -629,6 +646,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), c(17), diff --git a/tests/testthat/test-Start-reorder-metadata.R b/tests/testthat/test-Start-reorder-metadata.R index b522a36d9ae24371ced0c7aa57812929c95b6eab..4b6f909176214091a55866245e44e59009ae480c 100644 --- a/tests/testthat/test-Start-reorder-metadata.R +++ b/tests/testthat/test-Start-reorder-metadata.R @@ -11,6 +11,7 @@ lats.min <- 10 lats.max <- 20 # return_vars is NULL +suppressWarnings( res_null <- Start(dat = list(list(path = path_exp)), var = 'tas', sdate = '199212', @@ -25,7 +26,7 @@ res_null <- Start(dat = list(list(path = path_exp)), longitude = NULL, time = 'sdate'), retrieve = F) - +) expect_equal( length(attributes(attr(res_null, 'Variables')$common$longitude)), 2 @@ -73,6 +74,7 @@ res_null <- Start(dat = list(list(path = path_exp)), ) # return_vars is dat +suppressWarnings( res_dat <- Start(dat = list(list(path = path_exp)), var = 'tas', sdate = '199212', @@ -87,7 +89,7 @@ res_dat <- Start(dat = list(list(path = path_exp)), longitude = 'dat', time = 'sdate'), retrieve = F) - +) expect_equal( length(attributes(attr(res_dat, 'Variables')$dat1$longitude)), 2 @@ -146,6 +148,7 @@ lats.min <- 10 lats.max <- 20 # return_vars is NULL +suppressWarnings( res_null <- Start(dat = list(list(path = path_exp)), var = 'psl', member = 'all', @@ -162,7 +165,7 @@ res_null <- Start(dat = list(list(path = path_exp)), longitude = NULL, time = 'sdate'), retrieve = F) - +) expect_equal( length(attributes(attr(res_null, 'Variables')$common$longitude)), 2 @@ -210,6 +213,7 @@ res_null <- Start(dat = list(list(path = path_exp)), ) # return_vars is 'dat' +suppressWarnings( res_dat <- Start(dat = list(list(path = path_exp)), var = 'psl', member = 'all', @@ -226,7 +230,7 @@ res_dat <- Start(dat = list(list(path = path_exp)), longitude = 'dat', time = 'sdate'), retrieve = F) - +) expect_equal( length(attributes(attr(res_dat, 'Variables')$dat1$longitude)), 2 diff --git a/tests/testthat/test-Start-reorder-retrieve.R b/tests/testthat/test-Start-reorder-retrieve.R index cb6cfc6929ff778623d7285a40843a1c0979ba41..42a79ce343a0dad629e0b6a5f1577cc98ad03e47 100644 --- a/tests/testthat/test-Start-reorder-retrieve.R +++ b/tests/testthat/test-Start-reorder-retrieve.R @@ -5,7 +5,6 @@ context("Start() lon Reorder non-transform retrieve test") ############################################## test_that("original range 0to360", { -skip_on_cran() ## Origin longitude in file: [0:359.722222222222] path_exp <- '/esarchive/exp/ecmwf/system5_m1/daily_mean/$var$_f6h/$var$_$sdate$.nc' @@ -14,7 +13,7 @@ lons.max <- 2 lats.min <- 10 lats.max <- 12 - +suppressWarnings( res <- Start(dat = path_exp, var = 'psl', member = indices(1), @@ -30,8 +29,8 @@ res <- Start(dat = path_exp, longitude = 'dat', time = NULL), retrieve = T) - - +) +suppressWarnings( res1 <- Start(dat = path_exp, var = 'psl', member = indices(1), @@ -48,8 +47,8 @@ res1 <- Start(dat = path_exp, longitude = 'dat', time = NULL), retrieve = T) - - +) +suppressWarnings( res2 <- Start(dat = path_exp, var = 'psl', member = indices(1), @@ -66,7 +65,7 @@ res2 <- Start(dat = path_exp, longitude = 'dat', time = NULL), retrieve = T) - +) expect_equal( res1[1,1,1,1,1,1:7,], res[1,1,1,1,1,7:1,] @@ -85,7 +84,6 @@ res2 <- Start(dat = path_exp, ############################################## test_that("original range -180to180", { -skip_on_cran() ## Origin longitude in file: [0:359.722222222222] path_exp <- '/esarchive/recon/ecmwf/era5/original_files/reorder/daily_mean/$var$/$var$_$sdate$.nc' variable <- 'tas' @@ -96,7 +94,7 @@ lons.max <- 2 lats.min <- 10 lats.max <- 12 - +suppressWarnings( res <- Start(dat = path_exp, var = variable, sdate = '199212', @@ -110,7 +108,8 @@ res <- Start(dat = path_exp, longitude = 'dat', time = NULL), retrieve = T) - +) +suppressWarnings( res1 <- Start(dat = path_exp, var = variable, sdate = '199212', @@ -125,8 +124,8 @@ res1 <- Start(dat = path_exp, longitude = 'dat', time = NULL), retrieve = T) - - +) +suppressWarnings( res2 <- Start(dat = path_exp, var = variable, sdate = '199212', @@ -141,7 +140,7 @@ res2 <- Start(dat = path_exp, longitude = 'dat', time = NULL), retrieve = T) - +) expect_equal( res1[1,1,1,1,1:7,], res[1,1,1,1,7:1,] diff --git a/tests/testthat/test-Start-reshape.R b/tests/testthat/test-Start-reshape.R index 793a3b3cbcf0a28a07314af001d866812fc3ee19..3d576d806115cf4ce0caec983b475f45ad0a37be 100644 --- a/tests/testthat/test-Start-reshape.R +++ b/tests/testthat/test-Start-reshape.R @@ -53,6 +53,7 @@ sorted_dates <- sort(unique(format(dates, '%Y%m'))) unsorted_dates <- unique(format(dates, '%Y%m')) # unsorted dates +suppressWarnings( obs1 <- Start(dat = path_obs, var = var, date = unsorted_dates, @@ -69,8 +70,9 @@ obs1 <- Start(dat = path_obs, lat = NULL, time = 'date'), retrieve = TRUE) - +) # sorted_dates +suppressWarnings( obs2 <- Start(dat = path_obs, var = var, date = sorted_dates, @@ -87,7 +89,7 @@ obs2 <- Start(dat = path_obs, lat = NULL, time = 'date'), retrieve = TRUE) - +) expect_equal( dim(obs1), c(dat = 1, var = 1, sdate = 3, time = 90, lat = 1, lon = 1) @@ -117,7 +119,7 @@ as.vector(easy_array[, 3]) test_that("2. split + merge", { - +suppressWarnings( exp <- Start(dat = path_exp, var = var, sdate = sdate, @@ -131,13 +133,14 @@ exp <- Start(dat = path_exp, lat = NULL, time = 'sdate'), retrieve = FALSE) - +) dates <- attr(exp, 'Variables')$common$time sorted_dates <- sort(unique(format(dates, '%Y%m'))) unsorted_dates <- unique(format(dates, '%Y%m')) # unsorted dates +suppressWarnings( obs1 <- Start(dat = path_obs, var = var, date = unsorted_dates, @@ -154,8 +157,9 @@ obs1 <- Start(dat = path_obs, lat = NULL, time = 'date'), retrieve = TRUE) - +) # sorted_dates +suppressWarnings( obs2 <- Start(dat = path_obs, var = var, date = sorted_dates, @@ -172,7 +176,7 @@ obs2 <- Start(dat = path_obs, lat = NULL, time = 'date'), retrieve = TRUE) - +) expect_equal( dim(obs1), c(dat = 1, var = 1, sdate = 3, time = 62, lat = 1, lon = 1) @@ -241,7 +245,7 @@ test_that("4. merge + narm", { # (1) Notice that the NAs at the tail of 199402 won't be removed because Start() # considers all the files have the same length, i.e., 31. # The NAs in 199402 are regarded as part of the original file. - +suppressWarnings( obs3 <- Start(dat = path_obs, var = var, date = c('199312', '199401', '199402'), @@ -258,7 +262,7 @@ obs3 <- Start(dat = path_obs, lat = NULL, time = 'date'), retrieve = TRUE) - +) expect_equal( dim(obs3), c(dat = 1, var = 1, time = 93, lat = 1, lon = 1) @@ -273,6 +277,7 @@ c(as.vector(easy_array[, 1]), NA, NA, NA) # time = indices(93). # The first 14 time steps of 199312 will be removed but the NAs at the tail # of 199402 will be preserved. +suppressWarnings( obs4 <- Start(dat = path_obs, var = var, date = c('199312', '199401', '199402'), @@ -289,7 +294,7 @@ obs4 <- Start(dat = path_obs, lat = NULL, time = 'date'), retrieve = TRUE) - +) expect_equal( dim(obs4), c(dat = 1, var = 1, time = 79, lat = 1, lon = 1) @@ -300,6 +305,7 @@ c(as.vector(easy_array[15:90, 1]), NA, NA, NA) ) # (3) If time is values(), 199402 is considered time = 28, so NAs will be removed. +suppressWarnings( obs5 <- Start(dat = path_obs, var = var, date = c('199312', '199401', '199402'), @@ -316,6 +322,7 @@ obs5 <- Start(dat = path_obs, lat = NULL, time = 'date'), retrieve = TRUE) +) expect_equal( dim(obs5), c(dat = 1, var = 1, time = 90, lat = 1, lon = 1) @@ -333,6 +340,7 @@ date_array <- c('199312', '199401', '199412', '199501') dim(date_array) <- c(month = 2, year = 2) # split file dim +suppressWarnings( obs1 <- Start(dat = path_obs, var = var, date = date_array, # [month = 2, year = 2] @@ -349,7 +357,7 @@ obs1 <- Start(dat = path_obs, lat = NULL), # time = 'date'), retrieve = TRUE) - +) expect_equal( dim(obs1), c(dat = 1, var = 1, month = 2, year = 2, time = 31, lat = 1, lon = 1) @@ -374,6 +382,7 @@ as.vector(easy_array[32:62, 2]) # split inner time ## time is indices time_array <- array(1:62, dim = c(day = 31, month = 2)) +suppressWarnings( exp1 <- Start(dat = path_exp, var = var, sdate = sdate[1], @@ -388,7 +397,7 @@ exp1 <- Start(dat = path_exp, lat = NULL, time = 'sdate'), retrieve = TRUE) - +) # easyNCDF easy_sdate_exp <- '19931201' easy_file_exp <- NcOpen(paste0('/esarchive/exp/ecmwf/system5c3s/daily_mean/tas_f6h/tas_', @@ -410,6 +419,7 @@ as.vector(easy_exp) ## time is values time_array <- dates[1, 1:62] dim(time_array) <- c(day = 31, month = 2) +suppressWarnings( exp2 <- Start(dat = path_exp, var = var, sdate = sdate[1], @@ -424,6 +434,7 @@ exp2 <- Start(dat = path_exp, lat = NULL), # time = 'sdate'), retrieve = TRUE) +) expect_equal( dim(exp2), c(dat = 1, var = 1, sdate = 1, day = 31, month = 2, ensemble = 1, lat = 1, lon = 1) @@ -437,7 +448,7 @@ as.vector(exp2) }) test_that("6. repetitive values", { - +suppressWarnings( exp <- Start(dat = path_exp, var = var, sdate = c('19931101', '19931201'), @@ -452,6 +463,7 @@ exp <- Start(dat = path_exp, lat = NULL, time = 'sdate'), retrieve = F) +) dates <- attr(exp, 'Variables')$common$time # sorted and unsorted are the same here @@ -459,6 +471,7 @@ sorted_dates <- sort(unique(format(dates, '%Y%m'))) #unsorted_dates <- unique(format(dates, '%Y%m')) # sorted_dates +suppressWarnings( obs2 <- Start(dat = path_obs, var = var, date = sorted_dates, @@ -475,7 +488,7 @@ obs2 <- Start(dat = path_obs, lat = NULL, time = 'date'), retrieve = TRUE) - +) # easyNCDF easy_file_199311 <- NcOpen(paste0('/esarchive/recon/ecmwf/era5/daily_mean/tas_f1h-r360x181/tas_', '199311', '.nc')) diff --git a/tests/testthat/test-Start-split-merge.R b/tests/testthat/test-Start-split-merge.R index 9376f9afc895f1ad714046ddbe54e6e9793ccf27..fe686dc619c7aae495a6bd2815a35aefe1a4fd1a 100644 --- a/tests/testthat/test-Start-split-merge.R +++ b/tests/testthat/test-Start-split-merge.R @@ -180,7 +180,7 @@ c(file_date = 4, time = 1) ) expect_equal( attr(obs, 'Variables')$common$time[1, 1], -as.POSIXct('2013-11-15 23:30:00', tz = 'UTC') +as.POSIXct('2013-11-15', tz = 'UTC') ) diff --git a/tests/testthat/test-Start-transform-border.R b/tests/testthat/test-Start-transform-border.R new file mode 100644 index 0000000000000000000000000000000000000000..a84f1eca315b5929cc57da45ba3f305bbc6cdbb9 --- /dev/null +++ b/tests/testthat/test-Start-transform-border.R @@ -0,0 +1,501 @@ +context("Transform: check with cdo") +# This unit test checks different border situations: normal regional that doesn't touch the borders, +# global situation that uses all the grids, or one side reaches the border. + +# Compare the results with cdo. The example script is as below: +#library(easyNCDF) +#path <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc" +#file <- NcOpen(path) +#arr <- NcToArray(file, +# dim_indices = list(time = 1, ensemble = 1, +# latitude = 1:640, longitude = 1:1296), +# vars_to_read = 'tas') +#lats <- NcToArray(file, +# dim_indices = list(latitude = 1:640), vars_to_read = 'latitude') +#lons <- NcToArray(file, +# dim_indices = list(longitude = 1:1296), vars_to_read = 'longitude') +#NcClose(file) +# +#dim(arr) +#dim(lats) +#arr2 <- s2dv::CDORemap(arr, lons = as.vector(lons), lats = as.vector(lats), +# grid = 'r100x50', method = 'con', crop = c(10,20,20,40)) +#dim(arr2$data_array) + +# The result of cdo is from CDO version 1.9.8. + +test_that("1. normal regional situation", { + +lons.min <- 10 +lons.max <- 20 +lats.min <- 20 +lats.max <- 40 + +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = T) +) +expect_equal( +dim(drop(exp)), +c(latitude = 5, longitude = 3) +) +expect_equal( +drop(exp)[, 1], +c(284.9907, 282.9883, 281.2574, 284.1387, 285.6547), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 2], +c(285.4820, 282.9362, 282.6088, 287.3716, 285.0194), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 3], +c(286.1208, 284.3523, 285.9198, 287.7389, 286.1099), +tolerance = 0.0001 +) + +}) + +# The result is consistent with cdo result, using all the grid points to transform +# and crop the region. +# drop(exp)[, ] +# [,1] [,2] [,3] +#[1,] 284.9907 285.4820 286.1208 +#[2,] 282.9883 282.9362 284.3523 +#[3,] 281.2574 282.6088 285.9198 +#[4,] 284.1387 287.3716 287.7389 +#[5,] 285.6547 285.0194 286.1099 + +#------------------------------------------------ + +test_that("2. global situation", { + +lons.min <- 0 +lons.max <- 359.9 +lats.min <- 20 +lats.max <- 40 + +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = T) +) +expect_equal( +dim(drop(exp)), +c(latitude = 5, longitude = 100) +) +expect_equal( +drop(exp)[, 1], +c(286.4231, 283.8847, 280.4234, 277.7688, 284.3575), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 2], +c(288.0916, 283.9386, 280.9974, 278.4432, 284.8728), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 100], +c(285.9373, 283.6340, 280.6685, 279.6016, 279.5081), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 99], +c(286.3033, 283.8651, 279.9846, 285.0679, 282.6013), +tolerance = 0.0001 +) + +}) + +#> drop(arr2$data_array)[,1:3] +# [,1] [,2] [,3] +#[1,] 286.4231 288.0916 285.7435 +#[2,] 283.8847 283.9386 283.1867 +#[3,] 280.4234 280.9974 281.7465 +#[4,] 277.7688 278.4432 280.2615 +#[5,] 284.3575 284.8728 284.6408 +#> drop(arr2$data_array)[,98:100] +# [,1] [,2] [,3] +#[1,] 286.4648 286.3033 285.9373 +#[2,] 285.5226 283.8651 283.6340 +#[3,] 287.8567 279.9846 280.6685 +#[4,] 288.6723 285.0679 279.6016 +#[5,] 286.8253 282.6013 279.5081 + +#----------------------------------------------- + +test_that("3. left side too close to border", { + +lons.min <- 0 +lons.max <- 20 +lats.min <- 20 +lats.max <- 40 + +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = T) +) +expect_equal( +dim(drop(exp)), +c(latitude = 5, longitude = 6) +) +expect_equal( +drop(exp)[, 1], +c(286.4231, 283.8847, 280.4234, 277.7688, 284.3575), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 2], +c(288.0916, 283.9386, 280.9974, 278.4432, 284.8728), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 3], +c(285.7436, 283.1867, 281.7465, 280.2615, 284.6408), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 4], +c(284.9907, 282.9883, 281.2574, 284.1387, 285.6547), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 5], +c(285.4820, 282.9362, 282.6088, 287.3716, 285.0194), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 6], +c(286.1208, 284.3523, 285.9198, 287.7389, 286.1099), +tolerance = 0.0001 +) + +}) + + +#drop(arr2$data_array)[,] +# [,1] [,2] [,3] [,4] [,5] [,6] +#[1,] 286.4231 288.0916 285.7435 284.9907 285.4820 286.1208 +#[2,] 283.8847 283.9386 283.1867 282.9882 282.9362 284.3523 +#[3,] 280.4234 280.9974 281.7465 281.2574 282.6088 285.9198 +#[4,] 277.7688 278.4432 280.2615 284.1387 287.3716 287.7389 +#[5,] 284.3575 284.8728 284.6408 285.6547 285.0194 286.1099 + + + +test_that("4. right side too close to border", { + +lons.min <- 350 +lons.max <- 359 +lats.min <- 20 +lats.max <- 40 + +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = T) +) +expect_equal( +dim(drop(exp)), +c(latitude = 5, longitude = 2) +) +expect_equal( +drop(exp)[, 1], +c(286.3033, 283.8651, 279.9846, 285.0679, 282.6013), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 2], +c(285.9373, 283.6340, 280.6685, 279.6016, 279.5081), +tolerance = 0.0001 +) + +}) + +#> drop(arr2$data_array)[,] +# [,1] [,2] +#[1,] 286.3033 285.9373 +#[2,] 283.8651 283.6340 +#[3,] 279.9846 280.6685 +#[4,] 285.0679 279.6016 +#[5,] 282.6013 279.5081 + +#-------------------------------------------------- + +test_that("5. across meridian", { + +lons.min <- 170 +lons.max <- 190 +lats.min <- 20 +lats.max <- 40 + +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(-180, 180), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = T) +) +expect_equal( +dim(drop(exp)), +c(latitude = 5, longitude = 5) +) +expect_equal( +drop(exp)[, 1], +c(295.9371, 294.0865, 291.8104, 289.0014, 284.9630), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 2], +c(296.2407, 294.4130, 291.8895, 289.5334, 285.7766), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 3], +c(296.2065, 294.4305, 291.9352, 289.5931, 286.0924), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 4], +c(295.7689, 293.6672, 291.2874, 288.4160, 284.6429), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 5], +c(295.8033, 293.8032, 291.5909, 288.5543, 284.6293), +tolerance = 0.0001 +) + +}) + +# cdo result is [170:190]; Start() is [-180:-170; 170:180]. +# So drop(exp)[, 1:3] == drop(arr2$data_array)[, 3:5]. +#drop(arr2$data_array)[,] +# [,1] [,2] [,3] [,4] [,5] +#[1,] 295.7689 295.8034 295.9371 296.2407 296.2065 +#[2,] 293.6672 293.8032 294.0865 294.4130 294.4306 +#[3,] 291.2874 291.5910 291.8104 291.8895 291.9352 +#[4,] 288.4159 288.5543 289.0014 289.5334 289.5931 +#[5,] 284.6429 284.6293 284.9630 285.7766 286.0924 + + +test_that("6. normal case; [-180, 180]", { +# The lon range is too close to border for the original longitude [0, 360], but +# is normal case for [-180, 180]. In zzz.R, it is counted as normal case, and the +# result is the same as 3. +lons.min <- 0 +lons.max <- 20 +lats.min <- 20 +lats.max <- 40 + +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(-180, 180), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = T) +) +expect_equal( +dim(drop(exp)), +c(latitude = 5, longitude = 6) +) +expect_equal( +drop(exp)[, 1], +c(286.4231, 283.8847, 280.4234, 277.7688, 284.3575), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 2], +c(288.0916, 283.9386, 280.9974, 278.4432, 284.8728), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 3], +c(285.7436, 283.1867, 281.7465, 280.2615, 284.6408), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 4], +c(284.9907, 282.9883, 281.2574, 284.1387, 285.6547), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 5], +c(285.4820, 282.9362, 282.6088, 287.3716, 285.0194), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 6], +c(286.1208, 284.3523, 285.9198, 287.7389, 286.1099), +tolerance = 0.0001 +) + +}) + +#---------------------------------------------------------- + +test_that("6. left side too close to border; [-180, 180]", { +# The lon range is too close to border for the original longitude [0, 360], but +# is normal case for [-180, 180]. In zzz.R, it is counted as normal case, and the +# result is the same as 3. +lons.min <- -179 +lons.max <- -170 +lats.min <- 20 +lats.max <- 40 + +suppressWarnings( +exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(-180, 180), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(lons.min, lons.max, lats.min, lats.max)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve = T) +) +expect_equal( +dim(drop(exp)), +c(latitude = 5, longitude = 2) +) +expect_equal( +drop(exp)[, 1], +c(296.2407, 294.4130, 291.8895, 289.5334, 285.7766), +tolerance = 0.0001 +) +expect_equal( +drop(exp)[, 2], +c(296.2065, 294.4305, 291.9352, 289.5931, 286.0924), +tolerance = 0.0001 +) + +}) + +# cdo result is [181:190] +#> drop(arr2$data_array)[,] +# [,1] [,2] +#[1,] 296.2407 296.2065 +#[2,] 294.4130 294.4306 +#[3,] 291.8895 291.9352 +#[4,] 289.5334 289.5931 +#[5,] 285.7766 286.0924 + diff --git a/tests/testthat/test-Start-transform-lat-Sort-all.R b/tests/testthat/test-Start-transform-lat-Sort-all.R new file mode 100644 index 0000000000000000000000000000000000000000..28393699cd5c4e15194963f60135ee57a9e99b57 --- /dev/null +++ b/tests/testthat/test-Start-transform-lat-Sort-all.R @@ -0,0 +1,125 @@ +# This unit test uses 'all' to do the transformation and tests "lat_reorder". +# The results should be identical and consistent with cdo result (with precision difference). +# "lon_reorder = CircularSort(0, 360)" are used in all the tests. +# The test contains three calls: lat_reorder = Sort(), no lat_reorder, and lat_reorder = Sort(decreasing = T). +# Note that the original latitude is descending [90:-90]. cdo result is ascending [-90:90]. + +context("Transform and lat_reorder test: 'all'") + +#--------------------------------------------------------------- +# cdo is used to verify the data values +library(easyNCDF) +path <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc" +file <- NcOpen(path) +arr <- NcToArray(file, + dim_indices = list(time = 1, ensemble = 1, + latitude = 1:640, longitude = 1:1296), + vars_to_read = 'tas') +lats <- NcToArray(file, + dim_indices = list(latitude = 1:640), vars_to_read = 'latitude') +lons <- NcToArray(file, + dim_indices = list(longitude = 1:1296), vars_to_read = 'longitude') +NcClose(file) +arr2 <- s2dv::CDORemap(arr, lons = as.vector(lons), lats = as.vector(lats), + grid = 'r100x50', method = 'con', crop = FALSE)$data_array +#--------------------------------------------------------------- + +path <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' + +test_that("1. 'all'", { + +# lat should be ascending +suppressWarnings( +res1 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 'all', + latitude_reorder = Sort(), + longitude = 'all', + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be descending or ascending? Because Sort() is not specified and 'all' does not +# say the order either, it could follow the transformed order (if so, ascending). +suppressWarnings( +res2 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 'all', +# latitude_reorder = Sort(), + longitude = 'all', + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, #'dat', + longitude = NULL, #'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be descending +suppressWarnings( +res3 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 'all', + latitude_reorder = Sort(decreasing = T), + longitude = 'all', + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +expect_equal( +as.vector(res1), +as.vector(arr2), +tolerance = 0.0001 +) +expect_equal( +as.vector(res2), +as.vector(arr2), +tolerance = 0.0001 +) + +expect_equal( +as.vector(drop(res3)[50:1, ]), +as.vector(arr2), +tolerance = 0.0001 +) + +}) + diff --git a/tests/testthat/test-Start-transform-lat-Sort-indices.R b/tests/testthat/test-Start-transform-lat-Sort-indices.R new file mode 100644 index 0000000000000000000000000000000000000000..1a1f1ee924f0264c1371cafc33689ed0a29135eb --- /dev/null +++ b/tests/testthat/test-Start-transform-lat-Sort-indices.R @@ -0,0 +1,230 @@ +# This unit test uses indices() to do the transformation and tests "lat_reorder". +# The results should be identical and consistent with cdo result (with precision difference). +# The lat/lon range is all the grids here. +# "lon_reorder = CircularSort(0, 360)" are used in all the tests. +# Test 1 uses indices(1:640), and test 2 uses indices(640:1). +# Each of them contains three calls: lat_reorder = Sort(), no lat_reorder, and lat_reorder = Sort(decreasing = T). +# Note that the original latitude is descending [90:-90]. cdo result is ascending [-90:90]. + +#!!!!!!!!!!!!!!!!!!!!!PROBLEM in test 2, indices(640:1)!!!!!!!!!!!!!!!!!!!! +#TODO: Add regional test + +context("Transform and lat_reorder test: indices") + +#--------------------------------------------------------------- +# cdo is used to verify the data values +library(easyNCDF) +path <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc" +file <- NcOpen(path) +arr <- NcToArray(file, + dim_indices = list(time = 1, ensemble = 1, + latitude = 1:640, longitude = 1:1296), + vars_to_read = 'tas') +lats <- NcToArray(file, + dim_indices = list(latitude = 1:640), vars_to_read = 'latitude') +lons <- NcToArray(file, + dim_indices = list(longitude = 1:1296), vars_to_read = 'longitude') +NcClose(file) +arr2 <- s2dv::CDORemap(arr, lons = as.vector(lons), lats = as.vector(lats), + grid = 'r100x50', method = 'con', crop = FALSE)$data_array +#--------------------------------------------------------------- + +path <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' + +test_that("1. indices(1:640)", { + +# lat should be ascending +suppressWarnings( +res1 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = indices(1:640), + latitude_reorder = Sort(), + longitude = indices(1:1296), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be descending +suppressWarnings( +res2 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = indices(1:640), +# latitude_reorder = Sort(), + longitude = indices(1:1296), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be descending +suppressWarnings( +res3 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = indices(1:640), + latitude_reorder = Sort(decreasing = T), + longitude = indices(1:1296), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +expect_equal( +as.vector(res1), +as.vector(arr2), +tolerance = 0.0001 +) +expect_equal( +as.vector(drop(res2)[50:1, ]), +as.vector(arr2), +tolerance = 0.0001 +) +expect_equal( +as.vector(drop(res3)[50:1, ]), +as.vector(arr2), +tolerance = 0.0001 +) + +}) + +################################################### +################################################### +################################################### + +test_that("2. indices(640:1)", { + +# lat should be ascending +suppressWarnings( +res1 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = indices(640:1), + latitude_reorder = Sort(), + longitude = indices(1:1296), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be ascending +suppressWarnings( +res2 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = indices(640:1), +# latitude_reorder = Sort(), + longitude = indices(1:1296), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be descending +suppressWarnings( +res3 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = indices(640:1), + latitude_reorder = Sort(decreasing = T), + longitude = indices(1:1296), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +#WRONG!!!!!!!!!! it is descending now +#expect_equal( +#as.vector(res1), +#as.vector(arr2), +#tolerance = 0.0001 +#) + +expect_equal( +as.vector(res2), +as.vector(arr2), +tolerance = 0.0001 +) +#WRONG!!!!!!!!!! it is ascending now +#expect_equal( +#as.vector(drop(res3)[50:1, ]), +#as.vector(arr2), +#tolerance = 0.0001 +#) + +}) + diff --git a/tests/testthat/test-Start-transform-lat-Sort-values.R b/tests/testthat/test-Start-transform-lat-Sort-values.R new file mode 100644 index 0000000000000000000000000000000000000000..af00f73095106a416186ea4efa781aac0055f292 --- /dev/null +++ b/tests/testthat/test-Start-transform-lat-Sort-values.R @@ -0,0 +1,430 @@ +# This unit test uses values() to do the transformation and tests "lat_reorder". +# The results should be identical and consistent with cdo result (with precision difference). +# The lon range is all the grids here. +# "lon_reorder = CircularSort(0, 360)" are used in all the tests. +# Test 1 & 2 are global: test 1 uses values(list(-90, 90)) and test 2 uses values(list(90, -90)). +# Test 3 & 4 are regional: test 3 uses values(list(-90, -80)) and test 4 uses values(list(-80, -90)). +# Each of them contains three calls: lat_reorder = Sort(), no lat_reorder, and lat_reorder = Sort(decreasing = T). +# Note that the original latitude is descending [90:-90]. cdo result is ascending [-90:90]. + +context("Transform and lat_reorder test: values") + +#--------------------------------------------------------------- +# cdo is used to verify the data values +library(easyNCDF) +pathh <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc" +file <- NcOpen(pathh) +arr <- NcToArray(file, + dim_indices = list(time = 1, ensemble = 1, + latitude = 1:640, longitude = 1:1296), + vars_to_read = 'tas') +lats <- NcToArray(file, + dim_indices = list(latitude = 1:640), vars_to_read = 'latitude') +lons <- NcToArray(file, + dim_indices = list(longitude = 1:1296), vars_to_read = 'longitude') +NcClose(file) +arr2 <- s2dv::CDORemap(arr, lons = as.vector(lons), lats = as.vector(lats), + grid = 'r100x50', method = 'con', crop = FALSE)$data_array +#--------------------------------------------------------------- + +path <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' + +test_that("1. values(list(-90, 90))", { + +# lat should be ascending +suppressWarnings( +res1 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(-90, 90)), + latitude_reorder = Sort(), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be ascending +suppressWarnings( +res2 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(-90, 90)), +# latitude_reorder = Sort(), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be descending +suppressWarnings( +res3 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(-90, 90)), + latitude_reorder = Sort(decreasing = T), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +expect_equal( +as.vector(res1), +as.vector(arr2), +tolerance = 0.0001 +) +expect_equal( +as.vector(res2), +as.vector(arr2), +tolerance = 0.0001 +) +expect_equal( +as.vector(drop(res3)[50:1, ]), +as.vector(arr2), +tolerance = 0.0001 +) + +}) + +############################################################ +############################################################ +############################################################ + +test_that("2. values(list(90, -90))", { + +# lat should be ascending +suppressWarnings( +res1 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(90, -90)), + latitude_reorder = Sort(), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be descending +suppressWarnings( +res2 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(90, -90)), +# latitude_reorder = Sort(), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be descending +suppressWarnings( +res3 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(90, -90)), + latitude_reorder = Sort(decreasing = T), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + + +expect_equal( +as.vector(res1), +as.vector(arr2), +tolerance = 0.0001 +) +expect_equal( +as.vector(drop(res2)[50:1, ]), +as.vector(arr2), +tolerance = 0.0001 +) +expect_equal( +as.vector(drop(res3)[50:1, ]), +as.vector(arr2), +tolerance = 0.0001 +) + +}) + + +############################################################ +############################################################ +############################################################ + +#NOTE: The numbers at lat = 3 are different with cdo if transform_extra_cells = 2. + +test_that("3. values(list(-90, -80))", { + +# lat should be ascending +suppressWarnings( +res1 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(-90, -80)), + latitude_reorder = Sort(), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = T), # note that crop = T here + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be ascending +suppressWarnings( +res2 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(-90, -80)), +# latitude_reorder = Sort(), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = TRUE), #FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be descending +suppressWarnings( +res3 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(-90, -80)), + latitude_reorder = Sort(decreasing = T), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = TRUE), #FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +expect_equal( +as.vector(res1), +as.vector(drop(arr2)[1:3, ]), +tolerance = 0.0001 +) +expect_equal( +as.vector(res2), +as.vector(drop(arr2)[1:3, ]), +tolerance = 0.0001 +) +expect_equal( +as.vector(res3), +as.vector(drop(arr2)[3:1, ]), +tolerance = 0.0001 +) + +}) + +############################################################ +############################################################ +############################################################ + + +#NOTE: The numbers at lat = 3 are different with cdo if transform_extra_cells = 2. + +test_that("4. values(list(-80, -90))", { + +# lat should be ascending +suppressWarnings( +res1 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(-80, -90)), + latitude_reorder = Sort(), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = T), # note that crop = T here + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be descending +suppressWarnings( +res2 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(-80, -90)), +# latitude_reorder = Sort(), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = TRUE), #FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +# lat should be descending +suppressWarnings( +res3 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(-80, -90)), + latitude_reorder = Sort(decreasing = T), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = TRUE), #FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +expect_equal( +as.vector(res1), +as.vector(drop(arr2)[1:3, ]), +tolerance = 0.0001 +) +expect_equal( +as.vector(res2), +as.vector(drop(arr2)[3:1, ]), +tolerance = 0.0001 +) +expect_equal( +as.vector(res3), +as.vector(drop(arr2)[3:1, ]), +tolerance = 0.0001 +) + +}) + diff --git a/tests/testthat/test-Start-transform-lon-across_meridian.R b/tests/testthat/test-Start-transform-lon-across_meridian.R index 9ac0b8de89bb130a6a316e17ea27f2e4e37e3e03..f16404671bb44b0080c851f27b7388e55eeb1595 100644 --- a/tests/testthat/test-Start-transform-lon-across_meridian.R +++ b/tests/testthat/test-Start-transform-lon-across_meridian.R @@ -3,7 +3,6 @@ context("Start() transform across_meridian lon order check") test_that("first test", { -skip_on_cran() repos <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/$var$_$sdate$.nc" var <- 'tas' @@ -12,6 +11,7 @@ skip_on_cran() lat.min <- -10 #-90 lat.max <- 20 #90 +suppressWarnings( data_across <- Start(dat = repos, var = var, sdate = c('20170101'), @@ -33,7 +33,8 @@ skip_on_cran() longitude = 'dat', latitude = 'dat'), retrieve = T) - +) +suppressWarnings( data_no_across <- Start(dat = repos, var = var, sdate = c('20170101'), @@ -56,7 +57,7 @@ skip_on_cran() longitude = 'dat', latitude = 'dat'), retrieve = T) - +) expect_equal( as.vector(attr(data_across, 'Variables')$dat1$longitude), diff --git a/tests/testthat/test-Start-transform-metadata.R b/tests/testthat/test-Start-transform-metadata.R index f19a02a587a6859989be15eb3b97dd5c46d66952..ede3c959c22c258b384dc7789ab68fb299d7040c 100644 --- a/tests/testthat/test-Start-transform-metadata.R +++ b/tests/testthat/test-Start-transform-metadata.R @@ -11,6 +11,7 @@ lats.min <- 10 lats.max <- 20 # return_vars is NULL +suppressWarnings( res_null <- Start(dat = list(list(path = path_exp)), var = 'tas', sdate = '199212', @@ -32,7 +33,7 @@ res_null <- Start(dat = list(list(path = path_exp)), longitude = NULL, time = 'sdate'), retrieve = F) - +) expect_equal( length(attributes(attr(res_null, 'Variables')$common$latitude)), 1 @@ -72,6 +73,7 @@ res_null <- Start(dat = list(list(path = path_exp)), ) # return_vars is dat +suppressWarnings( res_dat <- Start(dat = list(list(path = path_exp)), var = 'tas', sdate = '199212', @@ -93,7 +95,7 @@ res_dat <- Start(dat = list(list(path = path_exp)), longitude = 'dat', time = 'sdate'), retrieve = F) - +) expect_equal( length(attributes(attr(res_dat, 'Variables')$dat1$latitude)), 1 @@ -144,6 +146,7 @@ lats.min <- 10 lats.max <- 20 # return_vars is NULL +suppressWarnings( res_null <- Start(dat = list(list(path = path_exp)), var = 'psl', member = 'all', @@ -167,7 +170,7 @@ res_null <- Start(dat = list(list(path = path_exp)), longitude = NULL, time = 'sdate'), retrieve = F) - +) expect_equal( length(attributes(attr(res_null, 'Variables')$common$latitude)), 1 @@ -207,6 +210,7 @@ res_null <- Start(dat = list(list(path = path_exp)), ) # return_vars is 'dat' +suppressWarnings( res_dat <- Start(dat = list(list(path = path_exp)), var = 'psl', member = 'all', @@ -230,7 +234,7 @@ res_dat <- Start(dat = list(list(path = path_exp)), longitude = 'dat', time = 'sdate'), retrieve = F) - +) expect_equal( length(attributes(attr(res_dat, 'Variables')$dat1$latitude)), 1 diff --git a/tests/testthat/test-Start-transform-three-selectors.R b/tests/testthat/test-Start-transform-three-selectors.R new file mode 100644 index 0000000000000000000000000000000000000000..3eb00409ba6f0a65fc91943c026af9f57cacf592 --- /dev/null +++ b/tests/testthat/test-Start-transform-three-selectors.R @@ -0,0 +1,194 @@ +# This unit test uses three different selector forms: indices(), values(), and 'all', to do +# the transformation. "lat_reorder" is also tested. +# Their results should be all identical and consistent with cdo result (with precision difference). +# The selected lat/lon range is all the grids here. +# "lon_reorder = CircularSort(0, 360)" and "lat = Sort()" are used in all the tests. +# To see different lat_reorder options, go to "test-Start-transform-lat-Sort-*". +# If values, the lat selector is [-90, 90] or [90, -90]; if indices, c(1:640) or c(640:1). + +# Note that the original latitude is descending [90:-90]. + +context("Transform: three selector forms") + +#--------------------------------------------------------------- +# cdo is used to verify the data values +library(easyNCDF) +path <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc" +file <- NcOpen(path) +arr <- NcToArray(file, + dim_indices = list(time = 1, ensemble = 1, + latitude = 1:640, longitude = 1:1296), + vars_to_read = 'tas') +lats <- NcToArray(file, + dim_indices = list(latitude = 1:640), vars_to_read = 'latitude') +lons <- NcToArray(file, + dim_indices = list(longitude = 1:1296), vars_to_read = 'longitude') +NcClose(file) +arr2 <- s2dv::CDORemap(arr, lons = as.vector(lons), lats = as.vector(lats), + grid = 'r100x50', method = 'con', crop = FALSE)$data_array +#--------------------------------------------------------------- + +path <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' + +test_that("1. indices", { + +suppressWarnings( +res1 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = indices(1:640), + latitude_reorder = Sort(), + longitude = indices(1:1296), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + + +suppressWarnings( +res2 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = indices(640:1), + latitude_reorder = Sort(), + longitude = indices(1:1296), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +expect_equal( +as.vector(res1), +as.vector(arr2), +tolerance = 0.0001 +) +#WRONG!!!!! res2 lat is descending now +#expect_equal( +#as.vector(res1), +#as.vector(res2) +#) + +}) + + +test_that("2. values", { + +suppressWarnings( +res1 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(-90, 90)), + latitude_reorder = Sort(), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) +suppressWarnings( +res2 <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(90, -90)), + latitude_reorder = Sort(), + longitude = values(list(0, 359.9)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +expect_equal( +as.vector(res1), +as.vector(arr2), +tolerance = 0.0001 +) +expect_equal( +as.vector(res2), +as.vector(arr2), +tolerance = 0.0001 +) + + +}) + + +test_that("3. all", { + +suppressWarnings( +res <- Start(dat = path, + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = 'all', + latitude_reorder = Sort(), + longitude = 'all', + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = FALSE), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 2, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = 'dat', + longitude = 'dat', + time = 'sdate'), + retrieve = T) +) + +expect_equal( +as.vector(res), +as.vector(arr2), +tolerance = 0.0001 +) + +}) diff --git a/tests/testthat/test-Start-two_dats.R b/tests/testthat/test-Start-two_dats.R new file mode 100644 index 0000000000000000000000000000000000000000..4fa8642e6eb238363912ad0c593a285e6bab7559 --- /dev/null +++ b/tests/testthat/test-Start-two_dats.R @@ -0,0 +1,100 @@ +# ex1_8 +context("Start() two dats and two vars in one call") + +test_that("1. ex1_8, case 1", { + +path_tas <- paste0('/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consortium/EC-Earth3/', + 'dcppA-hindcast/$member$/Amon/$var$/gr/v20190713/', + '$var$_Amon_EC-Earth3_dcppA-hindcast_s$sdate$-$member$_gr_$fyear$.nc') +path_tos <- paste0('/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consortium/EC-Earth3/', + 'dcppA-hindcast/$member$/Omon/$var$/gr/v20190713/', + '$var$_Omon_EC-Earth3_dcppA-hindcast_s$sdate$-$member$_gr_$fyear$.nc') +suppressWarnings( +data <- Start(dataset = list(list(path = path_tas), list(path = path_tos)), + var = c('tas', 'tos'), + sdate = paste0(1960), + time = 1, + lat = values(list(10, 20)), + lat_reorder = Sort(), + lon = values(list(150, 170)), + lon_reorder = CircularSort(0, 360), + fyear = 'all', + member = indices(1), + fyear_depends = 'sdate', + time_across = 'fyear', + merge_across_dims = TRUE, + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude')), + metadata_dims = c('dataset', 'var'), + return_vars = list(lat = 'dataset', lon = 'dataset'), + retrieve = TRUE) +) + +expect_equal( +dim(data), +c(dataset = 2, var = 2, sdate = 1, time = 1, lat = 15, lon = 28, member = 1) +) +expect_equal( +sum(data, na.rm = T), +264710, +tolerance = 0.0001 +) +expect_equal( +sum(is.na(data[1,1,,,,,])), +0 +) +# Amon also has tos (though the file is incorrect) +expect_equal( +sum(is.na(data[1,2,,,,,])), +0 +) +expect_equal( +sum(is.na(data[2,1,,,,,])), +420 +) +expect_equal( +sum(is.na(data[2,2,,,,,])), +0 +) + +expect_equal( +names(attr(data, 'Variables')), +c("common", "dat1", "dat2") +) +expect_equal( +names(attr(data, 'Variables')$common), +c("time") +) +expect_equal( +names(attr(data, 'Variables')$dat1), +c("lat", "lon", "tas", "tos") +) +expect_equal( +names(attr(data, 'Variables')$dat2), +c("lat", "lon", "tos") +) +expect_equal( +length(attr(data, 'Variables')$dat1$tas), +17 +) +expect_equal( +length(attr(data, 'Variables')$dat1$tos), +16 +) +expect_equal( +length(attr(data, 'Variables')$dat2$tos), +16 +) + +expect_equal( +data[1, , 1, 1, 1, 1, 1], +c(299.9199, 302.5184), +tolerance = 0.0001 +) +expect_equal( +data[2, , 1, 1, 1, 1, 1], +c(NA, 29.3684), +tolerance = 0.0001 +) + +}) diff --git a/tests/testthat/test-Start-values_list_vector.R b/tests/testthat/test-Start-values_list_vector.R new file mode 100644 index 0000000000000000000000000000000000000000..d93b2473526a0237e59b6174902ab6761513deab --- /dev/null +++ b/tests/testthat/test-Start-values_list_vector.R @@ -0,0 +1,245 @@ +# This unit test tests the consistence between list of values and vector of values. +# 1. transform +# 2. no transform +# 3. transform, indices reversed +# 4. no transform, indices reversed + +context("List of values and vector of values") + +#----------------------------------------------------------------- +# To get lat and lon vectors +library(easyNCDF) +pathh <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/tas_f6h/tas_20000101.nc" +file <- NcOpen(pathh) +lats <- NcToArray(file, + dim_indices = list(latitude = 1:35), vars_to_read = 'latitude') +lons <- NcToArray(file, + dim_indices = list(longitude = 1:33), vars_to_read = 'longitude') +NcClose(file) +#------------------------------------------------------------------ + +test_that("1. transform", { + +# lat and lon are lists of values +suppressWarnings( +exp1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(81, 88.2)), + latitude_reorder = Sort(), + longitude = values(list(0, 7.2)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(0, 9, 80, 90)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +# lat and lon are vectors of values. This one is a weird usage though... +suppressWarnings( +exp2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(c(81, 84.6, 88.2)), + latitude_reorder = Sort(), + longitude = values(c(0, 3.6, 7.2)), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(0, 9, 80, 90)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +expect_equal( +as.vector(exp1), +as.vector(exp2) +) + +}) + +############################################################# +############################################################# +############################################################# + +test_that("2. no transform", { + +# lat and lon are lists of indices +suppressWarnings( +exp1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(80, 90)), + latitude_reorder = Sort(), + longitude = values(list(0, 9)), + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +# lat and lon are vectors of indices +suppressWarnings( +exp2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(as.vector(lats)), + latitude_reorder = Sort(), + longitude = values(as.vector(lons)), + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +expect_equal( +as.vector(exp1), +as.vector(exp2) +) + +}) + + +############################################################# +############################################################# +############################################################# + +test_that("3. transform, vector reverse", { + +# lat and lon are lists of values +suppressWarnings( +exp1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(88.2, 81)), + latitude_reorder = Sort(), + longitude = values(list(0, 7.2)), # It can't be reversed; different meanings + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(0, 9, 80, 90)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +#WRONG!!!!!!!!!! +# lat and lon are vectors of values +suppressWarnings( +exp2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(rev(c(81, 84.6, 88.2))), + latitude_reorder = Sort(), + longitude = values(rev(c(0, 3.6, 7.2))), + longitude_reorder = CircularSort(0, 360), + transform = CDORemapper, + transform_params = list(grid = 'r100x50', + method = 'con', + crop = c(0, 9, 80, 90)), + transform_vars = c('latitude', 'longitude'), + transform_extra_cells = 8, + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +expect_equal( +as.vector(exp1), +as.vector(exp2) +) + +}) + +################################################################ +################################################################ +################################################################ + +test_that("4. no transform, vector reverse", { + +# lat and lon are lists of values +suppressWarnings( +exp1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(list(90, 80)), + latitude_reorder = Sort(), + longitude = values(list(0, 9)), # it can't be reversed; different meanings + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +# lat and lon are vectors of values +suppressWarnings( +exp2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', + var = 'tas', + sdate = '20000101', + ensemble = indices(1), + time = indices(1), + latitude = values(rev(as.vector(lats))), + latitude_reorder = Sort(), + longitude = values(rev(as.vector(lons))), + longitude_reorder = CircularSort(0, 360), + synonims = list(latitude = c('lat', 'latitude'), + longitude = c('longitude', 'lon')), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate'), + retrieve= T) +) + +expect_equal( +as.vector(exp1), +as.vector(exp2) +) + +})