Commit 92f6163a authored by Nicolau Manubens's avatar Nicolau Manubens
Browse files

Possible to send sub-attributes.

parent db226385
Pipeline #903 failed with stage
......@@ -335,10 +335,37 @@ Apply <- function(data, target_dims = NULL, fun, ...,
use_attributes <- vector('list', length = length(data))
}
for (i in 1:length(data)) {
if (any(!(use_attributes[[i]] %in% names(attributes(data[[i]]))))) {
stop("Parameter 'use_attributes' contains some attribute names ",
"that are not present in the attributes of the corresponding ",
"object in parameter 'data'.")
if (is.character(use_attributes[[i]])) {
use_attributes[[i]] <- as.list(use_attributes[[i]])
}
if (is.list(use_attributes[[i]])) {
if (length(use_attributes[[i]]) == 0) {
use_attributes[i] <- list(NULL)
} else {
if (!all(sapply(use_attributes[[i]],
function(x) all(is.character(x) & nchar(x) > 0)))) {
stop("All entries in 'use_attributes' must be character strings ",
"of length > 0.")
}
}
} else if (!is.null(use_attributes[[i]])) {
stop("Parameter 'use_attributes' must be a list of character vectors or ",
"a list of lists of character vectors.")
}
for (j in seq_along(use_attributes[[i]])) {
if (length(use_attributes[[i]][[j]]) == 1 &&
use_attributes[[i]][[j]] == 'dim') {
stop("Requesting the attribute 'dim' via the parameter ",
"'use_attributes' is forbidden.")
}
found_entry <- FALSE
entry <- try({`[[`(attributes(data[[i]]),
use_attributes[[i]][[j]])}, silent = TRUE)
if ('try-error' %in% class(entry)) {
stop("Parameter 'use_attributes' contains some attribute names ",
"that are not present in the attributes of the corresponding ",
"object in parameter 'data'.")
}
}
}
......@@ -519,11 +546,22 @@ Apply <- function(data, target_dims = NULL, fun, ...,
iteration_indices_to_take[[i]] <- as.list(rep(TRUE, length(dim(data[[i]]))))
names(iteration_indices_to_take[[i]]) <- names(dim(data[[i]]))
if (length(use_attributes[[i]]) > 0) {
attributes_to_send[[i]] <- attributes(data[[i]])
if ('dim' %in% names(attributes_to_send[[i]])) {
attributes_to_send[[i]][['dim']] <- NULL
attributes_to_send[[i]] <- list()
for (j in seq_along(use_attributes[[i]])) {
found_entry <- FALSE
entry <- try({`[[`(attributes(data[[i]]),
use_attributes[[i]][[j]])
}, silent = TRUE)
if ('try-error' %in% class(entry)) {
stop("Unexpected error with the attributes of the inputs.")
}
save_string <- "attributes_to_send[[i]]"
access_string <- "`[[`(attributes(data[[i]]), use_attributes[[i]][[j]])"
for (k in seq_along(use_attributes[[i]][[j]])) {
save_string <- paste0(save_string, '$', use_attributes[[i]][[j]][[k]])
}
eval(parse(text = paste(save_string, '<-', access_string)))
}
attributes_to_send[[i]] <- attributes_to_send[[i]][use_attributes[[i]]]
}
}
......
......@@ -1297,6 +1297,36 @@ test_that("Margin indices and extra info are provided correctly.", {
use_attributes = list(b = 'test_attr_b',
a = 'test_attr_a'),
f)
attr(b, 'test_attr_b') <- list(x = 1, z = 2)
attr(b, 'z') <- 3
f <- function(a, b) {
stopifnot(identical(attr(b, 'test_attr_b')$z, 2))
stopifnot(identical(attr(b, 'z'), 3))
}
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 = c('test_attr_b', 'z'),
a = 'test_attr_a'),
f)
f <- function(a, b) {
stopifnot(identical(attr(b, 'test_attr_b')$z, 2))
stopifnot(is.null(attr(b, 'test_attr_b')$x))
stopifnot(is.null(attr(b, 'z')))
}
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 = list(c('test_attr_b', 'z')),
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