#' (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) }