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

Browse Source

Add t() for list environments

fixes #22
feature/c
Henrik Bengtsson 3 months ago
parent
commit
9560e49eb0
  1. 1
      NAMESPACE
  2. 2
      NEWS
  3. 21
      R/aperm.R
  4. 58
      tests/aperm.R

1
NAMESPACE

@ -28,6 +28,7 @@ S3method(length,listenv)
S3method(lengths,listenv)
S3method(names,listenv)
S3method(print,listenv)
S3method(t,listenv)
S3method(undim,default)
S3method(undim,listenv)
S3method(unlist,listenv)

2
NEWS

@ -5,7 +5,7 @@ Version: 0.8.0-9000 [2021-02-14]
NEW FEATURES:
* Add aperm() for list-environment arrays.
* Add aperm() and t() for list-environment arrays.
* parse_env_subset() gained argument 'is_variable' to control whether or not
the inferred element named should be checked if it is a valid variable name

21
R/aperm.R

@ -50,3 +50,24 @@ aperm.listenv <- function(a, perm, ...) {
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) {
x <- aperm(x, perm = 2:1)
} else {
stop("Argument 'x' is not a matrix")
}
x
}

58
tests/aperm.R

@ -1,20 +1,50 @@
library("listenv")
message("*** aperm() ...")
message("*** aperm() and t() ...")
dim <- c(2, 3, 4)
dimnames <- lapply(dim, FUN = function(n) letters[seq_len(n)])
X_truth <- as.list(seq_len(prod(dim)))
dim(X_truth) <- dim
dimnames(X_truth) <- dimnames
X <- as.listenv(X_truth)
stopifnot(identical(as.list(X), X_truth))
for (ndim in 0:5) {
message("- Number of dimensions: ", ndim)
for (kk in 1:10) {
perm <- sample(seq_along(dim), replace = FALSE)
X_truth <- aperm(X_truth, perm = perm)
X <- aperm(X, perm = perm)
if (ndim == 0) {
n <- 3L
X_truth <- as.list(seq_len(n))
names(X_truth) <- letters[seq_len(n)]
} else {
dim <- seq_len(ndim) + 2L
dimnames <- lapply(dim, FUN = function(n) letters[seq_len(n)])
X_truth <- as.list(seq_len(prod(dim)))
dim(X_truth) <- dim
dimnames(X_truth) <- dimnames
}
X <- as.listenv(X_truth)
stopifnot(identical(as.list(X), X_truth))
}
if (ndim <= 1L) {
stopifnot(!is.null(names(X)) && !is.null(names(X_truth)))
stopifnot(identical(names(X), names(X_truth)))
} else {
stopifnot(is.null(names(X)) && is.null(names(X_truth)))
}
if (ndim > 0) {
message("- aperm()")
for (kk in 1:10) {
perm <- sample(seq_len(ndim), replace = FALSE)
X_truth <- aperm(X_truth, perm = perm)
X <- aperm(X, perm = perm)
stopifnot(identical(as.list(X), X_truth))
}
}
if (ndim <= 2) {
message("- t()")
X_truth <- t(X_truth)
X <- t(X)
## For comparision: t(<listenv>) preserves element names
names(X) <- NULL
stopifnot(identical(as.list(X), X_truth))
}
} ## for (ndim ...)
message("*** aperm() and t() ... DONE")
message("*** aperm() ... DONE")
Loading…
Cancel
Save