diff --git a/R/Start.R b/R/Start.R index bec09365a9b48c96dbdcc2791002159e5d9ac6b0..d977e714f9e8f0e04585a5f2b69edd3afa5d417a 100644 --- a/R/Start.R +++ b/R/Start.R @@ -2955,11 +2955,28 @@ Start <- function(..., # dim = indices/selectors, # 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. + # NOTE: The chunking criteria may not be 100% correct. The current way + # is to pick the sri that larger than the minimal sub_sub_array_of_values + # and smaller than the maximal sub_sub_array_of_values; if it's + # the first chunk, make sure the 1st sri is included; if it's the + # last chunk, make sure the last sri is included. if (chunks[[inner_dim]]["n_chunks"] > 1) { + sub_array_of_sri_complete <- sub_array_of_sri 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))) + # if it's 1st chunk & the first sri is not included, include it. + if (chunks[[inner_dim]]["chunk"] == 1 & + !(sub_array_of_sri_complete[1] %in% sub_array_of_sri)) { + sub_array_of_sri <- c(sub_array_of_sri_complete[1], sub_array_of_sri) + } + # if it's last chunk & the last sri is not included, include it. + if (chunks[[inner_dim]]["chunk"] == chunks[[inner_dim]]["n_chunks"] & + !(tail(sub_array_of_sri_complete, 1) %in% sub_array_of_sri)) { + sub_array_of_sri <- c(sub_array_of_sri, tail(sub_array_of_sri_complete, 1)) + } + # 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 @@ -2968,7 +2985,13 @@ Start <- function(..., # dim = indices/selectors, # 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 decreasing = F + if (transformed_subset_var[1] < transformed_subset_var[2]) { + previous_sri <- max(which(transformed_subset_var <= previous_sub_sub_array_of_values)) + } else { + # if decreasing = T + 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)] } @@ -2978,6 +3001,10 @@ Start <- function(..., # dim = indices/selectors, } else { # is vector tmp <- which(transformed_subset_var >= min(sub_sub_array_of_values) & transformed_subset_var <= max(sub_sub_array_of_values)) + # Ensure tmp and sub_array_of_sri are both ascending or descending + if (is.unsorted(tmp) != is.unsorted(sub_array_of_sri)) { + tmp <- rev(tmp) + } # 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 @@ -2998,14 +3025,21 @@ Start <- function(..., # dim = indices/selectors, # 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]) { + # if decreasing = F + if (transformed_subset_var[1] < transformed_subset_var[2]) { + previous_sri <- max(which(transformed_subset_var <= previous_sub_sub_array_of_values)) + } else { + # if decreasing = T + previous_sri <- max(which(transformed_subset_var >= previous_sub_sub_array_of_values)) + } + if (previous_sri + 1 != which(sub_array_of_sri[1] == sub_array_of_sri_complete)) { sub_array_of_sri <- (previous_sri + 1):sub_array_of_sri[length(sub_array_of_sri)] } } } } } + ordered_sri <- sub_array_of_sri sub_array_of_sri <- transformed_subset_var_unorder[sub_array_of_sri] diff --git a/R/zzz.R b/R/zzz.R index c1226bca3b9fc1be5ac04e16eb655302c23b43c2..941ecbe2b0414603296e6a370140625b585d990b 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -598,12 +598,24 @@ generate_sub_sub_array_of_values <- function(input_array_of_values, sub_array_of 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] + if (diff(unlist(sub_array_of_indices)) > 0) { + previous_sub_sub_array_of_values <- + input_array_of_values[sub_array_of_indices[[1]] - 1] + } else { + 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] + if (diff(sub_array_of_indices[1:2]) > 0) { + previous_sub_sub_array_of_values <- + input_array_of_values[sub_array_of_indices[1] - 1] + } else { + previous_sub_sub_array_of_values <- + input_array_of_values[sub_array_of_indices[1] + 1] + } } } diff --git a/tests/testthat/test-Compute-transform_indices.R b/tests/testthat/test-Compute-transform_indices.R index 162e4e8c5f57ffaf187a5be496caa40b9e70141d..3d7bb7d33174ebdf0af9e2f962e6d43bbea0a091 100644 --- a/tests/testthat/test-Compute-transform_indices.R +++ b/tests/testthat/test-Compute-transform_indices.R @@ -528,73 +528,22 @@ c(241.0894, 242.1896, 245.3183, 243.1169, 243.9446, 266.4386), 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) -) +#--------------------------------- +# lat indices is reversed -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 + lat = indices(80:1), # 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_params = list(grid = 'r100x50', method = 'conservative'), transform_vars = c('lat','lon'), synonims = list(lon = c('lon', 'longitude'), lat = c('lat', 'latitude')), return_vars = list(lat = 'dat', lon = 'dat', time = 'sdate'), @@ -608,26 +557,122 @@ step <- Step(func, target_dims = 'time', output_dims = 'time') wf <- AddStep(exp, step) suppressWarnings( -res_crop_T_1 <- Compute(wf, chunks = list(lon = 2)) +res4 <- 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)) +res5 <- Compute(wf, chunks = list(lat = 2)) ) expect_equal( -res_crop_F_1$output1, -res_crop_T_1$output1 +res4$output1, +res5$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 +as.vector(drop(res1$output1)[6:1, ]), +as.vector(drop(res4$output1)) ) +#------------------------------------------------------ +#NOTE_19/01/2022: crop is deprecated +## 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 index a8dae02ce6def77d14caa4cf7d94dc4666949470..1029b60fc1b504557d30fb8653d6fe8d639db05a 100644 --- a/tests/testthat/test-Compute-transform_values.R +++ b/tests/testthat/test-Compute-transform_values.R @@ -532,6 +532,78 @@ res_crop_T_1, res_crop_T_3 ) +# The region borders do not exist in the original grid value. For example, +# the original grid is [longitude = 1296], so 11 and 21 do not exist there +# (but 10 and 20 do, in the cases above) +lons.min <- 11 +lons.max <- 21 +lats.min <- 21 +lats.max <- 41 + +# 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(latitude = 3))$output1 +) + +expect_equal( +dim(res1), +c(sdate = 1, dat = 1, var = 1, ensemble = 1, time = 1, latitude = 5, longitude = 2) +) +expect_equal( +res1, +res2 +) +expect_equal( +res1, +res3 +) + +expect_equal( +drop(res1)[, 1], +c(285.4820, 282.9362, 282.6088, 287.3716, 285.0194), +tolerance = 0.0001 +) +expect_equal( +drop(res1)[, 2], +c(286.1208, 284.3523, 285.9198, 287.7389, 286.1099), +tolerance = 0.0001 +) + }) ############################################################################