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
83
84
85
86
87
88
89
90
91
|
#' Transpose a 'listenv' array by permuting its dimensions
#'
#' @param a,x (listenv) The list environment to be transposed
#'
#' @param perm (integer vector) An index vector of length `dim(a)`
#'
#' @param \ldots Additional arguments passed to [base::aperm()].
#'
#' @return Returns a list environment with permuted dimensions
#'
#' @seealso
#' These functions works like [base::aperm()] and [base::t()].
#'
#' @examples
#' x <- as.listenv(1:6)
#' dim(x) <- c(2, 3)
#' dimnames(x) <- list(letters[1:2], LETTERS[1:3])
#' print(x)
#'
#' x <- t(x)
#' print(x)
#'
#' x <- aperm(x, perm = 2:1)
#' print(x)
#'
#' @aliases t.listenv
#' @export
aperm.listenv <- function(a, perm, ...) {
dim <- dim(a)
if (is.null(dim)) {
stop("Argument 'a' must be a matrix or an array")
}
ndim <- length(dim)
if (length(perm) != ndim) {
stopf("Length of argument 'perm' does not match the dimension of 'a': %s != %s", length(perm), ndim)
}
if (any(perm < 1 | perm > ndim)) {
stop("Argument 'perm' specified dimensions out of range")
}
if (anyDuplicated(perm) > 0L) {
stop("Argument 'perm' must not contain duplicates")
}
## Nothing to do?
if (all(perm == seq_len(ndim))) return(a)
## Remap
idxs <- seq_len(prod(dim))
dim(idxs) <- dim
dimnames(idxs) <- dimnames(a)
idxs <- aperm(idxs, perm = perm, ...)
map <- mapping(a)
map <- map[idxs]
mapping(a) <- map
map <- NULL
attr(a, "dim.") <- dim(idxs)
attr(a, "dimnames.") <- dimnames(idxs)
idxs <- NULL
a
}
#' @rdname aperm.listenv
#' @export
t.listenv <- function(x) {
dim <- attr(x, "dim.")
ndim <- length(dim)
if (ndim == 0L) {
attr(x, "dim.") <- c(1L, length(x))
attr(x, "dimnames.") <- list(NULL, names(x))
} else if (ndim == 1L) {
attr(x, "dim.") <- c(1L, dim)
attr(x, "dimnames.") <- list(NULL, attr(x, "dimnames.")[[1]])
} else if (ndim == 2L) {
dim <- rev(dim)
idxs <- matrix(seq_len(prod(dim)), nrow = dim[1], ncol = dim[2], byrow = TRUE)
map <- mapping(x)
map <- map[idxs]
mapping(x) <- map
map <- NULL
attr(x, "dim.") <- dim
attr(x, "dimnames.") <- rev(attr(x, "dimnames."))
} else {
stop("Argument 'x' is not a matrix")
}
x
}
|
