# Array utilities for ff
# (c) 2007 Jens Oehlschägel
# Licence: GPL2
# Provided 'as is', use at your own risk
# Created: 2007-09-03
# Last changed: 2007-10-25
# source("D:/mwp/eanalysis/ff/R/array.R")
# xx TODO arrprint, print.arrprint (generalize matprint to arrays)
# an ff dimorder (storage layout) 2,3,1 means that data is stored fastest rotating along columns, then layers, slowest is rows
# Implementation: the R side submits dim[dimorder] to the C-Side (dimorder is transparent for the C-Side: C does not know about the dimorder)
# NOTE that therefor you MUST NEVER access the dim-attribute install("Dim") from C !!
# if we submit ff_array[]<-vector, vector is interpreted in dimorder 1,2,3 (by layer, by column, by row, i.e. row rotates fastest) whatever the ff dimorder
# we can change the intepretation of the vector by ff_array[,dimorder=c(2,3,1)]<-vector, now the vector elements are put fastest col then layer then row
# if we submit ff_array[seq_along(vector)]<-vector it is simply copied and ff dimorder DOES matter
# not exported, only used for display in vecprint, matprint
legalizeFactor <- function(x){
if (is.factor(x)){
a <- attributes(x)
attributes(x) <- NULL
if (any(!is.na(x) & x==0L)){
x <- x + 1L
a$levels <- c("<0>", a$levels)
}
setattributes(x, a) #attributes(x) <- a
}
x
}
#! \name{vector2array}
#! \alias{vector2array}
#! \title{ Array: make array from vector }
#! \description{
#! makes array from vector respecting \option{dim} and \option{dimorder}
#! }
#! \usage{
#! vector2array(x, dim, dimorder = NULL)
#! }
#! \arguments{
#! \item{x}{ an input vector, recyled if needed }
#! \item{dim}{ \code{\link{dim}} }
#! \item{dimorder}{ \code{\link{dimorder}} }
#! }
#! \details{
#! FILLS vector into array of dim where fastest rotating is dim[dimorder[1]], next is dim[dimorder[2]] and so forth.
#! This is a generalization of converting vector to matrix(, byrow=TRUE).
#! NOTE that the result is a ram array always stored in STANDARD dimorder !!!
#! In this usage we sometimes term the dimorder 'bydim' because it does not change the physical layout of the result,
#! rather bydim refers to the dimorder in which to interpret the vector (not the result).
#! In \command{ff}, \command{update} and \command{clone} we have 'bydim' to contrast it from 'dimorder', the latter describing the layout of the file.
#! }
#! \value{
#! a suitable \code{\link{array}}
#! }
#! \author{ Jens Oehlschlägel }
#! \seealso{ \code{\link{array2vector}}, \code{\link{vectorIndex2arrayIndex}} }
#! \examples{
#! vector2array(1:12, dim=c(3, 4)) # matrix(1:12, 3, 4)
#! vector2array(1:12, dim=c(3, 4), dimorder=2:1) # matrix(1:12, 3, 4, byrow=TRUE)
#! }
#! \keyword{ array }
#! \keyword{ data }
vector2array <- function(x, dim, dimorder=NULL){
if (is.null(dimorder) || identical(dimorder, seq_along(dim))){
array(x, dim=dim)
}else{
aperm(array(x, dim=dim[dimorder]), match(seq_along(dim), dimorder))
}
}
#! \name{array2vector}
#! \alias{array2vector}
#! \title{ Array: make vector from array }
#! \description{
#! Makes a vector from an array respecting \option{dim} and \option{dimorder}
#! }
#! \usage{
#! array2vector(x, dim = NULL, dimorder = NULL)
#! }
#! \arguments{
#! \item{x}{ an \code{\link{array}} }
#! \item{dim}{ \code{\link{dim}} }
#! \item{dimorder}{ \code{\link{dimorder}} }
#! }
#! \details{
#! This is the inverse function of \code{\link{vector2array}}.
#! It extracts the vector from the array by first moving through the fastest rotating dimension dim[dimorder[1]], then dim[dimorder[2]], and so forth
#! }
#! \value{
#! a vector
#! }
#! \author{ Jens Oehlschlägel }
#! \seealso{ \code{\link{vector2array}}, \code{\link{arrayIndex2vectorIndex}} }
#! \examples{
#! array2vector(matrix(1:12, 3, 4))
#! array2vector(matrix(1:12, 3, 4, byrow=TRUE), dimorder=2:1)
#! }
#! \keyword{ array }
#! \keyword{ data }
array2vector <- function(x, dim=NULL, dimorder=NULL){
if (is.array(x)){
if (is.null(dim))
dim <- dim(x)
else if (!identical(dim(x), dim))
stop("dim(x) differs from dim")
}else{
if (is.null(dim))
stop("need is.array(x) or dim")
}
if (is.null(dimorder))
dimorder <- dimorder(x)
if (is.null(dimorder)|| identical(dimorder, seq_along(dim)))
as.vector(x)
else{
if (is.array(x))
as.vector(aperm(x, dimorder))
else
as.vector(aperm(array(x, dim=dim), dimorder))
}
}
if (FALSE){
# regression tests
stopifnot(identical( vector2array(1:12, 3:4), matrix(1:12, 3, 4) ))
stopifnot(identical( vector2array(1:12, 3:4, 2:1), matrix(1:12, 3, 4, byrow=TRUE) ))
stopifnot(identical( vector2array(1:24, 4:2, c(2,1,3)), structure(c(1L, 4L, 7L, 10L, 2L, 5L, 8L, 11L, 3L, 6L, 9L, 12L, 13L, 16L, 19L, 22L, 14L, 17L, 20L, 23L, 15L, 18L, 21L, 24L), .Dim = c(4L, 3L, 2L)) ))
stopifnot(identical( array2vector(vector2array(1:12, 3:4)), 1:12 ))
stopifnot(identical( array2vector(vector2array(1:12, 3:4, 2:1), dimorder=2:1), 1:12 ))
stopifnot(identical( array2vector(vector2array(1:24, 4:2, c(2,1,3)), dimorder=c(2,1,3)), 1:24 ))
}
#! \name{arrayIndex2vectorIndex}
#! \alias{arrayIndex2vectorIndex}
#! \title{ Array: make vector positions from array index }
#! \description{
#! Make vector positions from a (non-symmetric) array index respecting \option{dim} and \option{dimorder}
#! }
#! \usage{
#! arrayIndex2vectorIndex(x, dim = NULL, dimorder = NULL, vw = NULL)
#! }
#! \arguments{
#! \item{x}{ an n by m matrix with n m-dimensional array indices }
#! \item{dim}{ NULL or \code{\link{dim}} }
#! \item{dimorder}{ NULL or \code{\link{dimorder}} }
#! \item{vw}{ NULL or integer vector[3] or integer matrix[3,m], see details }
#! }
#! \details{
#! The fastest rotating dimension is dim[dimorder[1]], then dim[dimorder[2]], and so forth. \cr
#! The parameters 'x' and 'dim' may refer to a subarray of a larger array, in this case, the array indices 'x' are interpreted as 'vw[1,] + x' within the larger array 'as.integer(colSums(vw))'.
#! }
#! \value{
#! a vector of indices in \code{seq_len(prod(dim))} (or \code{seq_len(prod(colSums(vw)))})
#! }
#! \author{ Jens Oehlschlägel }
#! \seealso{ \code{\link{array2vector}}, \code{\link{vectorIndex2arrayIndex}} }
#! \examples{
#! x <- matrix(1:12, 3, 4)
#! x
#! arrayIndex2vectorIndex(cbind(as.vector(row(x)), as.vector(col(x)))
#! , dim=dim(x))
#! arrayIndex2vectorIndex(cbind(as.vector(row(x)), as.vector(col(x)))
#! , dim=dim(x), dimorder=2:1)
#! matrix(1:30, 5, 6)
#! arrayIndex2vectorIndex(cbind(as.vector(row(x)), as.vector(col(x)))
#! , vw=rbind(c(0,1), c(3,4), c(2,1)))
#! arrayIndex2vectorIndex(cbind(as.vector(row(x)), as.vector(col(x)))
#! , vw=rbind(c(0,1), c(3,4), c(2,1)), dimorder=2:1)
#! }
#! \keyword{ array }
#! \keyword{ data }
arrayIndex2vectorIndex <- function(x, dim = NULL, dimorder=NULL, vw=NULL){
if (is.null(vw)){
if (is.null(dim))
stop("need 'dim' or 'vw'")
n <- length(dim)
}else{
n <- ncol(vw)
if (!identical(dim(vw), c(3L, n)))
stop("dim(vw) must be c(3L, length(dim))")
}
if(!is.matrix(x) || ncol(x)!=n)
stop("array indexing requires a matrix with ncol(matrix)=length(dim(array))")
if (is.null(dimorder))
dimorder <- seq_len(n)
if (is.null(vw)){
cdim <- cumprod(c(1, dim[dimorder][-n]))
as.integer(colSums(t(x[,dimorder,drop=FALSE]-1) * cdim) + 1L)
}else{
cdim <- cumprod(c(1, (colSums(vw))[dimorder][-n]))
as.integer(colSums((vw[1,dimorder] + t(x[,dimorder,drop=FALSE]-1)) * cdim) + 1L)
}
}
#! \name{vectorIndex2arrayIndex}
#! \alias{vectorIndex2arrayIndex}
#! \title{ Array: make array from index vector positions }
#! \description{
#! make array from index vector positions respecting \option{dim} and \option{dimorder}
#! }
#! \usage{
#! vectorIndex2arrayIndex(x, dim = NULL, dimorder = NULL, vw = NULL)
#! }
#! \arguments{
#! \item{x}{ a vector of indices in \code{seq_len(prod(dim))} }
#! \item{dim}{ NULL or \code{\link{dim}} }
#! \item{dimorder}{ NULL or \code{\link{dimorder}} }
#! \item{vw}{ NULL or integer matrix[2,m], see details }
#! }
#! \details{
#! The fastest rotating dimension is dim[dimorder[1]], then dim[dimorder[2]], and so forth. \cr
#! The parameters 'x' and 'dim' may refer to a subarray of a larger array, in this case, the array indices 'x' are interpreted as 'vw[1,] + x' within the larger array 'vw[1,] + x + vw[2,]'.
#! }
#! \value{
#! an n by m matrix with n m-dimensional array indices
#! }
#! \author{ Jens Oehlschlägel }
#! \seealso{ \code{\link{vector2array}}, \code{\link{arrayIndex2vectorIndex}} , \code{\link{symmIndex2vectorIndex}} }
#! \examples{
#! matrix(1:12, 3, 4)
#! vectorIndex2arrayIndex(1:12, dim=3:4)
#! vectorIndex2arrayIndex(1:12, dim=3:4, dimorder=2:1)
#! matrix(1:30, 5, 6)
#! vectorIndex2arrayIndex(c(6L, 7L, 8L, 11L, 12L, 13L, 16L, 17L, 18L, 21L, 22L, 23L)
#! , vw=rbind(c(0,1), c(3,4), c(2,1)))
#! vectorIndex2arrayIndex(c(2L, 8L, 14L, 3L, 9L, 15L, 4L, 10L, 16L, 5L, 11L, 17L)
#! , vw=rbind(c(0,1), c(3,4), c(2,1)), dimorder=2:1)
#!
#! \dontshow{
#! # incomplete regression tests
#! x <- matrix(1:12, 3, 4)
#! i <- cbind(as.vector(row(x)), as.vector(col(x)))
#! stopifnot(identical( array(arrayIndex2vectorIndex(i, dim=dim(x)), dim=dim(x)), x ))
#! stopifnot(identical( vectorIndex2arrayIndex(arrayIndex2vectorIndex(i, dim=dim(x), dimorder=1:2), dim=dim(x)), i ))
#!
#! y <- vector2array(1:12, c(3,4), 2:1)
#! i <- cbind(as.vector(row(y)), as.vector(col(y)))
#! stopifnot(identical( array(arrayIndex2vectorIndex(i, dim=dim(y), dimorder=2:1), dim=dim(y)), y ))
#! stopifnot(identical( vectorIndex2arrayIndex(arrayIndex2vectorIndex(i, dim=dim(y), dimorder=dimorder(y)), dim=dim(y), dimorder=dimorder(y)), i ))
#!
#! z <- vector2array(1:24, dim=4:2, dimorder=c(2,1,3))
#! stopifnot(identical( arrayIndex2vectorIndex(vectorIndex2arrayIndex(z, dim=dim(z), dimorder=c(2,1,3)), dim=dim(z), dimorder=c(2,1,3)), as.vector(z) ))
#! }
#! }
#! \keyword{ array }
#! \keyword{ data }
vectorIndex2arrayIndex <- function(x, dim=NULL, dimorder=NULL, vw=NULL){
if (is.null(vw)){
if (is.null(dim))
stop("need 'dim' or 'vw'")
n <- length(dim)
if (is.null(dimorder))
dimorder <- seq_len(n)
cdim <- as.integer(cumprod(dim[dimorder]))
vw <- matrix(0L, 3L, n)
}else{
n <- ncol(vw)
if (!identical(dim(vw), c(3L, n)))
stop("dim(vw) must be c(3L, length(dim))")
if (is.null(dimorder))
dimorder <- seq_len(n)
cdim <- as.integer(cumprod(colSums(vw)[dimorder]))
}
N <- cdim[n]
cdim <- c(1L,cdim[-n])
if(!is.vector(x))
x <- as.vector(x)
if (n==1)
return(cbind(x-vw[1,]))
if (!is.integer(x))
x <- as.integer(x - 1L)
else
x <- x - 1L
ret <- NULL
for (i in n:2){
ret <- rbind(x%/%cdim[i], ret)
x <- x%%cdim[i]
}
ret <- rbind(x, ret)
setattr(ret, "dimnames", NULL) #dimnames(ret) <- NULL
t(ret[match(seq_len(n), dimorder),,drop=FALSE] - vw[1,] + 1L)
}
#! \name{symmIndex2vectorIndex}
#! \alias{symmIndex2vectorIndex}
#! \title{ Array: make vector positions from symmetric array index }
#! \description{
#! make vector positions from (non-symmetric) array index respecting \option{dim} and \option{fixdiag}
#! }
#! \usage{
#! symmIndex2vectorIndex(x, dim, fixdiag = NULL)
#! }
#! \arguments{
#! \item{x}{ a matrix[,1:2] with matrix subscripts }
#! \item{dim}{ the dimensions of the symmetric matrix }
#! \item{fixdiag}{ NULL assumes free diagonal, any value assumes fixed diagonal }
#! }
#! \details{
#! With \option{fixdiag = NULL}
#! }
#! \value{
#! a vector of indices in \code{seq_len(prod(dim(x)))}
#! }
#! \author{ Jens Oehlschlägel }
#! \seealso{ \code{\link{arrayIndex2vectorIndex}} }
#! \examples{
#! symmIndex2vectorIndex(rbind(
#! c(1,1)
#! ,c(1,10)
#! ,c(10,1)
#! ,c(10,10)
#! ), dim=c(10,10))
#! symmIndex2vectorIndex(rbind(
#! c(1,1)
#! ,c(1,10)
#! ,c(10,1)
#! ,c(10,10)
#! ), dim=c(10,10), fixdiag=1)
#! }
#! \keyword{ array }
#! \keyword{ data }
# mapping row/col subscripts to position in symmetric matrix
# in R-counting 1..n
symmIndex2vectorIndex <- function(x, dim, fixdiag=NULL # setting to anything but NULL deactivates the diagonal (e.g. 0 as in dist)
){
one <- as.integer(1)
two <- as.integer(2)
r <- x[,1] - one
c <- x[,2] - one
n <- dim[[1]]
if (is.null(fixdiag)){
i <- as.integer(ifelse(r>c
, r + c*n - c*(c+one)/two + one
, c + r*n - r*(r+one)/two + one
))
}else{
i <- as.integer(ifelse(r>c
, r + c*(n-one) - c*(c+one)/two
, c + r*(n-one) - r*(r+one)/two
))
i[r==c] <- NA
}
i
}
#! \name{dummy.dimnames}
#! \alias{dummy.dimnames}
#! \title{ Array: make dimnames }
#! \description{
#! makes standard dimnames from letters and integers (for testing)
#! }
#! \usage{
#! dummy.dimnames(x)
#! }
#! \arguments{
#! \item{x}{ an \code{\link{array}} }
#! }
#! \value{
#! a list with character vectors suitable to be assigned as dimnames to x
#! }
#! \author{ Jens Oehlschlägel }
#! \seealso{ \code{\link{dimnames}} }
#! \examples{
#! dummy.dimnames(matrix(1:12, 3, 4))
#! }
#! \keyword{ array }
#! \keyword{ data }
dummy.dimnames <- function(x){
d <- dim(x)
if (is.null(d))
return(NULL)
lapply(seq_along(d), function(n)paste(c(letters,LETTERS)[n], seq_len(d[n]), sep=""))
}
#! \name{matcomb}
#! \alias{matcomb}
#! \title{ Array: make matrix indices from row and columns positions }
#! \description{
#! create matrix indices from row and columns positions
#! }
#! \usage{
#! matcomb(r, c)
#! }
#! \arguments{
#! \item{r}{ integer vector of row positions }
#! \item{c}{ integer vector of column positions }
#! }
#! \details{
#! rows rotate faster than columns
#! }
#! \value{
#! a k by 2 matrix of matrix indices where \code{ k = length(r) * length(c) }
#! }
#! \author{ Jens Oehlschlägel }
#! \seealso{ \code{\link{row}}, \code{\link{col}} , \code{\link{expand.grid}} }
#! \examples{
#! matcomb(1:3, 1:4)
#! matcomb(2:3, 2:4)
#! }
#! \keyword{ array }
#! \keyword{ data }
# create all combinations between r and c
# assuming integer input
matcomb <- function(r,c){
rc <- rep.int(r, length(c))
cr <- rep.int(c, rep(length(r), length(c)))
cbind(r=rc,c=cr)
}
#! \name{matprint}
#! \alias{matprint}
#! \alias{print.matprint}
#! \title{ Print beginning and end of big matrix }
#! \description{
#! Print beginning and end of big matrix
#! }
#! \usage{
#! matprint(x, maxdim = c(16, 16), digits = getOption("digits"))
#! \method{print}{matprint}(x, quote = FALSE, right = TRUE, \dots)
#! }
#! \arguments{
#! \item{x}{ a \code{\link{matrix}} }
#! \item{maxdim}{ max number of rows and columns for printing }
#! \item{digits}{ see \code{\link{format}} }
#! \item{quote}{ see \code{\link{print}} }
#! \item{right}{ see \code{\link{print}} }
#! \item{\dots}{ see \code{\link{print}} }
#! }
#! \value{
#! a list of class 'matprint' with components
#! \item{ subscript }{ a list with four vectors of subscripts: row begin, column begin, row end, column end }
#! \item{ example }{ the extracted example matrix as.characer including seperators }
#! \item{ rsep }{ logical scalar indicating whether row seperator is included }
#! \item{ csep }{ logical scalar indicating whether column seperator is included }
#! }
#! \author{ Jens Oehlschlägel }
#! \seealso{ \code{\link{vecprint}} }
#! \examples{
#! matprint(matrix(1:(300*400), 300, 400))
#! }
#! \keyword{ array }
#! \keyword{ print }
matprint <- function(x, maxdim=c(16,16), digits=getOption("digits")){
d <- dim(x)
if (any(d==0)){
return("[empty matrix]")
}
maxdim <- pmin(d,maxdim)
d2 <- maxdim %/% 2
d1 <- maxdim - d2
d2 <- ifelse(d1<maxdim, d - d2 + 1, 0)
rsep <- maxdim[1] < d[1]
csep <- maxdim[2] < d[2]
i <- matrix(list(1:d1[1], 1:d1[2], if (d2[1]) d2[1]:d[1], if (d2[2]) d2[2]:d[2]), 2, 2)
i1 <- c(i[[1,1]],i[[1,2]])
i2 <- c(i[[2,1]],i[[2,2]])
m <- x[ i1 , i2, drop=FALSE ]
if (is.data.frame(m)){
for (j in seq(along=m))
m[[j]] <- legalizeFactor(m[[j]])
m <- as.matrix(m)
}else{
m <- legalizeFactor(m)
}
# xx circumvent a bug in format of raw
if (is.raw(m)){
a <- attributes(m)
m <- as.character(m)
attributes(m) <- a
}else{
m <- format(m, digits=digits)
}
if (is.null(rownames(m)))
rownames(m) <- paste("[", c(i[[1,1]],i[[1,2]]),",]", sep="")
if (is.null(colnames(m)))
colnames(m) <- paste("[,", c(i[[2,1]],i[[2,2]]),"]", sep="")
if (csep){
r1 <- cbind( m[ 1 : d1[1],1:d1[2], drop=FALSE] , if(d2[2])cbind(" "=":", m[ 1 : d1[1],(d1[2]+1):maxdim[2], drop=FALSE] ))
r2 <- cbind( if(d2[1])m[(d1[1]+1):maxdim[1],1:d1[2], drop=FALSE] , if(d2[1]&&d2[2])cbind(" "=":", m[(d1[1]+1):maxdim[1],(d1[2]+1):maxdim[2], drop=FALSE] ))
}else{
r1 <- cbind( m[ 1 : d1[1],1:d1[2], drop=FALSE] , if(d2[2])m[ 1 : d1[1],(d1[2]+1):maxdim[2], drop=FALSE] )
r2 <- cbind( if(d2[1])m[(d1[1]+1):maxdim[1],1:d1[2], drop=FALSE] , if(d2[1]&&d2[2]) m[(d1[1]+1):maxdim[1],(d1[2]+1):maxdim[2], drop=FALSE] )
}
if (rsep)
m <- rbind(r1,":"=":",r2)
else
m <- rbind(r1,r2)
ret <- list(subscript=i, example=m, rsep=rsep, csep=csep)
class(ret) <- "matprint"
ret
}
print.matprint <- function(x, quote=FALSE, right=TRUE, ...){
print(x$example, quote=quote, right=right, ...)
}
#! \name{vecprint}
#! \alias{vecprint}
#! \alias{print.vecprint}
#! \title{ Print beginning and end of big vector }
#! \description{
#! Print beginning and end of big vector
#! }
#! \usage{
#! vecprint(x, maxlength = 16, digits = getOption("digits"))
#! \method{print}{vecprint}(x, quote = FALSE, \dots)
#! }
#! \arguments{
#! \item{x}{ a vector }
#! \item{maxlength}{ max number of elements for printing }
#! \item{digits}{ see \code{\link{format}} }
#! \item{quote}{ see \code{\link{print}} }
#! \item{\dots}{ see \code{\link{print}} }
#! }
#! \value{
#! a list of class 'vecprint' with components
#! \item{ subscript }{ a list with two vectors of subscripts: vector begin and vector end }
#! \item{ example }{ the extracted example vector as.character including seperator }
#! \item{ sep }{ the row seperator ":" }
#! }
#! \author{ Jens Oehlschlägel }
#! \seealso{ \code{\link{matprint}} }
#! \examples{
#! vecprint(10000:1)
#! }
#! \keyword{ print }
vecprint <- function(x, maxlength=16, digits=getOption("digits")){
d <- length(x)
if (d == 0){
i <- integer()
m <- character()
sep <- FALSE
} else {
maxlength <- min(maxlength, d)
d2 <- maxlength%/%2
d1 <- maxlength - d2
if (d1<maxlength){
i <- list(1:d1, (d - d2 + 1L):d)
sep <- TRUE
}else{
i <- list(1:d1)
sep <- FALSE
}
m <- format(legalizeFactor(x[ unlist(i) ]), digits=digits)
if (is.null(names(m)))
names(m) <- paste("[", unlist(i),"]", sep="")
if (sep){
m <- c(m[1:d1], if (d2) c(":", m[(d1+1):maxlength]))
}
}
ret <- list(subscript=i, example=m, sep=sep)
class(ret) <- "vecprint"
ret
}
print.vecprint <- function(x, quote=FALSE, ...){
if (length(x))
print(x$example, quote=quote, ...)
else
invisible()
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.