61 lines
1.9 KiB
R
61 lines
1.9 KiB
R
#' Tensor Times Matrix (n-mode tensor matrix product)
|
|
#'
|
|
#' @param T array of order at least \code{mode}
|
|
#' @param M matrix, the right hand side of the mode product such that
|
|
#' \code{ncol(M)} equals \code{dim(T)[mode]} if \code{transposed} is false,
|
|
#' otherwise the dimension matching is \code{nrow(M)} to \code{dim(T)[mode]}.
|
|
#' @param mode the mode of the product in the range \code{1:length(dim(T))}
|
|
#' @param transposed boolean to multiply with the transposed of \code{M}
|
|
#'
|
|
#' @returns multi-dimensional array of the same order as \code{T} with
|
|
#' \code{mode} dimension equal to \code{nrow(M)} or \code{ncol(M)} if
|
|
#' \code{transposed} is true.
|
|
#'
|
|
#' @examples
|
|
#' for (mode in 1:4) {
|
|
#' dimA <- sample.int(10, 4, replace = TRUE)
|
|
#' A <- array(rnorm(prod(dimA)), dim = dimA)
|
|
#' nrowB <- sample.int(10, 1)
|
|
#' B <- matrix(rnorm(nrowB * dimA[mode]), nrowB)
|
|
#'
|
|
#' C <- ttm(A, B, mode)
|
|
#'
|
|
#' dimC <- ifelse(seq_along(dims) != mode, dimA, nrowB)
|
|
#' C.ref <- mat(B %*% mat(A, mode), mode, dims = dimC, inv = TRUE)
|
|
#'
|
|
#' stopifnot(all.equal(C, C.ref))
|
|
#' }
|
|
#'
|
|
#' for (mode in 1:4) {
|
|
#' dimA <- sample.int(10, 4, replace = TRUE)
|
|
#' A <- array(rnorm(prod(dimA)), dim = dimA)
|
|
#' ncolB <- sample.int(10, 1)
|
|
#' B <- matrix(rnorm(dimA[mode] * ncolB), dimA[mode])
|
|
#'
|
|
#' C <- ttm(A, B, mode, transposed = TRUE)
|
|
#'
|
|
#' C.ref <- ttm(A, t(B), mode)
|
|
#'
|
|
#' stopifnot(all.equal(C, C.ref))
|
|
#' }
|
|
#'
|
|
#' @export
|
|
ttm <- function(T, M, mode = length(dim(T)), transposed = FALSE) {
|
|
storage.mode(T) <- storage.mode(M) <- "double"
|
|
dim(M) <- c(NROW(M), NCOL(M))
|
|
.Call("C_ttm", T, M, as.integer(mode), as.logical(transposed))
|
|
}
|
|
|
|
#' @rdname ttm
|
|
#' @export
|
|
`%x_1%` <- function(T, M) ttm(T, M, 1L)
|
|
#' @rdname ttm
|
|
#' @export
|
|
`%x_2%` <- function(T, M) ttm(T, M, 2L)
|
|
#' @rdname ttm
|
|
#' @export
|
|
`%x_3%` <- function(T, M) ttm(T, M, 3L)
|
|
#' @rdname ttm
|
|
#' @export
|
|
`%x_4%` <- function(T, M) ttm(T, M, 4L)
|