add: extended dist.subspace to support list of kronecker product components as well as needing less memory,

add: if for cond.threshold if non-finite, allows to disable regularization,
fix: TSIR's mode-wise sample covariance scaling factor

tensorPredictors/R/dist_subspace.R

@@ -1,7 +1,7 @@
 #' Subspace distance
 #'
-#' @param A,B Basis matrices as representations of elements of the Grassmann
+#' @param As,Bs Basis matrices or list of Kronecker components of basis matrices
-#'  manifold.
+#' as representations of elements of the Grassmann manifold.
 #' @param is.ortho Boolean to specify if \eqn{A} and \eqn{B} are semi-orthogonal.
 #'   If false, the projection matrices are computed as
 #' \deqn{P_A = A (A' A)^{-1} A'}
@@ -14,36 +14,41 @@
 #'  subspaces of different dimensions" <arXiv:1407.0900>
 #'
 #' @export
-dist.subspace <- function (A, B, is.ortho = FALSE, normalize = FALSE,
+dist.subspace <- function (As, Bs, is.ortho = FALSE, normalize = FALSE,
     tol = sqrt(.Machine$double.eps)
 ) {
-    if (!is.matrix(A)) A <- as.matrix(A)
+    As <- if (is.list(As)) Map(as.matrix, As) else list(as.matrix(As))
-    if (!is.matrix(B)) B <- as.matrix(B)
+    Bs <- if (is.list(Bs)) Map(as.matrix, Bs) else list(as.matrix(Bs))
 
     if (!is.ortho) {
-        qrA <- qr(A, tol)
+        As <- Map(function(A) {
-        if (qrA$rank < ncol(A)) {
+            qrA <- qr(A, tol)
-            A <- qr.Q(qrA)[, abs(diag(qr.R(qrA))) > tol, drop = FALSE]
+            if (qrA$rank < ncol(A)) {
-        } else {
+                qr.Q(qrA)[, abs(diag(qr.R(qrA))) > tol, drop = FALSE]
-            A <- qr.Q(qrA)
+            } else {
-        }
+                qr.Q(qrA)
-        qrB <- qr(B, tol)
+            }
-        if (qrB$rank < ncol(B)) {
+        }, As)
-            B <- qr.Q(qrB)[, abs(diag(qr.R(qrB))) > tol, drop = FALSE]
+        Bs <- Map(function(B) {
-        } else {
+            qrB <- qr(B, tol)
-            B <- qr.Q(qrB)
+            if (qrB$rank < ncol(B)) {
-        }
+                qr.Q(qrB)[, abs(diag(qr.R(qrB))) > tol, drop = FALSE]
+            } else {
+                qr.Q(qrB)
+            }
+        }, Bs)
     }
 
-    PA <- tcrossprod(A, A)
+    rankA <- prod(sapply(As, ncol))
-    PB <- tcrossprod(B, B)
+    rankB <- prod(sapply(Bs, ncol))
 
-    if (normalize) {
+    c <- if (normalize) {
-        rankSum <- ncol(A) + ncol(B)
+        rankSum <- rankA + rankB
-        c <- 1 / sqrt(max(1, min(rankSum, 2 * nrow(A) - rankSum)))
+        sqrt(1 / max(1, min(rankSum, 2 * prod(sapply(As, nrow)) - rankSum)))
     } else {
-        c <- 1
+        1
     }
 
-    c * norm(PA - PB, type = "F")
+    s <- prod(mapply(function(A, B) sum(crossprod(A, B)^2), As, Bs))
+    c * sqrt(max(0, rankA + rankB - 2 * s))
 }

tensorPredictors/R/gmlm_tensor_normal.R

@@ -105,11 +105,14 @@ gmlm_tensor_normal <- function(X, F, sample.axis = length(dim(X)),
         # Computing `Omega_j`s, the j'th mode presition matrices, in conjunction
         # with regularization of the j'th mode covariance estimate `Sigma_j`
         for (j in seq_along(Sigmas)) {
-            # Compute min and max eigen values
+            # Regularize Covariances
-            min_max <- range(eigen(Sigmas[[j]], TRUE, TRUE)$values)
+            if (is.finite(cond.threshold)) {
-            # The condition is approximately `kappa(Sigmas[[j]]) > cond.threshold`
+                # Compute min and max eigen values
-            if (min_max[2] > cond.threshold * min_max[1]) {
+                min_max <- range(eigen(Sigmas[[j]], TRUE, TRUE)$values)
-                Sigmas[[j]] <- Sigmas[[j]] + diag(0.2 * min_max[2], nrow(Sigmas[[j]]))
+                # The condition is approximately `kappa(Sigmas[[j]]) > cond.threshold`
+                if (min_max[2] > cond.threshold * min_max[1]) {
+                    Sigmas[[j]] <- Sigmas[[j]] + diag(0.2 * min_max[2], nrow(Sigmas[[j]]))
+                }
             }
             # Compute (unconstraint but regularized) Omega_j as covariance inverse
             Omegas[[j]] <- solve(Sigmas[[j]])