79 lines
2.7 KiB
R
79 lines
2.7 KiB
R
|
#' Kronecker decomposed Variance Matrix estimation.
|
||
|
|
#'
|
||
|
|
#' @description Computes the kronecker decomposition factors of the variance
|
||
|
|
#' matrix
|
||
|
|
#' \deqn{\var{X} = tr(L)tr(R) (L\otimes R).}
|
||
|
|
#'
|
||
|
|
#' @param X numeric matrix or 3d array.
|
||
|
|
#' @param shape in case of \code{X} being a matrix, this specifies the predictor
|
||
|
|
#' shape, otherwise ignored.
|
||
|
|
#' @param center boolean specifying if \code{X} is centered before computing the
|
||
|
|
#' left/right second moments. This is usefull in the case of allready centered
|
||
|
|
#' data.
|
||
|
|
#'
|
||
|
|
#' @returns List containing
|
||
|
|
#' \describe{
|
||
|
|
#' \item{lhs}{Left Hand Side \eqn{L} of the kronecker decomposed variance matrix}
|
||
|
|
#' \item{rhs}{Right Hand Side \eqn{R} of the kronecker decomposed variance matrix}
|
||
|
|
#' \item{trace}{Scaling factor \eqn{tr(L)tr(R)} for the variance matrix}
|
||
|
|
#' }
|
||
|
|
#'
|
||
|
|
#' @examples
|
||
|
|
#' n <- 503L # nr. of observations
|
||
|
|
#' p <- 32L # first predictor dimension
|
||
|
|
#' q <- 27L # second predictor dimension
|
||
|
|
#' lhs <- 0.5^abs(outer(seq_len(q), seq_len(q), `-`)) # Left Var components
|
||
|
|
#' rhs <- 0.5^abs(outer(seq_len(p), seq_len(p), `-`)) # Right Var components
|
||
|
|
#' X <- rmvnorm(n, sigma = kronecker(lhs, rhs)) # Multivariate normal data
|
||
|
|
#'
|
||
|
|
#' # Estimate kronecker decomposed variance matrix
|
||
|
|
#' dim(X) # c(n, p * q)
|
||
|
|
#' fit <- var.kronecker(X, shape = c(p, q))
|
||
|
|
#'
|
||
|
|
#' # equivalent
|
||
|
|
#' dim(X) <- c(n, p, q)
|
||
|
|
#' fit <- var.kronecker(X)
|
||
|
|
#'
|
||
|
|
#' # Compute complete estimated variance matrix
|
||
|
|
#' varX.hat <- fit$trace^-1 * kronecker(fit$lhs, fit$rhs)
|
||
|
|
#'
|
||
|
|
#' # or its inverse
|
||
|
|
#' varXinv.hat <- fit$trace * kronecker(solve(fit$lhs), solve(fit$rhs))
|
||
|
|
#'
|
||
|
|
var.kronecker <- function(X, shape = dim(X)[-1], center = TRUE) {
|
||
|
|
# Get and check predictor dimensions
|
||
|
|
n <- nrow(X)
|
||
|
|
if (length(dim(X)) == 2L) {
|
||
|
|
stopifnot(ncol(X) == prod(shape[1:2]))
|
||
|
|
p <- as.integer(shape[1]) # Predictor "height"
|
||
|
|
q <- as.integer(shape[2]) # Predictor "width"
|
||
|
|
dim(X) <- c(n, p, q)
|
||
|
|
} else if (length(dim(X)) == 3L) {
|
||
|
|
p <- dim(X)[2]
|
||
|
|
q <- dim(X)[3]
|
||
|
|
} else {
|
||
|
|
stop("'X' must be a matrix or 3-tensor")
|
||
|
|
}
|
||
|
|
|
||
|
|
if (isTRUE(center)) {
|
||
|
|
# Center X; X[, i, j] <- X[, i, j] - mean(X[, i, j])
|
||
|
|
X <- scale(X, scale = FALSE)
|
||
|
|
|
||
|
|
print(range(attr(X, "scaled:center")))
|
||
|
|
|
||
|
|
dim(X) <- c(n, p, q)
|
||
|
|
}
|
||
|
|
|
||
|
|
# Calc left/right side of kronecker structures covariance
|
||
|
|
# var(X) = var.lhs %x% var.rhs
|
||
|
|
var.lhs <- .rowMeans(apply(X, 1, crossprod), q * q, n)
|
||
|
|
dim(var.lhs) <- c(q, q)
|
||
|
|
var.rhs <- .rowMeans(apply(X, 1, tcrossprod), p * p, n)
|
||
|
|
dim(var.rhs) <- c(p, p)
|
||
|
|
|
||
|
|
# Estimate scalling factor tr(var(X)) = tr(var.lhs) tr(var.rhs)
|
||
|
|
trace <- sum(X^2) / n
|
||
|
|
|
||
|
|
list(lhs = var.lhs, rhs = var.rhs, trace = trace)
|
||
|
|
}
|