38 lines
1.3 KiB
R
38 lines
1.3 KiB
R
#' Higher Order Principal Component Analysis
|
|
#'
|
|
#' @param X multi-dimensional array (at least a matrix)
|
|
#' @param npc Number of Principal Components for each axis, if not specified
|
|
#' its the maximum
|
|
#' @param sample.axis index of the sample mode, a.k.a. observation axis index
|
|
#'
|
|
#' @return list of matrices, each entry are the first PCs of the corresponding
|
|
#' axis. The `i`'th entry are the `npc[i]` first Principal Components of the
|
|
#' `i`th axis excluding the sample axis (note: this means there is an index
|
|
#' shift after the sample axis).
|
|
#'
|
|
#' @export
|
|
hopca <- function(X, npc = dim(X)[-sample.axis], sample.axis = 1L) {
|
|
# observation index numbers (all axis except the sample axis)
|
|
modes <- seq_along(dim(X))[-sample.axis]
|
|
|
|
# Mean (a.k.a. sum elements over the sample axis)
|
|
mu <- apply(X, modes, mean, simplify = TRUE)
|
|
# Center `X` by subtraction of the mean `mu` from each observation
|
|
X.centered <- sweep(X, modes, mu)
|
|
|
|
# PCA for each mode (axis)
|
|
PCs <- Map(function(i) {
|
|
La.svd(mcrossprod(X.centered, modes[i]), npc[i], 0)$u
|
|
}, seq_along(modes))
|
|
|
|
# Set names if any
|
|
if (!is.null(dimnames(X))) {
|
|
names(PCs) <- names(dimnames(X)[-sample.axis])
|
|
for (i in seq_along(modes)) {
|
|
dimnames(PCs[[i]]) <- list(dimnames(X)[-sample.axis][[i]], NULL)
|
|
}
|
|
}
|
|
|
|
PCs
|
|
}
|