library(tensorPredictors) library(dplyr) library(ggplot2) ### Exec all methods for a given data set and collect logs ### sim <- function(X, Fy, shape, alpha.true, beta.true, max.iter = 500L) { # Logger creator logger <- function(name) { eval(substitute(function(iter, loss, alpha, beta, ...) { hist[iter + 1L, ] <<- c( iter = iter, loss = loss, dist = (dist <- dist.subspace(c(kronecker(alpha.true, beta.true)), c(kronecker(alpha, beta)))), dist.alpha = (dist.alpha <- dist.subspace(c(alpha.true), c(alpha))), dist.beta = (dist.beta <- dist.subspace(c( beta.true), c(beta ))), norm.alpha = norm(alpha, "F"), norm.beta = norm(beta, "F") ) cat(sprintf( "%3d | l = %-12.4f - dist = %-.4e - alpha(%d, %d) = %-.4e - beta(%d, %d) = %-.4e\n", iter, loss, dist, nrow(alpha), ncol(alpha), dist.alpha, nrow(beta), ncol(beta), dist.beta )) }, list(hist = as.symbol(paste0("hist.", name))))) } # Initialize logger history targets hist.base <- hist.new <- hist.momentum <- # hist.kron <- data.frame(iter = seq(0L, max.iter), loss = NA, dist = NA, dist.alpha = NA, dist.beta = NA, norm.alpha = NA, norm.beta = NA ) hist.kron <- NULL # TODO: fit kron version # Base (old) kpir.base(X, Fy, shape, max.iter = max.iter, logger = logger("base")) # New (simple Gradient Descent) kpir.new(X, Fy, shape, max.iter = max.iter, logger = logger("new")) # Gradient Descent with Nesterov Momentum kpir.momentum(X, Fy, shape, max.iter = max.iter, logger = logger("momentum")) # # Residual Covariance Kronecker product assumpton version # kpir.kron(X, Fy, shape, max.iter = max.iter, logger = logger("kron")) # Add method tags hist.base$type <- factor("base") hist.new$type <- factor("new") hist.momentum$type <- factor("momentum") # hist.kron$type <- factor("kron") # Combine results and return rbind(hist.base, hist.new, hist.momentum, hist.kron) } ## Generate some test data / DEBUG n <- 200 # Sample Size p <- sample(1:15, 1) # 11 q <- sample(1:15, 1) # 3 k <- sample(1:15, 1) # 7 r <- sample(1:15, 1) # 5 print(c(n, p, q, k, r)) hist <- NULL for (rep in 1:20) { alpha.true <- alpha <- matrix(rnorm(q * r), q, r) beta.true <- beta <- matrix(rnorm(p * k), p, k) y <- rnorm(n) Fy <- do.call(cbind, Map(function(slope, offset) { sin(slope * y + offset) }, head(rep(seq(1, ceiling(0.5 * k * r)), each = 2), k * r), head(rep(c(0, pi / 2), ceiling(0.5 * k * r)), k * r) )) Delta <- 0.5^abs(outer(seq_len(p * q), seq_len(p * q), `-`)) X <- tcrossprod(Fy, kronecker(alpha, beta)) + CVarE:::rmvnorm(n, sigma = Delta) hist.sim <- sim(X, Fy, shape = c(p, q, k, r), alpha.true, beta.true) hist.sim$repetition <- rep hist <- rbind(hist, hist.sim) } saveRDS(hist, file = "AR.rds") hist$repetition <- factor(hist$repetition) ggplot(hist, aes(x = iter, color = type, group = interaction(type, repetition))) + geom_line(aes(y = loss)) + geom_point(data = with(sub <- subset(hist, !is.na(loss)), aggregate(sub, list(type, repetition), tail, 1) ), aes(y = loss)) + labs( title = bquote(paste("Optimization Objective: negative log-likelihood ", l(hat(alpha), hat(beta)))), subtitle = bquote(paste(Delta[i][j] == 0.25, " * ", 0.5^abs(i - j), ", ", "20 repetitions, ", n == .(n), ", ", p == .(p), ", ", q == .(q), ", ", k == .(k), ", ", r == .(r))), x = "nr. of iterations", y = expression(l(hat(alpha), hat(beta))), color = "method" ) + theme(legend.position = "bottom") dev.print(png, file = "sim01_loss.png", width = 768, height = 768, res = 125) ggplot(hist, aes(x = iter, color = type, group = interaction(type, repetition))) + geom_line(aes(y = dist)) + geom_point(data = with(sub <- subset(hist, !is.na(dist)), aggregate(sub, list(type, repetition), tail, 1) ), aes(y = dist)) + labs( title = bquote(paste("Distance of estimate ", hat(B), " to true ", B == alpha %*% beta)), subtitle = bquote(paste(Delta[i][j] == 0.25, " * ", 0.5^abs(i - j), ", ", "20 repetitions, ", n == .(n), ", ", p == .(p), ", ", q == .(q), ", ", k == .(k), ", ", r == .(r))), x = "nr. of iterations", y = expression(abs(B * B^T - hat(B) * hat(B)^T)), color = "method" ) + theme(legend.position = "bottom") dev.print(png, file = "sim01_dist.png", width = 768, height = 768, res = 125) ggplot(hist, aes(x = iter, color = type, group = interaction(type, repetition))) + geom_line(aes(y = dist.alpha)) + geom_point(data = with(sub <- subset(hist, !is.na(dist.alpha)), aggregate(sub, list(type, repetition), tail, 1) ), aes(y = dist.alpha)) + labs( title = bquote(paste("Distance of estimate ", hat(alpha), " to true ", alpha)), subtitle = bquote(paste(Delta[i][j] == 0.25, " * ", 0.5^abs(i - j), ", ", "20 repetitions, ", n == .(n), ", ", p == .(p), ", ", q == .(q), ", ", k == .(k), ", ", r == .(r))), x = "nr. of iterations", y = expression(abs(alpha * alpha^T - hat(alpha) * hat(alpha)^T)), color = "method" ) + theme(legend.position = "bottom") dev.print(png, file = "sim01_dist_alpha.png", width = 768, height = 768, res = 125) ggplot(hist, aes(x = iter, color = type, group = interaction(type, repetition))) + geom_line(aes(y = dist.beta)) + geom_point(data = with(sub <- subset(hist, !is.na(dist.beta)), aggregate(sub, list(type, repetition), tail, 1) ), aes(y = dist.beta)) + labs( title = bquote(paste("Distance of estimate ", hat(beta), " to true ", beta)), subtitle = bquote(paste(Delta[i][j] == 0.25, " * ", 0.5^abs(i - j), ", ", "20 repetitions, ", n == .(n), ", ", p == .(p), ", ", q == .(q), ", ", k == .(k), ", ", r == .(r))), x = "nr. of iterations", y = expression(abs(beta * beta^T - hat(beta) * hat(beta)^T)), color = "method" ) + theme(legend.position = "bottom") dev.print(png, file = "sim01_dist_beta.png", width = 768, height = 768, res = 125) ggplot(hist, aes(x = iter, color = type, group = interaction(type, repetition))) + geom_line(aes(y = norm.alpha)) + geom_point(data = with(sub <- subset(hist, !is.na(norm.alpha)), aggregate(sub, list(type, repetition), tail, 1) ), aes(y = norm.alpha)) + labs( title = expression(paste("Norm of ", hat(alpha))), subtitle = bquote(paste(Delta[i][j] == 0.25, " * ", 0.5^abs(i - j), ", ", "20 repetitions, ", n == .(n), ", ", p == .(p), ", ", q == .(q), ", ", k == .(k), ", ", r == .(r))), x = "nr. of iterations", y = expression(abs(hat(alpha))[F]), color = "method" ) + theme(legend.position = "bottom") dev.print(png, file = "sim01_norm_alpha.png", width = 768, height = 768, res = 125) ggplot(hist, aes(x = iter, color = type, group = interaction(type, repetition))) + geom_line(aes(y = norm.beta)) + geom_point(data = with(sub <- subset(hist, !is.na(norm.beta)), aggregate(sub, list(type, repetition), tail, 1) ), aes(y = norm.beta)) + labs( title = expression(paste("Norm of ", hat(beta))), subtitle = bquote(paste(Delta[i][j] == 0.25, " * ", 0.5^abs(i - j), ", ", "20 repetitions, ", n == .(n), ", ", p == .(p), ", ", q == .(q), ", ", k == .(k), ", ", r == .(r))), x = "nr. of iterations", y = expression(abs(hat(beta))[F]), color = "method" ) + theme(legend.position = "bottom") dev.print(png, file = "sim01_norm_beta.png", width = 768, height = 768, res = 125) # local({ # par(mfrow = c(2, 3), oma = c(2, 1, 1, 1), mar = c(3.1, 2.1, 2.1, 1.1), lwd = 2) # plot(c(1, max.iter), range(c(hist.base$loss, hist.new$loss, hist.momentum$loss, hist.kron$loss), na.rm = TRUE), # type = "n", log = "x", main = "loss") # lines( hist.base$loss, col = 2) # lines( hist.new$loss, col = 3) # lines(hist.momentum$loss, col = 4) # lines( hist.kron$loss, col = 5) # yrange <- range(c(hist.base$step.size, hist.new$step.size, hist.momentum$step.size, hist.kron$step.size), # na.rm = TRUE) # plot(c(1, max.iter), yrange, # type = "n", log = "x", main = "step.size") # lines( hist.base$step.size, col = 2) # lines( hist.new$step.size, col = 3) # lines(hist.momentum$step.size, col = 4) # lines( hist.kron$step.size, col = 5) # # lines( hist.base$step.size, col = 4) # there is no step.size # plot(0, 0, type = "l", bty = "n", xaxt = "n", yaxt = "n") # legend("topleft", legend = c("Base", "GD", "GD + Momentum", "Kron + GD + Momentum"), col = 2:5, # lwd = par("lwd"), xpd = TRUE, horiz = FALSE, cex = 1.2, bty = "n", # x.intersp = 1, y.intersp = 1.5) # # xpd = TRUE makes the legend plot to the figure # plot(c(1, max.iter), range(c(hist.base$dist, hist.new$dist, hist.momentum$dist, hist.kron$dist), na.rm = TRUE), # type = "n", log = "x", main = "dist") # lines( hist.base$dist, col = 2) # lines( hist.new$dist, col = 3) # lines(hist.momentum$dist, col = 4) # lines( hist.kron$dist, col = 5) # plot(c(1, max.iter), range(c(hist.base$dist.alpha, hist.new$dist.alpha, hist.momentum$dist.alpha, hist.kron$dist.alpha), na.rm = TRUE), # type = "n", log = "x", main = "dist.alpha") # lines( hist.base$dist.alpha, col = 2) # lines( hist.new$dist.alpha, col = 3) # lines(hist.momentum$dist.alpha, col = 4) # lines( hist.kron$dist.alpha, col = 5) # plot(c(1, max.iter), range(c(hist.base$dist.beta, hist.new$dist.beta, hist.momentum$dist.beta, hist.kron$dist.beta), na.rm = TRUE), # type = "n", log = "x", main = "dist.beta") # lines( hist.base$dist.beta, col = 2) # lines( hist.new$dist.beta, col = 3) # lines(hist.momentum$dist.beta, col = 4) # lines( hist.kron$dist.beta, col = 5) # # par(fig = c(0, 1, 0, 1), oma = c(0, 0, 0, 0), mar = c(0, 0, 0, 0), new = TRUE) # # plot(0, 0, type = 'l', bty = 'n', xaxt = 'n', yaxt = 'n') # # legend('bottom', legend = c('GD', 'GD + Nesterov Momentum', 'Alternating'), col = 2:4, # # lwd = 5, xpd = TRUE, horiz = TRUE, cex = 1, seg.len = 1, bty = 'n') # # # xpd = TRUE makes the legend plot to the figure # }) # dev.print(png, file = "loss.png", width = 768, height = 768, res = 125) # with(list(a1 = alpha, a2 = fit.base$alpha, a3 = fit.new$alpha, a4 = fit.momentum$alpha, # b1 = beta, b2 = fit.base$beta, b3 = fit.new$beta, b4 = fit.momentum$beta), { # par(mfrow = c(2, 4)) # a2 <- sign(sum(sign(a1 * a2))) * a2 # a3 <- sign(sum(sign(a1 * a3))) * a3 # a4 <- sign(sum(sign(a1 * a4))) * a4 # b2 <- sign(sum(sign(b1 * b2))) * b2 # b3 <- sign(sum(sign(b1 * b3))) * b3 # b4 <- sign(sum(sign(b1 * b4))) * b4 # matrixImage(a1, main = expression(alpha)) # matrixImage(a2, main = expression(paste(hat(alpha)["Base"]))) # matrixImage(a3, main = expression(paste(hat(alpha)["GD"]))) # matrixImage(a4, main = expression(paste(hat(alpha)["GD+Nest"]))) # matrixImage(b1, main = expression(beta)) # matrixImage(b2, main = expression(paste(hat(beta)["Base"]))) # matrixImage(b3, main = expression(paste(hat(beta)["GD"]))) # matrixImage(b4, main = expression(paste(hat(beta)["GD+Nest"]))) # }) # dev.print(png, file = "estimates.png", width = 768, height = 768, res = 125) # with(list(d1 = Delta, d2 = fit.base$Delta, d3 = fit.new$Delta, d4 = fit.momentum$Delta), { # par(mfrow = c(2, 2)) # matrixImage(d1, main = expression(Delta)) # matrixImage(d2, main = expression(hat(Delta)["Base"])) # matrixImage(d3, main = expression(hat(Delta)["GD"])) # matrixImage(d4, main = expression(hat(Delta)["GD+Nest"])) # }) # dev.print(png, file = "Delta.png", width = 768, height = 768, res = 125) # with(list(a1 = alpha, a2 = fit.base$alpha, a3 = fit.new$alpha, a4 = fit.momentum$alpha, # b1 = beta, b2 = fit.base$beta, b3 = fit.new$beta, b4 = fit.momentum$beta), { # par(mfrow = c(2, 2)) # matrixImage(kronecker(a1, b1), main = expression(B)) # matrixImage(kronecker(a2, b2), main = expression(hat(B)["Base"])) # matrixImage(kronecker(a3, b3), main = expression(hat(B)["GD"])) # matrixImage(kronecker(a4, b4), main = expression(hat(B)["GD+Nest"])) # }) # dev.print(png, file = "B.png", width = 768, height = 768, res = 125) # with(list(a1 = alpha, a2 = fit.base$alpha, a3 = fit.new$alpha, a4 = fit.momentum$alpha, # b1 = beta, b2 = fit.base$beta, b3 = fit.new$beta, b4 = fit.momentum$beta), { # par(mfrow = c(3, 1), lwd = 1) # d2 <- kronecker(a1, b1) - kronecker(a2, b2) # d3 <- kronecker(a1, b1) - kronecker(a3, b3) # d4 <- kronecker(a1, b1) - kronecker(a4, b4) # xlim <- c(-1, 1) * max(abs(c(d2, d3, d4))) # breaks <- seq(xlim[1], xlim[2], len = 41) # hist(d2, main = expression(paste(base, (B - hat(B))[i])), # breaks = breaks, xlim = xlim, freq = FALSE) # lines(density(d2), col = 2) # abline(v = range(d2), lty = 2) # hist(d3, main = expression(paste(GD, (B - hat(B))[i])), # breaks = breaks, xlim = xlim, freq = FALSE) # lines(density(d3), col = 3) # abline(v = range(d3), lty = 2) # hist(d4, main = expression(paste(GD + Nest, (B - hat(B))[i])), # breaks = breaks, xlim = xlim, freq = FALSE) # lines(density(d4), col = 4) # abline(v = range(d4), lty = 2) # }) # dev.print(png, file = "hist.png", width = 768, height = 768, res = 125) # options(width = 300) # print(pr <- prof.tree::prof.tree("./Rprof.out"), limit = NULL # , pruneFun = function(x) x$percent > 0.01) # par(mfrow = c(2, 2)) # matrixImage(alpha, main = "alpha") # matrixImage(fit$alpha, main = "fit$alpha") # matrixImage(beta, main = "beta") # matrixImage(fit$beta, main = "fit$beta") # if (diff(dim(alpha) * dim(beta)) > 0) { # par(mfrow = c(2, 1)) # } else { # par(mfrow = c(1, 2)) # } # matrixImage(kronecker(alpha, beta), main = "kronecker(alpha, beta)") # matrixImage(kronecker(fit$alpha, fit$beta), main = "kronecker(fit$alpha, fit$beta)") # matrixImage(Delta, main = "Delta") # matrixImage(fit$Delta, main = "fit$Delta") # local({ # a <- (-1 * (sum(sign(fit$alpha) * sign(alpha)) < 0)) * fit$alpha / mean(fit$alpha^2) # b <- alpha / mean(alpha^2) # norm(a - b, "F") # }) # local({ # a <- (-1 * (sum(sign(fit$beta) * sign(beta)) < 0)) * fit$beta / mean(fit$beta^2) # b <- beta / mean(beta^2) # norm(a - b, "F") # }) # # Which Sequence? # x <- y <- 1 # replicate(40, x <<- (y <<- x + y) - x) # # Face-Splitting Product # n <- 100 # p <- 3 # q <- 500 # A <- matrix(rnorm(n * p), n) # B <- matrix(rnorm(n * q), n) # faceSplit <- function(A, B) { # C <- vapply(seq_len(ncol(A)), function(i) A[, i] * B, B) # dim(C) <- c(nrow(A), ncol(A) * ncol(B)) # C # } # all.equal( # tkhatriRao(A, B), # faceSplit(A, B) # ) # microbenchmark::microbenchmark( # tkhatriRao(A, B), # faceSplit(A, B) # ) # dist.kron <- function(a0, b0, a1, b1) { # sqrt(sum(a0^2) * sum(b0^2) - # 2 * sum(diag(crossprod(a0, a1))) * sum(diag(crossprod(b0, b1))) + # sum(a1^2) * sum(b1^2)) # } # alpha <- matrix(rnorm(q * r), q) # beta <- matrix(rnorm(p * k), p) # alpha.true <- matrix(rnorm(q * r), q) # beta.true <- matrix(rnorm(p * k), p) # all.equal( # dist.kron(alpha, beta, alpha.true, beta.true), # norm(kronecker(alpha, beta) - kronecker(alpha.true, beta.true), "F") # ) # A <- matrix(rnorm(p^2), p) # B <- matrix(rnorm(p^2), p) # tr <- function(A) sum(diag(A)) # tr(crossprod(A, B)) # tr(tcrossprod(B, A)) # tr(crossprod(A, A)) # tr(tcrossprod(A, A)) # sum(A^2) # alpha <- matrix(rnorm(q * r), q) # beta <- matrix(rnorm(p * k), p) # norm(kronecker(alpha, beta), "F")^2 # norm(alpha, "F")^2 * norm(beta, "F")^2 # tr(crossprod(kronecker(alpha, beta))) # tr(tcrossprod(kronecker(alpha, beta))) # tr(crossprod(kronecker(t(alpha), t(beta)))) # tr(crossprod(alpha)) * tr(crossprod(beta)) # tr(tcrossprod(alpha)) * tr(tcrossprod(beta)) # tr(crossprod(alpha)) * tr(tcrossprod(beta)) # sum(alpha^2) * sum(beta^2) # alpha <- matrix(rnorm(q * r), q) # beta <- matrix(rnorm(p * k), p) # alpha.true <- matrix(rnorm(q * r), q) # beta.true <- matrix(rnorm(p * k), p) # microbenchmark::microbenchmark( # norm(kronecker(alpha, beta), "F")^2, # norm(alpha, "F")^2 * norm(beta, "F")^2, # tr(crossprod(kronecker(alpha, beta))), # tr(tcrossprod(kronecker(alpha, beta))), # tr(crossprod(kronecker(t(alpha), t(beta)))), # tr(crossprod(alpha)) * tr(crossprod(beta)), # tr(tcrossprod(alpha)) * tr(tcrossprod(beta)), # tr(crossprod(alpha)) * tr(tcrossprod(beta)), # sum(alpha^2) * sum(beta^2), # setup = { # p <- sample(1:10, 1) # q <- sample(1:10, 1) # k <- sample(1:10, 1) # r <- sample(1:10, 1) # assign("alpha", matrix(rnorm(q * r), q), .GlobalEnv) # assign("beta", matrix(rnorm(p * k), p), .GlobalEnv) # assign("alpha.true", matrix(rnorm(q * r), q), .GlobalEnv) # assign("beta.true", matrix(rnorm(p * k), p), .GlobalEnv) # } # ) # p <- sample(1:15, 1) # 11 # q <- sample(1:15, 1) # 3 # k <- sample(1:15, 1) # 7 # r <- sample(1:15, 1) # 5 # A <- matrix(rnorm(q * r), q) # B <- matrix(rnorm(p * k), p) # a <- matrix(rnorm(q * r), q) # b <- matrix(rnorm(p * k), p) # all.equal( # kronecker(A + a, B + b), # kronecker(A, B) + kronecker(A, b) + kronecker(a, B) + kronecker(a, b) # ) # p <- 200L # n <- 100L # R <- matrix(rnorm(n * p), n) # A <- matrix(rnorm(p^2), p) # Base Matrix # B <- A + 0.01 * matrix(rnorm(p^2), p) # Distortion / Update of A # A.inv <- solve(A) # microbenchmark::microbenchmark( # solve = R %*% solve(B), # neumann.raw = R %*% (A.inv + A.inv %*% (A - B) %*% A.inv + A.inv %*% (A - B) %*% A.inv %*% (A - B) %*% A.inv), # neumann.fun = { # AD <- A.inv %*% (A - B) # res <- A.inv + AD %*% A.inv # res <- A.inv + AD %*% res # R %*% res # } # ) # all.equal( # A.inv + A.inv %*% (A - B) %*% A.inv + A.inv %*% (A - B) %*% A.inv %*% (A - B) %*% A.inv, # { # DA <- (A - B) %*% A.inv # res <- A.inv + A.inv %*% DA # res <- A.inv + res %*% DA # res # } # ) # all.equal( # A.inv + A.inv %*% (A - B) %*% A.inv + A.inv %*% (A - B) %*% A.inv %*% (A - B) %*% A.inv, # { # AD <- A.inv %*% (A - B) # res <- A.inv + AD %*% A.inv # res <- A.inv + AD %*% res # res # } # ) # ##### # sym <- function(A) A + t(A) # n <- 101 # p <- 7 # q <- 11 # r <- 3 # k <- 5 # R <- array(rnorm(n * p * q), dim = c(n = n, p = p, q = q)) # F <- array(rnorm(n * k * r), dim = c(n = n, k = k, r = r)) # alpha <- array(rnorm(q * r), dim = c(q = q, r = r)) # beta <- array(rnorm(p * k), dim = c(p = p, k = k)) # Delta.1 <- sym(matrix(rnorm(q * q), q, q)) # dim(Delta.1) <- c(q = q, q = q) # Delta.2 <- sym(matrix(rnorm(p * p), p, p)) # dim(Delta.2) <- c(p = p, p = p) # Delta <- kronecker(Delta.1, Delta.2) # grad.alpha.1 <- local({ # Di.1 <- solve(Delta.1) # Di.2 <- solve(Delta.2) # .R <- sapply(seq_len(n), function(i) tcrossprod(Di.1, R[i, , ]) %*% Di.2) # dim(.R) <- c(q, p, n) # .F <- sapply(seq_len(n), function(i) beta %*% F[i, , ]) # dim(.F) <- c(p, r, n) # .C <- sapply(seq_len(n), function(i) .R[i, , ] %*% .F[i, , ]) # dim(.C) <- c(n, q, r) # colSums(.C) # }) # grad.alpha.2 <- local({ # # Delta.1^-1 R' Delta.2^-1 # .R <- aperm(R, c(2, 1, 3)) # dim(.R) <- c(q, n * p) # .R <- solve(Delta.1) %*% .R # dim(.R) <- c(q, n, p) # .R <- aperm(.R, c(3, 2, 1)) # dim(.R) <- c(p, n * q) # .R <- solve(Delta.2) %*% .R # dim(.R) <- c(p, n, q) # .R <- aperm(.R, c(2, 3, 1)) # n x q x p # # beta F # .F <- aperm(F, c(2, 1, 3)) # dim(.F) <- c(k, n * r) # .F <- beta %*% .F # dim(.F) <- c(p, n, r) # .F <- aperm(.F, c(2, 1, 3)) # n x p x r # # (Delta.1^-1 R' Delta.2^-1) (beta F) # .R <- aperm(.R, c(1, 3, 2)) # dim(.R) <- c(n * p, q) # dim(.F) <- c(n * p, r) # crossprod(.R, .F) # }) # all.equal( # grad.alpha.1, # grad.alpha.2 # ) # all.equal({ # .R <- matrix(0, q, p) # Di.1 <- solve(Delta.1) # Di.2 <- solve(Delta.2) # for (i in 1:n) { # .R <- .R + Di.1 %*% t(R[i, , ]) %*% Di.2 # } # .R # }, { # .R <- R # Di.1 <- solve(Delta.1) # Di.2 <- solve(Delta.2) # .R <- sapply(seq_len(n), function(i) tcrossprod(Di.1, R[i, , ]) %*% Di.2) # dim(.R) <- c(q, p, n) # .R <- aperm(.R, c(3, 1, 2)) # colSums(.R) # }) # all.equal({ # Di.1 <- solve(Delta.1) # Di.2 <- solve(Delta.2) # .R <- sapply(seq_len(n), function(i) tcrossprod(Di.1, R[i, , ]) %*% Di.2) # dim(.R) <- c(q, p, n) # .R <- aperm(.R, c(3, 1, 2)) # .R # }, { # .R <- R # dim(.R) <- c(n * p, q) # .R <- .R %*% solve(Delta.1) # dim(.R) <- c(n, p, q) # .R <- aperm(.R, c(1, 3, 2)) # dim(.R) <- c(n * q, p) # .R <- .R %*% solve(Delta.2) # dim(.R) <- c(n, q, p) # .R # }) # all.equal({ # .F <- matrix(0, p, r) # for (i in 1:n) { # .F <- .F + beta %*% F[i, , ] # } # .F # }, { # .F <- apply(F, 1, function(Fi) beta %*% Fi) # dim(.F) <- c(p, r, n) # .F <- aperm(.F, c(3, 1, 2)) # colSums(.F) # }) # all.equal({ # .F <- apply(F, 1, function(Fi) beta %*% Fi) # dim(.F) <- c(p, r, n) # .F <- aperm(.F, c(3, 1, 2)) # colSums(.F) # }, { # .F <- aperm(F, c(1, 3, 2)) # dim(.F) <- c(n * r, k) # .F <- tcrossprod(.F, beta) # dim(.F) <- c(n, r, p) # t(colSums(.F)) # }) # all.equal({ # Di.1 <- solve(Delta.1) # Di.2 <- solve(Delta.2) # grad.alpha <- 0 # grad.beta <- 0 # dim(R) <- c(n, p, q) # dim(F) <- c(n, k, r) # for (i in 1:n) { # grad.alpha <- grad.alpha + ( # Di.1 %*% t(R[i, , ]) %*% Di.2 %*% beta %*% F[i, , ] # ) # grad.beta <- grad.beta + ( # Di.2 %*% R[i, , ] %*% Di.1 %*% alpha %*% t(F[i, , ]) # ) # } # g1 <- c(dim(grad.alpha), dim(grad.beta), grad.alpha, grad.beta) # }, { # # Note that the order is important since for grad.beta the residuals do NOT # # need to be transposes. # # left/right standardized residuals Delta_1^-1 R_i' Delta_2^-1 for i in 1:n # dim(R) <- c(n * p, q) # .R <- R %*% solve(Delta.1) # dim(.R) <- c(n, p, q) # .R <- aperm(.R, c(1, 3, 2)) # dim(.R) <- c(n * q, p) # .R <- .R %*% solve(Delta.2) # dim(.R) <- c(n, q, p) # # gradient with respect to beta # # Responces times beta (alpha f_i') # dim(F) <- c(n * k, r) # .F <- tcrossprod(F, alpha) # dim(.F) <- c(n, k, q) # .F <- aperm(.F, c(1, 3, 2)) # # Matricize # dim(.R) <- c(n * q, p) # dim(.F) <- c(n * q, k) # grad.beta <- crossprod(.R, .F) # # gradient with respect to beta # # Responces times alpha # dim(F) <- c(n, k, r) # .F <- aperm(F, c(1, 3, 2)) # dim(.F) <- c(n * r, k) # .F <- tcrossprod(.F, beta) # dim(.F) <- c(n, r, p) # .F <- aperm(.F, c(1, 3, 2)) # # Transpose stand. residuals # dim(.R) <- c(n, q, p) # .R <- aperm(.R, c(1, 3, 2)) # # Matricize # dim(.R) <- c(n * p, q) # dim(.F) <- c(n * p, r) # grad.alpha <- crossprod(.R, .F) # g2 <- c(dim(grad.alpha), dim(grad.beta), grad.alpha, grad.beta) # }) # microbenchmark::microbenchmark(R1 = { # Di.1 <- solve(Delta.1) # Di.2 <- solve(Delta.2) # grad.alpha <- 0 # matrix(0, q, r) # grad.beta <- 0 # matrix(0, p, k) # dim(R) <- c(n, p, q) # dim(F) <- c(n, k, r) # for (i in 1:n) { # grad.alpha <- grad.alpha + ( # Di.1 %*% t(R[i, , ]) %*% Di.2 %*% beta %*% F[i, , ] # ) # grad.beta <- grad.beta + ( # Di.2 %*% R[i, , ] %*% Di.1 %*% alpha %*% t(F[i, , ]) # ) # } # g1 <- c(dim(grad.alpha), dim(grad.beta), grad.alpha, grad.beta) # }, R3 = { # # Note that the order is important since for grad.beta the residuals do NOT # # need to be transposes. # # left/right standardized residuals Delta_1^-1 R_i' Delta_2^-1 for i in 1:n # dim(R) <- c(n * p, q) # .R <- R %*% solve(Delta.1) # dim(.R) <- c(n, p, q) # .R <- aperm(.R, c(1, 3, 2)) # dim(.R) <- c(n * q, p) # .R <- .R %*% solve(Delta.2) # dim(.R) <- c(n, q, p) # # gradient with respect to beta # # Responces times beta (alpha f_i') # dim(F) <- c(n * k, r) # .F <- tcrossprod(F, alpha) # dim(.F) <- c(n, k, q) # .F <- aperm(.F, c(1, 3, 2)) # # Matricize # dim(.R) <- c(n * q, p) # dim(.F) <- c(n * q, k) # grad.beta <- crossprod(.R, .F) # # gradient with respect to beta # # Responces times alpha # dim(F) <- c(n, k, r) # .F <- aperm(F, c(1, 3, 2)) # dim(.F) <- c(n * r, k) # .F <- tcrossprod(.F, beta) # dim(.F) <- c(n, r, p) # .F <- aperm(.F, c(1, 3, 2)) # # Transpose stand. residuals # dim(.R) <- c(n, q, p) # .R <- aperm(.R, c(1, 3, 2)) # # Matricize # dim(.R) <- c(n * p, q) # dim(.F) <- c(n * p, r) # grad.alpha <- crossprod(.R, .F) # g2 <- c(dim(grad.alpha), dim(grad.beta), grad.alpha, grad.beta) # }) # n <- 100 # p <- 7 # q <- 11 # k <- 3 # r <- 5 # X <- array(rnorm(n * p * q), dim = c(n = n, p = p, q = q)) # F <- array(rnorm(n * k * r), dim = c(n = n, k = k, r = r)) # alpha <- array(rnorm(q * r), dim = c(q = q, r = r)) # beta <- array(rnorm(p * k), dim = c(p = p, k = k)) # all.equal({ # R <- array(NA, dim = c(n, p, q)) # for (i in 1:n) { # R[i, , ] <- X[i, , ] - beta %*% F[i, , ] %*% t(alpha) # } # R # }, { # X - (F %x_3% alpha %x_2% beta) # }, check.attributes = FALSE) # microbenchmark::microbenchmark(base = { # R <- array(NA, dim = c(n, p, q)) # for (i in 1:n) { # R[i, , ] <- X[i, , ] - beta %*% F[i, , ] %*% t(alpha) # } # R # }, ttm = { # X - (F %x_3% alpha %x_2% beta) # }) # n <- 100; p <- 7; q <- 11; k <- 3; r <- 5 # sym <- function(x) t(x) + x # Di.1 <- sym(matrix(rnorm(q^2), q, q)) # Di.2 <- sym(matrix(rnorm(p^2), p, p)) # R <- array(rnorm(n, p, q), dim = c(n, p, q)) # F <- array(rnorm(n, k, r), dim = c(n, k, r)) # alpha <- matrix(rnorm(q * r), q, r) # beta <- matrix(rnorm(p * k), p, k) # all.equal({ # .R <- array(NA, dim = c(n, p, q)) # for (i in 1:n) { # .R[i, , ] <- Di.2 %*% R[i, , ] %*% Di.1 # } # .R # }, { # R %x_3% Di.1 %x_2% Di.2 # }) # all.equal({ # .Rt <- array(NA, dim = c(n, q, p)) # for (i in 1:n) { # .Rt[i, , ] <- Di.1 %*% t(R[i, , ]) %*% Di.2 # } # .Rt # }, { # .Rt <- R %x_3% Di.1 %x_2% Di.2 # aperm(.Rt, c(1, 3, 2)) # }) # all.equal({ # .Fa <- array(NA, dim = c(n, q, k)) # for (i in 1:n) { # .Fa[i, , ] <- alpha %*% t(F[i, , ]) # } # .Fa # }, { # aperm(F %x_3% alpha, c(1, 3, 2)) # }) # all.equal({ # .Fb <- array(NA, dim = c(n, p, r)) # for (i in 1:n) { # .Fb[i, , ] <- beta %*% F[i, , ] # } # .Fb # }, { # F %x_2% beta # }) # all.equal({ # .F <- array(NA, dim = c(n, p, q)) # for (i in 1:n) { # .F[i, , ] <- beta %*% F[i, , ] %*% t(alpha) # } # .F # }, { # F %x_3% alpha %x_2% beta # }) # all.equal({ # .Ga <- 0 # for (i in 1:n) { # .Ga <- .Ga + Di.1 %*% t(R[i, , ]) %*% Di.2 %*% beta %*% F[i, , ] # } # .Ga # }, { # .R <- R %x_3% Di.1 %x_2% Di.2 # dim(.R) <- c(n * p, q) # .Fb <- F %x_2% beta # dim(.Fb) <- c(n * p, r) # crossprod(.R, .Fb) # }) # all.equal({ # .Gb <- 0 # for (i in 1:n) { # .Gb <- .Gb + Di.2 %*% R[i, , ] %*% Di.1 %*% alpha %*% t(F[i, , ]) # } # .Gb # }, { # .Rt <- aperm(R %x_3% Di.1 %x_2% Di.2, c(1, 3, 2)) # dim(.Rt) <- c(n * q, p) # .Fa <- aperm(F %x_3% alpha, c(1, 3, 2)) # dim(.Fa) <- c(n * q, k) # crossprod(.Rt, .Fa) # }) # all.equal({ # .Ga <- 0 # for (i in 1:n) { # .Ga <- .Ga + Di.1 %*% t(R[i, , ]) %*% Di.2 %*% beta %*% F[i, , ] # } # .Gb <- 0 # for (i in 1:n) { # .Gb <- .Gb + Di.2 %*% R[i, , ] %*% Di.1 %*% alpha %*% t(F[i, , ]) # } # c(.Ga, .Gb) # }, { # .R <- R %x_3% Di.1 %x_2% Di.2 # .Fb <- F %x_2% beta # .Fa <- aperm(F %x_3% alpha, c(1, 3, 2)) # dim(.R) <- c(n * p, q) # dim(.Fb) <- c(n * p, r) # .Ga <- crossprod(.R, .Fb) # dim(.R) <- c(n, p, q) # .R <- aperm(.R, c(1, 3, 2)) # dim(.R) <- c(n * q, p) # dim(.Fa) <- c(n * q, k) # .Gb <- crossprod(.R, .Fa) # c(.Ga, .Gb) # }) # all.equal({ # .Ga <- 0 # for (i in 1:n) { # .Ga <- .Ga + Di.1 %*% t(R[i, , ]) %*% Di.2 %*% beta %*% F[i, , ] # } # .Gb <- 0 # for (i in 1:n) { # .Gb <- .Gb + Di.2 %*% R[i, , ] %*% Di.1 %*% alpha %*% t(F[i, , ]) # } # c(.Ga, .Gb) # }, { # .R <- R %x_3% Di.1 %x_2% Di.2 # .Ga <- tcrossprod(mat(.R, 3), mat(F %x_2% beta, 3)) # .Gb <- tcrossprod(mat(.R, 2), mat(F %x_3% alpha, 2)) # c(.Ga, .Gb) # }) # n <- 101; p <- 5; q <- 7 # sym <- function(x) crossprod(x) # D1 <- sym(matrix(rnorm(q^2), q, q)) # D2 <- sym(matrix(rnorm(p^2), p, p)) # X <- tensorPredictors:::rmvnorm(n, sigma = kronecker(D1, D2)) # dim(X) <- c(n, p, q) # D1.hat <- tcrossprod(mat(X, 3)) / n # D2.hat <- tcrossprod(mat(X, 2)) / n # local({ # par(mfrow = c(2, 2)) # matrixImage(D1, main = "D1") # matrixImage(D1.hat, main = "D1.hat") # matrixImage(D2, main = "D2") # matrixImage(D2.hat, main = "D2.hat") # }) # sum(X^2) / n # sum(diag(D1.hat)) # sum(diag(D2.hat)) # sum(diag(kronecker(D1, D2))) # sum(diag(kronecker(D1.hat / sqrt(sum(diag(D1.hat))), # D2.hat / sqrt(sum(diag(D1.hat)))))) # all.equal({ # mat(X, 1) %*% kronecker(D1.hat, D2.hat) # }, { # mat(X %x_3% D1.hat %x_2% D2.hat, 1) # }) # all.equal({ # C <- mat(X, 1) %*% kronecker(D1.hat, D2.hat) * (n / sum(X^2)) # dim(C) <- c(n, p, q) # C # }, { # (X %x_3% D1.hat %x_2% D2.hat) / sum(diag(D1.hat)) # }) # D.1 <- tcrossprod(mat(X, 3)) # D.2 <- tcrossprod(mat(X, 2)) # tr <- sum(diag(D.1)) # D.1 <- D.1 / sqrt(n * tr) # D.2 <- D.2 / sqrt(n * tr) # sum(diag(kronecker(D1, D2))) # sum(diag(kronecker(D.1, D.2))) # det(kronecker(D1, D2)) # det(kronecker(D.1, D.2)) # det(D.1)^p * det(D.2)^q # log(det(kronecker(D.1, D.2))) # p * log(det(D.1)) + q * log(det(D.2))