[Rd] Using 'dimname names' in aperm() and apply()

From: Michael Lachmann <lachmann_at_eva.mpg.de>
Date: Thu, 29 Jul 2010 21:31:28 +0200


I think that the "dimname names" of tables and arrays could make aperm() and apply() (and probably some other functions) easier to use. (dimname names are, for example, created by table() )

The use would be something like:

--
x <-table( from=sample(3,100,rep=T), to=sample(5,100,rep=T))
trans <- x / apply(x,"from",sum)

y <- aperm( trans, c("from","to") )
z <- aperm(y, c("to","from") )

res <-apply( y, "to", sum)
--

This makes the array much easier to handle than having to keep track
which dimension currently means what.

For aperm and apply, the change seems very simple - one new function,
and an additional line in each.
----------
dimnum.from.dimnamename <- function(A, dimensions)

{
if( is.character(dimensions) ) { n <- names(dimnames(A)) if( !is.null(n) ) { dimnum <- seq( along=n) names(dimnum) <- n dimensions <- dimnum[dimensions] } } dimensions } aperm <- function (a, perm, resize = TRUE)
{
if (missing(perm)) perm <- integer(0L) perm <- dimnum.from.dimnamename( a, perm) # this line was added to aperm .Internal(aperm(a, perm, resize)) } apply <- function (X, MARGIN, FUN, ...)
{
FUN <- match.fun(FUN) d <- dim(X) dl <- length(d) if (dl == 0L) stop("dim(X) must have a positive length") ds <- 1L:dl if (length(oldClass(X))) X <- if (dl == 2) as.matrix(X) else as.array(X) d <- dim(X) dn <- dimnames(X) MARGIN <- dimnum.from.dimnamename( X,MARGIN ) # this line was added to apply s.call <- ds[-MARGIN] s.ans <- ds[MARGIN] d.call <- d[-MARGIN] d.ans <- d[MARGIN] dn.call <- dn[-MARGIN] dn.ans <- dn[MARGIN] d2 <- prod(d.ans) if (d2 == 0L) { newX <- array(vector(typeof(X), 1L), dim = c(prod(d.call), 1L)) ans <- FUN(if (length(d.call) < 2L) newX[, 1] else array(newX[, 1L], d.call, dn.call), ...) return(if (is.null(ans)) ans else if (length(d.ans) < 2L) ans[1L][-1L] else array(ans, d.ans, dn.ans)) } newX <- aperm(X, c(s.call, s.ans)) dim(newX) <- c(prod(d.call), d2) ans <- vector("list", d2) if (length(d.call) < 2L) { if (length(dn.call)) dimnames(newX) <- c(dn.call, list(NULL)) for (i in 1L:d2) { tmp <- FUN(newX[, i], ...) if (!is.null(tmp)) ans[[i]] <- tmp } } else for (i in 1L:d2) { tmp <- FUN(array(newX[, i], d.call, dn.call), ...) if (!is.null(tmp)) ans[[i]] <- tmp } ans.list <- is.recursive(ans[[1L]]) l.ans <- length(ans[[1L]]) ans.names <- names(ans[[1L]]) if (!ans.list) ans.list <- any(unlist(lapply(ans, length)) != l.ans) if (!ans.list && length(ans.names)) { all.same <- sapply(ans, function(x) identical(names(x), ans.names)) if (!all(all.same)) ans.names <- NULL } len.a <- if (ans.list) d2 else length(ans <- unlist(ans, recursive = FALSE)) if (length(MARGIN) == 1L && len.a == d2) { names(ans) <- if (length(dn.ans[[1L]])) dn.ans[[1L]] return(ans) } if (len.a == d2) return(array(ans, d.ans, dn.ans)) if (len.a && len.a%%d2 == 0L) { if (is.null(dn.ans)) dn.ans <- vector(mode = "list", length(d.ans)) dn.ans <- c(list(ans.names), dn.ans) return(array(ans, c(len.a%/%d2, d.ans), if (!all(sapply(dn.ans, is.null))) dn.ans)) } return(ans) } ---------- Thanks, Michael -- Michael Lachmann, Max Planck institute of evolutionary anthropology Deutscher Platz. 6, 04103 Leipzig, Germany Tel: +49-341-3550521, Fax: +49-341-3550555 ______________________________________________
R-devel_at_r-project.org mailing list https://stat.ethz.ch/mailman/listinfo/r-devel
Received on Thu 29 Jul 2010 - 19:35:00 GMT

Archive maintained by Robert King, hosted by the discipline of statistics at the University of Newcastle, Australia.
Archive generated by hypermail 2.2.0, at Fri 30 Jul 2010 - 00:20:21 GMT.

Mailing list information is available at https://stat.ethz.ch/mailman/listinfo/r-devel. Please read the posting guide before posting to the list.

list of date sections of archive