Skip to content
GitLab
Commit e2e00550 authored by nperez's avatar nperez
Browse files

Version already installed in R3.2.0

parent 43be5d16
Pipeline #2024 passed with stage
in 1 minute and 14 seconds
Hide whitespace changes
Inline Side-by-side
R/Apply.R
View file @ e2e00550
......@@ -33,735 +33,690 @@
#' @importFrom plyr splat llply
#' @importFrom utils capture.output
#' @importFrom stats setNames
Apply <- function(data, target_dims = NULL, fun, ...,
output_dims = NULL, margins = NULL,
use_attributes = NULL, extra_info = NULL,
guess_dim_names = TRUE,
ncores = NULL, split_factor = 1) {
# Check data
if (!is.list(data)) {
data <- list(data)
}
#if (any(!sapply(data, is.numeric))) {
# stop("Parameter 'data' must be one or a list of numeric objects.")
#}
is_vector <- rep(FALSE, length(data))
is_unnamed <- rep(FALSE, length(data))
unnamed_dims <- c()
guessed_any_dimnames <- FALSE
for (i in 1 : length(data)) {
if (length(data[[i]]) < 1) {
stop("Arrays in 'data' must be of length > 0.")
}
if (is.null(dim(data[[i]]))) {
is_vector[i] <- TRUE
is_unnamed[i] <- TRUE
dim(data[[i]]) <- length(data[[i]])
}
if (!is.null(names(dim(data[[i]])))) {
if (any(sapply(names(dim(data[[i]])), nchar) == 0)) {
stop("Dimension names of arrays in 'data' must be at least ",
"one character long.")
}
if (length(unique(names(dim(data[[i]])))) != length(names(dim(data[[i]])))) {
stop("Arrays in 'data' must not have repeated dimension names.")
}
if (any(is.na(names(dim(data[[i]]))))) {
stop("Arrays in 'data' must not have NA as dimension names.")
}
} else {
is_unnamed[i] <- TRUE
new_unnamed_dims <- c()
unnamed_dims_copy <- unnamed_dims
for (j in 1 : length(dim(data[[i]]))) {
len_of_dim_j <- dim(data[[i]])[j]
found_match <- which(unnamed_dims_copy == len_of_dim_j)
if (!guess_dim_names && (length(found_match) > 0)) {
stop("Arrays in 'data' have multiple unnamed dimensions of the ",
"same length. Please provide dimension names.")
}
if (length(found_match) > 0) {
found_match <- found_match[1]
names(dim(data[[i]]))[j] <- names(unnamed_dims_copy[found_match])
unnamed_dims_copy <- unnamed_dims_copy[-found_match]
guessed_any_dimnames <- TRUE
} else {
new_dim <- len_of_dim_j
names(new_dim) <- paste0('_unnamed_dim_', length(unnamed_dims) +
length(new_unnamed_dims) + 1, '_')
new_unnamed_dims <- c(new_unnamed_dims, new_dim)
names(dim(data[[i]]))[j] <- names(new_dim)
}
}
unnamed_dims <- c(unnamed_dims, new_unnamed_dims)
}
}
if (guessed_any_dimnames) {
dim_names_string <- ""
Apply <- function (data, target_dims = NULL, fun, ..., output_dims = NULL,
margins = NULL, use_attributes = NULL, extra_info = NULL,
guess_dim_names = TRUE, ncores = NULL, split_factor = 1)
{
if (!is.list(data)) {
data <- list(data)
}
is_vector <- rep(FALSE, length(data))
is_unnamed <- rep(FALSE, length(data))
unnamed_dims <- c()
guessed_any_dimnames <- FALSE
for (i in 1:length(data)) {
dim_names_string <- c(dim_names_string, "\n\tInput ", i, ":",
sapply(capture.output(print(dim(data[[i]]))),
function(x) paste0('\n\t\t', x)))
}
warning("Guessed names for some unnamed dimensions of equal length ",
"found across different inputs in 'data'. Please check ",
"carefully the assumed names below are correct, or provide ",
"dimension names for safety, or disable the parameter ",
if (length(data[[i]]) < 1) {
stop("Arrays in 'data' must be of length > 0.")
}
if (is.null(dim(data[[i]]))) {
is_vector[i] <- TRUE
is_unnamed[i] <- TRUE
dim(data[[i]]) <- length(data[[i]])
}
if (!is.null(names(dim(data[[i]])))) {
if (any(sapply(names(dim(data[[i]])), nchar) == 0)) {
stop("Dimension names of arrays in 'data' must be at least ",
"one character long.")
}
if (length(unique(names(dim(data[[i]])))) != length(names(dim(data[[i]])))) {
stop("Arrays in 'data' must not have repeated dimension names.")
}
if (any(is.na(names(dim(data[[i]]))))) {
stop("Arrays in 'data' must not have NA as dimension names.")
}
}
else {
is_unnamed[i] <- TRUE
new_unnamed_dims <- c()
unnamed_dims_copy <- unnamed_dims
for (j in 1:length(dim(data[[i]]))) {
len_of_dim_j <- dim(data[[i]])[j]
found_match <- which(unnamed_dims_copy == len_of_dim_j)
if (!guess_dim_names && (length(found_match) >
0)) {
stop("Arrays in 'data' have multiple unnamed dimensions of the ",
"same length. Please provide dimension names.")
}
if (length(found_match) > 0) {
found_match <- found_match[1]
names(dim(data[[i]]))[j] <- names(unnamed_dims_copy[found_match])
unnamed_dims_copy <- unnamed_dims_copy[-found_match]
guessed_any_dimnames <- TRUE
}
else {
new_dim <- len_of_dim_j
names(new_dim) <- paste0("_unnamed_dim_", length(unnamed_dims) +
length(new_unnamed_dims) + 1, "_")
new_unnamed_dims <- c(new_unnamed_dims, new_dim)
names(dim(data[[i]]))[j] <- names(new_dim)
}
}
unnamed_dims <- c(unnamed_dims, new_unnamed_dims)
}
}
if (guessed_any_dimnames) {
dim_names_string <- ""
for (i in 1:length(data)) {
dim_names_string <- c(dim_names_string, "\n\tInput ",
i, ":", sapply(capture.output(print(dim(data[[i]]))),
function(x) paste0("\n\t\t", x)))
}
warning("Guessed names for some unnamed dimensions of equal length ",
"found across different inputs in 'data'. Please check ",
"carefully the assumed names below are correct, or provide ",
"dimension names for safety, or disable the parameter ",
"'guess_dim_names'.", dim_names_string)
}
# Check fun
if (is.character(fun)) {
fun_name <- fun
err <- try({
fun <- get(fun)
}, silent = TRUE)
}
if (is.character(fun)) {
fun_name <- fun
err <- try({
fun <- get(fun)
}, silent = TRUE)
if (!is.function(fun)) {
stop("Could not find the function '", fun_name, "'.")
}
}
if (!is.function(fun)) {
stop("Could not find the function '", fun_name, "'.")
}
}
if (!is.function(fun)) {
stop("Parameter 'fun' must be a function or a character string ",
"with the name of a function.")
}
if (!is.null(attributes(fun))) {
if (is.null(target_dims)) {
if ('target_dims' %in% names(attributes(fun))) {
target_dims <- attr(fun, 'target_dims')
}
}
if (is.null(output_dims)) {
if ('output_dims' %in% names(attributes(fun))) {
output_dims <- attr(fun, 'output_dims')
}
}
}
# Check target_dims and margins
arglist <- as.list(match.call())
if (!any(c('margins', 'target_dims') %in% names(arglist)) &&
is.null(target_dims)) {
stop("One of 'margins' or 'target_dims' must be specified.")
}
margins_names <- vector('list', length(data))
target_dims_names <- vector('list', length(data))
if ('margins' %in% names(arglist)) {
# Check margins and build target_dims accordingly
if (!is.list(margins)) {
margins <- rep(list(margins), length(data))
}
if (any(!sapply(margins,
function(x) is.character(x) || is.numeric(x) || is.null(x)))) {
stop("Parameter 'margins' must be one or a list of numeric or ",
"character vectors.")
}
if (any(sapply(margins, function(x) is.character(x) && (length(x) == 0)))) {
stop("Parameter 'margins' must not contain length-0 character vectors.")
}
duplicate_dim_specs <- sapply(margins,
function(x) {
length(unique(x)) != length(x)
})
if (any(duplicate_dim_specs)) {
stop("Parameter 'margins' must not contain duplicated dimension ",
"specifications.")
}
target_dims <- vector('list', length(data))
for (i in 1 : length(data)) {
if (length(margins[[i]]) > 0) {
if (is.character(unlist(margins[i]))) {
if (is.null(names(dim(data[[i]])))) {
stop("Parameter 'margins' contains dimension names, but ",
"some of the corresponding objects in 'data' do not have ",
"dimension names.")
}
margins2 <- margins[[i]]
margins2_new_num <- c()
for (j in 1 : length(margins2)) {
matches <- which(names(dim(data[[i]])) == margins2[j])
if (length(matches) < 1) {
stop("Could not find dimension '", margins2[j], "' in ", i,
"th object provided in 'data'.")
}
margins2_new_num[j] <- matches[1]
}
margins_names[[i]] <- margins[[i]]
margins[[i]] <- margins2_new_num
}
if (length(margins[[i]]) == length(dim(data[[i]]))) {
target_dims_names[i] <- list(NULL)
target_dims[i] <- list(NULL)
margins_names[[i]] <- names(dim(data[[i]]))
} else {
margins_names[[i]] <- names(dim(data[[i]]))[margins[[i]]]
target_dims_names[[i]] <- names(dim(data[[i]]))[- margins[[i]]]
target_dims[[i]] <- (1 : length(dim(data[[i]])))[- margins[[i]]]
}
} else {
target_dims[[i]] <- 1 : length(dim(data[[i]]))
if (!is.null(names(dim(data[[i]])))) {
target_dims_names[[i]] <- names(dim(data[[i]]))
}
}
}
} else {
# Check target_dims and build margins accordingly
if (!is.list(target_dims)) {
target_dims <- rep(list(target_dims), length(data))
}
if (any(!sapply(target_dims,
function(x) is.character(x) || is.numeric(x) || is.null(x)))) {
stop("Parameter 'target_dims' must be one or a list of numeric or ",
"character vectors.")
}
if (any(sapply(target_dims, function(x) is.character(x) && (length(x) == 0)))) {
stop("Parameter 'target_dims' must not contain length-0 character vectors.")
}
duplicate_dim_specs <- sapply(target_dims,
function(x) {
length(unique(x)) != length(x)
})
if (any(duplicate_dim_specs)) {
stop("Parameter 'target_dims' must not contain duplicated dimension ",
"specifications.")
}
margins <- vector('list', length(data))
for (i in 1 : length(data)) {
if (length(target_dims[[i]]) > 0) {
if (is.character(unlist(target_dims[i]))) {
if (is.null(names(dim(data[[i]])))) {
stop("Parameter 'target_dims' contains dimension names, but ",
"some of the corresponding objects in 'data' do not have ",
"dimension names.")
}
targs2 <- target_dims[[i]]
targs2_new_num <- c()
for (j in 1 : length(targs2)) {
matches <- which(names(dim(data[[i]])) == targs2[j])
if (length(matches) < 1) {
stop("Could not find dimension '", targs2[j], "' in ", i,
"th object provided in 'data'.")
}
targs2_new_num[j] <- matches[1]
}
target_dims_names[[i]] <- target_dims[[i]]
target_dims[[i]] <- targs2_new_num
}
if (length(target_dims[[i]]) == length(dim(data[[i]]))) {
margins_names[i] <- list(NULL)
margins[i] <- list(NULL)
target_dims_names[[i]] <- names(dim(data[[i]]))
} else {
target_dims_names[[i]] <- names(dim(data[[i]]))[target_dims[[i]]]
margins_names[[i]] <- names(dim(data[[i]]))[- target_dims[[i]]]
margins[[i]] <- (1 : length(dim(data[[i]])))[- target_dims[[i]]]
}
} else {
margins[[i]] <- 1 : length(dim(data[[i]]))
if (!is.null(names(dim(data[[i]])))) {
margins_names[[i]] <- names(dim(data[[i]]))
}
}
}
}
# Reorder dimensions of input data for target dims to be left-most
# and in the required order.
for (i in 1 : length(data)) {
if (length(target_dims[[i]]) > 0) {
if (is.unsorted(target_dims[[i]]) ||
(max(target_dims[[i]]) > length(target_dims[[i]]))) {
marg_dims <- (1 : length(dim(data[[i]])))[- target_dims[[i]]]
data[[i]] <- .aperm2(data[[i]], c(target_dims[[i]], marg_dims))
target_dims[[i]] <- 1 : length(target_dims[[i]])
target_dims_names[[i]] <- names(dim(data[[i]]))[target_dims[[i]]]
if (length(target_dims[[i]]) < length(dim(data[[i]]))) {
margins[[i]] <- (length(target_dims[[i]]) + 1) : length(dim(data[[i]]))
margins_names[[i]] <- names(dim(data[[i]]))[margins[[i]]]
}
}
}
}
# Check output_dims
if (!is.null(output_dims)) {
if (!is.list(output_dims)) {
output_dims <- list(output1 = output_dims)
stop("Parameter 'fun' must be a function or a character string ",
"with the name of a function.")
}
if (any(sapply(output_dims, function(x) !(is.character(x) || is.null(x))))) {
stop("Parameter 'output_dims' must be one or a list of vectors of character strings (or NULLs).")
if (!is.null(attributes(fun))) {
if (is.null(target_dims)) {
if ("target_dims" %in% names(attributes(fun))) {
target_dims <- attr(fun, "target_dims")
}
}
if (is.null(output_dims)) {
if ("output_dims" %in% names(attributes(fun))) {
output_dims <- attr(fun, "output_dims")
}
}
}
if (is.null(names(output_dims))) {
names(output_dims) <- rep('', length(output_dims))
arglist <- as.list(match.call())
if (!any(c("margins", "target_dims") %in% names(arglist)) &&
is.null(target_dims)) {
stop("One of 'margins' or 'target_dims' must be specified.")
}
missing_output_names <- which(sapply(names(output_dims), nchar) == 0)
if (length(missing_output_names) > 0) {
names(output_dims)[missing_output_names] <- paste0('output', missing_output_names)
margins_names <- vector("list", length(data))
target_dims_names <- vector("list", length(data))
if ("margins" %in% names(arglist)) {
if (!is.list(margins)) {
margins <- rep(list(margins), length(data))
}
if (any(!sapply(margins, function(x) is.character(x) ||
is.numeric(x) || is.null(x)))) {
stop("Parameter 'margins' must be one or a list of numeric or ",
"character vectors.")
}
if (any(sapply(margins, function(x) is.character(x) &&
(length(x) == 0)))) {
stop("Parameter 'margins' must not contain length-0 character vectors.")
}
duplicate_dim_specs <- sapply(margins, function(x) {
length(unique(x)) != length(x)
})
if (any(duplicate_dim_specs)) {
stop("Parameter 'margins' must not contain duplicated dimension ",
"specifications.")
}
target_dims <- vector("list", length(data))
for (i in 1:length(data)) {
if (length(margins[[i]]) > 0) {
if (is.character(unlist(margins[i]))) {
if (is.null(names(dim(data[[i]])))) {
stop("Parameter 'margins' contains dimension names, but ",
"some of the corresponding objects in 'data' do not have ",
"dimension names.")
}
margins2 <- margins[[i]]
margins2_new_num <- c()
for (j in 1:length(margins2)) {
matches <- which(names(dim(data[[i]])) ==
margins2[j])
if (length(matches) < 1) {
stop("Could not find dimension '", margins2[j],
"' in ", i, "th object provided in 'data'.")
}
margins2_new_num[j] <- matches[1]
}
margins_names[[i]] <- margins[[i]]
margins[[i]] <- margins2_new_num
}
if (length(margins[[i]]) == length(dim(data[[i]]))) {
target_dims_names[i] <- list(NULL)
target_dims[i] <- list(NULL)
margins_names[[i]] <- names(dim(data[[i]]))
}
else {
margins_names[[i]] <- names(dim(data[[i]]))[margins[[i]]]
target_dims_names[[i]] <- names(dim(data[[i]]))[-margins[[i]]]
target_dims[[i]] <- (1:length(dim(data[[i]])))[-margins[[i]]]
}
}
else {
target_dims[[i]] <- 1:length(dim(data[[i]]))
if (!is.null(names(dim(data[[i]])))) {
target_dims_names[[i]] <- names(dim(data[[i]]))
}
}
}
}
else {
if (!is.list(target_dims)) {
target_dims <- rep(list(target_dims), length(data))
}
if (any(!sapply(target_dims, function(x) is.character(x) ||
is.numeric(x) || is.null(x)))) {
stop("Parameter 'target_dims' must be one or a list of numeric or ",
"character vectors.")
}
if (any(sapply(target_dims, function(x) is.character(x) &&
(length(x) == 0)))) {
stop("Parameter 'target_dims' must not contain length-0 character vectors.")
}
duplicate_dim_specs <- sapply(target_dims, function(x) {
length(unique(x)) != length(x)
})
if (any(duplicate_dim_specs)) {
stop("Parameter 'target_dims' must not contain duplicated dimension ",
"specifications.")
}
margins <- vector("list", length(data))
for (i in 1:length(data)) {
if (length(target_dims[[i]]) > 0) {
if (is.character(unlist(target_dims[i]))) {
if (is.null(names(dim(data[[i]])))) {
stop("Parameter 'target_dims' contains dimension names, but ",
"some of the corresponding objects in 'data' do not have ",
"dimension names.")
}
targs2 <- target_dims[[i]]
targs2_new_num <- c()
for (j in 1:length(targs2)) {
matches <- which(names(dim(data[[i]])) ==
targs2[j])
if (length(matches) < 1) {
stop("Could not find dimension '", targs2[j],
"' in ", i, "th object provided in 'data'.")
}
targs2_new_num[j] <- matches[1]
}
target_dims_names[[i]] <- target_dims[[i]]
target_dims[[i]] <- targs2_new_num
}
if (length(target_dims[[i]]) == length(dim(data[[i]]))) {
margins_names[i] <- list(NULL)
margins[i] <- list(NULL)
target_dims_names[[i]] <- names(dim(data[[i]]))
}
else {
target_dims_names[[i]] <- names(dim(data[[i]]))[target_dims[[i]]]
margins_names[[i]] <- names(dim(data[[i]]))[-target_dims[[i]]]
margins[[i]] <- (1:length(dim(data[[i]])))[-target_dims[[i]]]
}
}
else {
margins[[i]] <- 1:length(dim(data[[i]]))
if (!is.null(names(dim(data[[i]])))) {
margins_names[[i]] <- names(dim(data[[i]]))
}
}
}
}
}
# Check use_attributes
if (!is.null(use_attributes)) {
if (!is.list(use_attributes)) {
stop("Parameter 'use_attributes' must be a list.")
}
if (is.null(names(data)) && !is.null(names(use_attributes))) {
warning("Parameter 'use_attributes' provided with names, but ",
"no names provided for 'data'. All names will be ",
"disregarded.")
names(use_attributes) <- NULL
}
if (!is.null(names(use_attributes))) {
if (!all(sapply(names(use_attributes), function(x) nchar(x) > 0))) {
stop("If providing names for the list 'use_attributes', all ",
"components must be named.")
}
if (length(unique(names(use_attributes))) !=
length(names(use_attributes))) {
stop("The list in parameter 'use_attributes' must not ",
"contain repeated names.")
}
if (any(!(names(use_attributes) %in% names(data)))) {
stop("Provided some names in parameter 'use_attributes' not present ",
"in parameter 'data'.")
}
use_attributes <- use_attributes[names(data)]
} else {
if (length(use_attributes) != length(data)) {
warning("Provided different number of items in 'use_attributes' ",
"and in 'data'. Assuming same order.")
}
use_attributes <- use_attributes[1:length(data)]
}
} else {
use_attributes <- vector('list', length = length(data))
}
for (i in 1:length(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'.")
}
}
}
# Check extra_info
if (is.null(extra_info)) {
extra_info <- list()
}
raise_error <- FALSE
if (!is.list(extra_info)) {
raise_error <- TRUE
} else if (length(extra_info) > 0) {
if (is.null(names(extra_info))) {
raise_error <- TRUE
}
if (any(sapply(names(extra_info), function(x) nchar(x) == 0))) {