diff --git a/R/Load.R b/R/Load.R index cdb30bef93a1e38ecaf2b65895fc5a21a2462ca3..3c3aa8ea0d9c6408c272f3c1ecf4e49f2ae25666 100644 --- a/R/Load.R +++ b/R/Load.R @@ -1878,11 +1878,11 @@ Load <- function(var, exp = NULL, obs = NULL, sdates, nmember = NULL, } # We calculate the % of total progress that each work piece represents so # that progress bar can be updated properly - exp_work_piece_percent <- prod(dim_exp) / (prod(dim_obs) + prod(dim_exp)) - obs_work_piece_percent <- prod(dim_obs) / (prod(dim_obs) + prod(dim_exp)) + exp_work_piece_percent <- prod(unlist(dim_exp)) / (prod(unlist(dim_obs)) + prod(unlist(dim_exp))) + obs_work_piece_percent <- prod(unlist(dim_obs)) / (prod(unlist(dim_obs)) + prod(unlist(dim_exp))) # Add some important extra fields in the work pieces before sending - exp_work_pieces <- lapply(exp_work_pieces, function (x) c(x, list(dataset_type = 'exp', dims = dim_exp, out_pointer = pointer_var_exp)))###, progress_amount = exp_work_piece_progress))) - obs_work_pieces <- lapply(obs_work_pieces, function (x) c(x, list(dataset_type = 'obs', dims = dim_obs, out_pointer = pointer_var_obs)))###, progress_amount = obs_work_piece_progress))) + exp_work_pieces <- lapply(exp_work_pieces, function (x) c(x, list(dataset_type = 'exp', dims = unlist(dim_exp), out_pointer = pointer_var_exp)))###, progress_amount = exp_work_piece_progress))) + obs_work_pieces <- lapply(obs_work_pieces, function (x) c(x, list(dataset_type = 'obs', dims = unlist(dim_obs), out_pointer = pointer_var_obs)))###, progress_amount = obs_work_piece_progress))) work_pieces <- c(exp_work_pieces, obs_work_pieces) # Calculate the progress %s that will be displayed and assign them to the # appropriate work pieces @@ -1953,15 +1953,15 @@ Load <- function(var, exp = NULL, obs = NULL, sdates, nmember = NULL, bytes_obs <- 0 obs_dim_sizes <- '0' } else { - bytes_obs <- prod(c(dim_obs, 8)) - obs_dim_sizes <- paste(na.omit(as.vector(dim_obs[c('dataset', 'member', 'sdate', 'ftime', 'lat', 'lon')])), collapse = ' x ') + bytes_obs <- prod(c(unlist(dim_obs), 8)) + obs_dim_sizes <- paste(na.omit(as.vector(unlist(dim_obs)[c('dataset', 'member', 'sdate', 'ftime', 'lat', 'lon')])), collapse = ' x ') } if (length(dim_exp) == 0) { bytes_exp <- 0 exp_dim_sizes <- '0' } else { - bytes_exp <- prod(c(dim_exp, 8)) - exp_dim_sizes <- paste(na.omit(as.vector(dim_exp[c('dataset', 'member', 'sdate', 'ftime', 'lat', 'lon')])), collapse = ' x ') + bytes_exp <- prod(c(unlist(dim_exp), 8)) + exp_dim_sizes <- paste(na.omit(as.vector(unlist(dim_exp)[c('dataset', 'member', 'sdate', 'ftime', 'lat', 'lon')])), collapse = ' x ') } .message(paste("Total size of requested data: ", bytes_obs + bytes_exp, "bytes.")) .message(paste("- Experimental data: (", exp_dim_sizes, ") x 8 bytes =", bytes_exp, "bytes."), indent = 2) @@ -2146,7 +2146,7 @@ Load <- function(var, exp = NULL, obs = NULL, sdates, nmember = NULL, old_dims <- dim_exp dim_exp <- dim_exp[dim_reorder] mod_data <- - aperm(array(bigmemory::as.matrix(var_exp), dim = old_dims), dim_reorder) + aperm(array(bigmemory::as.matrix(var_exp), dim = unlist(old_dims)), dim_reorder) attr(mod_data, 'dimensions') <- names(dim_exp) names(dim(mod_data)) <- names(dim_exp) number_ftime <- dim_exp[["ftime"]] diff --git a/R/Utils.R b/R/Utils.R index 1f39694ee5d0c9f88a905e49f1e8a11bdabbe94b..c13691499e7db59f4247411b0ad79498f9c0a65b 100644 --- a/R/Utils.R +++ b/R/Utils.R @@ -349,11 +349,11 @@ if (!is.null(work_piece[['progress_amount']])) { cat("\n") } - cat(paste0("! Warning: the dataset with index ", + .warning(paste0("The dataset with index ", tail(work_piece[['indices']], 1), " in '", work_piece[['dataset_type']], "' doesn't start at longitude 0 and will be re-interpolated in order to align its longitudes with the standard CDO grids definable with the names 'tgrid' or 'rx', which are by definition starting at the longitude 0.\n")) if (!is.null(mask)) { - cat(paste0("! Warning: a mask was provided for the dataset with index ", + .warning(paste0("A mask was provided for the dataset with index ", tail(work_piece[['indices']], 1), " in '", work_piece[['dataset_type']], "'. This dataset has been re-interpolated to align its longitudes to start at 0. You must re-interpolate the corresponding mask to align its longitudes to start at 0 as well, if you haven't done so yet. Running cdo remapcon,", common_grid_name, " original_mask_file.nc new_mask_file.nc will fix it.\n")) } @@ -363,7 +363,7 @@ cat("\n") } if (!explore_dims) { - cat(paste0("! Warning: the dataset with index ", tail(work_piece[['indices']], 1), + .warning(paste0("The dataset with index ", tail(work_piece[['indices']], 1), " in '", work_piece[['dataset_type']], "' is originally on ", "a grid coarser than the common grid and it has been ", "extrapolated. Check the results carefully. It is ", @@ -836,7 +836,7 @@ if (!all(dim_matches == sort(dim_matches))) { if (!found_disordered_dims && rev(work_piece[['indices']])[2] == 1 && rev(work_piece[['indices']])[3] == 1) { found_disordered_dims <- TRUE - cat(paste0("! Warning: the dimensions for the variable ", namevar, " in the files of the experiment with index ", tail(work_piece[['indices']], 1), " are not in the optimal order for loading with Load(). The optimal order would be '", paste(expected_dims, collapse = ', '), "'. One of the files of the dataset is stored in ", filename)) + .warning(paste0("The dimensions for the variable ", namevar, " in the files of the experiment with index ", tail(work_piece[['indices']], 1), " are not in the optimal order for loading with Load(). The optimal order would be '", paste(expected_dims, collapse = ', '), "'. One of the files of the dataset is stored in ", filename)) } tmp <- aperm(tmp, dim_matches) } @@ -879,13 +879,13 @@ } if (output == 'areave' || output == 'lon') { - weights <- InsertDim(cos(final_lats * pi / 180), 1, length(final_lons)) + weights <- InsertDim(cos(final_lats * pi / 180), 1, length(final_lons), name = 'lon') weights[which(is.na(x))] <- NA if (output == 'areave') { weights <- weights / mean(weights, na.rm = TRUE) mean(x * weights, na.rm = TRUE) } else { - weights <- weights / InsertDim(MeanDims(weights, 2, na.rm = TRUE), 2, length(final_lats)) + weights <- weights / InsertDim(MeanDims(weights, 2, na.rm = TRUE), 2, length(final_lats), name = 'lat') MeanDims(x * weights, 2, na.rm = TRUE) } } else if (output == 'lat') { diff --git a/tests/testthat/test-Load.R b/tests/testthat/test-Load.R new file mode 100644 index 0000000000000000000000000000000000000000..826613920b57c4306db09918997185a524f85414 --- /dev/null +++ b/tests/testthat/test-Load.R @@ -0,0 +1,182 @@ +context("s2dv::Load tests") + +############################################## + +test_that("1-1.", { + +path <- "/esarchive/exp/meteofrance/system6c3s/$STORE_FREQ$_mean/$VAR_NAME$_f6h/$VAR_NAME$_$START_DATE$.nc" +dateseq <- c("19930501", "19940501", "19950501") +suppressWarnings( +res1 <- Load(var = 'sfcWind', + exp = list(list(name = 'meteofrance/system6c3s', path = path)), + obs = 'erainterim', + sdates = dateseq, leadtimemin = 2, leadtimemax = 3, + lonmin = -9, lonmax = 1.5, latmin = 75, latmax = 79.5, + storefreq = "daily", sampleperiod = 1, nmember = 3, + output = "lonlat", method = "bilinear", + grid = "r360x180", nprocs = 1) +) +#suppressWarnings( +#res2 <- Load(var = 'sfcWind', +# exp = list(list(name = 'meteofrance/system6c3s', path = path)), +# obs = 'erainterim', +# sdates = dateseq, leadtimemin = 2, leadtimemax = 3, +# lonmin = -9, lonmax = 1.5, latmin = 75, latmax = 79.5, +# storefreq = "daily", sampleperiod = 1, nmember = 3, +# output = "lonlat", method = "bilinear", +# grid = "r360x180") +#) +#expect_equal( +#res1$mod, res2$mod +#) +#expect_equal( +#res1$obs, res2$obs +#) +#expect_equal( +#names(res1), names(res2) +#) +expect_equal( +dim(res1$mod), +c(dataset = 1, member = 3, sdate = 3, ftime = 2, lat = 5, lon = 11) +) +expect_equal( +dim(res1$obs), +c(dataset = 1, member = 1, sdate = 3, ftime = 2, lat = 5, lon = 11) +) +expect_equal( +as.vector(drop(res1$mod)[1, , 2, 3, 4]), +c(2.0504, 2.2746, 3.4189), +tolerance = 0.0001 +) +expect_equal( +as.vector(drop(res1$obs)[, 2, 3, 4]), +c(5.9923, 2.7927, 2.5408), +tolerance = 0.0001 +) +expect_equal( +mean(res1$mod, na.rm = T), +6.007487, +tolerance = 0.0001 +) +expect_equal( +mean(res1$obs, na.rm = T), +5.043017, +tolerance = 0.0001 +) + +}) + + +test_that("1-2.", { + +path <- "/esarchive/exp/meteofrance/system6c3s/$STORE_FREQ$_mean/$VAR_NAME$_f6h/$VAR_NAME$_$START_DATE$.nc" +dateseq <- c("19930501", "19940501", "19950501") +suppressWarnings( +res1 <- Load(var = 'sfcWind', + exp = list(list(name = 'meteofrance/system6c3s', path = path)), + obs = 'erainterim', + sdates = dateseq, leadtimemin = 2, leadtimemax = 3, + lonmin = -9, lonmax = 1.5, latmin = 75, latmax = 79.5, + storefreq = "daily", sampleperiod = 1, nmember = 3, + output = "areave", + nprocs = 1) +) +#suppressWarnings( +#res2 <- Load(var = 'sfcWind', +# exp = list(list(name = 'meteofrance/system6c3s', path = path)), +# obs = 'erainterim', +# sdates = dateseq, leadtimemin = 2, leadtimemax = 3, +# lonmin = -9, lonmax = 1.5, latmin = 75, latmax = 79.5, +# storefreq = "daily", sampleperiod = 1, nmember = 3, +# output = "areave") +#) +#expect_equal( +#res1$mod, res2$mod +#) +#expect_equal( +#res1$obs, res2$obs +#) +#expect_equal( +#names(res1), names(res2) +#) +expect_equal( +dim(res1$mod), +c(dataset = 1, member = 3, sdate = 3, ftime = 2) +) +expect_equal( +dim(res1$obs), +c(dataset = 1, member = 1, sdate = 3, ftime = 2) +) +expect_equal( +as.vector(drop(res1$mod)[1, , 2]), +c(5.037364, 2.395024, 5.418090), +tolerance = 0.0001 +) +expect_equal( +as.vector(drop(res1$obs)[, 2]), +c(8.728424, 2.931754, 3.918583), +tolerance = 0.0001 +) +expect_equal( +mean(res1$mod, na.rm = T), +6.162087, +tolerance = 0.0001 +) +expect_equal( +mean(res1$obs, na.rm = T), +5.178091, +tolerance = 0.0001 +) + +}) + + +test_that("1-3.", { + + ecearth <- list(name = 'm04o', + path = file.path('/esarchive/exp/ecearth', + '/$EXP_NAME$/monthly_mean', + '/$VAR_NAME$_f6h/$VAR_NAME$_$START_DATE$.nc')) + + ecmwf <- list(name = 'system5c3s', + path = file.path('/esarchive/exp/ecmwf', + '/$EXP_NAME$/monthly_mean', + '/$VAR_NAME$_f6h/$VAR_NAME$_$START_DATE$.nc')) + + era5 <- list(name = 'era5', + path = file.path('/esarchive/recon/ecmwf', + '$OBS_NAME$/monthly_mean', + '$VAR_NAME$_f1h/$VAR_NAME$_$YEAR$$MONTH$.nc')) + + startDates <- format(seq(as.POSIXct('1999-01-01'), as.POSIXct('1999-12-01'), by = 'months'), '%Y%m%d') + time_length <- 2 + +suppressWarnings( + data <- Load(var = 'psl', + exp = list(ecearth, ecmwf), + obs = list(era5), + sdates = startDates, + storefreq = "monthly", + leadtimemax = time_length, + output = 'lonlat', + lonmin = -2, lonmax = 2, + latmin = -5, latmax = 5, + nprocs = 1) +) + +expect_equal( +dim(data$mod), +c(dataset = 2, member = 10, sdate = 12, ftime = 2, lat = 14, lon = 5) +) +expect_equal( +dim(data$obs), +c(dataset = 1, member = 1, sdate = 12, ftime = 2, lat = 14, lon = 5) +) +expect_equal( +as.vector(data$mod[1, 1, , 2, 2, 3]), +c(rep(NA, 4), 101250, rep(NA, 5), 100940, NA), +tolerance = 0.0001 +) + + +})