64 lines
1.9 KiB
R
64 lines
1.9 KiB
R
|
#' Samples uniform from the Stiefel Manifold
|
||
|
|
#'
|
||
|
|
#' @param p row dim.
|
||
|
|
#' @param q col dim.
|
||
|
|
#' @return `(p, q)` semi-orthogonal matrix
|
||
|
|
#' @examples
|
||
|
|
#' V <- rStiefel(6, 4)
|
||
|
|
#' @export
|
||
|
|
rStiefl <- function(p, q) {
|
||
|
|
return(qr.Q(qr(matrix(rnorm(p * q, 0, 1), p, q))))
|
||
|
|
}
|
||
|
|
|
||
|
|
#' Null space basis of given matrix `V`
|
||
|
|
#'
|
||
|
|
#' @param V `(p, q)` matrix
|
||
|
|
#' @return Semi-orthogonal `(p, p - q)` matrix spaning the null space of `V`.
|
||
|
|
#' @keywords internal
|
||
|
|
#' @export
|
||
|
|
null <- function(V) {
|
||
|
|
tmp <- qr(V)
|
||
|
|
set <- if(tmp$rank == 0L) seq_len(ncol(V)) else -seq_len(tmp$rank)
|
||
|
|
return(qr.Q(tmp, complete=TRUE)[, set, drop=FALSE])
|
||
|
|
}
|
||
|
|
|
||
|
|
#' Creates a (numeric) matrix where each row contains
|
||
|
|
#' an element to element matching.
|
||
|
|
#' @param elements numeric vector of elements to match
|
||
|
|
#' @return matrix of size `(n * (n - 1) / 2, 2)` for a argument of lenght `n`.
|
||
|
|
#' @keywords internal
|
||
|
|
#' @export
|
||
|
|
elem.pairs <- function(elements) {
|
||
|
|
# Number of elements to match.
|
||
|
|
n <- length(elements)
|
||
|
|
# Create all combinations.
|
||
|
|
pairs <- cbind(rep(elements, each=n), rep(elements, n))
|
||
|
|
# Select unique combinations without self interaction.
|
||
|
|
return(pairs[pairs[, 1] < pairs[, 2], ])
|
||
|
|
}
|
||
|
|
|
||
|
|
#' Apply function to pairs of matrix rows or columns.
|
||
|
|
#'
|
||
|
|
#' \code{row.pair.apply} applies \code{FUN} to each unique row pair without self
|
||
|
|
#' interaction while \code{col.pair.apply} does the same for columns.
|
||
|
|
#' @param X Matrix.
|
||
|
|
#' @param FUN Function to apply to each pair.
|
||
|
|
#' @examples
|
||
|
|
#' X <- matrix(seq(12), 4, 3)
|
||
|
|
#' # matrix containing all row to row differences.
|
||
|
|
#' row.pair.apply(X, `-`)
|
||
|
|
#' @aliases row.pair.apply, col.pair.apply
|
||
|
|
#' @keywords internal
|
||
|
|
#' @export
|
||
|
|
row.pair.apply <- function(X, FUN) {
|
||
|
|
pairs <- elem.pairs(seq(nrow(X)))
|
||
|
|
return(FUN(X[pairs[, 1], ], X[pairs[, 2], ]))
|
||
|
|
}
|
||
|
|
#' @rdname row.pair.apply
|
||
|
|
#' @keywords internal
|
||
|
|
#' @export
|
||
|
|
col.pair.apply <- function(X, FUN) {
|
||
|
|
pairs <- elem.pairs(seq(ncol(X)))
|
||
|
|
return(FUN(X[, pairs[, 1]], X[, pairs[, 2]]))
|
||
|
|
}
|