137 lines
4.9 KiB
R
137 lines
4.9 KiB
R
#' (Slightly altered) old implementation
|
|
#'
|
|
#' @export
|
|
kpir.base <- function(X, Fy, shape = c(dim(X)[-1], dim(Fy[-1])),
|
|
method = c("mle", "ls"),
|
|
eps1 = 1e-10, eps2 = 1e-10, max.iter = 500L,
|
|
logger = NULL
|
|
) {
|
|
|
|
# Check if X and Fy have same number of observations
|
|
stopifnot(nrow(X) == NROW(Fy))
|
|
n <- nrow(X) # Number of observations
|
|
|
|
# Get and check predictor dimensions
|
|
if (length(dim(X)) == 2L) {
|
|
stopifnot(!missing(shape))
|
|
stopifnot(ncol(X) == prod(shape[1:2]))
|
|
p <- as.integer(shape[1]) # Predictor "height"
|
|
q <- as.integer(shape[2]) # Predictor "width"
|
|
} else if (length(dim(X)) == 3L) {
|
|
p <- dim(X)[2]
|
|
q <- dim(X)[3]
|
|
dim(X) <- c(n, p * q)
|
|
} else {
|
|
stop("'X' must be a matrix or 3-tensor")
|
|
}
|
|
|
|
# Get and check response dimensions
|
|
if (!is.array(Fy)) {
|
|
Fy <- as.array(Fy)
|
|
}
|
|
if (length(dim(Fy)) == 1L) {
|
|
k <- r <- 1L
|
|
dim(Fy) <- c(n, 1L)
|
|
} else if (length(dim(Fy)) == 2L) {
|
|
stopifnot(!missing(shape))
|
|
stopifnot(ncol(Fy) == prod(shape[3:4]))
|
|
k <- as.integer(shape[3]) # Response functional "height"
|
|
r <- as.integer(shape[4]) # Response functional "width"
|
|
} else if (length(dim(Fy)) == 3L) {
|
|
k <- dim(Fy)[2]
|
|
r <- dim(Fy)[3]
|
|
dim(Fy) <- c(n, k * r)
|
|
} else {
|
|
stop("'Fy' must be a vector, matrix or 3-tensor")
|
|
}
|
|
|
|
log.likelihood <- function(par, X, Fy, Delta.inv, da, db) {
|
|
alpha <- matrix(par[1:prod(da)], da[1L])
|
|
beta <- matrix(par[(prod(da) + 1):length(par)], db[1L])
|
|
error <- X - tcrossprod(Fy, kronecker(alpha, beta))
|
|
sum(error * (error %*% Delta.inv))
|
|
}
|
|
|
|
# Validate method using unexact matching.
|
|
method <- match.arg(method)
|
|
|
|
### Step 1: (Approx) Least Squares solution for `X = Fy B' + epsilon`
|
|
cpFy <- crossprod(Fy)
|
|
if (n <= k * r || qr(cpFy)$rank < k * r) {
|
|
# In case of under-determined system replace the inverse in the normal
|
|
# equation by the Moore-Penrose Pseudo Inverse
|
|
B <- t(matpow(cpFy, -1) %*% crossprod(Fy, X))
|
|
} else {
|
|
# Compute OLS estimate by the Normal Equation
|
|
B <- t(solve(cpFy, crossprod(Fy, X)))
|
|
}
|
|
|
|
# Estimate alpha, beta as nearest kronecker approximation.
|
|
c(alpha, beta) %<-% approx.kronecker(B, c(q, r), c(p, k))
|
|
|
|
if (method == "ls") {
|
|
# Estimate Delta.
|
|
B <- kronecker(alpha, beta)
|
|
rank <- if (ncol(Fy) == 1) 1L else qr(Fy)$rank
|
|
resid <- X - tcrossprod(Fy, B)
|
|
Delta <- crossprod(resid) / (nrow(X) - rank)
|
|
|
|
} else { # mle
|
|
B <- kronecker(alpha, beta)
|
|
|
|
# Compute residuals
|
|
resid <- X - tcrossprod(Fy, B)
|
|
|
|
# Estimate initial Delta.
|
|
Delta <- crossprod(resid) / nrow(X)
|
|
|
|
# call logger with initial starting value
|
|
if (is.function(logger)) {
|
|
# Transformed Residuals (using `matpow` as robust inversion algo,
|
|
# uses Moore-Penrose Pseudo Inverse in case of singular `Delta`)
|
|
resid.trans <- resid %*% matpow(Delta, -1)
|
|
loss <- 0.5 * (nrow(X) * log(det(Delta)) + sum(resid.trans * resid))
|
|
logger(0L, loss, alpha, beta, Delta, NA)
|
|
}
|
|
|
|
for (iter in 1:max.iter) {
|
|
# Optimize log-likelihood for alpha, beta with fixed Delta.
|
|
opt <- optim(c(alpha, beta), log.likelihood, gr = NULL,
|
|
X, Fy, matpow(Delta, -1), c(q, r), c(p, k))
|
|
# Store previous alpha, beta and Delta (for break consition).
|
|
Delta.last <- Delta
|
|
B.last <- B
|
|
# Extract optimized alpha, beta.
|
|
alpha <- matrix(opt$par[1:(q * r)], q, r)
|
|
beta <- matrix(opt$par[(q * r + 1):length(opt$par)], p, k)
|
|
# Calc new Delta with likelihood optimized alpha, beta.
|
|
B <- kronecker(alpha, beta)
|
|
resid <- X - tcrossprod(Fy, B)
|
|
Delta <- crossprod(resid) / nrow(X)
|
|
|
|
# call logger before break condition check
|
|
if (is.function(logger)) {
|
|
# Transformed Residuals (using `matpow` as robust inversion algo,
|
|
# uses Moore-Penrose Pseudo Inverse in case of singular `Delta`)
|
|
resid.trans <- resid %*% matpow(Delta, -1)
|
|
loss <- 0.5 * (nrow(X) * log(det(Delta)) + sum(resid.trans * resid))
|
|
logger(iter, loss, alpha, beta, Delta, NA)
|
|
}
|
|
|
|
# Check break condition 1.
|
|
if (norm(Delta - Delta.last, "F") < eps1 * norm(Delta, "F")) {
|
|
# Check break condition 2.
|
|
if (norm(B - B.last, "F") < eps2 * norm(B, "F")) {
|
|
break
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# calc final loss
|
|
resid.trans <- resid %*% matpow(Delta, -1)
|
|
loss <- 0.5 * (nrow(X) * log(det(Delta)) + sum(resid.trans * resid))
|
|
|
|
list(loss = loss, alpha = alpha, beta = beta, Delta = Delta)
|
|
}
|