tensor_predictors/tensorPredictors/R/kpir_base.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)
}