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

Merge branch 'master' of https://git.art-ist.cc/daniel/tensor_predictors

This commit is contained in:
Daniel Kapla 2022-12-06 15:15:02 +01:00
parent ed7b913de7 cbe779d1e0
commit 40132c2565
2 changed files with 55 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
mvbernoulli/src/ising_model.cpp
View File

@ -310,7 +310,7 @@ Rcpp::NumericVector ising_marginal_probs(const VechView& theta) {
return score;
}
//' Natural parameters from the sufficient conditional probability statistis `pi`
//' Natural parameters from the sufficient conditional probability statistic `pi`
//'
//' Computes the natural parameters `theta` of the Ising model from zero
//' conditioned probabilites for single and two way effects.
@ -348,7 +348,7 @@ Rcpp::NumericVector ising_theta_from_cond_prob(const VechView& pi) {
return theta;
}
//' Computes the log-lokelihood at natural parameters `theta` of the Ising model
//' Computes the log-likelihood at natural parameters `theta` of the Ising model
//' given a set of observations `Y`
//'
//' l(theta) = log(p_0(theta)) + n^-1 sum_i vech(y_i y_i')' theta
@ -583,6 +583,8 @@ Rcpp::NumericVector ising_conditional_score(const Rcpp::NumericMatrix& alpha,
// as the garbage collector stack gets out of sync.
// SEE: https://stackoverflow.com/questions/42119609/how-to-handle-mismatching-in-calling-convention-in-r-and-c-using-rcpp
//
// NOTE: The below algorithm implements the _old_ `theta` to `eta` relation
//
// // [[Rcpp::export(rng = false)]]
// Rcpp::NumericVector ising_conditional_score_mt(const Rcpp::NumericMatrix& alpha,
// const Rcpp::NumericMatrix& X, const MVBinary& Y

61
tensorPredictors/R/make_gmlm_family.R
View File

@ -132,17 +132,58 @@ make.gmlm.family <- function(name) {
q <- head(dim(Fy), -1) # response dimensions
r <- length(p) # single predictor/response tensor order
# Hij = Cov(ti(X) %x% tj(X) | Y = y), i, j = 1, 2
H11 <- Reduce(`%x%`, rev(Map(solve, Omegas))) # covariance
# 3rd central moment is zero
H12 <- H21 <- 0
# 4th moment by "Isserlis' theorem" a.k.a. "Wick's theorem"
H22 <- kronecker(H11, H11)
dim(H22) <- rep(prod(p), 4)
H22 <- H22 + aperm(H22, c(1, 3, 2, 4)) + aperm(H22, c(1, 3, 2, 4))
# Note: independent of Y
Deltas <- Map(solve, Omegas)
dim(H11) <- c(p, p)
dim(H22) <- c(p, p, p, p)
# Conditional Mean E1 = mu_y = E[X | Y = y]
# Get the i#th observation from Fy
FyGet <- function(i) {
obs <- eval(str2lang(paste(
"Fy[",
paste(rep(",", r), collapse = ""),
"i, drop = FALSE]"
, collapse = "")))
dim(obs) <- head(dim(obs), -1)
obs
}
E1 <- mlm(mlm(Fy, alphas) + c(eta1), Deltas)
## Hij = Cov(t_i(X), t_j(X) | Y = y) for i, j = 1, 2
# = partial^2 b(eta_y) / partial eta_yi partial eta_yj
#
# Cov(vec(X) | Y = y)
# Note: Independent of Y
H11 <- Reduce(`%x%`, rev(Deltas))
# Cov(vec(X), vec(X) %x% vec(X) | Y = y)
# = (mu_y %o% Sigma)_(3, (1, 2)) + (mu_y %o% Sigma)_(3, (2, 1))
# = (Sigma %o% mu_y)_(1, (2, 3)) + (Sigma %o% mu_y)_(1, (3, 2))
H12 <- outer(H11, E1)
H12 <- H12 + aperm(H12, c(1, 3, 2))
H21 <- aperm(H12, c(2, 3, 1))
# H22 = Cov(vec X %x% vec X | Y = y)
H22 <- local({
# mu_i %o% mu_i %o% Sigma + Sigma %o% Sigma + Sigma %o% mu_i %o% mu_i
h22 <- outer(outer(E1, E1), H11) + outer(H11, H11) + outer(H11, outer(E1, E1))
aperm(h22, c(1, 3, 2, 4)) + aperm(h22, c(1, 3, 4, 2))
})
# # Hij = Cov(ti(X) %x% tj(X) | Y = y), i, j = 1, 2
# H11 <- Reduce(`%x%`, rev(Map(solve, Omegas))) # covariance
# # 3rd central moment is zero
# H12 <- H21 <- 0
# # 4th moment by "Isserlis' theorem" a.k.a. "Wick's theorem"
# H22 <- kronecker(H11, H11)
# dim(H22) <- rep(prod(p), 4)
# H22 <- H22 + aperm(H22, c(1, 3, 2, 4)) + aperm(H22, c(1, 3, 2, 4))
# dim(H11) <- c(p, p)
# dim(H22) <- c(p, p, p, p)
## Fisher Information: Tensor Normal Specific
# known exponential family constants