78 lines
2.8 KiB
R
78 lines
2.8 KiB
R
#' Per mode (axis) alternating least squares estimate
|
|
#'
|
|
#' @param sample.axis index of the sample mode, a.k.a. observation axis index
|
|
#'
|
|
#' @export
|
|
kpir.ls <- function(X, Fy, max.iter = 20L, sample.axis = 1L,
|
|
eps = .Machine$double.eps, logger = NULL
|
|
) {
|
|
# Check if X and Fy have same number of observations
|
|
if (!is.array(Fy)) {
|
|
# scalar response case (add new axis of size 1)
|
|
dim(Fy) <- local({
|
|
dims <- rep(1, length(dim(X)))
|
|
dims[sample.axis] <- length(Fy)
|
|
dims
|
|
})
|
|
} else {
|
|
stopifnot(dim(X)[sample.axis] == dim(Fy)[sample.axis])
|
|
}
|
|
# Check dimensions
|
|
stopifnot(length(dim(X)) == length(dim(Fy)))
|
|
stopifnot(dim(X)[sample.axis] == dim(Fy)[sample.axis])
|
|
# and model constraints
|
|
stopifnot(all(dim(Fy) <= dim(X)))
|
|
|
|
# mode index sequence (exclude sample mode, a.k.a. observation axis)
|
|
modes <- seq_along(dim(X))[-sample.axis]
|
|
|
|
|
|
### Step 1: initial per mode estimates
|
|
alphas <- Map(function(mode, ncol) {
|
|
La.svd(mcrossprod(X, mode = mode), ncol)$u
|
|
}, modes, dim(Fy)[modes])
|
|
|
|
# # Scaling of alpha, such that `tr(alpha_i' alpha_i) = tr(alpha_j' alpha_j)``
|
|
# # for `i, j = 1, ..., r`.
|
|
# traces <- unlist(Map(function(alpha) sum(alpha^2)))
|
|
# alphas <- Map(`*`, prod(traces)^(1 / length(alphas)) / traces, alphas)
|
|
|
|
# Call history callback (logger) before the first iteration
|
|
if (is.function(logger)) { do.call(logger, c(0L, NA, rev(alphas))) }
|
|
|
|
|
|
### Step 2: iterate per mode (axis) least squares estimates
|
|
for (iter in seq_len(max.iter)) {
|
|
# cyclic iterate over modes
|
|
for (j in seq_along(modes)) {
|
|
# least squares solution for `alpha_j | alpha_i, i != j`
|
|
Z <- mlm(Fy, alphas[-j], modes = modes[-j])
|
|
alphas[[j]] <- t(solve(mcrossprod(Z, mode = modes[j]),
|
|
tcrossprod(mat(Z, modes[j]), mat(X, modes[j]))))
|
|
# TODO: alphas[[j]] <- t(solve(mcrossprod(Z, j), mcrossprod(Z, X, j)))
|
|
}
|
|
|
|
# # Scaling of alpha, such that `tr(alpha_i' alpha_i) = tr(alpha_j' alpha_j)``
|
|
# # for `i, j = 1, ..., r`.
|
|
# traces <- unlist(Map(function(alpha) sum(alpha^2)))
|
|
# alphas <- Map(`*`, prod(traces)^(1 / length(alphas)) / traces, alphas)
|
|
|
|
# Call logger (invoke history callback)
|
|
if (is.function(logger)) { do.call(logger, c(iter, NA, rev(alphas))) }
|
|
|
|
# TODO: add some kind of break condition
|
|
}
|
|
|
|
### Step 3: Moment estimates for `Delta_i`
|
|
# Residuals
|
|
R <- X - mlm(Fy, alphas, modes = modes)
|
|
# Moment estimates for `Delta_i`s
|
|
Deltas <- Map(mcrossprod, list(R), mode = modes)
|
|
Deltas <- Map(`*`, 1 / dim(X)[sample.axis], Deltas)
|
|
|
|
list(
|
|
alphas = structure(alphas, names = as.character(modes)),
|
|
Deltas = structure(Deltas, names = as.character(modes))
|
|
)
|
|
}
|