83 lines
		
	
	
		
			1.8 KiB
		
	
	
	
		
			R
		
	
	
	
	
	
			
		
		
	
	
			83 lines
		
	
	
		
			1.8 KiB
		
	
	
	
		
			R
		
	
	
	
	
	
#' Half vectorization of a matrix (lower part)
 | 
						|
#' @export
 | 
						|
vech <- function(A) A[lower.tri(A, diag = TRUE)]
 | 
						|
 | 
						|
#' @export
 | 
						|
vech.index <- function(p) which(.row(c(p, p)) >= .col(c(p, p)))
 | 
						|
 | 
						|
#' @export
 | 
						|
vech.pinv.index <- function(p) {
 | 
						|
    index <- matrix(NA_integer_, p, p)
 | 
						|
    index[lower.tri(index, diag = TRUE)] <- seq_len(p * (p + 1L) / 2L)
 | 
						|
    index[upper.tri(index)] <- t(index)[upper.tri(index)]
 | 
						|
 | 
						|
    index
 | 
						|
}
 | 
						|
 | 
						|
#' pseudo inserse of the half vectorization
 | 
						|
#'
 | 
						|
#' @examples
 | 
						|
#' # only valid for symmetric matrices
 | 
						|
#' A <- matrix(rnorm(4^2), 4)
 | 
						|
#' A <- A + t(A)
 | 
						|
#' all.equal(A, vech.pinv(vech(A)))
 | 
						|
#'
 | 
						|
#' @export
 | 
						|
vech.pinv <- function(a) {
 | 
						|
    # determin original dimensions
 | 
						|
    p <- as.integer((sqrt(8 * length(a) + 1) - 1) / 2)
 | 
						|
    stopifnot(p * (p + 1L) == 2L * length(a))
 | 
						|
 | 
						|
    # de-vectorized matrix
 | 
						|
    matrix(a[vech.pinv.index(p)], p, p)
 | 
						|
}
 | 
						|
 | 
						|
 | 
						|
# vech <- function(A) {
 | 
						|
#     stopifnot(all(nrow(A) == dim(A)))
 | 
						|
 | 
						|
#     axis <- seq_len(nrow(A))
 | 
						|
#     grid <- expand.grid(c(list(rev(axis)), rep(list(axis), length(dim(A)) - 1)))
 | 
						|
 | 
						|
#     A[rowSums(grid - 1) < nrow(A)]
 | 
						|
# }
 | 
						|
 | 
						|
# p <- 4
 | 
						|
# X <- matrix(rnorm(p^2), p)
 | 
						|
 | 
						|
# vech(outer(X, X))
 | 
						|
 | 
						|
# vech(outer(c(X), c(X)))
 | 
						|
 | 
						|
# sort(unique(c(sym(outer(X, X)))))
 | 
						|
# sort(vech(sym(outer(X, X))))
 | 
						|
 | 
						|
# # (I <- matrix(c(
 | 
						|
# #     1, 1, 1,
 | 
						|
# #     2, 1, 1,
 | 
						|
# #     3, 1, 1,
 | 
						|
# #     2, 2, 1,
 | 
						|
# #     3, 2, 1,
 | 
						|
# #     3, 3, 1,
 | 
						|
# #     2, 1, 2,
 | 
						|
# #     3, 1, 2,
 | 
						|
# #     3, 2, 2,
 | 
						|
# #     3, 1, 3
 | 
						|
# # ), ncol = 3, byrow = TRUE))
 | 
						|
 | 
						|
# # ((I - 1) %*% nrow(A)^(seq_along(dim(A)) - 1) + 1)
 | 
						|
 | 
						|
# # p <- 3
 | 
						|
# # ord <- 4
 | 
						|
# # A <- array(seq_len(p^ord), rep(p, ord))
 | 
						|
 | 
						|
# # axis <- seq_len(nrow(A))
 | 
						|
# # grid <- expand.grid(c(list(rev(axis)), rep(list(axis), length(dim(A)) - 1)))
 | 
						|
# # array(rowSums(grid - 1), dim(A))
 | 
						|
 | 
						|
# # A[rowSums(grid - 1) < nrow(A)]
 | 
						|
 | 
						|
 | 
						|
 | 
						|
# # apply(indices, 1, function(i) do.call(`[`, c(list(A), as.list(i))))
 |