daniel
/
tensor_predictors
1
0
Fork 0
Code Issues Pull Requests Releases 1 Wiki Activity

GMLM.tex: Fisher Information, 

add: ttt,
fix: ttm - allow vector as p x 1 matrix,
add: num_deriv2
This commit is contained in:
Daniel Kapla 2022-10-25 17:00:24 +02:00
parent cc9222cb62
commit 79f16c58dc
6 changed files with 947 additions and 286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1137
LaTeX/GMLM.tex
View File

File diff suppressed because it is too large Load Diff

2
tensorPredictors/NAMESPACE
View File

@ -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)

50
tensorPredictors/R/GMLM.R
View File

@ -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

15
tensorPredictors/R/num_deriv.R
View File

@ -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)
}
}

1
tensorPredictors/R/ttm.R
View File

@ -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))
}

14
tensorPredictors/R/ttt.R Normal file
View File

@ -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
}