Commit 3392a8c7 authored by Nicolau Manubens's avatar Nicolau Manubens
Browse files

Margin indices, extra info and attributes propagated correctly to atomic function.

parent 1a7ed156
Pipeline #900 canceled with stage
......@@ -571,7 +571,10 @@ Apply <- function(data, target_dims = NULL, fun, ...,
attributes_to_send[[i]])
}
assign('.margin_indices', as.list(first_marg_indices), envir = fun_env)
assign(".margin_indices",
setNames(as.integer(first_marg_indices),
names(first_marg_indices)),
envir = fun_env)
# SPLATTED_F
result <- splatted_f(iteration_input, ...)
......
# Function to permute arrays of non-atomic elements (e.g. POSIXct)
.aperm2 <- function(x, new_order) {
old_dims <- dim(x)
attr_bk <- attributes(x)
if ('dim' %in% names(attr_bk)) {
attr_bk[['dim']] <- NULL
}
if (is.numeric(x)) {
x <- aperm(x, new_order)
} else {
......@@ -9,5 +13,6 @@
x <- x[as.vector(y)]
}
dim(x) <- old_dims[new_order]
attributes(x) <- c(attributes(x), attr_bk)
x
}
......@@ -1260,27 +1260,43 @@ test_that("Margin indices and extra info are provided correctly.", {
a <- array(1:prod(1:6), dim = c(a = 1, b = 2, c = 3, d = 4, e = 5, f = 6))
b <- array(1:prod(c(1, 2, 3, 5, 6)), dim = c(a = 1, b = 2, c = 3, e = 5, f = 6))
x <- NULL
y <- NULL
z <- NULL
attr(a, 'test_attr_a') <- 'test_a'
attr(b, 'test_attr_b') <- list(x = 1, z = 2)
f <- function(a, b) {
if (all(.margin_indices == 1)) {
x <<- .margin_indices
}
y <<- .margin_indices
z <<- .test_info
stopifnot(length(.margin_indices) == 3)
stopifnot(identical(names(.margin_indices), c('a', 'e', 'f')))
stopifnot(all(is.integer(.margin_indices)))
stopifnot(identical(.test_info, 'test'))
stopifnot(!is.null(attr(a, 'test_attr_a')))
stopifnot(identical(attr(a, 'test_attr_a'), 'test_a'))
stopifnot(!is.null(attr(b, 'test_attr_b')))
stopifnot(identical(attr(b, 'test_attr_b'), list(x = 1, z = 2)))
}
r <- multiApply::Apply(list(a, b),
list(c('b', 'c', 'd'),
c('b', 'c')),
extra_info = list(test_info = 'test'),
use_attributes = list(a = 'test_attr_a',
b = 'test_attr_b'),
f)
expect_equal(x, list(a = 1, e = 1, f = 1))
expect_equal(y, list(a = 1, e = 5, f = 6))
expect_equal(z, 'test')
r <- multiApply::Apply(list(a = a, b = b),
list(c('b', 'c', 'd'),
c('b', 'c')),
extra_info = list(test_info = 'test'),
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')),
extra_info = list(test_info = 'test'),
use_attributes = list(b = 'test_attr_b',
a = 'test_attr_a'),
f)
})
# Test .aperm2
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment