52 lines
1.9 KiB
R
52 lines
1.9 KiB
R
#' Mode wise Covariance Estimates
|
|
#'
|
|
#' Estimates Covariances \eqn{\Sigma_k}{Sigma_k} for each mode \eqn{k}.
|
|
#' This is equivalent to assuming a Kronecker structured Covariance
|
|
#'
|
|
#' \deqn{\Sigma = \Sigma_r\otimes ... \otimes\Sigma_1}{%
|
|
#' Sigma = Sigma_r %x% ... %x% Sigma_1}
|
|
#'
|
|
#' where \eqn{\Sigma}{Sigma} is the Covariance \eqn{cov(vec(X))} of the
|
|
#' vectorized variables. This function estimates the Kronecerk components
|
|
#' \eqn{\Sigma_k}{Sigma_k}.
|
|
#'
|
|
#' @param X multi-dimensional array
|
|
#' @param sample.axis observation axis index
|
|
#' @param center logical, if `TRUE` (the default) compute the centered second
|
|
#' moment, that is, the mode-wise covariances. Otherwise, the raw second moment
|
|
#' of each mode is computed. This is specifically usefull in case `X` is
|
|
#' already centered.
|
|
#'
|
|
#' @export
|
|
mcov <- function(X, sample.axis = length(dim(X)), center = TRUE) {
|
|
# observation modes (axis indices)
|
|
modes <- seq_along(dim(X))[-sample.axis]
|
|
# observation dimensions
|
|
p <- dim(X)[modes]
|
|
# observation tensor order
|
|
r <- length(p)
|
|
|
|
# ensure observations are on the last mode
|
|
if (sample.axis != r + 1L) {
|
|
X <- aperm(X, c(modes, sample.axis))
|
|
}
|
|
# centering: X <- X - E[X]
|
|
if (center) {
|
|
X <- X - c(rowMeans(X, dims = r))
|
|
}
|
|
|
|
# estimes (unscaled) covariances for each mode
|
|
Sigmas <- .mapply(mcrossprod, list(mode = seq_len(r)), MoreArgs = list(X))
|
|
# scale by per mode "sample" size
|
|
Sigmas <- .mapply(`*`, list(Sigmas, p / prod(dim(X))), NULL)
|
|
|
|
# estimate trace of Kronecker product of covariances
|
|
tr.est <- prod(p) * mean(X^2)
|
|
|
|
# as well as the current trace of the unscaled covariances
|
|
tr.Sigmas <- prod(unlist(.mapply(function(S) sum(diag(S)), list(Sigmas), NULL)))
|
|
|
|
# Scale each mode Covariance to match the estimated Kronecker product scale
|
|
.mapply(`*`, list(Sigmas), MoreArgs = list((tr.est / tr.Sigmas)^(1 / r)))
|
|
}
|