THIS IS A TEST INSTANCE ONLY! REPOSITORIES CAN BE DELETED AT ANY TIME!

You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 

96 lines
2.2 KiB

#' Transpose a 'listenv' array by permuting its dimensions
#'
#' @usage
#' \method{aperm}{listenv}(a, perm, ...)
#'
#' \method{t}{listenv}(x)
#'
#' @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) {
stop("Length of argument 'perm' does not match the dimension of 'a': ", 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
#' @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
}