Newer
Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
Subset <- function(x, along, indices, drop = FALSE) {
# Check x
if (!is.array(x)) {
stop("Input array 'x' must be a numeric array.")
}
# Take the input array dimension names
dim_names <- attr(x, 'dimensions')
if (!is.character(dim_names)) {
dim_names <- names(dim(x))
}
if (!is.character(dim_names)) {
if (any(sapply(along, is.character))) {
stop("The input array 'x' doesn't have labels for the dimensions but the parameter 'along' contains dimension names.")
}
}
# Check along
if (any(sapply(along, function(x) !is.numeric(x) && !is.character(x)))) {
stop("All provided dimension indices in 'along' must be integers or character strings.")
}
if (any(sapply(along, is.character))) {
req_dimnames <- along[which(sapply(along, is.character))]
if (length(unique(req_dimnames)) < length(req_dimnames)) {
stop("The parameter 'along' must not contain repeated dimension names.")
}
along[which(sapply(along, is.character))] <- match(req_dimnames, dim_names)
if (any(is.na(along))) {
stop("Could not match all dimension names in 'indices' with dimension names in input array 'x'.")
}
along <- as.numeric(along)
}
# Check indices
if (!is.list(indices)) {
indices <- list(indices)
}
# Check parameter drop
dims_to_drop <- c()
if (is.character(drop)) {
if (drop == 'all') {
drop <- TRUE
} else if (any(drop %in% c('selected', 'non-selected', 'none'))) {
if (drop == 'selected') {
dims_to_drop <- along[which(sapply(indices, length) == 1)]
} else if (drop == 'non-selected') {
dims_to_drop <- dim(x) == 1
dims_to_drop[along] <- FALSE
dims_to_drop <- which(dims_to_drop)
}
drop <- FALSE
} else {
stop("Parameter 'drop' must be one of TRUE, FALSE, 'all', 'selected', 'non-selected', 'none'.")
}
} else if (!is.logical(drop)) {
stop("Parameter 'drop' must be one of TRUE, FALSE, 'all', 'selected', 'non-selected', 'none'.")
}
# Take the subset
nd <- length(dim(x))
index <- as.list(rep(TRUE, nd))
index[along] <- indices
subset <- eval(as.call(c(as.name("["), as.name("x"), index, drop = drop)))
# If dropped all dimensions, need to drop dimnames too
if (is.character(dim_names) && drop == TRUE) {
dim_names_to_remove <- unique(c(along[which(sapply(indices, length) == 1)],
which(dim(x) == 1)))
if (length(dim_names_to_remove) > 0) {
dim_names <- dim_names[-dim_names_to_remove]
}
}
# Amend the final dimensions and put dimnames and attributes
metadata <- attributes(x)
metadata[['dim']] <- dim(subset)
if (length(dims_to_drop) > 0) {
metadata[['dim']] <- metadata[['dim']][-dims_to_drop]
if (is.character(dim_names)) {
names(metadata[['dim']]) <- dim_names[-dims_to_drop]
metadata[['dimensions']] <- dim_names[-dims_to_drop]
}
if (length(metadata[['dim']]) == 0) {
metadata['dim'] <- list(NULL)
metadata['dimensions'] <- list(NULL)
}
} else if (is.character(dim_names)) {
names(metadata[['dim']]) <- dim_names
metadata[['dimensions']] <- dim_names
}
attributes(subset) <- metadata
subset
}