GMLM.tex: Fisher Information,

add: ttt,
fix: ttm - allow vector as p x 1 matrix,
add: num_deriv2

tensorPredictors/NAMESPACE

@@ -47,11 +47,13 @@ export(mkm)
 export(mlm)
 export(mtvk)
 export(num.deriv)
+export(num.deriv2)
 export(reduce)
 export(rowKronecker)
 export(rtensornorm)
 export(tensor_predictor)
 export(ttm)
+export(ttt)
 export(vech)
 export(vech.index)
 export(vech.pinv)

tensorPredictors/R/GMLM.R

@@ -32,10 +32,12 @@ make.gmlm.family <- function(name) {
                 # Extract main mode covariance directions
                 # Note: (the directions are transposed!)
                 XDirs <- Map(function(Sigma) {
-                    with(La.svd(Sigma, nu = 0), sqrt(d) * vt)
+                    SVD <- La.svd(Sigma, nu = 0)
+                    sqrt(SVD$d) * SVD$vt
                 }, XSigmas)
                 YDirs <- Map(function(Sigma) {
-                    with(La.svd(Sigma, nu = 0), sqrt(d) * vt)
+                    SVD <- La.svd(Sigma, nu = 0)
+                    sqrt(SVD$d) * SVD$vt
                 }, YSigmas)
 
                 alphas <- Map(function(xdir, ydir) {
@@ -80,7 +82,6 @@ make.gmlm.family <- function(name) {
                 # retrieve dimensions
                 n <- tail(dim(X), 1)        # sample size
                 p <- head(dim(X), -1)       # predictor dimensions
-                q <- head(dim(Fy), -1)      # response dimensions
                 r <- length(p)              # single predictor/response tensor order
 
                 ## "Inverse" Link: Tensor Normal Specific
@@ -139,10 +140,12 @@ make.gmlm.family <- function(name) {
                 # Extract main mode covariance directions
                 # Note: (the directions are transposed!)
                 XDirs <- Map(function(Sigma) {
-                    with(La.svd(Sigma, nu = 0), sqrt(d) * vt)
+                    SVD <- La.svd(Sigma, nu = 0)
+                    sqrt(SVD$d) * SVD$vt
                 }, XSigmas)
                 YDirs <- Map(function(Sigma) {
-                    with(La.svd(Sigma, nu = 0), sqrt(d) * vt)
+                    SVD <- La.svd(Sigma, nu = 0)
+                    sqrt(SVD$d) * SVD$vt
                 }, YSigmas)
 
                 alphas <- Map(function(xdir, ydir) {
@@ -158,42 +161,6 @@ make.gmlm.family <- function(name) {
                 )
             }
 
-            # initialize <- function(X, Fy) {
-            #     r <- length(dim(X)) - 1L
-
-            #     # Mode-Covariances
-            #     XSigmas <- mcov(X, sample.axis = r + 1L)
-            #     YSigmas <- mcov(Fy, sample.axis = r + 1L)
-
-            #     # Extract main mode covariance directions
-            #     # Note: (the directions are transposed!)
-            #     XDirs <- Map(function(Sigma) {
-            #         with(La.svd(Sigma, nu = 0), sqrt(d) * vt)
-            #     }, XSigmas)
-            #     YDirs <- Map(function(Sigma) {
-            #         with(La.svd(Sigma, nu = 0), sqrt(d) * vt)
-            #     }, YSigmas)
-
-            #     alphas <- Map(function(xdir, ydir) {
-            #         s <- min(ncol(xdir), nrow(ydir))
-            #         crossprod(xdir[seq_len(s), , drop = FALSE],
-            #                   ydir[seq_len(s), , drop = FALSE])
-            #     }, XDirs, YDirs)
-
-            #     # Scatter matrices from Residuals (intercept not considered)
-            #     Deltas <- mcov(X - mlm(Fy, alphas), sample.axis = r + 1L)
-            #     Omegas <- Map(solve, Deltas)
-
-            #     # and the intercept
-            #     eta1 <- mlm(rowMeans(X, dims = r), Deltas)
-
-            #     list(
-            #         eta1 = eta1,
-            #         alphas = alphas,
-            #         Omegas = Omegas
-            #     )
-            # }
-
             params <- function(Fy, eta1, alphas, Omegas, c1 = 1, c2 = 1) {
                 # number of observations
                 n <- tail(dim(Fy), 1)
@@ -243,7 +210,6 @@ make.gmlm.family <- function(name) {
                 # retrieve dimensions
                 n <- tail(dim(X), 1)        # sample size
                 p <- head(dim(X), -1)       # predictor dimensions
-                q <- head(dim(Fy), -1)      # response dimensions
                 r <- length(p)              # single predictor/response tensor order
 
                 ## "Inverse" Link: Ising Model Specific

tensorPredictors/R/num_deriv.R

@@ -19,3 +19,18 @@ num.deriv <- function(F, X, h = 1e-6, sym = FALSE) {
         })
     }
 }
+
+#' Second numeric derivative
+#'
+#' @export
+num.deriv2 <- function(F, X, Y, h = 1e-6, symX = FALSE, symY = FALSE) {
+    if (missing(Y)) {
+        num.deriv(function(x) {
+            num.deriv(function(z) F(z), x, h = h, sym = symX)
+        }, X, h = h, sym = symX)
+    } else {
+        num.deriv(function(y) {
+            num.deriv(function(x) F(x, y), X, h = h, sym = symX)
+        }, Y, h = h, sym = symY)
+    }
+}

tensorPredictors/R/ttm.R

@@ -14,6 +14,7 @@
 #' @export
 ttm <- function(T, M, mode = length(dim(T)), transposed = FALSE) {
     storage.mode(T) <- storage.mode(M) <- "double"
+    dim(M) <- c(NROW(M), NCOL(M))
     .Call("C_ttm", T, M, as.integer(mode), as.logical(transposed))
 }
 

tensorPredictors/R/ttt.R

@@ -0,0 +1,14 @@
+#' Tensor Times Tensor
+#'
+#' @examples
+#' A <- array(rnorm(3 * 7 * 11 * 17), dim = c(3, 7, 11, 17))
+#' B <- array(rnorm(17 * 2 * 11 * 5 * 7), dim = c(17, 2, 11, 5, 7))
+#'
+#' ttt(A, B, 2:4, c(5, 3, 1))
+#'
+#' @export
+ttt <- function(A, B, modesA, modesB = modesA, dimsA = dim(A), dimsB = dim(B)) {
+    R <- crossprod(mat(A, modesA, dimsA), mat(B, modesB, dimsB))
+    dim(R) <- c(dim(A)[-modesA], dim(B)[-modesB])
+    R
+}