From 424895e6bffd8c4522f81004bc4537d6cd22c32d Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 29 Nov 2022 18:46:06 +0100 Subject: [PATCH 1/3] suppressWarnings --- tests/testthat/test-use-cases.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-use-cases.R b/tests/testthat/test-use-cases.R index 169366c..349fbe6 100644 --- a/tests/testthat/test-use-cases.R +++ b/tests/testthat/test-use-cases.R @@ -800,9 +800,11 @@ test_that("in1: 2 dim; in2: 1 dim; targ. dims: 0-2, 0-1; out1: 1 dim; out2: 1 va "Guessed names for some unnamed dimensions" ) expect_equal( + suppressWarnings( Apply(list(array(1:10, dim = c(10, 3)), array(1:3 * 10, dim = c(3))), - NULL, f), + NULL, f) + ), list(output1 = array(sapply(c(10, 20, 30), function(x) { x + rep(sapply(1:10, function(y) { y:(y + 3) @@ -1274,6 +1276,7 @@ test_that("Margin indices and extra info are provided correctly.", { stopifnot(identical(attr(b, 'test_attr_b'), list(x = 1, z = 2))) } +suppressWarnings({ r <- multiApply::Apply(list(a, b), list(c('b', 'c', 'd'), c('b', 'c')), @@ -1281,7 +1284,7 @@ test_that("Margin indices and extra info are provided correctly.", { use_attributes = list(a = 'test_attr_a', b = 'test_attr_b'), f) - +}) r <- multiApply::Apply(list(a = a, b = b), list(c('b', 'c', 'd'), c('b', 'c')), -- GitLab From 3b93cbbfb4e3144a6d568eb4e7618b6ae050a966 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 29 Nov 2022 18:46:40 +0100 Subject: [PATCH 2/3] Return errors when results don't share the same dimension length --- R/Apply.R | 34 ++++ .../test-inconsistent_output_length.R | 159 ++++++++++++++++++ 2 files changed, 193 insertions(+) create mode 100644 tests/testthat/test-inconsistent_output_length.R diff --git a/R/Apply.R b/R/Apply.R index bbd71ae..ecbdfd9 100644 --- a/R/Apply.R +++ b/R/Apply.R @@ -666,6 +666,25 @@ Apply <- function(data, target_dims = NULL, fun, ..., if (!is.null(component_dims)) { atomic_fun_out_dims[[component]] <- component_dims } + + # Check if component_dims matches the first_sub_result + if (found_first_sub_result) { + error_inconsistent_output <- FALSE + if (is.null(atomic_fun_out_dims[[component]])) { # result[[component]] is a number + if (length(dim(sub_arrays_of_results[[component]])) != 1) { + error_inconsistent_output <- TRUE + } + } else if (!identical(atomic_fun_out_dims[[component]], + head(dim(sub_arrays_of_results[[component]]), + length(dim(sub_arrays_of_results[[component]])) - 1))) { + #NOTE: The last dim in sub_arrays_of_results[[component]] is chunk_sizes[m] + error_inconsistent_output <- TRUE + } + if (error_inconsistent_output) { + stop("Output '", names(sub_arrays_of_results)[[component]], "' doesn't have consistent output length among chunks.") + } + } + if (length(result[[component]]) > 0) { sub_arrays_of_results[[component]][(1:prod(component_dims)) + (n - 1) * prod(component_dims)] <- result[[component]] @@ -697,6 +716,21 @@ Apply <- function(data, target_dims = NULL, fun, ..., parallel <- ncores > 1 if (parallel) registerDoParallel(ncores) result <- llply(1:length(chunk_sizes), iteration, .parallel = parallel) + + # Check if all the results have the same output length + for (i_output in 1:sapply(result, length)[1]) { + result_i_output <- lapply(result, '[[', i_output) + dims_each_result <- lapply(result_i_output, dim) + tmp <- lapply(dims_each_result, length) + dims_each_result_without_chunk <- lapply(1:length(dims_each_result), function(ii) { + head(dims_each_result[[ii]], tmp[[ii]] - 1) + }) + + if (length(unique(dims_each_result_without_chunk)) != 1) { + stop("Output '", names(result[[1]])[i_output], "' doesn't have consistent output length among chunks.") + } + } + if (parallel) registerDoSEQ() # Merge the results arrays_of_results <- NULL diff --git a/tests/testthat/test-inconsistent_output_length.R b/tests/testthat/test-inconsistent_output_length.R new file mode 100644 index 0000000..8f1470c --- /dev/null +++ b/tests/testthat/test-inconsistent_output_length.R @@ -0,0 +1,159 @@ +context("Inconsistent output length") + +test_that("dat1", { + +dat1 <- array(1:60, dim = c(time = 5, sdate = 2, member = 6)) + +func1 <- function(x) { + res <- if (ii %% 2 == 0) {x} else {x[1:2, ]} + ii <<- ii + 1 + return(list(res, x)) +} + +ii <- 1 +expect_error( +Apply(dat1, fun = func1, target_dims = c("time", "sdate")), +"Output 'output1' doesn't have consistent output length among chunks." +) +#--------------------------- + +func2 <- function(x) { + res <- if (ii %% 2 == 0) {x} else {x[1, ]} + ii <<- ii + 1 + return(list(out1 = res, out2 = x)) +} +ii <- 2 +expect_error( +Apply(dat1, fun = func2, target_dims = c("time", "sdate")), +"Output 'out1' doesn't have consistent output length among chunks." +) +#--------------------------- + +func3 <- function(x) { + res <- x[1, ] + return(list(res, x)) +} +res <- Apply(dat1, fun = func3, target_dims = c("time", "sdate")) +expect_equal( +dim(res[[1]]), +c(2, member = 6) +) +expect_equal( +dim(res[[2]]), +c(time = 5, sdate = 2, member = 6) +) +#-------------------------------- + +}) + + +test_that("dat2", { + +dat2 <- array(1:60, dim = c(time = 5, member = 7)) + +func1 <- function(x) { + res <- if (ii %% 2 == 0) {x} else {x[1:2]} + ii <<- ii + 1 + return(list(res)) +} + +ii <- 1 +expect_error( +Apply(dat2, fun = func1, target_dims = c("time")), +"Output 'output1' doesn't have consistent output length among chunks." +) +#--------------------------- + + +func2 <- function(x) { + res <- if (ii %% 2 == 0) {x} else {x[1]} + ii <<- ii + 1 + return(list(out1 = res, out2 = x)) +} +ii <- 1 +expect_error( +Apply(dat2, fun = func2, target_dims = c("time")), +"Output 'out1' doesn't have consistent output length among chunks." +) +#--------------------------- + +func3 <- function(x) { + res <- x[1] + return(list(res, x)) +} +res <- Apply(dat2, fun = func3, target_dims = c("time")) +expect_equal( +dim(res[[1]]), +c(member = 7) +) +expect_equal( +dim(res[[2]]), +c(time = 5, member = 7) +) +expect_equal( +as.vector(res[[1]]), +seq(1, 31, by = 5) +) +expect_equal( +res[[2]], +dat2 +) +#-------------------------------- + +}) + + +test_that("dat3", { + +dat3 <- array(1:15, dim = c(time = 5, member = 3)) + +func2 <- function(x) { + res <- if (ii %% 2 == 0) {x} else {as.vector(x[1])} + ii <<- ii + 1 + return(list(out1 = res)) +} +ii <- 1 +expect_error( +Apply(dat3, fun = func2, target_dims = c("time")), +"Output 'out1' doesn't have consistent output length among chunks." +) +ii <- 2 +expect_error( +Apply(dat3, fun = func2, target_dims = c("time")), +"Output 'out1' doesn't have consistent output length among chunks." +) +#--------------------------- + +func3 <- function(x) { + res <- as.vector(x[1:2]) + return(list(res)) +} +res <- Apply(dat3, fun = func3, target_dims = "time") + +expect_equal( +dim(res[[1]]), +c(2, member = 3) +) +expect_equal( +as.vector(res[[1]]), +c(1, 2, 6, 7, 11, 12) +) +#------------------------- + +func4 <- function(x) { + res <- x[1:2] + return(list(res)) +} +res <- Apply(dat3, fun = func4, target_dims = "time") + +expect_equal( +dim(res[[1]]), +c(time = 2, member = 3) +) +expect_equal( +as.vector(res[[1]]), +c(1, 2, 6, 7, 11, 12) +) + +}) + -- GitLab From 5d5b855957342fc55ce1c181304360390d20b737 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 29 Nov 2022 18:51:45 +0100 Subject: [PATCH 3/3] Update R module --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index a7d3f89..050032e 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -4,7 +4,7 @@ stages: build: stage: build script: - - module load R + - module load R/4.1.2-foss-2015a-bare - R CMD build --resave-data . - R CMD check --as-cran multiApply_*.tar.gz - R -e 'covr::package_coverage()' -- GitLab