tensor_predictors/tensorPredictors/R/kpir_base.R

103 lines
3.8 KiB
R

#' (Slightly altered) old implementation
#'
#' @export
kpir.base <- function(X, Fy, p, t, k = 1L, r = 1L, d1 = 1L, d2 = 1L,
method = c("mle", "ls"),
eps1 = 1e-10, eps2 = 1e-10, max.iter = 500L,
logger = NULL
) {
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:
# # OLS estimate of the model `X = F_y B + epsilon`.
# B <- t(solve(crossprod(Fy), crossprod(Fy, X)))
### 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(t, 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(t, 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:(t * r)], t, r)
beta <- matrix(opt$par[(t * 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)
}