diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index a7d3f8954fc859541b2ce5e564804bf6b7624848..050032ee92013d96f52eb851c09600443a00233a 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()' diff --git a/R/Apply.R b/R/Apply.R index bbd71ae426f9973c3ea77ea4f2a0c214a5f4d4ce..ecbdfd93db0aaea17a4946b672ead9f84f6c44a8 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 0000000000000000000000000000000000000000..8f1470cdde98822b6ddc1c98a7642ba65b990674 --- /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) +) + +}) + diff --git a/tests/testthat/test-use-cases.R b/tests/testthat/test-use-cases.R index 169366cc57127e4efc4b660da272ec697c5b7ef7..349fbe6880e79be3e04ae64a3bcdd03294ba8959 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')),