#' Compute get gradient of `L(V)` given a dataset `X`. #' #' @param X Data matrix. #' @param Y Responce. #' @param V Position to compute the gradient at, aka point on Stiefl manifold. #' @param h Bandwidth #' @param loss.only Boolean to only compute the loss, of \code{TRUE} a single #' value loss is returned and \code{envir} is ignored. #' @keywords internal #' @export grad <- function(X, Y, V, h, loss.out = FALSE, loss.log = FALSE, loss.only = FALSE) { # Get number of samples and dimension. n <- nrow(X) p <- ncol(X) # Compute lookup indexes for symmetrie, lower/upper # triangular parts and vectorization. pair.index <- elem.pairs(seq(n)) i <- pair.index[, 1] # `i` indices of `(i, j)` pairs j <- pair.index[, 2] # `j` indices of `(i, j)` pairs # Matrix of vectorized indices. (vec(index) -> seq) index <- matrix(seq(n * n), n, n) lower <- index[lower.tri(index)] upper <- t(index)[lower] # Create all pairewise differences of rows of `X`. X_diff <- X[i, , drop = F] - X[j, , drop = F] # Projection matrix onto `span(V)` Q <- diag(1, p) - (V %*% t(V)) # Vectorized distance matrix `D`. vecD <- rowSums((X_diff %*% Q)^2) # Weight matrix `W` (dnorm ... gaussean density function) W <- matrix(dnorm(0), n, n) W[lower] <- dnorm(vecD / h) # Set lower tri. part W[upper] <- t(W)[upper] # Mirror lower tri. to upper W <- sweep(W, 2, colSums(W), FUN = `/`) # Col-Normalize # Weighted `Y` momentums y1 <- Y %*% W # Result is 1D -> transposition irrelevant y2 <- Y^2 %*% W # Per example loss `L(V, X_i)` L <- y2 - y1^2 if (loss.out | loss.log | loss.only) { meanL <- mean(L) if (loss.out) { # Bubble environments up and write to loss variable, aka out param. loss <<- meanL } if (loss.log) { loss.history[epoch, attempt] <<- meanL } if (loss.only) { # Mean for total loss `L(V)`. return(meanL) } } # Vectorized Weights with forced symmetry vecS <- (L[i] - (Y[j] - y1[i])^2) * W[lower] vecS <- vecS + ((L[j] - (Y[i] - y1[j])^2) * W[upper]) # Compute scaling of `X` row differences vecS <- vecS * vecD # The gradient. G <- t(X_diff) %*% sweep(X_diff %*% V, 1, vecS, `*`) G <- (-2 / (n * h^2)) * G return(G) }