tensor_predictors/tensorPredictors/R/var_kronecker.R

79 lines
2.7 KiB
R
Raw Normal View History

2022-03-22 15:26:24 +00:00
#' 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)
}