swh:1:snp:81eadaa089e8253d8469bcef66aa332632c6c669
Tip revision: 113add4c7a9bfd37466a9b41cf2dc060b7b87091 authored by HwB on 06 December 2012, 00:00:00 UTC
version 1.3.1
version 1.3.1
Tip revision: 113add4
accumarray.R
##
## a c c u m a r r a y . R Accumulate Vector Elements
##
uniq <- function(a, first = FALSE) {
if (length(a) == 0)
return(list(b = c(), m = c(), n = c()))
if (!is.numeric(a) || !is.vector(a))
stop("Argument 'a' must be a numeric vector.")
la <- length(a); n <- numeric(la)
u <- unique(a)
lu <- length(u); m <- numeric(lu)
mima <- if (first) min else max
for (i in 1:lu) {
w <- which(a == u[i])
m[i] <- mima(w)
n[w] <- i
}
return(list(b = u, m = m, n = n))
}
accumarray <- function(subs, val, sz = NULL, func = sum, fillval = 0) {
stopifnot(is.numeric(subs), is.numeric(val))
subs <- floor(subs)
val <- c(val)
if (any(subs < 1))
stop("Argument 'subs' must be a matrix of integer indices.")
matrix_p <- TRUE
if (is.vector(subs)) {
subs <- as.matrix(subs)
matrix_p <- FALSE
}
n <- nrow(subs); m <- ncol(subs)
if (length(val) < n)
stop("Length of 'vals' must not be smaller than no. of rows of 'subs'.")
dm <- apply(subs, 2, max)
if (!is.null(sz)) {
if (length(sz) != ncol(subs) || any(sz < dm))
stop("Argument 'sz' does not fit with 'subs'.")
dm <- sz
}
if (m == 1) {
A <- rep(fillval, dm)
for (i in unique(subs)) {
A[i] <- func(val[subs == i])
}
if (matrix_p) A <- as.matrix(A)
} else {
cm <- cumprod(dm[1:(m-1)])
A <- array(fillval, dim = dm)
K <- numeric(n)
for (i in 1:n) {
K[i] <- subs[i, 1] + sum(cm * (subs[i, 2:m]-1))
}
for (i in unique(K)) {
A[i] <- func(val[K == i])
}
}
return(A)
}