From ce5a260bf034973a9bede07988ce994b532e2913 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 13 May 2020 09:57:33 +0200 Subject: [PATCH 01/66] Add TODO and NOTE about character selectors and * expression --- R/Start.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/R/Start.R b/R/Start.R index 3c544a4..f4d4c0f 100644 --- a/R/Start.R +++ b/R/Start.R @@ -930,6 +930,8 @@ Start <- function(..., # dim = indices/selectors, .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) @@ -943,6 +945,10 @@ Start <- function(..., # dim = indices/selectors, } #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) } -- GitLab From 1b04d1d2de8809cdd1d1f522543d11d1e01b372b Mon Sep 17 00:00:00 2001 From: nperez Date: Tue, 2 Mar 2021 13:01:58 +0100 Subject: [PATCH 02/66] split Start step to found_pattern_dims using parent.frame() env --- R/Start.R | 42 ++++-------------------------------------- R/zzz.R | 46 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 50 insertions(+), 38 deletions(-) diff --git a/R/Start.R b/R/Start.R index 33d5809..33c6ab1 100644 --- a/R/Start.R +++ b/R/Start.R @@ -874,45 +874,11 @@ 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. diff --git a/R/zzz.R b/R/zzz.R index af04e6e..7dda044 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -182,3 +182,49 @@ 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]] + 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) +} + -- GitLab From 906093bed81e6a81ac76334ffd697850611d2b88 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 31 Mar 2021 15:27:22 +0200 Subject: [PATCH 03/66] Choose the right indices when selector is value and has dimension of file dim. --- R/Start.R | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/R/Start.R b/R/Start.R index 5139ac5..27663d5 100644 --- a/R/Start.R +++ b/R/Start.R @@ -1853,16 +1853,21 @@ Start <- function(..., # dim = indices/selectors, (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 + 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 { 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 + stop(paste0("Found '", inner_dim, "' has across dependency on the pattern dim '", + found_pattern_dim, "', which is not allowed.")) } else { common_return_vars[[inner_dim]] <- file_dim_name + tmp <- file_dim_name } } .warning(paste0("Found ", inner_dim, " dependency on file diemnsion '", tmp, @@ -3851,7 +3856,13 @@ Start <- function(..., # dim = indices/selectors, first_round_indices <- lapply(inner_dims, function (x) { if (is.null(file_dim_across_files[[x]])) { - selectors[[x]][['fri']][[1]] + 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]] @@ -3861,7 +3872,13 @@ Start <- function(..., # dim = indices/selectors, second_round_indices <- lapply(inner_dims, function (x) { if (is.null(file_dim_across_files[[x]])) { - selectors[[x]][['sri']][[1]] + 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]] -- GitLab From 4445b9d9b072c7b86ae3f6ba4b2d84b4acfd8252 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 31 Mar 2021 16:14:28 +0200 Subject: [PATCH 04/66] Unit test for region with different index between files --- tests/testthat/test-Start-selector_with_dim.R | 70 +++++++++++++++++++ 1 file changed, 70 insertions(+) create mode 100644 tests/testthat/test-Start-selector_with_dim.R diff --git a/tests/testthat/test-Start-selector_with_dim.R b/tests/testthat/test-Start-selector_with_dim.R new file mode 100644 index 0000000..47762d3 --- /dev/null +++ b/tests/testthat/test-Start-selector_with_dim.R @@ -0,0 +1,70 @@ +#--------------------------------------------------- +# 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 inner 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)) + +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) + +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) + +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, ] +) + + +}) -- GitLab From 0b8e7d4fc3acfb16e751a3d06a6b4483992634d8 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 31 Mar 2021 16:58:54 +0200 Subject: [PATCH 05/66] Add FAQ about how to define selector if the indices in the files are not aligned --- inst/doc/faq.md | 68 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 67 insertions(+), 1 deletion(-) diff --git a/inst/doc/faq.md b/inst/doc/faq.md index 3b6d5fa..1770d49 100644 --- a/inst/doc/faq.md +++ b/inst/doc/faq.md @@ -24,7 +24,8 @@ 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) 2. **Something goes wrong...** @@ -848,6 +849,71 @@ 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) +``` + + # Something goes wrong... ### 1. No space left on device -- GitLab From 7ea2e0f0c062d191da11e4e2ccde8dd167f8a414 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 31 Mar 2021 17:58:26 +0200 Subject: [PATCH 06/66] Add TODO --- R/Start.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/Start.R b/R/Start.R index 853dcaf..9cecb87 100644 --- a/R/Start.R +++ b/R/Start.R @@ -3483,6 +3483,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 -- GitLab From cde06001ac09048ff28df783eb90a0cb59baf67a Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 5 May 2021 09:47:58 +0200 Subject: [PATCH 07/66] Correct the results. The data were wrong after the UTC time zone fix. --- inst/doc/usecase/ex1_7_split_merge.R | 53 +++++++++++++++++----------- 1 file changed, 33 insertions(+), 20 deletions(-) diff --git a/inst/doc/usecase/ex1_7_split_merge.R b/inst/doc/usecase/ex1_7_split_merge.R index 539a24d..d041e4e 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,43 @@ 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 + 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. -- GitLab From ec1d8bf3406f41e677406c5ac48b1b9fc1eb08a1 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 5 May 2021 10:54:09 +0200 Subject: [PATCH 08/66] Add easyNCDF check --- inst/doc/usecase/ex1_3_attr_loadin.R | 110 ++++++++++++++++++--------- 1 file changed, 72 insertions(+), 38 deletions(-) diff --git a/inst/doc/usecase/ex1_3_attr_loadin.R b/inst/doc/usecase/ex1_3_attr_loadin.R index d514c30..1968159 100644 --- a/inst/doc/usecase/ex1_3_attr_loadin.R +++ b/inst/doc/usecase/ex1_3_attr_loadin.R @@ -25,17 +25,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 +41,7 @@ substr, 1, 7)))) # dates_file #[1] "199405" "199406" "199407" "199408" "199409" "199410" "199411" "199412" + # ----------------------------------------------------------- # observational data @@ -79,36 +75,23 @@ # If the NAs are not removed, unwanted NAs will exist and make the # values misplaced in the array. See 'bonus' below for more explanation. -#------- 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 +# --> The experimental and observational data are comparable with same structure. -# 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. - -#---------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 +100,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,11 +130,40 @@ 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 -# //////////////////"BONUS"////////////////////// +#-------------------------------------------------------- +# BONUS +#-------------------------------------------------------- # Here is something more to show the usage of parameter 'merge_across_dims_narm'. # If the last day of 30-day months is NA instead of the first day of the following month, # NAs are needed to exist in the array. In this case, 'merge_across_dims_narm' -- GitLab From 81df28e7969e7975ae235990814da4ecfdeeed9f Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 22 Jun 2021 09:38:03 +0200 Subject: [PATCH 09/66] Revise the checks for depending dimension list names; Add explanation of how to use values() to define dependency relation. --- R/Start.R | 14 +++- tests/testthat/test-Start-depends_values.R | 83 ++++++++++++++++++++++ 2 files changed, 96 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/test-Start-depends_values.R diff --git a/R/Start.R b/R/Start.R index ff4b978..443e07b 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 @@ -1484,6 +1488,13 @@ Start <- function(..., # dim = indices/selectors, for (file_dim in file_dims) { if (file_dim %in% names(depending_file_dims)) { ## 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 ", @@ -1491,7 +1502,8 @@ Start <- function(..., # dim = indices/selectors, "vector of selectors must be provided for ", "each selector of the dimension it depends on, '", depending_file_dims[[file_dim]], "'.")) - } else if (!all(names(dat_selectors[[file_dim]]) == dat_selectors[[depending_file_dims[[file_dim]]]][[1]])) { + } else if (is.null(names(dat_selectors[[file_dim]])) | + !all(names(dat_selectors[[file_dim]]) == dat_selectors[[depending_file_dims[[file_dim]]]][[1]])) { stop(paste0("If providing selectors for the depending ", "dimension '", file_dim, "', the name of the ", "provided vectors of selectors must match ", diff --git a/tests/testthat/test-Start-depends_values.R b/tests/testthat/test-Start-depends_values.R new file mode 100644 index 0000000..07a1612 --- /dev/null +++ b/tests/testthat/test-Start-depends_values.R @@ -0,0 +1,83 @@ +# 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. ", { +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:500), + j = indices(650:700), + time_across = 'chunk', + merge_across_dims = TRUE, + return_vars = list(time = 'sdate'), + retrieve = TRUE) + + +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:500), + j = indices(650: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.28614, + tolerance = 0.0001 + ) + expect_equal( + mean(dat1, na.rm = T), + 29.21995, + tolerance = 0.0001 + ) + expect_equal( + dat2[1, 1, 2, 2, 1:3, 10], + c(28.99903, 28.98451, 28.96989), + tolerance = 0.0001 + ) + +}) + +test_that("2. ", { +expect_error( + Start(dat = path, + var = 'tos', + sdate = sdates, + chunk = list(chunks[, 1], chunks[, 2], chunks[ ,3]), + chunk_depends = 'sdate', + time = 'all', + i = indices(400:500), + j = indices(600:700), + time_across = 'chunk', + merge_across_dims = TRUE, + return_vars = list(time = 'sdate'), + retrieve = TRUE), + "If providing selectors for the depending dimension 'chunk', the name of the provided vectors of selectors must match exactly the selectors of the dimension it depends on, 'sdate'." +) + +}) -- GitLab From 632f6a8b40d275d30ddafd474b815b9f4e5e88b0 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 22 Jun 2021 14:23:46 +0200 Subject: [PATCH 10/66] Keep the original code available and return a warning if the depending dim doesn't have list names. --- R/Start.R | 7 +++-- tests/testthat/test-Start-depends_values.R | 36 ++++++++++------------ 2 files changed, 22 insertions(+), 21 deletions(-) diff --git a/R/Start.R b/R/Start.R index 443e07b..a55ff6b 100644 --- a/R/Start.R +++ b/R/Start.R @@ -1502,13 +1502,16 @@ Start <- function(..., # dim = indices/selectors, "vector of selectors must be provided for ", "each selector of the dimension it depends on, '", depending_file_dims[[file_dim]], "'.")) - } else if (is.null(names(dat_selectors[[file_dim]])) | - !all(names(dat_selectors[[file_dim]]) == dat_selectors[[depending_file_dims[[file_dim]]]][[1]])) { + } else if (!all(names(dat_selectors[[file_dim]]) == dat_selectors[[depending_file_dims[[file_dim]]]][[1]])) { stop(paste0("If providing selectors for the depending ", "dimension '", file_dim, "', the name of the ", "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.")) } } } diff --git a/tests/testthat/test-Start-depends_values.R b/tests/testthat/test-Start-depends_values.R index 07a1612..14f9533 100644 --- a/tests/testthat/test-Start-depends_values.R +++ b/tests/testthat/test-Start-depends_values.R @@ -41,6 +41,19 @@ dat2 <- Start(dat = path, return_vars = list(time = 'sdate'), retrieve = TRUE) + dat3 <- Start(dat = path, + var = 'tos', + sdate = sdates, + chunk = list(chunks[, 1], chunks[, 2], 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) + expect_equal( dat1[1,1,1:2,,,], dat2[1,1,1:2,,,] @@ -60,24 +73,9 @@ dat2 <- Start(dat = path, c(28.99903, 28.98451, 28.96989), tolerance = 0.0001 ) - + expect_equal( + as.vector(dat2), + as.vector(dat3) + ) }) -test_that("2. ", { -expect_error( - Start(dat = path, - var = 'tos', - sdate = sdates, - chunk = list(chunks[, 1], chunks[, 2], chunks[ ,3]), - chunk_depends = 'sdate', - time = 'all', - i = indices(400:500), - j = indices(600:700), - time_across = 'chunk', - merge_across_dims = TRUE, - return_vars = list(time = 'sdate'), - retrieve = TRUE), - "If providing selectors for the depending dimension 'chunk', the name of the provided vectors of selectors must match exactly the selectors of the dimension it depends on, 'sdate'." -) - -}) -- GitLab From 6add9c1d67901cdc99365bf80c53248808ee9909 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 22 Jun 2021 16:24:31 +0200 Subject: [PATCH 11/66] Change merge_across_dims to FALSE if no *_across argument. --- R/Start.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/Start.R b/R/Start.R index ff4b978..d46ac2a 100644 --- a/R/Start.R +++ b/R/Start.R @@ -857,6 +857,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)) { -- GitLab From 0cba01dabe5289b3e9091e8b52b46c0b492499cc Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 22 Jun 2021 16:25:37 +0200 Subject: [PATCH 12/66] Update .Rd --- man/Start.Rd | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/man/Start.Rd b/man/Start.Rd index efd258f..3bdae42 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 -- GitLab From acd2bc2531cbf5382987e063504cbd1b220b4a96 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 29 Jun 2021 22:51:51 +0200 Subject: [PATCH 13/66] Let target dimensions be able to have different length among dataset --- R/ByChunks.R | 3 +- .../test-Compute-inconsistent_target_dim.R | 147 ++++++++++++++++++ 2 files changed, 149 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/test-Compute-inconsistent_target_dim.R diff --git a/R/ByChunks.R b/R/ByChunks.R index dd10112..0088235 100644 --- a/R/ByChunks.R +++ b/R/ByChunks.R @@ -354,7 +354,8 @@ 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'))])) { + # 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/tests/testthat/test-Compute-inconsistent_target_dim.R b/tests/testthat/test-Compute-inconsistent_target_dim.R new file mode 100644 index 0000000..3da65c0 --- /dev/null +++ b/tests/testthat/test-Compute-inconsistent_target_dim.R @@ -0,0 +1,147 @@ +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. + +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 <- 1982 +months <- 12:1 +leadtimemin <- 1; leadtimemax <- 3 + +indices <- c('NINO34', 'ALT3') +lons.min <- 190 +lons.max <- 240 +lats.min <- -5 +lats.max <- 5 + + +ini_month <- sprintf("%02d", months[1]) +sdate <- paste0(y1:y2, ini_month, '01') + +suppressWarnings( +exp <- Start(data = path.exp, + var = var, + member = 'all', + sdate = sdate, + time = leadtimemin:leadtimemax, + 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, ini_month, '01'), + 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) + + lons.obs <- as.vector(attr(obs, 'Variables')$common$longitude) + lats.obs <- as.vector(attr(obs, 'Variables')$common$latitude) + 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) + +res <- Compute(workflow$ind_exp, + chunks = list(var = 1), + threads_load = 2, + threads_compute = 4) + + +expect_equal( +attr(exp, 'Dimensions'), +c(data = 1, var = 1, member = 25, sdate = 2, time = 3, latitude = 11, longitude = 51) +) +expect_equal( +attr(obs, 'Dimensions'), +c(data = 1, var = 1, sdate = 2, time = 3, latitude = 41, longitude = 201) +) +expect_equal( +names(res), +c('ind_exp', 'ind_obs') +) +expect_equal( +mean(res$ind_exp)*10^14, +-1.376677, +tolerance = 0.00001 +) +expect_equal( +mean(res$ind_obs)*10^14, +-4.424239, +tolerance = 0.00001 +) + -- GitLab From 0fadf66763b7d27d505c8f1630e03e489ca14dae Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 29 Jun 2021 23:39:18 +0200 Subject: [PATCH 14/66] Fix unit test --- tests/testthat/test-Compute-inconsistent_target_dim.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-Compute-inconsistent_target_dim.R b/tests/testthat/test-Compute-inconsistent_target_dim.R index 3da65c0..2080be6 100644 --- a/tests/testthat/test-Compute-inconsistent_target_dim.R +++ b/tests/testthat/test-Compute-inconsistent_target_dim.R @@ -141,7 +141,7 @@ tolerance = 0.00001 ) expect_equal( mean(res$ind_obs)*10^14, --4.424239, +-1.471046, tolerance = 0.00001 ) -- GitLab From 8dac0e7462ba05443623341a51e137c5d7a770bf Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 30 Jun 2021 01:33:13 +0200 Subject: [PATCH 15/66] Reduce the weight --- .../test-Compute-inconsistent_target_dim.R | 29 ++++++++----------- 1 file changed, 12 insertions(+), 17 deletions(-) diff --git a/tests/testthat/test-Compute-inconsistent_target_dim.R b/tests/testthat/test-Compute-inconsistent_target_dim.R index 2080be6..2e4d6ee 100644 --- a/tests/testthat/test-Compute-inconsistent_target_dim.R +++ b/tests/testthat/test-Compute-inconsistent_target_dim.R @@ -9,24 +9,21 @@ path.obs <- '/esarchive/recon/ecmwf/era5/monthly_mean/$var$_f1h-r1440x721cds/$va var <- 'tos' y1 <- 1981 -y2 <- 1982 -months <- 12:1 +y2 <- 1983 leadtimemin <- 1; leadtimemax <- 3 indices <- c('NINO34', 'ALT3') -lons.min <- 190 +lons.min <- 220 lons.max <- 240 lats.min <- -5 lats.max <- 5 - -ini_month <- sprintf("%02d", months[1]) -sdate <- paste0(y1:y2, ini_month, '01') +sdate <- paste0(y1:y2, '1201') suppressWarnings( exp <- Start(data = path.exp, var = var, - member = 'all', + member = indices(1:2), sdate = sdate, time = leadtimemin:leadtimemax, latitude = values(list(lats.min, lats.max)), @@ -45,7 +42,7 @@ lats.exp <- attr(exp, 'Variables')$common$latitude dates.exp <- attr(exp, 'Variables')$common$time # Manually create date/ime -dates.obs <- c(paste0(y1:y2, ini_month, '01'), +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", @@ -117,31 +114,29 @@ workflow <- AddStep(list(exp = exp, obs = obs), step, lons_obs = lons_obs, lats_obs = lats_obs) res <- Compute(workflow$ind_exp, - chunks = list(var = 1), - threads_load = 2, - threads_compute = 4) + chunks = list(var = 1)) expect_equal( attr(exp, 'Dimensions'), -c(data = 1, var = 1, member = 25, sdate = 2, time = 3, latitude = 11, longitude = 51) +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 = 2, time = 3, latitude = 41, longitude = 201) +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^14, --1.376677, +mean(res$ind_exp)*10^18, +-9.251859, tolerance = 0.00001 ) expect_equal( -mean(res$ind_obs)*10^14, --1.471046, +mean(res$ind_obs)*10^15, +-9.584944, tolerance = 0.00001 ) -- GitLab From 648d807a188ccde4b27097027c527782d226ea4a Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 1 Jul 2021 13:52:18 +0200 Subject: [PATCH 16/66] Create use case for different lengths of target dim. AAAdd check for inconsistent margin dim --- R/ByChunks.R | 9 ++ .../ex2_11_two_dat_inconsistent_target_dim.R | 149 ++++++++++++++++++ .../test-Compute-inconsistent_target_dim.R | 6 +- 3 files changed, 159 insertions(+), 5 deletions(-) create mode 100644 inst/doc/usecase/ex2_11_two_dat_inconsistent_target_dim.R diff --git a/R/ByChunks.R b/R/ByChunks.R index 0088235..8185763 100644 --- a/R/ByChunks.R +++ b/R/ByChunks.R @@ -354,6 +354,15 @@ ByChunks <- function(step_fun, cube_headers, ..., chunks = 'auto', # Check all input headers have matching dimensions cube_index <- 1 for (cube_header in cube_headers) { + + # 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 ", 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 0000000..521a248 --- /dev/null +++ b/inst/doc/usecase/ex2_11_two_dat_inconsistent_target_dim.R @@ -0,0 +1,149 @@ +# 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 <- paste0('/esarchive/exp/ecmwf/system4_m1/6hourly/', + '$var$/$var$_$sdate$.nc') + sdate <- sapply(1994, function(x) paste0(x, sprintf('%02d', 9:12), '01')) + + + exp <- Start(dat = repos, + var = 'tas', + sdate = sdate, + time = indices(seq(1, 124, 4)), #first time step per day + ensemble = 'all', + latitude = values(list(lats.min, lats.max)), + latitude_reorder = Sort(), + longitude = values(list(lons.min, lons.max)), + longitude_reorder = CircularSort(0, 360), + return_vars = list(latitude = NULL, + longitude = NULL, + time = 'sdate')) + + + dates <- attr(system4, 'Variables')$common$time + + dates_file <- sort(unique(gsub('-', '', sapply(as.character(dates), + substr, 1, 7)))) + + +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, '%Y%m')), + time = values(dates), + 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/tests/testthat/test-Compute-inconsistent_target_dim.R b/tests/testthat/test-Compute-inconsistent_target_dim.R index 2e4d6ee..241ab6e 100644 --- a/tests/testthat/test-Compute-inconsistent_target_dim.R +++ b/tests/testthat/test-Compute-inconsistent_target_dim.R @@ -10,9 +10,7 @@ path.obs <- '/esarchive/recon/ecmwf/era5/monthly_mean/$var$_f1h-r1440x721cds/$va var <- 'tos' y1 <- 1981 y2 <- 1983 -leadtimemin <- 1; leadtimemax <- 3 -indices <- c('NINO34', 'ALT3') lons.min <- 220 lons.max <- 240 lats.min <- -5 @@ -25,7 +23,7 @@ exp <- Start(data = path.exp, var = var, member = indices(1:2), sdate = sdate, - time = leadtimemin:leadtimemax, + time = 1:3, latitude = values(list(lats.min, lats.max)), latitude_reorder = Sort(decreasing = TRUE), longitude = values(list(lons.min, lons.max)), @@ -88,8 +86,6 @@ fun <- function(exp, obs, path.output, latdim = which(names(dim(e)) == 'latitude')) index.exp <- (sst.e - mean(sst.e))/sd(sst.e) - lons.obs <- as.vector(attr(obs, 'Variables')$common$longitude) - lats.obs <- as.vector(attr(obs, 'Variables')$common$latitude) o <- s2dv::MeanDims(drop(obs), 'time') sst.o <- ClimProjDiags::WeightedMean(o, lons_obs, lats_obs, londim = which(names(dim(o)) == 'longitude'), -- GitLab From b18a1cecd2ced0e5dc184329c7ce07339a1b14e5 Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 1 Jul 2021 14:10:45 +0200 Subject: [PATCH 17/66] Add new usecase to the document --- inst/doc/usecase.md | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/inst/doc/usecase.md b/inst/doc/usecase.md index 06f2c04..2d1ab9d 100644 --- a/inst/doc/usecase.md +++ b/inst/doc/usecase.md @@ -72,8 +72,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. -- GitLab From 098ad85e7dfb7ae5a7395167b9fe4ccd435d6729 Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 1 Jul 2021 16:28:54 +0200 Subject: [PATCH 18/66] Correct use case --- inst/doc/usecase/ex2_4_two_func.R | 27 +++++++++---------- inst/doc/usecase/ex2_6_ext_param_func.R | 8 +++--- .../ex2_7_seasonal_forecast_verification.R | 4 +-- inst/doc/usecase/ex2_9_mask.R | 18 +++++++++++-- 4 files changed, 34 insertions(+), 23 deletions(-) diff --git a/inst/doc/usecase/ex2_4_two_func.R b/inst/doc/usecase/ex2_4_two_func.R index 4f3da94..d4d1b5f 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 302b52a..8bd128f 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 f24fa42..8b74607 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_9_mask.R b/inst/doc/usecase/ex2_9_mask.R index 13be878..aca6162 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'])) { -- GitLab From eb429e4299af1a803a5dea309236a28da6135235 Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 5 Jul 2021 10:34:21 +0200 Subject: [PATCH 19/66] Correct the script --- .../ex2_11_two_dat_inconsistent_target_dim.R | 30 ++----------------- 1 file changed, 3 insertions(+), 27 deletions(-) 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 index 521a248..69267b0 100644 --- a/inst/doc/usecase/ex2_11_two_dat_inconsistent_target_dim.R +++ b/inst/doc/usecase/ex2_11_two_dat_inconsistent_target_dim.R @@ -7,32 +7,8 @@ # ------------------------------------------------------------------ library(startR) -# exp - repos <- paste0('/esarchive/exp/ecmwf/system4_m1/6hourly/', - '$var$/$var$_$sdate$.nc') - sdate <- sapply(1994, function(x) paste0(x, sprintf('%02d', 9:12), '01')) - - - exp <- Start(dat = repos, - var = 'tas', - sdate = sdate, - time = indices(seq(1, 124, 4)), #first time step per day - ensemble = 'all', - latitude = values(list(lats.min, lats.max)), - latitude_reorder = Sort(), - longitude = values(list(lons.min, lons.max)), - longitude_reorder = CircularSort(0, 360), - return_vars = list(latitude = NULL, - longitude = NULL, - time = 'sdate')) - - - dates <- attr(system4, 'Variables')$common$time - - dates_file <- sort(unique(gsub('-', '', sapply(as.character(dates), - substr, 1, 7)))) - +# 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') @@ -70,8 +46,8 @@ dates_exp 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, '%Y%m')), - time = values(dates), + date = unique(format(dates_exp, '%Y%m')), + time = values(dates_exp), time_across = 'date', merge_across_dims = TRUE, split_multiselected_dims = TRUE, -- GitLab From 4ac97e73f3fefaa0a248fa06a91f312e7b6985d4 Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 5 Jul 2021 16:58:33 +0200 Subject: [PATCH 20/66] Revise ex1_2 and add explanation of time attributes --- inst/doc/usecase.md | 3 +- inst/doc/usecase/ex1_2_exp_obs_attr.R | 173 +++++++++++++++++++++----- inst/doc/usecase/ex1_3_attr_loadin.R | 5 +- 3 files changed, 150 insertions(+), 31 deletions(-) diff --git a/inst/doc/usecase.md b/inst/doc/usecase.md index 06f2c04..c5f8fe4 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). diff --git a/inst/doc/usecase/ex1_2_exp_obs_attr.R b/inst/doc/usecase/ex1_2_exp_obs_attr.R index 2e4b5da..fa2323d 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 e2c8211..80690ee 100644 --- a/inst/doc/usecase/ex1_3_attr_loadin.R +++ b/inst/doc/usecase/ex1_3_attr_loadin.R @@ -2,10 +2,13 @@ # 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. #--------------------------------------------------------------------- # experimental data -- GitLab From 50e8b9090f74559aba3f6d2dcad0f86e206ed13d Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 6 Jul 2021 13:38:46 +0200 Subject: [PATCH 21/66] Add unit testing from use case of Compute() --- tests/testthat/test-Compute-CDORemap.R | 53 +++++++++ tests/testthat/test-Compute-extra_params.R | 122 ++++++++++++++++++++ tests/testthat/test-Compute-timedim.R | 55 +++++++++ tests/testthat/test-Compute-two_data.R | 78 +++++++++++++ tests/testthat/test-Compute-use_attribute.R | 56 +++++++++ 5 files changed, 364 insertions(+) create mode 100644 tests/testthat/test-Compute-CDORemap.R create mode 100644 tests/testthat/test-Compute-extra_params.R create mode 100644 tests/testthat/test-Compute-timedim.R create mode 100644 tests/testthat/test-Compute-two_data.R create mode 100644 tests/testthat/test-Compute-use_attribute.R diff --git a/tests/testthat/test-Compute-CDORemap.R b/tests/testthat/test-Compute-CDORemap.R new file mode 100644 index 0000000..67f2a10 --- /dev/null +++ b/tests/testthat/test-Compute-CDORemap.R @@ -0,0 +1,53 @@ +context("Compute use CDORemap") + +test_that("ex2_3", { + + repos <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' + 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) + + 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-extra_params.R b/tests/testthat/test-Compute-extra_params.R new file mode 100644 index 0000000..9dae43c --- /dev/null +++ b/tests/testthat/test-Compute-extra_params.R @@ -0,0 +1,122 @@ +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 +#=================== + 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) + + 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-timedim.R b/tests/testthat/test-Compute-timedim.R new file mode 100644 index 0000000..4c17806 --- /dev/null +++ b/tests/testthat/test-Compute-timedim.R @@ -0,0 +1,55 @@ +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) + + 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-two_data.R b/tests/testthat/test-Compute-two_data.R new file mode 100644 index 0000000..e55a153 --- /dev/null +++ b/tests/testthat/test-Compute-two_data.R @@ -0,0 +1,78 @@ +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')) + + 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)))) + + 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 + 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 0000000..2ca73a7 --- /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 +) + +}) -- GitLab From 73ebe1c335098e535aea85a8d1f7e24501eb07c8 Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 8 Jul 2021 18:48:16 +0200 Subject: [PATCH 22/66] Fix CSTools:::.cal function and the obs Start() call. --- inst/doc/usecase/ex2_8_calibration.R | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/inst/doc/usecase/ex2_8_calibration.R b/inst/doc/usecase/ex2_8_calibration.R index d02afc1..23ab3b0 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 -- GitLab From ecdbd0f423b380881eb19398c6d59ae8d5aab7f9 Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 12 Jul 2021 18:03:41 +0200 Subject: [PATCH 23/66] Create new use case --- inst/doc/usecase/ex1_13_implicit_dependency.R | 69 +++++++++++++++++++ 1 file changed, 69 insertions(+) create mode 100644 inst/doc/usecase/ex1_13_implicit_dependency.R 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 0000000..d59d563 --- /dev/null +++ b/inst/doc/usecase/ex1_13_implicit_dependency.R @@ -0,0 +1,69 @@ +# Author: An-Chi Ho +# Date: 20th Aug. 2020 +#--------------------------------------------------------------------- +# 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 an 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' + +yr1 <- "2001" +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) + +#============================================================================= + +# 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) + + + + + + + + + -- GitLab From cf6a3c7979299bc91ad528ef880118c562aac5f9 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 13 Jul 2021 10:40:31 +0200 Subject: [PATCH 24/66] Finish use case --- inst/doc/usecase/ex1_13_implicit_dependency.R | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/inst/doc/usecase/ex1_13_implicit_dependency.R b/inst/doc/usecase/ex1_13_implicit_dependency.R index d59d563..8a869b6 100644 --- a/inst/doc/usecase/ex1_13_implicit_dependency.R +++ b/inst/doc/usecase/ex1_13_implicit_dependency.R @@ -1,5 +1,5 @@ # Author: An-Chi Ho -# Date: 20th Aug. 2020 +# Date: 13rd 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 @@ -9,7 +9,7 @@ # 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 an array for region selector so Start() can look for 'Nino3' in +# index 11. Create a value array for region selector so Start() can look for 'Nino3' in # each file. #--------------------------------------------------------------------- @@ -57,8 +57,16 @@ data <- Start(dat = path, merge_across_dims = TRUE, return_vars = list(time = c('sdate', 'chunk'), region = 'sdate'), - retrieve = T) + 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 -- GitLab From 9823ae0bccad40c7375d0e6e107d3acf9c4f23b0 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 13 Jul 2021 13:03:12 +0200 Subject: [PATCH 25/66] Revise unit tests for new testthat version --- tests/testthat/test-AddStep-DimNames.R | 4 +- tests/testthat/test-Compute-CDORemap.R | 8 ++- tests/testthat/test-Compute-NumChunks.R | 31 ++++++---- tests/testthat/test-Compute-extra_params.R | 6 +- .../test-Compute-inconsistent_target_dim.R | 5 +- tests/testthat/test-Compute-timedim.R | 4 +- tests/testthat/test-Compute-two_data.R | 9 ++- .../testthat/test-Start-DCPP-across-depends.R | 10 +++- tests/testthat/test-Start-calendar.R | 19 +++++- .../testthat/test-Start-first_file_missing.R | 17 +++--- .../test-Start-global-lon-across_meridian.R | 5 +- ...t-Start-implicit_dependency_by_selector.R} | 57 +++++++++++++++++- .../testthat/test-Start-largest_dims_length.R | 9 ++- .../test-Start-line_order-consistency.R | 16 +++-- tests/testthat/test-Start-metadata_dims.R | 36 ++++++----- tests/testthat/test-Start-multiple-sdates.R | 36 ++++++----- .../test-Start-path_glob_permissive.R | 15 ++--- tests/testthat/test-Start-reorder-lat.R | 60 +++++++++++-------- tests/testthat/test-Start-reorder-latCoarse.R | 58 +++++++++++------- ...80.R => test-Start-reorder-lon-180to180.R} | 49 ++++++++++++++- ...st-Start-reorder-lon-transform_-180to180.R | 46 ++++++++++++-- .../test-Start-reorder-lon-transform_0to360.R | 50 ++++++++++++++-- ...Start-reorder-lon-transform_0to360Coarse.R | 47 ++++++++++++++- ...to360.R => test-Start-reorder-lon0to360.R} | 38 +++++++++++- .../test-Start-reorder-lon0to360Coarse.R | 38 +++++++++++- tests/testthat/test-Start-reorder-metadata.R | 12 ++-- tests/testthat/test-Start-reorder-retrieve.R | 23 +++---- tests/testthat/test-Start-reshape.R | 39 ++++++++---- ...test-Start-transform-lon-across_meridian.R | 6 +- .../testthat/test-Start-transform-metadata.R | 12 ++-- 30 files changed, 586 insertions(+), 179 deletions(-) rename tests/testthat/{test-Start-selector_with_dim.R => test-Start-implicit_dependency_by_selector.R} (59%) rename tests/testthat/{test-Start-reorder-lon_-180to180.R => test-Start-reorder-lon-180to180.R} (98%) rename tests/testthat/{test-Start-reorder-lon_0to360.R => test-Start-reorder-lon0to360.R} (98%) diff --git a/tests/testthat/test-AddStep-DimNames.R b/tests/testthat/test-AddStep-DimNames.R index 5577ff5..46042f1 100644 --- a/tests/testthat/test-AddStep-DimNames.R +++ b/tests/testthat/test-AddStep-DimNames.R @@ -2,7 +2,8 @@ context("Error with bad dimensions tests.") test_that("Single File - Local execution", { -skip_on_cran() +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 +16,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 index 67f2a10..991e7e1 100644 --- a/tests/testthat/test-Compute-CDORemap.R +++ b/tests/testthat/test-Compute-CDORemap.R @@ -3,6 +3,8 @@ 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'), @@ -12,7 +14,7 @@ test_that("ex2_3", { 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) @@ -28,9 +30,11 @@ test_that("ex2_3", { 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) diff --git a/tests/testthat/test-Compute-NumChunks.R b/tests/testthat/test-Compute-NumChunks.R index 319a18b..507f981 100644 --- a/tests/testthat/test-Compute-NumChunks.R +++ b/tests/testthat/test-Compute-NumChunks.R @@ -3,6 +3,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 +18,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 +27,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-extra_params.R b/tests/testthat/test-Compute-extra_params.R index 9dae43c..9b42e43 100644 --- a/tests/testthat/test-Compute-extra_params.R +++ b/tests/testthat/test-Compute-extra_params.R @@ -11,6 +11,7 @@ test_that("ex2_6", { #=================== # Get daily winds #=================== +suppressWarnings( wind <- Start(dataset = dataset, var = "sfcWind", sdate = sdates, @@ -21,6 +22,7 @@ test_that("ex2_6", { retrieve = FALSE, synonims = list(longitude = c('lon', 'longitude'), latitude = c('lat', 'latitude'))) +) # Synthetic MJO for 'season = OND': set.seed(1) @@ -78,9 +80,11 @@ test_that("ex2_6", { 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'), diff --git a/tests/testthat/test-Compute-inconsistent_target_dim.R b/tests/testthat/test-Compute-inconsistent_target_dim.R index 241ab6e..fa4992a 100644 --- a/tests/testthat/test-Compute-inconsistent_target_dim.R +++ b/tests/testthat/test-Compute-inconsistent_target_dim.R @@ -4,6 +4,7 @@ context("Compute()/ByChunks(): dimension consistence check") # 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' @@ -109,9 +110,10 @@ 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'), @@ -136,3 +138,4 @@ mean(res$ind_obs)*10^15, tolerance = 0.00001 ) +}) diff --git a/tests/testthat/test-Compute-timedim.R b/tests/testthat/test-Compute-timedim.R index 4c17806..80d96ff 100644 --- a/tests/testthat/test-Compute-timedim.R +++ b/tests/testthat/test-Compute-timedim.R @@ -27,9 +27,11 @@ suppressWarnings( 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) diff --git a/tests/testthat/test-Compute-two_data.R b/tests/testthat/test-Compute-two_data.R index e55a153..9cb7145 100644 --- a/tests/testthat/test-Compute-two_data.R +++ b/tests/testthat/test-Compute-two_data.R @@ -7,6 +7,7 @@ test_that("ex2_7", { '$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, @@ -19,12 +20,12 @@ test_that("ex2_7", { 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, @@ -36,7 +37,7 @@ test_that("ex2_7", { 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)) @@ -48,8 +49,10 @@ test_that("ex2_7", { # Compute() on fatnodes +suppressWarnings( res <- Compute(wf, chunks = list(latitude = 2)) +) expect_equal( attr(exp, 'Dimensions'), diff --git a/tests/testthat/test-Start-DCPP-across-depends.R b/tests/testthat/test-Start-DCPP-across-depends.R index f5a5dc6..452a230 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 328aa0e..8ac0760 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-first_file_missing.R b/tests/testthat/test-Start-first_file_missing.R index 25f4d02..392841a 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 1650703..0c01db5 100644 --- a/tests/testthat/test-Start-global-lon-across_meridian.R +++ b/tests/testthat/test-Start-global-lon-across_meridian.R @@ -12,6 +12,7 @@ skip_on_cran() lat.min <- -90 lat.max <- 90 +suppressWarnings( data <- Start(dat = repos, var = var, sdate = c('20170101'), @@ -26,7 +27,8 @@ skip_on_cran() latitude = 'dat'), retrieve = FALSE ) - +) +suppressWarnings( data2 <- Start(dat = repos, var = var, sdate = c('20170101'), @@ -41,6 +43,7 @@ skip_on_cran() latitude = 'dat'), retrieve = FALSE ) +) expect_equal( attr(data, 'Dimensions'), diff --git a/tests/testthat/test-Start-selector_with_dim.R b/tests/testthat/test-Start-implicit_dependency_by_selector.R similarity index 59% rename from tests/testthat/test-Start-selector_with_dim.R rename to tests/testthat/test-Start-implicit_dependency_by_selector.R index 47762d3..bcc5ac1 100644 --- a/tests/testthat/test-Start-selector_with_dim.R +++ b/tests/testthat/test-Start-implicit_dependency_by_selector.R @@ -1,8 +1,12 @@ +# 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 inner dimension") +context("Start() implicit dependency by selector dimension") test_that("1. region with different index between files", { @@ -14,6 +18,7 @@ path <- paste0('/esarchive/exp/ecearth/a35b/diags/DCPP/EC-Earth-Consortium/', # 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'), @@ -26,7 +31,8 @@ data <- Start(dat = path, return_vars = list(time = c('sdate', 'chunk'), region = 'sdate'), retrieve = T) - +) +suppressWarnings( data1 <- Start(dat = path, var = 'tosmean', sdate = c('1993'), @@ -39,7 +45,8 @@ data1 <- Start(dat = path, return_vars = list(time = c('sdate', 'chunk'), region = NULL), retrieve = T) - +) +suppressWarnings( data2 <- Start(dat = path, var = 'tosmean', sdate = c('2013'), @@ -52,6 +59,7 @@ data2 <- Start(dat = path, return_vars = list(time = c('sdate', 'chunk'), region = NULL), retrieve = T) +) expect_equal( dim(data), @@ -67,4 +75,47 @@ data2[1, 1, 1, 1, ] ) +}) + +test_that("2. time depends on sdate", { + +library(lubridate) + +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') + +suppressWarnings( +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: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-largest_dims_length.R b/tests/testthat/test-Start-largest_dims_length.R index fe0899e..59b73e8 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 74ffae2..dab0290 100644 --- a/tests/testthat/test-Start-line_order-consistency.R +++ b/tests/testthat/test-Start-line_order-consistency.R @@ -13,6 +13,7 @@ context("Start() line order consistency check") test_that("1. lon and lat order", { skip_on_cran() +suppressWarnings( dat1 <- Start(dat = obs.path, var = variable, file_date = dates_file, @@ -31,7 +32,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 +52,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) @@ -64,7 +66,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 +85,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 +107,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 +128,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 b446d1c..b514df6 100644 --- a/tests/testthat/test-Start-metadata_dims.R +++ b/tests/testthat/test-Start-metadata_dims.R @@ -2,6 +2,7 @@ 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', @@ -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 @@ -45,7 +46,7 @@ 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', @@ -62,7 +63,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 @@ -100,7 +101,7 @@ test_that("3. One data set, two vars", { '$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), @@ -112,7 +113,7 @@ test_that("3. One data set, two vars", { lon = c('lon', 'longitude')), retrieve = TRUE ) - +) expect_equal( length(attr(data, 'Variables')), 2 @@ -143,7 +144,7 @@ test_that("3. One data set, two vars", { 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'), @@ -160,7 +161,7 @@ test_that("4. Two data sets, two vars", { metadata_dims = 'dat', retrieve = T ) - +) expect_equal( length(attr(data, 'Variables')), 3 @@ -190,7 +191,7 @@ test_that("4. Two data sets, two vars", { 11 ) - +suppressWarnings( data <- Start(dat = list(list(name = 'system4_m1', path = repos2), list(name = 'system5_m1', path = repos)), var = c('tas', 'sfcWind'), @@ -207,6 +208,8 @@ test_that("4. Two data sets, two vars", { metadata_dims = c('dat', 'var'), retrieve = T ) +) + expect_equal( length(attr(data, 'Variables')), 3 @@ -249,7 +252,7 @@ test_that("4. Two data sets, two vars", { 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 +269,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 +301,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 +311,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 +340,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,7 +357,7 @@ 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 @@ -387,7 +393,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 +409,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 832205a..89c8ed8 100644 --- a/tests/testthat/test-Start-multiple-sdates.R +++ b/tests/testthat/test-Start-multiple-sdates.R @@ -17,23 +17,25 @@ 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 +53,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) @@ -89,7 +91,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 +106,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 +129,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 2809d73..f298bd4 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), @@ -99,7 +99,7 @@ test_that("2. tag at the end", { 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, @@ -109,7 +109,7 @@ exp <- Start(dat = path, 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') @@ -117,6 +117,7 @@ exp <- Start(dat = path, qwe, files ) +suppressWarnings( exp <- Start(dat = path, var = "tas", sdate = sdates.seq.thu, @@ -126,7 +127,7 @@ exp <- Start(dat = path, 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') diff --git a/tests/testthat/test-Start-reorder-lat.R b/tests/testthat/test-Start-reorder-lat.R index 9c2729a..262cf37 100644 --- a/tests/testthat/test-Start-reorder-lat.R +++ b/tests/testthat/test-Start-reorder-lat.R @@ -23,7 +23,7 @@ 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 +38,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -86,7 +86,7 @@ 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 +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)), @@ -130,7 +130,7 @@ 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 +145,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -172,7 +172,7 @@ 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 +187,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -215,7 +215,7 @@ 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 +230,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -278,7 +278,7 @@ 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 +293,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -320,7 +320,7 @@ 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 +335,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -361,7 +362,7 @@ 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 +377,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -402,7 +404,7 @@ 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 +419,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = NULL, time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$common$latitude)), @@ -444,7 +447,7 @@ 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 +462,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = NULL, time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$common$latitude)), @@ -486,7 +490,7 @@ 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 +506,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -548,7 +553,7 @@ 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 +569,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -590,7 +596,7 @@ 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 +612,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -632,7 +639,7 @@ 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 +655,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -687,7 +695,7 @@ 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 +717,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -736,7 +745,7 @@ 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 +768,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -785,7 +795,7 @@ 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 +819,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -835,7 +846,7 @@ 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 +868,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-latCoarse.R b/tests/testthat/test-Start-reorder-latCoarse.R index 4229b06..b9d923c 100644 --- a/tests/testthat/test-Start-reorder-latCoarse.R +++ b/tests/testthat/test-Start-reorder-latCoarse.R @@ -25,7 +25,7 @@ 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 +40,7 @@ res <- Start(dat = list(list(path = path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -88,7 +88,7 @@ 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 +103,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -132,7 +132,7 @@ 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 +147,7 @@ res <- Start(dat = list(list(path = path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -174,7 +174,7 @@ 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 +189,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -218,6 +218,7 @@ lons.max <- 45 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -232,7 +233,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -280,7 +281,7 @@ 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 +296,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -322,7 +323,7 @@ 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 +338,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -363,7 +365,7 @@ 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 +380,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -405,6 +408,7 @@ lons.max <- 45 lats.min <- 10 lats.max <- 20 +suppressWarnings( res <- Start(dat = list(list(path=path_exp)), var = 'psl', member = 'all', @@ -419,6 +423,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = NULL, time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$common$latitude)), @@ -446,7 +451,7 @@ 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 +466,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = NULL, time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$common$latitude)), @@ -488,7 +494,7 @@ 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 +510,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -550,7 +557,7 @@ 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 +573,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -592,7 +600,7 @@ 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 +616,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -634,7 +643,7 @@ 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 +659,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -689,7 +699,7 @@ 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 +721,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -738,7 +749,7 @@ 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 +772,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -787,7 +799,7 @@ 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 +823,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) # lat expect_equal( range((attr(res, 'Variables')$dat1$latitude)), @@ -837,7 +850,7 @@ 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 +872,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 bdfc1da..f3c2a3c 100644 --- a/tests/testthat/test-Start-reorder-lon_-180to180.R +++ b/tests/testthat/test-Start-reorder-lon-180to180.R @@ -25,6 +25,7 @@ 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 +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)), @@ -65,6 +66,7 @@ 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 +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.12500, 19.96875), @@ -95,6 +98,7 @@ 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 +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(-19.96875, -10.12500), @@ -126,6 +130,7 @@ 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 +143,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), @@ -157,6 +162,7 @@ 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 +175,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), @@ -188,6 +195,7 @@ 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 +208,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), @@ -218,6 +227,7 @@ 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 +240,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), @@ -249,6 +260,7 @@ 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 +275,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), @@ -288,6 +301,7 @@ 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 +316,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), @@ -323,6 +338,7 @@ 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 +353,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), 1244 @@ -358,6 +375,7 @@ 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 +390,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), 1244 @@ -394,6 +413,7 @@ 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 +428,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), 1244 @@ -430,6 +451,7 @@ 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 +466,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), 1244 @@ -461,6 +484,7 @@ 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 +499,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), @@ -492,6 +517,7 @@ 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 +532,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), @@ -523,6 +550,7 @@ 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 +565,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), @@ -564,6 +593,7 @@ 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 +608,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), @@ -595,6 +626,7 @@ 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 +641,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), @@ -631,6 +664,7 @@ 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 +679,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), @@ -671,6 +706,7 @@ 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 +721,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), @@ -703,6 +740,7 @@ 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 +755,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), @@ -740,6 +779,7 @@ 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 +794,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( length((attr(res, 'Variables')$dat1$longitude)), 71, @@ -772,6 +813,7 @@ 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 +828,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 efbe178..218a8a1 100644 --- a/tests/testthat/test-Start-reorder-lon-transform_-180to180.R +++ b/tests/testthat/test-Start-reorder-lon-transform_-180to180.R @@ -24,6 +24,7 @@ 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, @@ -41,6 +42,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), @@ -67,6 +69,7 @@ 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, @@ -84,6 +87,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), @@ -106,6 +110,7 @@ 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, @@ -123,6 +128,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), @@ -145,6 +151,7 @@ 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, @@ -162,6 +169,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), @@ -183,6 +191,7 @@ 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, @@ -200,6 +209,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), @@ -223,6 +233,7 @@ 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 +255,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -270,6 +282,7 @@ 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 +304,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), @@ -318,6 +331,7 @@ 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 +353,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,6 +380,7 @@ 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 +402,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), @@ -408,6 +424,7 @@ 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 +446,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), @@ -456,6 +473,7 @@ 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 +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(20, 350), @@ -499,6 +517,7 @@ 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 +539,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), @@ -541,6 +561,7 @@ 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 +583,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -591,6 +613,7 @@ 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 +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(10, 20), @@ -637,6 +661,7 @@ 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 +683,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), @@ -684,6 +710,7 @@ 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 +732,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), @@ -731,6 +759,7 @@ 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 +781,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), @@ -774,6 +804,7 @@ 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 +826,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), @@ -816,6 +848,7 @@ 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 +870,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), @@ -863,6 +897,7 @@ 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 +919,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), @@ -905,6 +941,7 @@ 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 +963,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 0a973bc..0887615 100644 --- a/tests/testthat/test-Start-reorder-lon-transform_0to360.R +++ b/tests/testthat/test-Start-reorder-lon-transform_0to360.R @@ -24,6 +24,7 @@ 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), @@ -43,6 +44,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), @@ -69,6 +71,7 @@ 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), @@ -88,6 +91,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), @@ -109,6 +113,7 @@ 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), @@ -128,6 +133,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), @@ -150,6 +156,7 @@ 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), @@ -169,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), @@ -190,6 +198,7 @@ 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), @@ -209,6 +218,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), @@ -230,6 +240,7 @@ 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), @@ -249,6 +260,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), @@ -272,6 +284,7 @@ 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 +308,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), @@ -321,6 +334,7 @@ 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 +358,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), @@ -371,6 +385,7 @@ 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 +409,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), @@ -421,6 +436,7 @@ 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 +460,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), @@ -465,6 +482,7 @@ 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 +506,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), @@ -515,6 +533,7 @@ 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 +557,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), @@ -560,6 +579,7 @@ 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 +603,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), @@ -604,6 +625,7 @@ 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 +649,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), @@ -656,6 +678,7 @@ 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 +702,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), @@ -704,6 +728,7 @@ 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 +752,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), @@ -753,6 +779,7 @@ 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 +803,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), @@ -802,6 +830,7 @@ 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 +854,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), @@ -847,6 +877,7 @@ 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 +901,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), @@ -891,6 +923,7 @@ 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 +947,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), @@ -940,6 +974,7 @@ 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 +998,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), @@ -984,6 +1020,7 @@ 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 +1044,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 01b5d68..6d45a67 100644 --- a/tests/testthat/test-Start-reorder-lon-transform_0to360Coarse.R +++ b/tests/testthat/test-Start-reorder-lon-transform_0to360Coarse.R @@ -28,6 +28,7 @@ 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), @@ -47,6 +48,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), @@ -73,6 +75,7 @@ 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), @@ -92,6 +95,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), @@ -113,6 +117,7 @@ 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), @@ -132,6 +137,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), @@ -154,6 +160,7 @@ 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), @@ -173,6 +180,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), @@ -194,6 +202,7 @@ 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), @@ -213,6 +222,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), @@ -234,6 +244,7 @@ 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), @@ -253,6 +264,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), @@ -276,6 +288,7 @@ 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 +312,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -325,6 +339,7 @@ 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 +363,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), @@ -375,6 +390,7 @@ 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 +414,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), @@ -425,6 +441,7 @@ 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 +465,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), @@ -469,6 +487,7 @@ 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 +511,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -519,6 +539,7 @@ 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 +563,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) +) expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -564,6 +586,7 @@ 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 +610,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), @@ -608,6 +632,7 @@ 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 +656,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), @@ -660,6 +685,7 @@ 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 +709,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), @@ -708,6 +735,7 @@ 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 +759,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), @@ -757,6 +786,7 @@ 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 +810,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), @@ -806,6 +837,7 @@ 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 +861,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), @@ -851,6 +884,7 @@ 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 +908,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), @@ -895,6 +930,7 @@ 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 +954,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), @@ -944,6 +981,7 @@ 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 +1005,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), @@ -988,6 +1027,7 @@ 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 +1051,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 5faf713..20066d4 100644 --- a/tests/testthat/test-Start-reorder-lon_0to360.R +++ b/tests/testthat/test-Start-reorder-lon0to360.R @@ -23,6 +23,7 @@ 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)), @@ -65,6 +66,7 @@ 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 +81,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), @@ -96,6 +99,7 @@ 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 +114,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), @@ -129,6 +134,7 @@ 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 +149,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), @@ -161,6 +168,7 @@ 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 +183,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), @@ -192,6 +201,7 @@ 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 +216,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), @@ -225,6 +236,7 @@ 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 +253,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), @@ -266,6 +279,7 @@ 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 +296,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), @@ -303,6 +318,7 @@ 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 +335,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) @@ -340,6 +357,7 @@ 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 +374,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) @@ -378,6 +397,7 @@ 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 +414,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) @@ -416,6 +437,7 @@ 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 +454,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) @@ -449,6 +472,7 @@ 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 +489,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), @@ -482,6 +507,7 @@ 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 +524,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), @@ -516,6 +543,7 @@ 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 +560,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), @@ -545,6 +574,7 @@ 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 +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(-30, -10), @@ -579,6 +610,7 @@ 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 +627,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), @@ -613,6 +646,8 @@ 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 +664,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 cb7649a..bb2153e 100644 --- a/tests/testthat/test-Start-reorder-lon0to360Coarse.R +++ b/tests/testthat/test-Start-reorder-lon0to360Coarse.R @@ -23,6 +23,8 @@ 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 +39,7 @@ res <- Start(dat = list(list(path=path_exp)), longitude = 'dat', time = NULL), retrieve = F) - +) # lon expect_equal( range((attr(res, 'Variables')$dat1$longitude)), @@ -65,6 +67,7 @@ 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 +82,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), @@ -96,6 +100,7 @@ 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 +115,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), @@ -129,6 +135,7 @@ 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 +150,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), @@ -161,6 +169,7 @@ 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 +184,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), @@ -192,6 +202,7 @@ 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 +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(350, 358.75), @@ -225,6 +237,7 @@ 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 +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(10, 20), @@ -266,6 +280,7 @@ 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 +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(10, 20), @@ -303,6 +319,7 @@ 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 +336,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) @@ -340,6 +358,7 @@ 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 +375,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) @@ -378,6 +398,7 @@ 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 +415,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) @@ -416,6 +438,7 @@ 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 +455,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) @@ -449,6 +473,7 @@ 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 +490,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), @@ -482,6 +508,7 @@ 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 +525,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), @@ -516,6 +544,7 @@ 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 +561,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), @@ -545,6 +575,7 @@ 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 +592,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), @@ -579,6 +611,7 @@ 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 +628,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), @@ -613,6 +647,7 @@ 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 +664,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 b522a36..4b6f909 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 cb6cfc6..09928fd 100644 --- a/tests/testthat/test-Start-reorder-retrieve.R +++ b/tests/testthat/test-Start-reorder-retrieve.R @@ -14,7 +14,7 @@ lons.max <- 2 lats.min <- 10 lats.max <- 12 - +suppressWarnings( res <- Start(dat = path_exp, var = 'psl', member = indices(1), @@ -30,8 +30,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 +48,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 +66,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,] @@ -96,7 +96,7 @@ lons.max <- 2 lats.min <- 10 lats.max <- 12 - +suppressWarnings( res <- Start(dat = path_exp, var = variable, sdate = '199212', @@ -110,7 +110,8 @@ res <- Start(dat = path_exp, longitude = 'dat', time = NULL), retrieve = T) - +) +suppressWarnings( res1 <- Start(dat = path_exp, var = variable, sdate = '199212', @@ -125,8 +126,8 @@ res1 <- Start(dat = path_exp, longitude = 'dat', time = NULL), retrieve = T) - - +) +suppressWarnings( res2 <- Start(dat = path_exp, var = variable, sdate = '199212', @@ -141,7 +142,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 793a3b3..3d576d8 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-transform-lon-across_meridian.R b/tests/testthat/test-Start-transform-lon-across_meridian.R index 9ac0b8d..caa2b75 100644 --- a/tests/testthat/test-Start-transform-lon-across_meridian.R +++ b/tests/testthat/test-Start-transform-lon-across_meridian.R @@ -12,6 +12,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 +34,8 @@ skip_on_cran() longitude = 'dat', latitude = 'dat'), retrieve = T) - +) +suppressWarnings( data_no_across <- Start(dat = repos, var = var, sdate = c('20170101'), @@ -56,7 +58,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 f19a02a..ede3c95 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 -- GitLab From 02a20dfde78674cdc4a837a390f1c4d5697b3158 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 13 Jul 2021 13:20:41 +0200 Subject: [PATCH 26/66] Add ex1_13 to the list --- inst/doc/usecase.md | 6 ++++++ inst/doc/usecase/ex1_13_implicit_dependency.R | 13 ++++++++++++- 2 files changed, 18 insertions(+), 1 deletion(-) diff --git a/inst/doc/usecase.md b/inst/doc/usecase.md index cd42b6b..b1cca75 100644 --- a/inst/doc/usecase.md +++ b/inst/doc/usecase.md @@ -55,6 +55,12 @@ 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. + + 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) diff --git a/inst/doc/usecase/ex1_13_implicit_dependency.R b/inst/doc/usecase/ex1_13_implicit_dependency.R index 8a869b6..8d8f337 100644 --- a/inst/doc/usecase/ex1_13_implicit_dependency.R +++ b/inst/doc/usecase/ex1_13_implicit_dependency.R @@ -19,7 +19,6 @@ library(lubridate) # Case 1: 'time' depends on 'sdate' repos <- '/esarchive/exp/ecmwf/system4_m1/daily_mean/$var$_f24h/$var$_$sdate$.nc' -yr1 <- "2001" 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)) @@ -37,6 +36,18 @@ exp <- Start(dat = repos, 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' -- GitLab From ca0c5e3f7d19eb4401b48b064e4e3a851cff48f5 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 13 Jul 2021 17:20:56 +0200 Subject: [PATCH 27/66] New use case for file dependency --- inst/doc/usecase.md | 4 + inst/doc/usecase/ex1_13_implicit_dependency.R | 2 +- inst/doc/usecase/ex1_14_file_dependency.R | 79 +++++++++++++++++++ tests/testthat/test-Start-depends_values.R | 27 ++++--- 4 files changed, 99 insertions(+), 13 deletions(-) create mode 100644 inst/doc/usecase/ex1_14_file_dependency.R diff --git a/inst/doc/usecase.md b/inst/doc/usecase.md index b1cca75..013b47a 100644 --- a/inst/doc/usecase.md +++ b/inst/doc/usecase.md @@ -60,6 +60,10 @@ You can find more explanation in FAQ [How-to-20](inst/doc/faq.md#20-use-metadata 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) diff --git a/inst/doc/usecase/ex1_13_implicit_dependency.R b/inst/doc/usecase/ex1_13_implicit_dependency.R index 8d8f337..1ea9381 100644 --- a/inst/doc/usecase/ex1_13_implicit_dependency.R +++ b/inst/doc/usecase/ex1_13_implicit_dependency.R @@ -1,5 +1,5 @@ # Author: An-Chi Ho -# Date: 13rd July 2021 +# 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 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 0000000..c23266c --- /dev/null +++ b/inst/doc/usecase/ex1_14_file_dependency.R @@ -0,0 +1,79 @@ +# 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') + + +# 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/tests/testthat/test-Start-depends_values.R b/tests/testthat/test-Start-depends_values.R index 14f9533..49114e7 100644 --- a/tests/testthat/test-Start-depends_values.R +++ b/tests/testthat/test-Start-depends_values.R @@ -14,63 +14,66 @@ 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:500), - j = indices(650:700), + 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:500), - j = indices(650:700), + 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:500), - j = indices(650:700), + 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.28614, + 29.11137, tolerance = 0.0001 ) expect_equal( mean(dat1, na.rm = T), - 29.21995, + 29.07394, tolerance = 0.0001 ) expect_equal( dat2[1, 1, 2, 2, 1:3, 10], - c(28.99903, 28.98451, 28.96989), + c(28.38624, 28.19837, 28.08603), tolerance = 0.0001 ) expect_equal( -- GitLab From 3cd8124e0d28e17f231c2df97e2b657b728af826 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 14 Jul 2021 16:06:10 +0200 Subject: [PATCH 28/66] Fix error of missing 'crop' in transform_params. --- .../test-Start-reorder-lon-transform_-180to180.R | 10 +++++----- .../testthat/test-Start-reorder-lon-transform_0to360.R | 2 -- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/tests/testthat/test-Start-reorder-lon-transform_-180to180.R b/tests/testthat/test-Start-reorder-lon-transform_-180to180.R index 218a8a1..14c3d54 100644 --- a/tests/testthat/test-Start-reorder-lon-transform_-180to180.R +++ b/tests/testthat/test-Start-reorder-lon-transform_-180to180.R @@ -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 = F), transform_vars = c('longitude', 'latitude'), transform_extra_cells = 2, synonims = list(latitude=c('lat','latitude'), @@ -78,7 +78,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'), @@ -119,7 +119,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'), @@ -160,7 +160,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,7 +200,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'), diff --git a/tests/testthat/test-Start-reorder-lon-transform_0to360.R b/tests/testthat/test-Start-reorder-lon-transform_0to360.R index 0887615..7841591 100644 --- a/tests/testthat/test-Start-reorder-lon-transform_0to360.R +++ b/tests/testthat/test-Start-reorder-lon-transform_0to360.R @@ -19,7 +19,6 @@ sdate <- '19821201' ############################################## test_that("1-1-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 @@ -66,7 +65,6 @@ 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 -- GitLab From af662fb62d3e780f20a4af4718dd0c73016feaf1 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 14 Jul 2021 17:30:52 +0200 Subject: [PATCH 29/66] Fix error of missing 'crop' in transform_params. Remove skip_on_cran() so the tests can run on pipeline --- tests/testthat/test-AddStep-DimNames.R | 1 - tests/testthat/test-Compute-NumChunks.R | 1 - .../test-Start-global-lon-across_meridian.R | 1 - .../test-Start-line_order-consistency.R | 2 -- tests/testthat/test-Start-multiple-sdates.R | 2 -- tests/testthat/test-Start-reorder-lat.R | 18 ---------- tests/testthat/test-Start-reorder-latCoarse.R | 18 ---------- .../test-Start-reorder-lon-180to180.R | 23 ------------- ...st-Start-reorder-lon-transform_-180to180.R | 21 ------------ .../test-Start-reorder-lon-transform_0to360.R | 32 ++++------------- ...Start-reorder-lon-transform_0to360Coarse.R | 34 ++++--------------- tests/testthat/test-Start-reorder-lon0to360.R | 18 ---------- .../test-Start-reorder-lon0to360Coarse.R | 18 ---------- tests/testthat/test-Start-reorder-retrieve.R | 2 -- ...test-Start-transform-lon-across_meridian.R | 1 - 15 files changed, 12 insertions(+), 180 deletions(-) diff --git a/tests/testthat/test-AddStep-DimNames.R b/tests/testthat/test-AddStep-DimNames.R index 46042f1..2fe6b39 100644 --- a/tests/testthat/test-AddStep-DimNames.R +++ b/tests/testthat/test-AddStep-DimNames.R @@ -2,7 +2,6 @@ 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', diff --git a/tests/testthat/test-Compute-NumChunks.R b/tests/testthat/test-Compute-NumChunks.R index 507f981..9e626e4 100644 --- a/tests/testthat/test-Compute-NumChunks.R +++ b/tests/testthat/test-Compute-NumChunks.R @@ -2,7 +2,6 @@ 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', diff --git a/tests/testthat/test-Start-global-lon-across_meridian.R b/tests/testthat/test-Start-global-lon-across_meridian.R index 0c01db5..34c861f 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' diff --git a/tests/testthat/test-Start-line_order-consistency.R b/tests/testthat/test-Start-line_order-consistency.R index dab0290..6b797a8 100644 --- a/tests/testthat/test-Start-line_order-consistency.R +++ b/tests/testthat/test-Start-line_order-consistency.R @@ -12,7 +12,6 @@ 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, @@ -65,7 +64,6 @@ suppressWarnings( test_that("2. dim length check: with/out reorder", { -skip_on_cran() suppressWarnings( dat1 <- Start(dat = obs.path, var = variable, diff --git a/tests/testthat/test-Start-multiple-sdates.R b/tests/testthat/test-Start-multiple-sdates.R index 89c8ed8..d0c4bd3 100644 --- a/tests/testthat/test-Start-multiple-sdates.R +++ b/tests/testthat/test-Start-multiple-sdates.R @@ -16,7 +16,6 @@ var100_name <- 'windagl100' sdates.seq <- c("20161222","20161229","20170105","20170112") test_that("1. ", { -skip_on_cran() suppressWarnings( hcst <- Start(dat = ecmwf_path_hc, var = var_name, @@ -90,7 +89,6 @@ obs <- Start(dat = obs_path, }) test_that("2. change the file_date order", { -skip_on_cran() suppressWarnings( hcst <- Start(dat = ecmwf_path_hc, var = var_name, diff --git a/tests/testthat/test-Start-reorder-lat.R b/tests/testthat/test-Start-reorder-lat.R index 262cf37..e2ef5d9 100644 --- a/tests/testthat/test-Start-reorder-lat.R +++ b/tests/testthat/test-Start-reorder-lat.R @@ -18,7 +18,6 @@ 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 @@ -81,7 +80,6 @@ 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 @@ -125,7 +123,6 @@ 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 @@ -167,7 +164,6 @@ 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 @@ -210,7 +206,6 @@ 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 @@ -273,7 +268,6 @@ 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 @@ -315,7 +309,6 @@ 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 @@ -357,7 +350,6 @@ 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 @@ -399,7 +391,6 @@ 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 @@ -442,7 +433,6 @@ 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 @@ -485,7 +475,6 @@ 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 @@ -548,7 +537,6 @@ 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 @@ -591,7 +579,6 @@ 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 @@ -634,7 +621,6 @@ 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 @@ -690,7 +676,6 @@ 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 @@ -740,7 +725,6 @@ 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 @@ -790,7 +774,6 @@ 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 @@ -841,7 +824,6 @@ 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 diff --git a/tests/testthat/test-Start-reorder-latCoarse.R b/tests/testthat/test-Start-reorder-latCoarse.R index b9d923c..4fc62ad 100644 --- a/tests/testthat/test-Start-reorder-latCoarse.R +++ b/tests/testthat/test-Start-reorder-latCoarse.R @@ -20,7 +20,6 @@ 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 @@ -83,7 +82,6 @@ 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 @@ -127,7 +125,6 @@ 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 @@ -169,7 +166,6 @@ 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 @@ -212,7 +208,6 @@ 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 @@ -276,7 +271,6 @@ 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 @@ -318,7 +312,6 @@ 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 @@ -360,7 +353,6 @@ 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 @@ -402,7 +394,6 @@ 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 @@ -446,7 +437,6 @@ 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 @@ -489,7 +479,6 @@ 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 @@ -552,7 +541,6 @@ 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 @@ -595,7 +583,6 @@ 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 @@ -638,7 +625,6 @@ 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 @@ -694,7 +680,6 @@ 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 @@ -744,7 +729,6 @@ 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 @@ -794,7 +778,6 @@ 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 @@ -845,7 +828,6 @@ 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 diff --git a/tests/testthat/test-Start-reorder-lon-180to180.R b/tests/testthat/test-Start-reorder-lon-180to180.R index f3c2a3c..aa209b8 100644 --- a/tests/testthat/test-Start-reorder-lon-180to180.R +++ b/tests/testthat/test-Start-reorder-lon-180to180.R @@ -20,7 +20,6 @@ sdate <- '199212' ############################################## test_that("1-1-2-2-1-1-1-x", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 @@ -61,7 +60,6 @@ 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 @@ -93,7 +91,6 @@ 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 @@ -125,7 +122,6 @@ 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 @@ -157,7 +153,6 @@ 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 @@ -190,7 +185,6 @@ 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 @@ -222,7 +216,6 @@ 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 @@ -255,7 +248,6 @@ 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 @@ -296,7 +288,6 @@ 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 @@ -333,7 +324,6 @@ 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 @@ -370,7 +360,6 @@ 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 @@ -408,7 +397,6 @@ 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 @@ -446,7 +434,6 @@ 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 @@ -479,7 +466,6 @@ 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 @@ -512,7 +498,6 @@ 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 @@ -545,7 +530,6 @@ 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 @@ -588,7 +572,6 @@ 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 @@ -621,7 +604,6 @@ 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 @@ -659,7 +641,6 @@ 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 @@ -701,7 +682,6 @@ 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 @@ -735,7 +715,6 @@ 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 @@ -774,7 +753,6 @@ 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 @@ -808,7 +786,6 @@ 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 diff --git a/tests/testthat/test-Start-reorder-lon-transform_-180to180.R b/tests/testthat/test-Start-reorder-lon-transform_-180to180.R index 14c3d54..d8b43ee 100644 --- a/tests/testthat/test-Start-reorder-lon-transform_-180to180.R +++ b/tests/testthat/test-Start-reorder-lon-transform_-180to180.R @@ -19,7 +19,6 @@ sdate <- '199212' ############################################## test_that("1-1-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 @@ -64,7 +63,6 @@ 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 @@ -105,7 +103,6 @@ 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 @@ -146,7 +143,6 @@ 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 @@ -186,7 +182,6 @@ 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 @@ -228,7 +223,6 @@ 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 @@ -277,7 +271,6 @@ 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 @@ -326,7 +319,6 @@ 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 @@ -375,7 +367,6 @@ 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 @@ -419,7 +410,6 @@ 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 @@ -468,7 +458,6 @@ 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 @@ -512,7 +501,6 @@ 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 @@ -556,7 +544,6 @@ 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 @@ -608,7 +595,6 @@ 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 @@ -656,7 +642,6 @@ 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 @@ -705,7 +690,6 @@ 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 @@ -754,7 +738,6 @@ 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 @@ -799,7 +782,6 @@ 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 @@ -843,7 +825,6 @@ 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 @@ -892,7 +873,6 @@ 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 @@ -936,7 +916,6 @@ 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 diff --git a/tests/testthat/test-Start-reorder-lon-transform_0to360.R b/tests/testthat/test-Start-reorder-lon-transform_0to360.R index 7841591..a722bea 100644 --- a/tests/testthat/test-Start-reorder-lon-transform_0to360.R +++ b/tests/testthat/test-Start-reorder-lon-transform_0to360.R @@ -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'), @@ -79,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'), @@ -106,7 +106,6 @@ 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 @@ -121,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'), @@ -149,7 +148,6 @@ 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 @@ -164,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'), @@ -191,7 +189,6 @@ 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 @@ -206,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'), @@ -233,7 +230,6 @@ 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 @@ -248,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'), @@ -277,7 +273,6 @@ 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 @@ -327,7 +322,6 @@ 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 @@ -378,7 +372,6 @@ 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 @@ -429,7 +422,6 @@ 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 @@ -475,7 +467,6 @@ 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 @@ -526,7 +517,6 @@ 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 @@ -572,7 +562,6 @@ 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 @@ -618,7 +607,6 @@ 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 @@ -671,7 +659,6 @@ 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 @@ -721,7 +708,6 @@ 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 @@ -772,7 +758,6 @@ 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 @@ -823,7 +808,6 @@ 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 @@ -870,7 +854,6 @@ 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 @@ -916,7 +899,6 @@ 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 @@ -967,7 +949,6 @@ 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 @@ -1013,7 +994,6 @@ 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 diff --git a/tests/testthat/test-Start-reorder-lon-transform_0to360Coarse.R b/tests/testthat/test-Start-reorder-lon-transform_0to360Coarse.R index 6d45a67..2a4f2ca 100644 --- a/tests/testthat/test-Start-reorder-lon-transform_0to360Coarse.R +++ b/tests/testthat/test-Start-reorder-lon-transform_0to360Coarse.R @@ -23,7 +23,6 @@ sdate <- '20001101' ############################################## test_that("1-1-2-2-1-1-2-4", { -skip_on_cran() lons.min <- 10 lons.max <- 20 lats.min <- 10 @@ -38,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'), @@ -70,7 +69,6 @@ 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 @@ -85,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'), @@ -112,7 +110,6 @@ 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 @@ -127,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'), @@ -155,7 +152,6 @@ 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 @@ -170,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'), @@ -197,7 +193,6 @@ 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 @@ -212,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'), @@ -239,7 +234,6 @@ 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 @@ -254,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'), @@ -283,7 +277,6 @@ 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 @@ -334,7 +327,6 @@ 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 @@ -385,7 +377,6 @@ 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 @@ -436,7 +427,6 @@ 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 @@ -482,7 +472,6 @@ 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 @@ -534,7 +523,6 @@ 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 @@ -581,7 +569,6 @@ 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 @@ -627,7 +614,6 @@ 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 @@ -680,7 +666,6 @@ 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 @@ -730,7 +715,6 @@ 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 @@ -781,7 +765,6 @@ 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 @@ -832,7 +815,6 @@ 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 @@ -879,7 +861,6 @@ 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 @@ -925,7 +906,6 @@ 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 @@ -976,7 +956,6 @@ 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 @@ -1022,7 +1001,6 @@ 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 diff --git a/tests/testthat/test-Start-reorder-lon0to360.R b/tests/testthat/test-Start-reorder-lon0to360.R index 20066d4..340860a 100644 --- a/tests/testthat/test-Start-reorder-lon0to360.R +++ b/tests/testthat/test-Start-reorder-lon0to360.R @@ -18,7 +18,6 @@ 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 @@ -61,7 +60,6 @@ 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 @@ -94,7 +92,6 @@ 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 @@ -129,7 +126,6 @@ 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 @@ -163,7 +159,6 @@ 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 @@ -196,7 +191,6 @@ 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 @@ -231,7 +225,6 @@ 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 @@ -274,7 +267,6 @@ 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 @@ -313,7 +305,6 @@ 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 @@ -352,7 +343,6 @@ 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 @@ -392,7 +382,6 @@ 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 @@ -432,7 +421,6 @@ 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 @@ -467,7 +455,6 @@ 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 @@ -502,7 +489,6 @@ 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 @@ -538,7 +524,6 @@ 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 @@ -569,7 +554,6 @@ 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 @@ -605,7 +589,6 @@ 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 @@ -641,7 +624,6 @@ 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 diff --git a/tests/testthat/test-Start-reorder-lon0to360Coarse.R b/tests/testthat/test-Start-reorder-lon0to360Coarse.R index bb2153e..e093a88 100644 --- a/tests/testthat/test-Start-reorder-lon0to360Coarse.R +++ b/tests/testthat/test-Start-reorder-lon0to360Coarse.R @@ -18,7 +18,6 @@ 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 @@ -62,7 +61,6 @@ 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 @@ -95,7 +93,6 @@ 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 @@ -130,7 +127,6 @@ 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 @@ -164,7 +160,6 @@ 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 @@ -197,7 +192,6 @@ 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 @@ -232,7 +226,6 @@ 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 @@ -275,7 +268,6 @@ 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 @@ -314,7 +306,6 @@ 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 @@ -353,7 +344,6 @@ 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 @@ -393,7 +383,6 @@ 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 @@ -433,7 +422,6 @@ 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 @@ -468,7 +456,6 @@ 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 @@ -503,7 +490,6 @@ 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 @@ -539,7 +525,6 @@ 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 @@ -570,7 +555,6 @@ 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 @@ -606,7 +590,6 @@ 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 @@ -642,7 +625,6 @@ 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 diff --git a/tests/testthat/test-Start-reorder-retrieve.R b/tests/testthat/test-Start-reorder-retrieve.R index 09928fd..42a79ce 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' @@ -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' diff --git a/tests/testthat/test-Start-transform-lon-across_meridian.R b/tests/testthat/test-Start-transform-lon-across_meridian.R index caa2b75..f164046 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' -- GitLab From e07c0a87ae725aa2d8f3588822443cbb0a97a636 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 16 Jul 2021 17:58:34 +0200 Subject: [PATCH 30/66] Modularize Start() in progress --- R/Start.R | 294 +++++++++++++----------------------------------------- R/zzz.R | 194 ++++++++++++++++++++++++++++++++++- 2 files changed, 262 insertions(+), 226 deletions(-) diff --git a/R/Start.R b/R/Start.R index 00e9877..d723ea4 100644 --- a/R/Start.R +++ b/R/Start.R @@ -885,7 +885,7 @@ Start <- function(..., # dim = indices/selectors, # 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 @@ -950,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_dim == 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, @@ -972,64 +972,12 @@ 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_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 <- dim_params[[found_pattern_dim]] + #NOTE: This function creates the object 'dat_names' + dat <- mount_dat(dat, pattern_dim, found_pattern_dim) + + 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)) { @@ -1127,7 +1075,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.") @@ -1242,8 +1207,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 ", @@ -1340,60 +1303,34 @@ 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' 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.")) } } } -#================================================== - # 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], "'.")) - } - } -#===================================================== - ## (Check the *_var parameters). if (any(!(unlist(var_params) %in% names(return_vars)))) { vars_to_add <- which(!(unlist(var_params) %in% names(return_vars))) @@ -1406,15 +1343,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 && @@ -1446,15 +1385,18 @@ 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)) { ## TODO: Detect multi-dependancies and forbid. @@ -1540,112 +1482,13 @@ 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)) - } - #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: "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. @@ -1654,6 +1497,7 @@ Start <- function(..., # dim = indices/selectors, } } } +#NEW # Now fetch for the first available file if (dataset_has_files[i]) { known_dims <- file_dims diff --git a/R/zzz.R b/R/zzz.R index 7dda044..9d607d2 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -204,7 +204,8 @@ found_pattern_dims <- function(pattern_dims, dim_names, var_params, 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 <- 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.")) @@ -228,3 +229,194 @@ found_pattern_dims <- function(pattern_dims, dim_names, var_params, 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_dim, found_pattern_dim) { + +# 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_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.") + } + + 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) +} + -- GitLab From e2ea2a47d1b424a5be8a01a6ad0531dd919b572b Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 2 Aug 2021 09:43:31 +0200 Subject: [PATCH 31/66] Modify unit test for the change of netCDF file timestamps --- .../testthat/test-Start-implicit_inner_dim.R | 2 +- .../test-Start-path_glob_permissive.R | 90 +++++++++++-------- tests/testthat/test-Start-split-merge.R | 2 +- 3 files changed, 57 insertions(+), 37 deletions(-) diff --git a/tests/testthat/test-Start-implicit_inner_dim.R b/tests/testthat/test-Start-implicit_inner_dim.R index 26e3ce7..6a3262a 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-path_glob_permissive.R b/tests/testthat/test-Start-path_glob_permissive.R index f298bd4..ddd69be 100644 --- a/tests/testthat/test-Start-path_glob_permissive.R +++ b/tests/testthat/test-Start-path_glob_permissive.R @@ -96,45 +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" -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 - ) +#!!!!!!!!!!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( -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) +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) ) - asd <- as.list(attr(exp, 'ExpectedFiles')) - qwe <- sapply(sapply(asd, strsplit, '/'), '[[', 9) - files <- paste0('tas_', sdates.seq.thu, '_', 24, '.nc') - expect_equal( - qwe, files - ) +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-split-merge.R b/tests/testthat/test-Start-split-merge.R index 9376f9a..fe686dc 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') ) -- GitLab From f414d54c6396ca361b3fcfc6af46481f1639ecc7 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 4 Aug 2021 12:04:37 +0200 Subject: [PATCH 32/66] ex1_8 has bugs --- inst/doc/usecase/ex1_8_tasandtos.R | 5 +- tests/testthat/test-Start-two_dats.R | 89 ++++++++++++++++++++++++++++ 2 files changed, 92 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/test-Start-two_dats.R diff --git a/inst/doc/usecase/ex1_8_tasandtos.R b/inst/doc/usecase/ex1_8_tasandtos.R index 38fdf95..a384368 100644 --- a/inst/doc/usecase/ex1_8_tasandtos.R +++ b/inst/doc/usecase/ex1_8_tasandtos.R @@ -19,7 +19,7 @@ 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'), + var = c('tas', 'tos'), sdate = paste0(1960:1962), fmonth = 1, lat = values(list(0, 10)), @@ -29,9 +29,10 @@ data1 <- Start(dataset = paths, 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) diff --git a/tests/testthat/test-Start-two_dats.R b/tests/testthat/test-Start-two_dats.R new file mode 100644 index 0000000..74738d0 --- /dev/null +++ b/tests/testthat/test-Start-two_dats.R @@ -0,0 +1,89 @@ +# ex1_8 +context("Start() two dats in one call") + +test_that("1. ex1_8", { + +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:1962), + fmonth = 1, + lat = values(list(8, 10)), + lon = values(list(8, 10)), + fyear = 'all', + member = indices(1), + fyear_depends = 'sdate', + fmonth_across = 'fyear', + merge_across_dims = TRUE, + synonims = list(fmonth = c('fmonth', 'time'), + lon = c('lon', 'longitude'), + lat = c('lat', 'latitude')), + metadata_dims = 'var', + return_vars = list(lat = 'dataset', lon = 'dataset'), + retrieve = TRUE) +) + +expect_equal( +dim(data), +c(dataset = 2, var = 2, sdate = 3, fmonth = 1, lat = 3, lon = 3, member = 1) +) +expect_equal( +sum(data, na.rm = T), +15396.7, +tolerance = 0.0001 +) +expect_equal( +length(data[is.na(data)]), +54 +) +expect_equal( +sum(is.na(data[1,1,,,,,])), +0 +) +# Amon also has tos +expect_equal( +sum(is.na(data[1,2,,,,,])), +0 +) +expect_equal( +sum(is.na(data[2,1,,,,,])), +27 +) +# WRONG!!!! Omon should have tos. The value should be 0 +expect_equal( +sum(is.na(data[2,2,,,,,])), +27 +) + +expect_equal( +names(attr(data, 'Variables')), +c("common", "dat1", "dat2") +) +expect_equal( +names(attr(data, 'Variables')$common), +c("fmonth", "tas", "tos") +) +expect_equal( +names(attr(data, 'Variables')$dat1), +c("lat", "lon") +) +expect_equal( +names(attr(data, 'Variables')$dat2), +c("lat", "lon") +) +expect_equal( +length(attr(data, 'Variables')$common$tas), +17 +) +expect_equal( +length(attr(data, 'Variables')$common$tos), +16 +) + +}) -- GitLab From a87d15793e41e2585366363eed7e56e7401a0a58 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 4 Aug 2021 12:05:07 +0200 Subject: [PATCH 33/66] Finish the first stage of modularization --- R/Start.R | 969 +++++++++++------------------------------------------- R/zzz.R | 752 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 944 insertions(+), 777 deletions(-) diff --git a/R/Start.R b/R/Start.R index d723ea4..6f602a5 100644 --- a/R/Start.R +++ b/R/Start.R @@ -1428,6 +1428,7 @@ Start <- function(..., # dim = indices/selectors, } } } + # 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) { @@ -1497,7 +1498,8 @@ Start <- function(..., # dim = indices/selectors, } } } -#NEW + dat[[i]][['selectors']] <- dat_selectors + # Now fetch for the first available file if (dataset_has_files[i]) { known_dims <- file_dims @@ -1514,24 +1516,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 @@ -1541,9 +1552,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))) { @@ -1561,13 +1576,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.") @@ -1616,7 +1632,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.") @@ -1640,6 +1655,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 @@ -1652,6 +1668,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) { @@ -1660,7 +1679,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'. @@ -1672,38 +1690,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) { - 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 { - common_return_vars[[inner_dim]] <- file_dim_as_selector_array_dim - tmp <- 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) { - stop(paste0("Found '", inner_dim, "' has across dependency on the pattern dim '", - found_pattern_dim, "', which is not allowed.")) - } else { - common_return_vars[[inner_dim]] <- file_dim_name - tmp <- 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) } } } @@ -1719,6 +1716,7 @@ Start <- function(..., # dim = indices/selectors, } #//////////////////////////////////////////// + # 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) @@ -1727,29 +1725,34 @@ 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 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]]) && + 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]]) } } + 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]] @@ -1759,35 +1762,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) { @@ -1800,15 +1798,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(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 if (var_to_read %in% names(common_return_vars)) { @@ -1829,13 +1819,11 @@ Start <- function(..., # dim = indices/selectors, "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))) { + if (any(class(first_sample) %in% names(time_special_types()))) { array_size <- prod(c(var_file_dims, var_dims)) - new_array <- rep(special_types[[class(first_sample)[1]]](NA), array_size) + 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)) @@ -1895,16 +1883,14 @@ Start <- function(..., # dim = indices/selectors, 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))) { + if (any(var_class %in% names(time_special_types()))) { padding_size <- prod(padding_dims) - padding <- rep(special_types[[var_class[1]]](NA), padding_size) + padding <- rep(time_special_types()[[var_class[1]]](NA), padding_size) dim(padding) <- padding_dims } else { padding <- array(dim = padding_dims) @@ -1975,7 +1961,7 @@ Start <- function(..., # dim = indices/selectors, 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'))) { + if (all(class(picked_common_vars[[var_to_read]]) == names(time_special_types))) { attr(picked_common_vars[[var_to_read]], "tzone") <- 'UTC' } } else { @@ -1984,7 +1970,7 @@ Start <- function(..., # dim = indices/selectors, 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'))) { + if (all(class(picked_vars[[i]][[var_to_read]]) == names(time_special_types))) { attr(picked_vars[[i]][[var_to_read]], "tzone") <- 'UTC' } } @@ -2051,15 +2037,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 @@ -2074,57 +2052,15 @@ 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]]) + 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) - # 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. @@ -2133,38 +2069,13 @@ Start <- function(..., # dim = indices/selectors, 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, @@ -2674,6 +2585,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) { @@ -2697,23 +2609,25 @@ 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 goes_across_prime_meridian <- FALSE + is_circular_dim <- FALSE if (!is.null(var_ordered) && !selectors_are_indices) { if (!is.null(dim_reorder_params[[inner_dim]])) { 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 ('circular' %in% names(attributes(dim_reorder_params[[inner_dim]]))) { + is_circular_dim <- attr(dim_reorder_params[[inner_dim]], "circular") + } + 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 @@ -2724,19 +2638,12 @@ Start <- function(..., # dim = indices/selectors, #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') } @@ -2781,23 +2688,13 @@ Start <- function(..., # dim = indices/selectors, # 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 (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') } } @@ -2857,84 +2754,16 @@ 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) + 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 @@ -3030,9 +2859,11 @@ Start <- function(..., # dim = indices/selectors, 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:") @@ -3072,30 +2903,11 @@ 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) } if (!is.null(var_unorder_indices)) { if (is.null(ordered_fri)) { @@ -3111,7 +2923,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,95 +3290,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) } } @@ -3594,7 +3348,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? @@ -3602,24 +3356,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 ########### @@ -3668,136 +3413,22 @@ 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]])) { - 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[[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, + metadata_folder = metadata_folder, debug = debug) } } #print("N") @@ -3807,65 +3438,7 @@ 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. @@ -3893,7 +3466,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 = '') } } @@ -3907,38 +3481,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)) { @@ -3949,70 +3494,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) @@ -4044,45 +3528,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) } @@ -4141,65 +3590,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, @@ -4208,7 +3622,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 9d607d2..a775b47 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -420,3 +420,755 @@ find_ufd_value <- function(undefined_file_dims, dat, i, replace_values, 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.")) +} + + +# 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) { + 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) { + # 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) { + 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) { + 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 (((last_index + beta) - (first_index - beta) + 1) >= n) { + if (start_padding <= beta & end_padding <= beta) { + 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 { + 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, + 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[[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 + } + + } + } + } + + 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) +} -- GitLab From 6e7523c429be9ea9a5e20343b65bdebbf6c57c63 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 4 Aug 2021 16:05:44 +0200 Subject: [PATCH 34/66] Add data value check --- tests/testthat/test-Start-metadata_dims.R | 70 ++++++++++++++++++----- 1 file changed, 56 insertions(+), 14 deletions(-) diff --git a/tests/testthat/test-Start-metadata_dims.R b/tests/testthat/test-Start-metadata_dims.R index b514df6..841786d 100644 --- a/tests/testthat/test-Start-metadata_dims.R +++ b/tests/testthat/test-Start-metadata_dims.R @@ -8,8 +8,8 @@ suppressWarnings( 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', @@ -39,6 +39,11 @@ suppressWarnings( length(attr(data, 'Variables')$common$tas), 12 ) + expect_equal( + data[1, 1, 1, 1, 1, , 1], + c(248.5012, 248.7815), + tolerance = 0.0001 + ) }) @@ -53,8 +58,8 @@ suppressWarnings( 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', @@ -92,7 +97,16 @@ suppressWarnings( 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", { @@ -100,13 +114,12 @@ 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'), @@ -138,7 +151,16 @@ suppressWarnings( 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", { @@ -151,8 +173,8 @@ suppressWarnings( 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', @@ -190,7 +212,18 @@ suppressWarnings( 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)), @@ -198,8 +231,8 @@ suppressWarnings( 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', @@ -246,7 +279,16 @@ suppressWarnings( 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", { -- GitLab From 87c0f579be4aa897f57172db8cfae2419f4643c3 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 4 Aug 2021 18:13:16 +0200 Subject: [PATCH 35/66] Revise ex1_8 and its corresponding unit test --- inst/doc/usecase/ex1_8_tasandtos.R | 137 +++++++++++++++++---------- tests/testthat/test-Start-two_dats.R | 61 +++++++----- 2 files changed, 125 insertions(+), 73 deletions(-) diff --git a/inst/doc/usecase/ex1_8_tasandtos.R b/inst/doc/usecase/ex1_8_tasandtos.R index a384368..2c9e75e 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,21 +10,35 @@ # 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, +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', @@ -32,75 +47,101 @@ data1 <- Start(dataset = paths, synonims = list(fmonth = c('fmonth', 'time'), lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), - metadata_dims = 'var', + 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'), @@ -108,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'), @@ -130,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 - -# --------------------------------------------------------------------- +# 1 1 3 1 15 28 1 -# Comparison cases 1) to 3): -#---------------------------------------------------------------------- - -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/tests/testthat/test-Start-two_dats.R b/tests/testthat/test-Start-two_dats.R index 74738d0..4fa8642 100644 --- a/tests/testthat/test-Start-two_dats.R +++ b/tests/testthat/test-Start-two_dats.R @@ -1,7 +1,7 @@ # ex1_8 -context("Start() two dats in one call") +context("Start() two dats and two vars in one call") -test_that("1. ex1_8", { +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/', @@ -12,53 +12,49 @@ path_tos <- paste0('/esarchive/exp/ecearth/a1ua/cmorfiles/DCPP/EC-Earth-Consorti suppressWarnings( data <- Start(dataset = list(list(path = path_tas), list(path = path_tos)), var = c('tas', 'tos'), - sdate = paste0(1960:1962), - fmonth = 1, - lat = values(list(8, 10)), - lon = values(list(8, 10)), + 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', - fmonth_across = 'fyear', + time_across = 'fyear', merge_across_dims = TRUE, - synonims = list(fmonth = c('fmonth', 'time'), - lon = c('lon', 'longitude'), + synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), - metadata_dims = 'var', + metadata_dims = c('dataset', 'var'), return_vars = list(lat = 'dataset', lon = 'dataset'), retrieve = TRUE) ) expect_equal( dim(data), -c(dataset = 2, var = 2, sdate = 3, fmonth = 1, lat = 3, lon = 3, member = 1) +c(dataset = 2, var = 2, sdate = 1, time = 1, lat = 15, lon = 28, member = 1) ) expect_equal( sum(data, na.rm = T), -15396.7, +264710, tolerance = 0.0001 ) expect_equal( -length(data[is.na(data)]), -54 -) -expect_equal( sum(is.na(data[1,1,,,,,])), 0 ) -# Amon also has tos +# 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,,,,,])), -27 +420 ) -# WRONG!!!! Omon should have tos. The value should be 0 expect_equal( sum(is.na(data[2,2,,,,,])), -27 +0 ) expect_equal( @@ -67,23 +63,38 @@ c("common", "dat1", "dat2") ) expect_equal( names(attr(data, 'Variables')$common), -c("fmonth", "tas", "tos") +c("time") ) expect_equal( names(attr(data, 'Variables')$dat1), -c("lat", "lon") +c("lat", "lon", "tas", "tos") ) expect_equal( names(attr(data, 'Variables')$dat2), -c("lat", "lon") +c("lat", "lon", "tos") ) expect_equal( -length(attr(data, 'Variables')$common$tas), +length(attr(data, 'Variables')$dat1$tas), 17 ) expect_equal( -length(attr(data, 'Variables')$common$tos), +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 +) }) -- GitLab From 93ac5f8c4b076c3ec94e343e8a56f8792fc8cc4a Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 4 Aug 2021 18:15:12 +0200 Subject: [PATCH 36/66] Bugfix for metadata file count --- R/Start.R | 4 ++-- R/zzz.R | 64 +++++++++++++++++++++++++++---------------------------- 2 files changed, 34 insertions(+), 34 deletions(-) diff --git a/R/Start.R b/R/Start.R index 6f602a5..5f4a295 100644 --- a/R/Start.R +++ b/R/Start.R @@ -3440,8 +3440,8 @@ Start <- function(..., # dim = indices/selectors, # the appropriate work pieces. 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, diff --git a/R/zzz.R b/R/zzz.R index a775b47..d5429d1 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1087,41 +1087,41 @@ create_metadata_list <- function(array_of_metadata_flags, metadata_dims, pattern #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[[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 - } - + 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) } -- GitLab From 17dc8d4101667cacd56e68e8ca4fbe5ded180b1a Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 6 Aug 2021 13:51:12 +0200 Subject: [PATCH 37/66] Enable transformation of 'all' --- R/Start.R | 15 ++- tests/testthat/test-Compute-transform_all.R | 114 ++++++++++++++++++++ 2 files changed, 127 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/test-Compute-transform_all.R diff --git a/R/Start.R b/R/Start.R index 5f4a295..46c2d21 100644 --- a/R/Start.R +++ b/R/Start.R @@ -1318,7 +1318,7 @@ Start <- function(..., # dim = indices/selectors, 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 = '", + dim_name, "_var' provided. ", '"', dim_name, "_var = '", 'var_names', "'", '"', " has been automatically added to ", "the Start call.")) } else { @@ -1329,6 +1329,14 @@ Start <- function(..., # dim = indices/selectors, "the Start call.")) } } + if (attr(dat_selectors[[dim_name]], 'indices') & (dim_name %in% transform_vars) & + !(dim_name %in% names(var_params))) { + 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.")) + } } ## (Check the *_var parameters). @@ -3141,7 +3149,10 @@ 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(vars_to_crop[[var_to_crop]], inner_dim, crop_indices) } diff --git a/tests/testthat/test-Compute-transform_all.R b/tests/testthat/test-Compute-transform_all.R new file mode 100644 index 0000000..db13f35 --- /dev/null +++ b/tests/testthat/test-Compute-transform_all.R @@ -0,0 +1,114 @@ +context("Transform with 'all'") + +test_that("1. Specify lat and lon with 'all'; retrieve = TRUE", { + +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( +data1 <- Start(dat = path, + var = 'tos', + sdate = paste0(1960), + time = indices(1:2), #'all', + lat = 'all', + lon = 'all', +# lat_reorder = Sort(decreasing = F), +# lon_reorder = CircularSort(0, 360), +# lat_var = 'lat', +# lon_var = 'lon', + fyear = indices(1), + member = indices(1), + 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 = T) +) + +suppressWarnings( +data2 <- Start(dat = path, + var = 'tos', + sdate = paste0(1960), + time = indices(1:2), #'all', + lat = values(list(-90, 90)), + lon = values(list(0, 359.9)), + lat_reorder = Sort(decreasing = F), + lon_reorder = CircularSort(0, 360), +# lat_var = 'lat', +# lon_var = 'lon', + fyear = indices(1), + member = indices(1), + 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 = T) +) + +expect_equal( +dim(data1), +c(dat = 1, var = 1, sdate = 1, time = 2, lat = 50, lon = 100, fyear = 1, member = 1) +) +expect_equal( +dim(data1), +dim(data2) +) +expect_equal( +as.vector(data1), +as.vector(data2) +) +expect_equal( +data1[1, 1, 1, 2, 10:12, 20, 1, 1], +c(274.6942, 276.2658, 278.2566), +tolerance = 0.0001 +) + +}) + +test_that("2. Specify lat and lon with 'all'; retrieve = FALSE", { + +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 +) + + +}) -- GitLab From 5834f9315400f9a541463b808c72b2e1babf210b Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 16 Aug 2021 16:48:13 +0200 Subject: [PATCH 38/66] Fix the warning and note from check --- DESCRIPTION | 3 ++- R/Start.R | 8 +++++--- R/zzz.R | 8 ++++---- 3 files changed, 11 insertions(+), 8 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 27d4a77..6ad8a64 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -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/Start.R b/R/Start.R index 5f4a295..5571dae 100644 --- a/R/Start.R +++ b/R/Start.R @@ -950,7 +950,7 @@ 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(pattern_dims, metadata_dims[-which(metadata_dim == pattern_dims)]) + 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)) { @@ -974,7 +974,8 @@ Start <- function(..., # dim = indices/selectors, dim_params[[found_pattern_dim]] <- dim_params[[found_pattern_dim]][dats_to_take] dat <- dim_params[[found_pattern_dim]] #NOTE: This function creates the object 'dat_names' - dat <- mount_dat(dat, pattern_dim, found_pattern_dim) + dat_names <- c() + dat <- mount_dat(dat, pattern_dims, found_pattern_dim, dat_names) dim_params[[found_pattern_dim]] <- dat_names @@ -3427,7 +3428,8 @@ Start <- function(..., # dim = indices/selectors, 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 = picked_common_vars, + picked_common_vars_ordered = picked_common_vars_ordered, metadata_folder = metadata_folder, debug = debug) } } diff --git a/R/zzz.R b/R/zzz.R index d5429d1..b045e85 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -232,11 +232,11 @@ found_pattern_dims <- function(pattern_dims, dim_names, var_params, # 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_dim, found_pattern_dim) { +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() +# dat_names <- c() if (!is.list(dat)) { dat <- as.list(dat) } else { @@ -252,7 +252,7 @@ mount_dat <- function(dat, pattern_dim, found_pattern_dim) { dat[[i]] <- list(name = dat[[i]]) } } else if (!is.list(dat[[i]])) { - stop(paste0("Parameter '", pattern_dim, + 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))) { @@ -770,7 +770,7 @@ build_work_pieces <- function(work_pieces, i, selectors, file_dims, inner_dims, 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, - metadata_folder, debug = debug) { + 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), -- GitLab From e054a9814ebc106e4701fbbe5727fc6397356701 Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 16 Aug 2021 17:37:41 +0200 Subject: [PATCH 39/66] Remove lubridate dependency in tests --- tests/testthat.R | 4 ++++ .../test-Start-implicit_dependency_by_selector.R | 13 +++++-------- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/tests/testthat.R b/tests/testthat.R index d424073..5073b5e 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,5 +1,9 @@ library(testthat) library(startR) +library(SpecsVerification) +library(dplyr) +library(plyr) +library(s2dv) test_check("startR") diff --git a/tests/testthat/test-Start-implicit_dependency_by_selector.R b/tests/testthat/test-Start-implicit_dependency_by_selector.R index bcc5ac1..5c2f050 100644 --- a/tests/testthat/test-Start-implicit_dependency_by_selector.R +++ b/tests/testthat/test-Start-implicit_dependency_by_selector.R @@ -79,19 +79,16 @@ data2[1, 1, 1, 1, ] test_that("2. time depends on sdate", { -library(lubridate) - 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') +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 = format(sdates, "%Y%m%d"), + sdate = sdates, time = times, #dim: [time = 31, sdate = 3]. time is corresponding to each sdate ensemble = indices(1:2), lat = indices(1:3), -- GitLab From ccbc008d16fa9e52b2d3e6c4103f4890e151ea9b Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 20 Aug 2021 17:26:57 +0200 Subject: [PATCH 40/66] Development of transform+chunk meanwhile --- R/Start.R | 62 +++++++++++---- R/zzz.R | 15 ++-- tests/testthat/test-Compute-transform_chunk.R | 77 +++++++++++++++++++ 3 files changed, 134 insertions(+), 20 deletions(-) create mode 100644 tests/testthat/test-Compute-transform_chunk.R diff --git a/R/Start.R b/R/Start.R index 5571dae..e4a97df 100644 --- a/R/Start.R +++ b/R/Start.R @@ -2721,21 +2721,47 @@ Start <- function(..., # dim = indices/selectors, ## 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 (chunks[[inner_dim]]["n_chunks"] > 1) { + 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 wkthin 'sub_sub_array_of_values' and chunk sri. + if (!is.null(var_ordered) && !selectors_are_indices) { #var_ordered + if (is.list(sub_array_of_indices)) { + sub_sub_array_of_values <- + var_ordered[sub_array_of_indices[[1]]:sub_array_of_indices[[2]]] + } else { + sub_sub_array_of_values <- var_ordered[sub_array_of_indices] + } + } else { # sub_array_of_values + if (is.list(sub_array_of_indices)) { + sub_sub_array_of_values <- + sub_array_of_values[sub_array_of_indices[[1]]:sub_array_of_indices[[2]]] + } else { + sub_sub_array_of_values <- sub_array_of_values[sub_array_of_indices] + } + } + #---------------------------------------------------------- + if (debug) { if (inner_dim %in% dims_to_check) { print("-> TRANSFORMATION REQUESTED?") @@ -2855,6 +2881,14 @@ Start <- function(..., # dim = indices/selectors, } ordered_sri <- sub_array_of_sri sub_array_of_sri <- transformed_subset_var_unorder[sub_array_of_sri] + + # Chunk sub_array_of_sri if this inner_dim needs to be chunked + 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) { diff --git a/R/zzz.R b/R/zzz.R index b045e85..14fa62e 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -624,15 +624,18 @@ generate_sub_array_of_fri <- function(with_transform, goes_across_prime_meridian print_warning <- TRUE } } else { #longitude - # if (((last_index + beta) - (first_index - beta) + 1) >= n) { - if (start_padding <= beta & end_padding <= beta) { + 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 + } 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 + } 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) } } diff --git a/tests/testthat/test-Compute-transform_chunk.R b/tests/testthat/test-Compute-transform_chunk.R new file mode 100644 index 0000000..af336ef --- /dev/null +++ b/tests/testthat/test-Compute-transform_chunk.R @@ -0,0 +1,77 @@ +context("Compute with two datasets") + +test_that("transform lat/lon and chunk over them", { + +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', #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( +res <- Compute(wf, + chunks = list(latitude = 2, longitude = 2))$output1 +) + +expect_equal( +dim(res), +c(sdate = 1, dat = 1, var = 1, ensemble = 1, time = 1, latitude = 5, longitude = 3) +) +expect_equal( +drop(res)[, 1], +c(284.9907, 282.9883, 281.2574, 284.1387, 285.6547), +tolerance = 0.0001 +) +expect_equal( +drop(res)[, 2], +c(285.4820, 282.9362, 282.6088, 287.3716, 285.0194), +tolerance = 0.0001 +) +expect_equal( +drop(res)[, 3], +c(286.1208, 284.3523, 285.9198, 287.7389, 286.1099), +tolerance = 0.0001 +) + +suppressWarnings( +res1 <- Compute(wf, + chunks = list(latitude = 3))$output1 +) +expect_equal( +dim(res), +dim(res1) +) +expect_equal( +drop(res), +drop(res1) +) + +}) -- GitLab From 08859f5a6ac9b8c99bd88ff5017febcffef3e084 Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 23 Aug 2021 19:50:06 +0200 Subject: [PATCH 41/66] Correct title --- tests/testthat/test-Compute-transform_chunk.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-Compute-transform_chunk.R b/tests/testthat/test-Compute-transform_chunk.R index af336ef..a54cad0 100644 --- a/tests/testthat/test-Compute-transform_chunk.R +++ b/tests/testthat/test-Compute-transform_chunk.R @@ -1,4 +1,4 @@ -context("Compute with two datasets") +context("Compute: Transform and chunk along lat/lon") test_that("transform lat/lon and chunk over them", { -- GitLab From 5f0aae9fc0c7b5d792302541344bdf697657b2cf Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 23 Aug 2021 19:50:35 +0200 Subject: [PATCH 42/66] Revise code for across meridian cases --- R/Start.R | 12 +- tests/testthat/test-Start-transform-border.R | 368 +++++++++++++++++++ 2 files changed, 376 insertions(+), 4 deletions(-) create mode 100644 tests/testthat/test-Start-transform-border.R diff --git a/R/Start.R b/R/Start.R index e4a97df..45424fd 100644 --- a/R/Start.R +++ b/R/Start.R @@ -2870,10 +2870,14 @@ 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)) { diff --git a/tests/testthat/test-Start-transform-border.R b/tests/testthat/test-Start-transform-border.R new file mode 100644 index 0000000..4f3590d --- /dev/null +++ b/tests/testthat/test-Start-transform-border.R @@ -0,0 +1,368 @@ +context("Transform: check with cdo") +# The result of cdo is from CDO version 1.9.8. + +# 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) + + +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 -- GitLab From f16dc3475150a4dead6ef323372715a360dec546 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 24 Aug 2021 10:22:37 +0200 Subject: [PATCH 43/66] Add more tests --- tests/testthat/test-Start-transform-border.R | 131 +++++++++++++++++++ 1 file changed, 131 insertions(+) diff --git a/tests/testthat/test-Start-transform-border.R b/tests/testthat/test-Start-transform-border.R index 4f3590d..506e4b7 100644 --- a/tests/testthat/test-Start-transform-border.R +++ b/tests/testthat/test-Start-transform-border.R @@ -366,3 +366,134 @@ tolerance = 0.0001 #[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 + -- GitLab From a7583aae1dd2f1212c786531961698545da552a8 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 24 Aug 2021 11:08:45 +0200 Subject: [PATCH 44/66] Add chunk test (undone) --- tests/testthat/test-Compute-transform_all.R | 37 +++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/tests/testthat/test-Compute-transform_all.R b/tests/testthat/test-Compute-transform_all.R index db13f35..2489c59 100644 --- a/tests/testthat/test-Compute-transform_all.R +++ b/tests/testthat/test-Compute-transform_all.R @@ -110,5 +110,42 @@ c(274.2808, 275.8509, 277.7623), tolerance = 0.0001 ) +}) + +test_that("3. Specify lat and lon with 'all'; retrieve = FALSE; chunk along lon", { + +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', #values(list(lats.min, lats.max)), +# latitude_reorder = Sort(), + longitude = 'all', #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 = 2, + 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) { + mean(x, na.rm = TRUE) + } + step <- Step(func, target_dims = 'time', output_dims = NULL) + wf <- AddStep(exp, step) +suppressWarnings( + res <- Compute(wf, chunks = list(longitude = 2)) +) + }) -- GitLab From 3ad4caff4a689d505437020ffb5c8b4cd5620d8a Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 24 Aug 2021 12:19:33 +0200 Subject: [PATCH 45/66] Fix for return_vars is NULL --- R/Start.R | 6 +++++- tests/testthat/test-Compute-transform_all.R | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/R/Start.R b/R/Start.R index 67fb5c7..b6e3263 100644 --- a/R/Start.R +++ b/R/Start.R @@ -3168,7 +3168,11 @@ 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 { #old code common_vars_to_crop[[common_var_to_crop]] <- Subset(common_vars_to_crop[[common_var_to_crop]], inner_dim, crop_indices) } diff --git a/tests/testthat/test-Compute-transform_all.R b/tests/testthat/test-Compute-transform_all.R index db13f35..67011ee 100644 --- a/tests/testthat/test-Compute-transform_all.R +++ b/tests/testthat/test-Compute-transform_all.R @@ -43,7 +43,7 @@ data2 <- Start(dat = path, 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'), + return_vars = list(lat = NULL, lon = NULL, time = 'sdate'), retrieve = T) ) -- GitLab From b75a7d3d1b8366c66eaf69a0fedfb833e5741b6d Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 25 Aug 2021 18:24:51 +0200 Subject: [PATCH 46/66] Enable indices selector to transform --- R/Start.R | 91 +++++++++++++++------ tests/testthat/test-Compute-transform_all.R | 6 +- 2 files changed, 71 insertions(+), 26 deletions(-) diff --git a/R/Start.R b/R/Start.R index f4f4f71..45c1223 100644 --- a/R/Start.R +++ b/R/Start.R @@ -2621,6 +2621,15 @@ Start <- function(..., # dim = indices/selectors, #NOTE: goes_across_prime_meridian may be TRUE only if the selector is list 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.null(var_ordered) && !selectors_are_indices) { if (!is.null(dim_reorder_params[[inner_dim]])) { if (is.list(sub_array_of_selectors)) { @@ -2707,6 +2716,7 @@ Start <- function(..., # dim = indices/selectors, } } +#TODO: sub_array_of_values here is NULL if selectors are indices. sub_array_of_indices <- selector_checker(sub_array_of_selectors, sub_array_of_values, tolerance = if (aiat) { NULL @@ -2752,22 +2762,35 @@ Start <- function(..., # dim = indices/selectors, # '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 wkthin 'sub_sub_array_of_values' and chunk sri. - if (!is.null(var_ordered) && !selectors_are_indices) { #var_ordered - if (is.list(sub_array_of_indices)) { - sub_sub_array_of_values <- - var_ordered[sub_array_of_indices[[1]]:sub_array_of_indices[[2]]] - } else { - sub_sub_array_of_values <- var_ordered[sub_array_of_indices] - } - } else { # sub_array_of_values - if (is.list(sub_array_of_indices)) { - sub_sub_array_of_values <- - sub_array_of_values[sub_array_of_indices[[1]]:sub_array_of_indices[[2]]] - } else { - sub_sub_array_of_values <- sub_array_of_values[sub_array_of_indices] + # transformed value within 'sub_sub_array_of_values' and chunk sri. + if (with_transform) { + if (!is.null(var_ordered)) { #var_ordered + if (is.list(sub_array_of_indices)) { + sub_sub_array_of_values <- + var_ordered[sub_array_of_indices[[1]]:sub_array_of_indices[[2]]] + } else { + sub_sub_array_of_values <- var_ordered[sub_array_of_indices] + } + } else { # sub_array_of_values + # Not sure if 'vars_to_transform' is correct to use. + if (is.null(sub_array_of_values)) { # selectors are indices + if (is.list(sub_array_of_indices)) { + sub_sub_array_of_values <- + vars_to_transform[[var_with_selectors_name]][sub_array_of_indices[[1]]:sub_array_of_indices[[2]]] + } else { + sub_sub_array_of_values <- vars_to_transform[[var_with_selectors_name]][sub_array_of_indices] + } + } else { # selectors are values + if (is.list(sub_array_of_indices)) { + sub_sub_array_of_values <- + sub_array_of_values[sub_array_of_indices[[1]]:sub_array_of_indices[[2]]] + } else { + sub_sub_array_of_values <- sub_array_of_values[sub_array_of_indices] + } + } } } + #---------------------------------------------------------- if (debug) { @@ -2806,16 +2829,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) @@ -2853,12 +2883,27 @@ 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 + }) + } else { # selectors are indices + # Need to transfer to values first, then use the values to get the new + # indices in transformed_subset_var. + 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 + }) + 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 diff --git a/tests/testthat/test-Compute-transform_all.R b/tests/testthat/test-Compute-transform_all.R index e3697e0..84fcdde 100644 --- a/tests/testthat/test-Compute-transform_all.R +++ b/tests/testthat/test-Compute-transform_all.R @@ -118,12 +118,12 @@ suppressWarnings( exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc', var = 'tas', sdate = '20000101', - ensemble = indices(1), + ensemble = indices(1:2), time = indices(1), latitude = 'all', #values(list(lats.min, lats.max)), -# latitude_reorder = Sort(), + latitude_reorder = Sort(), longitude = 'all', #values(list(lons.min, lons.max)), -# longitude_reorder = CircularSort(0, 360), + longitude_reorder = CircularSort(0, 360), transform = CDORemapper, transform_params = list(grid = 'r100x50', method = 'con', -- GitLab From 0dceae5e73e57b92c6acd0286c20148cebcee922 Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 2 Sep 2021 13:23:06 +0200 Subject: [PATCH 47/66] Fix problems of indices() transform+chunk. --- R/Start.R | 85 ++- R/zzz.R | 8 +- tests/testthat/test-Compute-transform_all.R | 50 +- tests/testthat/test-Compute-transform_chunk.R | 77 --- .../testthat/test-Compute-transform_indices.R | 612 +++++++++++++++++ .../testthat/test-Compute-transform_values.R | 635 ++++++++++++++++++ tests/testthat/test-Start-transform-border.R | 4 +- .../test-Start-transform-lat-Sort-all.R | 128 ++++ .../test-Start-transform-lat-Sort-indices.R | 230 +++++++ .../test-Start-transform-lat-Sort-values.R | 430 ++++++++++++ .../test-Start-transform-three-selectors.R | 194 ++++++ 11 files changed, 2361 insertions(+), 92 deletions(-) delete mode 100644 tests/testthat/test-Compute-transform_chunk.R create mode 100644 tests/testthat/test-Compute-transform_indices.R create mode 100644 tests/testthat/test-Compute-transform_values.R create mode 100644 tests/testthat/test-Start-transform-lat-Sort-all.R create mode 100644 tests/testthat/test-Start-transform-lat-Sort-indices.R create mode 100644 tests/testthat/test-Start-transform-lat-Sort-values.R create mode 100644 tests/testthat/test-Start-transform-three-selectors.R diff --git a/R/Start.R b/R/Start.R index 45c1223..9386996 100644 --- a/R/Start.R +++ b/R/Start.R @@ -2648,8 +2648,12 @@ Start <- function(..., # dim = indices/selectors, 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 @@ -2763,13 +2767,17 @@ Start <- function(..., # dim = indices/selectors, # 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) { + if (with_transform & chunks[[inner_dim]]["n_chunks"] > 1) { + previous_sub_sub_array_of_values <- NULL if (!is.null(var_ordered)) { #var_ordered if (is.list(sub_array_of_indices)) { sub_sub_array_of_values <- var_ordered[sub_array_of_indices[[1]]:sub_array_of_indices[[2]]] } else { sub_sub_array_of_values <- var_ordered[sub_array_of_indices] + if (chunks[[inner_dim]]["chunk"] > 1) { + previous_sub_sub_array_of_values <- var_ordered[sub_array_of_indices[1] - 1] + } } } else { # sub_array_of_values # Not sure if 'vars_to_transform' is correct to use. @@ -2817,6 +2825,12 @@ Start <- function(..., # dim = indices/selectors, 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)) { @@ -2940,12 +2954,71 @@ Start <- function(..., # dim = indices/selectors, sub_array_of_sri <- transformed_subset_var_unorder[sub_array_of_sri] # 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) { - 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] + if (!selectors_are_indices) { # values + sub_array_of_sri <- which(transformed_subset_var >= min(sub_sub_array_of_values) & + transformed_subset_var <= max(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 { + 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)] + } + } + } + } } +###########################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) { diff --git a/R/zzz.R b/R/zzz.R index 14fa62e..d548784 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -571,7 +571,7 @@ show_out_of_range_warning <- function(inner_dim, range, bound) { # 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) { + 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, @@ -584,7 +584,7 @@ generate_sub_array_of_fri <- function(with_transform, goes_across_prime_meridian # global longitude sub_array_of_fri <- 1:n # n = prod(dim(var_with_selectors)) - if (with_transform & beta != 0) { + if (with_transform & beta != 0 & add_beta) { # Warning if transform_extra_cell != 0 print_warning <- TRUE } @@ -593,7 +593,7 @@ generate_sub_array_of_fri <- function(with_transform, goes_across_prime_meridian # 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) { + 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), @@ -612,7 +612,7 @@ generate_sub_array_of_fri <- function(with_transform, goes_across_prime_meridian # 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) { + 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) diff --git a/tests/testthat/test-Compute-transform_all.R b/tests/testthat/test-Compute-transform_all.R index 84fcdde..46784f3 100644 --- a/tests/testthat/test-Compute-transform_all.R +++ b/tests/testthat/test-Compute-transform_all.R @@ -1,5 +1,7 @@ context("Transform with 'all'") +#!!!!!!!!!!!!!!NOTE: Sort() and CircularSort() are not functional with 'all'!!!!!!!!!!!!!!!! + test_that("1. Specify lat and lon with 'all'; retrieve = TRUE", { 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' @@ -114,11 +116,14 @@ tolerance = 0.0001 test_that("3. Specify lat and lon with 'all'; retrieve = FALSE; chunk along lon", { +#!!!!!!!!!!!!!!!!!!!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:2), + ensemble = indices(1), time = indices(1), latitude = 'all', #values(list(lats.min, lats.max)), latitude_reorder = Sort(), @@ -129,7 +134,7 @@ exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$ method = 'con', crop = FALSE), transform_vars = c('latitude', 'longitude'), - transform_extra_cells = 2, + transform_extra_cells = 8, synonims = list(latitude = c('lat', 'latitude'), longitude = c('longitude', 'lon')), return_vars = list(latitude = 'dat',#NULL, @@ -139,13 +144,50 @@ exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$ ) func <- function(x) { - mean(x, na.rm = TRUE) + return(x) } - step <- Step(func, target_dims = 'time', output_dims = NULL) + 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_chunk.R b/tests/testthat/test-Compute-transform_chunk.R deleted file mode 100644 index a54cad0..0000000 --- a/tests/testthat/test-Compute-transform_chunk.R +++ /dev/null @@ -1,77 +0,0 @@ -context("Compute: Transform and chunk along lat/lon") - -test_that("transform lat/lon and chunk over them", { - -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', #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( -res <- Compute(wf, - chunks = list(latitude = 2, longitude = 2))$output1 -) - -expect_equal( -dim(res), -c(sdate = 1, dat = 1, var = 1, ensemble = 1, time = 1, latitude = 5, longitude = 3) -) -expect_equal( -drop(res)[, 1], -c(284.9907, 282.9883, 281.2574, 284.1387, 285.6547), -tolerance = 0.0001 -) -expect_equal( -drop(res)[, 2], -c(285.4820, 282.9362, 282.6088, 287.3716, 285.0194), -tolerance = 0.0001 -) -expect_equal( -drop(res)[, 3], -c(286.1208, 284.3523, 285.9198, 287.7389, 286.1099), -tolerance = 0.0001 -) - -suppressWarnings( -res1 <- Compute(wf, - chunks = list(latitude = 3))$output1 -) -expect_equal( -dim(res), -dim(res1) -) -expect_equal( -drop(res), -drop(res1) -) - -}) diff --git a/tests/testthat/test-Compute-transform_indices.R b/tests/testthat/test-Compute-transform_indices.R new file mode 100644 index 0000000..cd568bf --- /dev/null +++ b/tests/testthat/test-Compute-transform_indices.R @@ -0,0 +1,612 @@ +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", { + +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 = 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", { + +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", { + + +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 0000000..1a09e6b --- /dev/null +++ b/tests/testthat/test-Compute-transform_values.R @@ -0,0 +1,635 @@ +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", { + +lons.min <- 0 +lons.max <- 359.9 +lats.min <- -90 +lats.max <- 90 + +# 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 = 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 = 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 +) + +#------------------------------------------------------- +#!!!!!!!!!!!!!!!!!!!!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) +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 +) +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", { + +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", { + +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 = 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 +) + +}) diff --git a/tests/testthat/test-Start-transform-border.R b/tests/testthat/test-Start-transform-border.R index 506e4b7..a84f1ec 100644 --- a/tests/testthat/test-Start-transform-border.R +++ b/tests/testthat/test-Start-transform-border.R @@ -1,5 +1,6 @@ context("Transform: check with cdo") -# The result of cdo is from CDO version 1.9.8. +# 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) @@ -21,6 +22,7 @@ context("Transform: check with cdo") # 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", { 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 0000000..d1d56c8 --- /dev/null +++ b/tests/testthat/test-Start-transform-lat-Sort-all.R @@ -0,0 +1,128 @@ +# 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]. + +#NOTE!!!!!!!!!!!!! Sort() and CircularSort() are not functional with 'all' now!!!!!!!!!!!!!!!!!!!!!!!! + +context("Transform and lat_reorder test: values") + +#--------------------------------------------------------------- +# 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 +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 = '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 = '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 +) +#WRONG!!! now lat is ascending +#expect_equal( +#as.vector(drop(res2)[50:1, ]), +#as.vector(arr2), +#tolerance = 0.0001 +#) + +#WRONG!!! now lat is ascending +#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 0000000..1a1f1ee --- /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 0000000..af00f73 --- /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-three-selectors.R b/tests/testthat/test-Start-transform-three-selectors.R new file mode 100644 index 0000000..3eb0040 --- /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 +) + +}) -- GitLab From d97a91e0db5e19525d50d84b24185581f4b295ea Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 2 Sep 2021 16:34:23 +0200 Subject: [PATCH 48/66] Fix chunking on depended dim (temporarily. Need further refinement) --- R/Start.R | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/R/Start.R b/R/Start.R index 5571dae..6a693c1 100644 --- a/R/Start.R +++ b/R/Start.R @@ -1374,10 +1374,23 @@ Start <- function(..., # dim = indices/selectors, 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)] + if (chunks[[file_dim]]['n_chunks'] > 1) { + 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)] + # chunk the depending dim as well + if (file_dim %in% depending_file_dims) { + depending_dim_name <- names(which(file_dim == depending_file_dims)) + #TODO: If j is more than 1? What will it be like? + # Should version (depending dim) has list = 1 (j) above? + if (!is.null(names(dat_selectors[[depending_dim_name]]))) { + dat_selectors[[depending_dim_name]] <- + dat_selectors[[depending_dim_name]][dat_selectors[[file_dim]][[j]]] + } + } + } } 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)) || -- GitLab From 4c9b39c27bedcc1f8f2647345df433e0ac8613a2 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 3 Sep 2021 17:26:02 +0200 Subject: [PATCH 49/66] Add missing line --- inst/doc/usecase/ex1_14_file_dependency.R | 1 + 1 file changed, 1 insertion(+) diff --git a/inst/doc/usecase/ex1_14_file_dependency.R b/inst/doc/usecase/ex1_14_file_dependency.R index c23266c..95cc3da 100644 --- a/inst/doc/usecase/ex1_14_file_dependency.R +++ b/inst/doc/usecase/ex1_14_file_dependency.R @@ -19,6 +19,7 @@ path <- paste0('/esarchive/exp/CMIP6/dcppA-hindcast/hadgem3-gc31-mm/', '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' -- GitLab From cf4467344fb66b1d0f8ac2934005dc4f6cdc5aad Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 3 Sep 2021 17:26:22 +0200 Subject: [PATCH 50/66] Fix the bug of chunking over depended dim. --- R/Start.R | 41 +++- .../testthat/test-Compute-chunk_depend_dim.R | 219 ++++++++++++++++++ 2 files changed, 249 insertions(+), 11 deletions(-) create mode 100644 tests/testthat/test-Compute-chunk_depend_dim.R diff --git a/R/Start.R b/R/Start.R index 6a693c1..8c5a2e8 100644 --- a/R/Start.R +++ b/R/Start.R @@ -1363,6 +1363,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)) || @@ -1371,23 +1374,28 @@ 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 + # Take chunk if needed (only defined dim; undefined dims will be chunked later in + # find_ufd_value(). if (chunks[[file_dim]]['n_chunks'] > 1) { - 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)] + 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)) - #TODO: If j is more than 1? What will it be like? - # Should version (depending dim) has list = 1 (j) above? - if (!is.null(names(dat_selectors[[depending_dim_name]]))) { - dat_selectors[[depending_dim_name]] <- - dat_selectors[[depending_dim_name]][dat_selectors[[file_dim]][[j]]] + # 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] + } } } } @@ -1413,6 +1421,17 @@ Start <- function(..., # dim = indices/selectors, # 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 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 0000000..a08b1e5 --- /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." +) + +}) -- GitLab From 86766d5a695f0361eaa9e5ee82bfb791b4e9375a Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 7 Sep 2021 16:51:37 +0200 Subject: [PATCH 51/66] Bugfixes and unit tests for list of indices and vector of values --- R/Start.R | 65 +++-- R/zzz.R | 27 ++ .../testthat/test-Compute-transform_indices.R | 12 +- .../testthat/test-Compute-transform_values.R | 14 +- .../testthat/test-Start-indices_list_vector.R | 237 +++++++++++++++++ .../testthat/test-Start-values_list_vector.R | 245 ++++++++++++++++++ 6 files changed, 553 insertions(+), 47 deletions(-) create mode 100644 tests/testthat/test-Start-indices_list_vector.R create mode 100644 tests/testthat/test-Start-values_list_vector.R diff --git a/R/Start.R b/R/Start.R index 9386996..4d98daf 100644 --- a/R/Start.R +++ b/R/Start.R @@ -2618,7 +2618,7 @@ 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 + #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 @@ -2630,6 +2630,7 @@ Start <- function(..., # dim = indices/selectors, } } + # 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 (is.list(sub_array_of_selectors)) { @@ -2720,7 +2721,9 @@ Start <- function(..., # dim = indices/selectors, } } -#TODO: sub_array_of_values here is NULL if selectors are indices. + # 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 @@ -2768,37 +2771,22 @@ Start <- function(..., # dim = indices/selectors, # 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) { - previous_sub_sub_array_of_values <- NULL if (!is.null(var_ordered)) { #var_ordered - if (is.list(sub_array_of_indices)) { - sub_sub_array_of_values <- - var_ordered[sub_array_of_indices[[1]]:sub_array_of_indices[[2]]] - } else { - sub_sub_array_of_values <- var_ordered[sub_array_of_indices] - if (chunks[[inner_dim]]["chunk"] > 1) { - previous_sub_sub_array_of_values <- var_ordered[sub_array_of_indices[1] - 1] - } - } - } else { # sub_array_of_values - # Not sure if 'vars_to_transform' is correct to use. + input_array_of_values <- var_ordered + } else { if (is.null(sub_array_of_values)) { # selectors are indices - if (is.list(sub_array_of_indices)) { - sub_sub_array_of_values <- - vars_to_transform[[var_with_selectors_name]][sub_array_of_indices[[1]]:sub_array_of_indices[[2]]] - } else { - sub_sub_array_of_values <- vars_to_transform[[var_with_selectors_name]][sub_array_of_indices] - } - } else { # selectors are values - if (is.list(sub_array_of_indices)) { - sub_sub_array_of_values <- - sub_array_of_values[sub_array_of_indices[[1]]:sub_array_of_indices[[2]]] - } else { - sub_sub_array_of_values <- sub_array_of_values[sub_array_of_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) { @@ -2908,7 +2896,11 @@ Start <- function(..., # dim = indices/selectors, } else { # selectors are indices # Need to transfer to values first, then use the values to get the new # indices in transformed_subset_var. - ori_values <- vars_to_transform[[var_with_selectors_name]][sub_array_of_selectors] + 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) { @@ -2916,6 +2908,8 @@ Start <- function(..., # dim = indices/selectors, } 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) } @@ -2961,9 +2955,10 @@ Start <- function(..., # dim = indices/selectors, # situation happens, but don't know if the transformed result is # correct or not. if (chunks[[inner_dim]]["n_chunks"] > 1) { - if (!selectors_are_indices) { # values - sub_array_of_sri <- which(transformed_subset_var >= min(sub_sub_array_of_values) & - transformed_subset_var <= max(sub_sub_array_of_values)) + 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 @@ -2974,12 +2969,12 @@ Start <- function(..., # dim = indices/selectors, 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)] + sub_array_of_sri <- (previous_sri + 1):sub_array_of_sri[length(sub_array_of_sri)] } } } - } else { + } 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 @@ -3004,7 +2999,7 @@ Start <- function(..., # dim = indices/selectors, 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)] + sub_array_of_sri <- (previous_sri + 1):sub_array_of_sri[length(sub_array_of_sri)] } } } diff --git a/R/zzz.R b/R/zzz.R index d548784..f739500 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -568,6 +568,33 @@ show_out_of_range_warning <- function(inner_dim, range, bound) { "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, diff --git a/tests/testthat/test-Compute-transform_indices.R b/tests/testthat/test-Compute-transform_indices.R index cd568bf..b9807cb 100644 --- a/tests/testthat/test-Compute-transform_indices.R +++ b/tests/testthat/test-Compute-transform_indices.R @@ -151,16 +151,16 @@ 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_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_3 <- Compute(wf, chunks = list(lon = 3)) +#) suppressWarnings( res_crop_T_4 <- Compute(wf, chunks = list(lat = 2)) ) diff --git a/tests/testthat/test-Compute-transform_values.R b/tests/testthat/test-Compute-transform_values.R index 1a09e6b..17f76d8 100644 --- a/tests/testthat/test-Compute-transform_values.R +++ b/tests/testthat/test-Compute-transform_values.R @@ -170,15 +170,17 @@ func <- function(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 -) +#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 ) -suppressWarnings( -res_crop_T_3 <- Compute(wf, chunks = list(longitude = 3))$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 ) 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 0000000..763b2c1 --- /dev/null +++ b/tests/testthat/test-Start-indices_list_vector.R @@ -0,0 +1,237 @@ +# 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(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) +) + +# 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(exp1), +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_reorder = Sort(), + longitude = indices(list(40, 1)), + 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_reorder = Sort(), + longitude = 40:1, + 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) +) + +}) 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 0000000..d93b247 --- /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) +) + +}) -- GitLab From 285d5ef24ee2af70562c4dea5a9bc983764f818e Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 7 Sep 2021 18:20:10 +0200 Subject: [PATCH 52/66] Fix bugs of is_circular_dim --- R/Start.R | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/R/Start.R b/R/Start.R index 4d98daf..451499d 100644 --- a/R/Start.R +++ b/R/Start.R @@ -2626,18 +2626,22 @@ Start <- function(..., # dim = indices/selectors, 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") + 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. - if ('circular' %in% names(attributes(dim_reorder_params[[inner_dim]]))) { - is_circular_dim <- attr(dim_reorder_params[[inner_dim]], "circular") - } 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]. -- GitLab From a8d04b310ac7176319c5fffa75c3362ed929345f Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 8 Sep 2021 00:11:06 +0200 Subject: [PATCH 53/66] Fix unit test and warning --- R/Start.R | 2 +- tests/testthat/test-Start-indices_list_vector.R | 12 ++++++++---- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/R/Start.R b/R/Start.R index 451499d..42a1a3b 100644 --- a/R/Start.R +++ b/R/Start.R @@ -2714,7 +2714,7 @@ Start <- function(..., # dim = indices/selectors, } else { # Add warning if the boundary is out of range - if (is.list(sub_array_of_selectors)) { + 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') diff --git a/tests/testthat/test-Start-indices_list_vector.R b/tests/testthat/test-Start-indices_list_vector.R index 763b2c1..39ecb24 100644 --- a/tests/testthat/test-Start-indices_list_vector.R +++ b/tests/testthat/test-Start-indices_list_vector.R @@ -137,7 +137,7 @@ exp1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var time = indices(1), latitude = indices(list(30, 1)), latitude_reorder = Sort(), - longitude = indices(list(40, 1)), + longitude = indices(list(1, 40)), # can't reverse. Different meaning longitude_reorder = CircularSort(0, 360), transform = CDORemapper, transform_params = list(grid = 'r100x50', @@ -179,7 +179,7 @@ exp2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var ) expect_equal( -as.vector(exp1), +as.vector(drop(exp1)[, 4:1]), as.vector(exp2) ) @@ -199,8 +199,10 @@ exp1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var ensemble = indices(1), time = indices(1), latitude = indices(list(30, 1)), + latitude_var = 'latitude', latitude_reorder = Sort(), - longitude = indices(list(40, 1)), + 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')), @@ -218,8 +220,10 @@ exp2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var 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')), @@ -230,7 +234,7 @@ exp2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var ) expect_equal( -as.vector(exp1), +as.vector(drop(exp1)[, 40:1]), as.vector(exp2) ) -- GitLab From 7cab743946c1493d491b9c5cd79ff6b9d9bed848 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 8 Sep 2021 10:57:35 +0200 Subject: [PATCH 54/66] Remove package coverage check for faster pipeline speed --- .gitlab-ci.yml | 1 - tests/testthat.R | 3 ++- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 8cd9e96..ef540fe 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/tests/testthat.R b/tests/testthat.R index 5073b5e..04a698c 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,8 +1,9 @@ library(testthat) library(startR) library(SpecsVerification) -library(dplyr) library(plyr) +library(dplyr) +library(easyNCDF) library(s2dv) test_check("startR") -- GitLab From 1081e3b0f0b78f7f8fa0605da895a8b596f79631 Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 9 Sep 2021 19:34:36 +0200 Subject: [PATCH 55/66] Bugfix of different longitude range when chunking --- R/Start.R | 31 ++- .../testthat/test-Compute-transform_values.R | 234 +++++++++++++++++- 2 files changed, 254 insertions(+), 11 deletions(-) diff --git a/R/Start.R b/R/Start.R index 42a1a3b..2dc9f89 100644 --- a/R/Start.R +++ b/R/Start.R @@ -2743,14 +2743,24 @@ 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 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), @@ -2948,8 +2958,6 @@ Start <- function(..., # dim = indices/selectors, } else if (is.list(sub_array_of_sri)) { sub_array_of_sri <- sub_array_of_sri[[1]]:sub_array_of_sri[[2]] } - ordered_sri <- sub_array_of_sri - sub_array_of_sri <- transformed_subset_var_unorder[sub_array_of_sri] # Chunk sub_array_of_sri if this inner_dim needs to be chunked #TODO: Potential problem: the transformed_subset_var value falls between @@ -3009,6 +3017,8 @@ Start <- function(..., # dim = indices/selectors, } } } + 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) { @@ -3073,6 +3083,9 @@ Start <- function(..., # dim = indices/selectors, 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 diff --git a/tests/testthat/test-Compute-transform_values.R b/tests/testthat/test-Compute-transform_values.R index 17f76d8..e616d23 100644 --- a/tests/testthat/test-Compute-transform_values.R +++ b/tests/testthat/test-Compute-transform_values.R @@ -14,6 +14,8 @@ 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', @@ -81,10 +83,74 @@ mean(res1), 276.3901, tolerance = 0.001 ) +#-------------------------------------------------- -#------------------------------------------------------- +# 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', @@ -524,7 +590,63 @@ 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( @@ -581,6 +703,61 @@ 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', @@ -633,5 +810,58 @@ 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 +) }) -- GitLab From a7ba37c606e8760e91bce73248f56810d1b06804 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 14 Sep 2021 18:47:30 +0200 Subject: [PATCH 56/66] Development of 'all' + reorder functions. Create FAQ and use cases for transform + chunk --- R/Start.R | 50 +++++- inst/doc/faq.md | 44 ++++- inst/doc/usecase/ex2_12_transform_and_chunk.R | 163 ++++++++++++++++++ tests/testthat/test-Compute-transform_all.R | 77 +-------- .../test-Start-transform-lat-Sort-all.R | 31 ++-- 5 files changed, 272 insertions(+), 93 deletions(-) create mode 100644 inst/doc/usecase/ex2_12_transform_and_chunk.R diff --git a/R/Start.R b/R/Start.R index 2dc9f89..b9a6fa3 100644 --- a/R/Start.R +++ b/R/Start.R @@ -2105,7 +2105,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 ", @@ -2118,7 +2118,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 @@ -2255,6 +2256,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]] @@ -2268,7 +2270,9 @@ Start <- function(..., # dim = indices/selectors, 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) { @@ -2276,6 +2280,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][[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) { @@ -2283,6 +2303,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 @@ -2433,7 +2467,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)) @@ -3321,6 +3359,9 @@ Start <- function(..., # dim = indices/selectors, 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) @@ -3340,6 +3381,9 @@ Start <- function(..., # dim = indices/selectors, 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) diff --git a/inst/doc/faq.md b/inst/doc/faq.md index 4cd9124..fbf2efb 100644 --- a/inst/doc/faq.md +++ b/inst/doc/faq.md @@ -26,6 +26,8 @@ This document intends to be the first reference for any doubts that you may have 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) 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...** @@ -322,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 @@ -920,6 +922,46 @@ data <- Start(dat = path, 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... 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 0000000..8b2eb83 --- /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/tests/testthat/test-Compute-transform_all.R b/tests/testthat/test-Compute-transform_all.R index 46784f3..c99ae5f 100644 --- a/tests/testthat/test-Compute-transform_all.R +++ b/tests/testthat/test-Compute-transform_all.R @@ -1,75 +1,6 @@ context("Transform with 'all'") -#!!!!!!!!!!!!!!NOTE: Sort() and CircularSort() are not functional with 'all'!!!!!!!!!!!!!!!! - -test_that("1. Specify lat and lon with 'all'; retrieve = TRUE", { - -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( -data1 <- Start(dat = path, - var = 'tos', - sdate = paste0(1960), - time = indices(1:2), #'all', - lat = 'all', - lon = 'all', -# lat_reorder = Sort(decreasing = F), -# lon_reorder = CircularSort(0, 360), -# lat_var = 'lat', -# lon_var = 'lon', - fyear = indices(1), - member = indices(1), - 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 = T) -) - -suppressWarnings( -data2 <- Start(dat = path, - var = 'tos', - sdate = paste0(1960), - time = indices(1:2), #'all', - lat = values(list(-90, 90)), - lon = values(list(0, 359.9)), - lat_reorder = Sort(decreasing = F), - lon_reorder = CircularSort(0, 360), -# lat_var = 'lat', -# lon_var = 'lon', - fyear = indices(1), - member = indices(1), - 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 = NULL, lon = NULL, time = 'sdate'), - retrieve = T) -) - -expect_equal( -dim(data1), -c(dat = 1, var = 1, sdate = 1, time = 2, lat = 50, lon = 100, fyear = 1, member = 1) -) -expect_equal( -dim(data1), -dim(data2) -) -expect_equal( -as.vector(data1), -as.vector(data2) -) -expect_equal( -data1[1, 1, 1, 2, 10:12, 20, 1, 1], -c(274.6942, 276.2658, 278.2566), -tolerance = 0.0001 -) - -}) - -test_that("2. Specify lat and lon with 'all'; retrieve = FALSE", { +test_that("1. Chunk along non-lat/lon dim", { 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( @@ -114,7 +45,7 @@ tolerance = 0.0001 }) -test_that("3. Specify lat and lon with 'all'; retrieve = FALSE; chunk along lon", { +test_that("2. chunk along lon", { #!!!!!!!!!!!!!!!!!!!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. @@ -125,9 +56,9 @@ exp <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$ sdate = '20000101', ensemble = indices(1), time = indices(1), - latitude = 'all', #values(list(lats.min, lats.max)), + latitude = 'all', latitude_reorder = Sort(), - longitude = 'all', #values(list(lons.min, lons.max)), + longitude = 'all', longitude_reorder = CircularSort(0, 360), transform = CDORemapper, transform_params = list(grid = 'r100x50', diff --git a/tests/testthat/test-Start-transform-lat-Sort-all.R b/tests/testthat/test-Start-transform-lat-Sort-all.R index d1d56c8..31c7ab5 100644 --- a/tests/testthat/test-Start-transform-lat-Sort-all.R +++ b/tests/testthat/test-Start-transform-lat-Sort-all.R @@ -6,7 +6,7 @@ #NOTE!!!!!!!!!!!!! Sort() and CircularSort() are not functional with 'all' now!!!!!!!!!!!!!!!!!!!!!!!! -context("Transform and lat_reorder test: values") +context("Transform and lat_reorder test: 'all'") #--------------------------------------------------------------- # cdo is used to verify the data values @@ -55,7 +55,8 @@ res1 <- Start(dat = path, retrieve = T) ) -# lat should be descending +# 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', @@ -74,8 +75,8 @@ res2 <- Start(dat = path, transform_extra_cells = 2, synonims = list(latitude = c('lat', 'latitude'), longitude = c('longitude', 'lon')), - return_vars = list(latitude = 'dat', - longitude = 'dat', + return_vars = list(latitude = NULL, #'dat', + longitude = NULL, #'dat', time = 'sdate'), retrieve = T) ) @@ -110,19 +111,17 @@ as.vector(res1), as.vector(arr2), tolerance = 0.0001 ) -#WRONG!!! now lat is ascending -#expect_equal( -#as.vector(drop(res2)[50:1, ]), -#as.vector(arr2), -#tolerance = 0.0001 -#) +expect_equal( +as.vector(res2), +as.vector(arr2), +tolerance = 0.0001 +) -#WRONG!!! now lat is ascending -#expect_equal( -#as.vector(drop(res3)[50:1, ]), -#as.vector(arr2), -#tolerance = 0.0001 -#) +expect_equal( +as.vector(drop(res3)[50:1, ]), +as.vector(arr2), +tolerance = 0.0001 +) }) -- GitLab From b13227e1dca718c37643d0ee300b503310461313 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 15 Sep 2021 13:10:20 +0200 Subject: [PATCH 57/66] Add the method to verify regridding data --- inst/doc/data_check.md | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/inst/doc/data_check.md b/inst/doc/data_check.md index ae73f50..156a253 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 + +``` -- GitLab From 73716631de8cde77824ac0f6f1ce7dc91c25e182 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 15 Sep 2021 13:27:16 +0200 Subject: [PATCH 58/66] Fix Sort() + 'all' (no transform) --- R/Start.R | 16 ++- tests/testthat/test-Start-reorder-lat.R | 166 +++++++++++++++++++++++- 2 files changed, 176 insertions(+), 6 deletions(-) diff --git a/R/Start.R b/R/Start.R index b9a6fa3..72014b3 100644 --- a/R/Start.R +++ b/R/Start.R @@ -1330,13 +1330,21 @@ Start <- function(..., # dim = indices/selectors, "the Start call.")) } } - if (attr(dat_selectors[[dim_name]], 'indices') & (dim_name %in% transform_vars) & - !(dim_name %in% names(var_params))) { - var_params <- c(var_params, setNames(list(dim_name), dim_name)) - .warning(paste0("Found dimension '", dim_name, "' is required to transform but no '", + + 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.")) + } } } diff --git a/tests/testthat/test-Start-reorder-lat.R b/tests/testthat/test-Start-reorder-lat.R index e2ef5d9..c61a00e 100644 --- a/tests/testthat/test-Start-reorder-lat.R +++ b/tests/testthat/test-Start-reorder-lat.R @@ -880,7 +880,169 @@ 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 +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 +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 +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 +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 +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 +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) +) + +}) +############################################## -- GitLab From 7bcf10514401327e424919f9a411eed670b5de4b Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 17 Sep 2021 09:19:27 +0200 Subject: [PATCH 59/66] Change the metadata result of non-existing data due to new development --- tests/testthat/test-Start-metadata_dims.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-Start-metadata_dims.R b/tests/testthat/test-Start-metadata_dims.R index 841786d..3239e7d 100644 --- a/tests/testthat/test-Start-metadata_dims.R +++ b/tests/testthat/test-Start-metadata_dims.R @@ -406,7 +406,7 @@ suppressWarnings( ) expect_equal( attr(data, "Variables")$system4_m1, - NULL + list(lon = NULL, lat = NULL) ) expect_equal( length(attr(data, "Variables")$system5_m1$lon), -- GitLab From bbffadcb82cca8554768a01735ad9a6646fa3589 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 17 Sep 2021 09:19:48 +0200 Subject: [PATCH 60/66] Add suppressWarnings --- tests/testthat/test-Start-reorder-lat.R | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test-Start-reorder-lat.R b/tests/testthat/test-Start-reorder-lat.R index c61a00e..4133cf0 100644 --- a/tests/testthat/test-Start-reorder-lat.R +++ b/tests/testthat/test-Start-reorder-lat.R @@ -884,6 +884,7 @@ 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', @@ -899,9 +900,10 @@ exp1_1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$v 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', @@ -917,9 +919,10 @@ exp1_2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$v 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', @@ -935,7 +938,7 @@ exp1_3 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$v 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), @@ -967,6 +970,7 @@ 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', @@ -982,9 +986,10 @@ exp2_1 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$v 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', @@ -1000,9 +1005,10 @@ exp2_2 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$v 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', @@ -1018,7 +1024,7 @@ exp2_3 <- Start(dat = '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$v longitude = 'dat', time = 'sdate'), retrieve = T) - +) expect_equal( as.vector(drop(exp1_1)), as.vector(drop(exp2_1)) -- GitLab From 74f4fd65e156d8672cdfda319494d13380ca338b Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 17 Sep 2021 11:07:22 +0200 Subject: [PATCH 61/66] Modularize the part that generates picked_vars and picked_common_vars --- R/Start.R | 301 +++++++++++++++--------------------------------------- R/zzz.R | 155 ++++++++++++++++++++++++++++ 2 files changed, 238 insertions(+), 218 deletions(-) diff --git a/R/Start.R b/R/Start.R index 72014b3..8c0bd0d 100644 --- a/R/Start.R +++ b/R/Start.R @@ -1733,7 +1733,26 @@ Start <- function(..., # dim = indices/selectors, } #//////////////////////////////////////////// - # Create 'picked_common_vars' + # 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) @@ -1743,33 +1762,19 @@ Start <- function(..., # dim = indices/selectors, picked_common_vars_ordered <- picked_common_vars picked_common_vars_unorder_indices <- picked_common_vars - # Create 'picked_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]]) || # 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]]) - } - } - - 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]] @@ -1817,179 +1822,42 @@ Start <- function(..., # dim = indices/selectors, # Need to translate accoridng to synonims: 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]) - } - 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') - 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] - 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(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) - } - 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]]) == names(time_special_types))) { - 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]]) == names(time_special_types))) { - 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 @@ -1998,7 +1866,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]) } } @@ -2011,21 +1879,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)) @@ -2040,7 +1894,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. @@ -2068,7 +1925,8 @@ Start <- function(..., # dim = indices/selectors, } } - } else { # largest_dims_length == TRUE + ## 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]], @@ -2078,8 +1936,11 @@ Start <- function(..., # dim = indices/selectors, # Need to translate accoridng to synonims: names(data_dims) <- replace_with_synonmins(data_dims, synonims) - } # end of if (largest_dims_length == TRUE) + } # end 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)))) { @@ -2139,16 +2000,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] } } } @@ -2275,6 +2136,7 @@ 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 } @@ -2293,7 +2155,7 @@ Start <- function(..., # dim = indices/selectors, if (is.null(transformed_var_unordered_indices)) { transformed_var_unordered_indices <- 1:m } - transformed_var_with_selectors <- transformed_vars[[i]][transformed_picked_vars][[var_with_selectors_name]][transformed_var_unordered_indices] + 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) @@ -2953,6 +2815,9 @@ Start <- function(..., # dim = indices/selectors, } else { NULL }) + if (is.vector(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. diff --git a/R/zzz.R b/R/zzz.R index f739500..7d9c9a8 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1202,3 +1202,158 @@ combine_metadata_picked_vars <- function(return_metadata, picked_vars, picked_co 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[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] + + 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? +} + -- GitLab From 2d30847e77ef1a49f9c75d382442a02996b3b1f3 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 17 Sep 2021 11:07:55 +0200 Subject: [PATCH 62/66] Add test for indices(list()) and values(c()) --- .../testthat/test-Compute-transform_indices.R | 36 +++++++++++++ .../testthat/test-Compute-transform_values.R | 53 +++++++++++++++++++ 2 files changed, 89 insertions(+) diff --git a/tests/testthat/test-Compute-transform_indices.R b/tests/testthat/test-Compute-transform_indices.R index b9807cb..9eab93a 100644 --- a/tests/testthat/test-Compute-transform_indices.R +++ b/tests/testthat/test-Compute-transform_indices.R @@ -72,6 +72,42 @@ 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( diff --git a/tests/testthat/test-Compute-transform_values.R b/tests/testthat/test-Compute-transform_values.R index e616d23..fa1613b 100644 --- a/tests/testthat/test-Compute-transform_values.R +++ b/tests/testthat/test-Compute-transform_values.R @@ -85,6 +85,59 @@ 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 -- GitLab From 41f23ddc5fe50b15e1e68af3ab0b62b74c64bf7e Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 17 Sep 2021 12:27:56 +0200 Subject: [PATCH 63/66] Skip some tests on CRAN to speed up the pipeline --- tests/testthat/test-Compute-transform_all.R | 2 ++ tests/testthat/test-Compute-transform_indices.R | 4 +++- tests/testthat/test-Compute-transform_values.R | 4 ++++ tests/testthat/test-Start-transform-lat-Sort-all.R | 2 -- 4 files changed, 9 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-Compute-transform_all.R b/tests/testthat/test-Compute-transform_all.R index c99ae5f..46430d7 100644 --- a/tests/testthat/test-Compute-transform_all.R +++ b/tests/testthat/test-Compute-transform_all.R @@ -1,6 +1,7 @@ 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( @@ -46,6 +47,7 @@ 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. diff --git a/tests/testthat/test-Compute-transform_indices.R b/tests/testthat/test-Compute-transform_indices.R index 9eab93a..d9d65cb 100644 --- a/tests/testthat/test-Compute-transform_indices.R +++ b/tests/testthat/test-Compute-transform_indices.R @@ -22,6 +22,7 @@ context("Transform with indices") test_that("1. global", { +skip_on_cran() path <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' @@ -250,6 +251,7 @@ res_crop_T_4$output1 test_that("2. regional, no border", { +skip_on_cran() path <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' @@ -463,7 +465,7 @@ res_crop_T_3$output1 test_that("3. regional, at lon border", { - +skip_on_cran() path <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' diff --git a/tests/testthat/test-Compute-transform_values.R b/tests/testthat/test-Compute-transform_values.R index fa1613b..74975f7 100644 --- a/tests/testthat/test-Compute-transform_values.R +++ b/tests/testthat/test-Compute-transform_values.R @@ -7,6 +7,7 @@ context("Compute: Transform and chunk values()") ##################################################################### test_that("1. Global", { +skip_on_cran() lons.min <- 0 lons.max <- 359.9 @@ -345,6 +346,8 @@ res_crop_T_4 test_that("2. Regional, no border", { +skip_on_cran() + lons.min <- 10 lons.max <- 20 lats.min <- 20 @@ -553,6 +556,7 @@ res_crop_T_3 test_that("3. Regional, at lon border", { +skip_on_cran() lons.min <- 0 lons.max <- 20 diff --git a/tests/testthat/test-Start-transform-lat-Sort-all.R b/tests/testthat/test-Start-transform-lat-Sort-all.R index 31c7ab5..2839369 100644 --- a/tests/testthat/test-Start-transform-lat-Sort-all.R +++ b/tests/testthat/test-Start-transform-lat-Sort-all.R @@ -4,8 +4,6 @@ # 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]. -#NOTE!!!!!!!!!!!!! Sort() and CircularSort() are not functional with 'all' now!!!!!!!!!!!!!!!!!!!!!!!! - context("Transform and lat_reorder test: 'all'") #--------------------------------------------------------------- -- GitLab From f17f3e171fda60cd787fb665bc57c8041c768330 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 17 Sep 2021 12:28:08 +0200 Subject: [PATCH 64/66] Fix typo --- R/zzz.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/zzz.R b/R/zzz.R index 7d9c9a8..3eeed1a 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1261,7 +1261,7 @@ generate_picked_var_of_read <- function(var_to_read, var_to_check, array_of_file paste(paste0("'", names(array_var_dims), "'"), collapse = ', '), " but found ", paste(paste0("'", names(var_dims), "'"), collapse = ', '), - ".\n", array_of_var_files[j]) + ".\n", array_of_var_files) } if (any(var_dims > array_var_dims)) { longer_dims <- which(var_dims > array_var_dims) -- GitLab From 0640c06586f0d4fb1e0f36e12977cc4a188b9595 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 17 Sep 2021 13:23:42 +0200 Subject: [PATCH 65/66] Correct conditional statement --- R/Start.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/Start.R b/R/Start.R index 8c0bd0d..2e2258a 100644 --- a/R/Start.R +++ b/R/Start.R @@ -2815,7 +2815,7 @@ Start <- function(..., # dim = indices/selectors, } else { NULL }) - if (is.vector(sub_array_of_sri)) { + if (!is.list(sub_array_of_sri)) { sub_array_of_sri <- unique(sub_array_of_sri) } } else { # selectors are indices -- GitLab From 4add3357ac01b0e93671f452c50e21f19ef40623 Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 20 Sep 2021 09:39:06 +0200 Subject: [PATCH 66/66] version bump to v2.1.0-5 --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6ad8a64..f1a9778 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")), -- GitLab