91 lines
3.0 KiB
R
91 lines
3.0 KiB
R
|
# ilustration of the Ising model sampling routine
|
||
|
|
|
||
|
|
sym <- function(A) A + t(A)
|
||
|
|
|
||
|
|
vech <- function(A) A[lower.tri(A, diag = TRUE)]
|
||
|
|
|
||
|
|
vech.inv <- function(a) {
|
||
|
|
# determin original matrix dimensions `p by p`
|
||
|
|
p <- as.integer((sqrt(8 * length(a) + 1) - 1) / 2)
|
||
|
|
# create matrix of dim `p by p` of the same data type as `a`
|
||
|
|
A <- matrix(do.call(typeof(a), list(1)), p, p)
|
||
|
|
# write elements of `a` into the correct positions of `A`
|
||
|
|
A[lower.tri(A, diag = TRUE)] <- a
|
||
|
|
A[upper.tri(A)] <- t(A)[upper.tri(A)]
|
||
|
|
A
|
||
|
|
}
|
||
|
|
|
||
|
|
flip <- function(A) A[rev(seq_len(nrow(A))), rev(seq_len(ncol(A)))]
|
||
|
|
|
||
|
|
# # R calculation of Theta
|
||
|
|
# Theta.R <- local({
|
||
|
|
# P <- diag(cond_probs)
|
||
|
|
# PtP <- tcrossprod(P, P)
|
||
|
|
# Theta <- log(((1 - PtP) * cond_probs) / (PtP * (1 - cond_probs)))
|
||
|
|
# diag(Theta) <- log(P / (1 - P))
|
||
|
|
# Theta
|
||
|
|
# })
|
||
|
|
|
||
|
|
# # ### MatLab computation of Theta
|
||
|
|
# # q = 7;
|
||
|
|
# # cond_probs = 0.75 .^ (1 + abs((1:q)' - (1:q)));
|
||
|
|
# # % compute natural parameter theta
|
||
|
|
# # P = cond_probs(sub2ind(size(cond_probs), 1:q, 1:q));
|
||
|
|
# # PtP = P' * P;
|
||
|
|
# # % first: off diagonal elements
|
||
|
|
# # theta = log(((1 - PtP) .* cond_probs) ./ (PtP .* (1 - cond_probs)));
|
||
|
|
# # % second: diagonal elements
|
||
|
|
# # theta(sub2ind(size(theta), 1:q, 1:q)) = log(P ./ (1 - P));
|
||
|
|
|
||
|
|
|
||
|
|
q <- 20
|
||
|
|
|
||
|
|
# conditional probabilities
|
||
|
|
cond_probs <- 0.75 ^ (1 + abs(outer(1:q, 1:q, `-`)))
|
||
|
|
cond_probs[tail(1:q, 3), ] <- 0.1
|
||
|
|
cond_probs[, tail(1:q, 3)] <- 0.1
|
||
|
|
cond_probs[tail(1:q, 3), tail(1:q, 3)] <- diag(0.4, 3, 3) + 0.1
|
||
|
|
|
||
|
|
theta <- ising_theta_from_cond_prob(flip(cond_probs)[lower.tri(cond_probs, diag = TRUE)])
|
||
|
|
|
||
|
|
system.time(Y <- ising_sample(10000, theta))
|
||
|
|
|
||
|
|
ising_expectation(theta)
|
||
|
|
stopifnot(all.equal(mean.mvbinary(Y), colMeans(as.mvbmatrix(Y))))
|
||
|
|
|
||
|
|
ising_cov(theta)
|
||
|
|
stopifnot(all.equal(cov.mvbinary(Y), cov(as.mvbmatrix(Y))))
|
||
|
|
|
||
|
|
|
||
|
|
# covariances
|
||
|
|
cov.true <- ising_cov(theta)
|
||
|
|
cov.est <- cov.mvbinary(Y)
|
||
|
|
|
||
|
|
# marginal probabilities
|
||
|
|
mar_probs.true <- flip(vech.inv(ising_marginal_probs(theta)))
|
||
|
|
mar_probs.est <- crossprod(as.mvbmatrix(Y)) / length(Y)
|
||
|
|
|
||
|
|
par(mfrow = c(2, 3), mar = c(3, 2, 4, 1), oma = c(1, 0, 5, 0))
|
||
|
|
tensorPredictors::matrixImage(cond_probs,
|
||
|
|
main = expression(pi == P[theta(pi)](paste(Y[i] == 1, ", ", Y[j] == 1, " | ", Y[paste(-i, ", ", -j)] == 0)))
|
||
|
|
)
|
||
|
|
tensorPredictors::matrixImage(cov.true,
|
||
|
|
main = expression(cov[theta(pi)](Y)))
|
||
|
|
tensorPredictors::matrixImage(cov.est,
|
||
|
|
main = expression(hat(cov)(Y)),
|
||
|
|
sub = paste("Est. Error:", round(norm(cov.true - cov.est, "F"), 3)))
|
||
|
|
tensorPredictors::matrixImage(flip(vech.inv(theta)),
|
||
|
|
main = expression({vech^-1}(theta(pi)))
|
||
|
|
)
|
||
|
|
tensorPredictors::matrixImage(mar_probs.true,
|
||
|
|
main = expression(P[theta(pi)](Y[i] == 1, Y[j] == 1)))
|
||
|
|
tensorPredictors::matrixImage(mar_probs.est,
|
||
|
|
main = expression(hat(P)(Y[i] == 1, Y[j] == 1)),
|
||
|
|
sub = paste("Est. Error:", round(norm(mar_probs.true - mar_probs.est, "F"), 3)))
|
||
|
|
mtext(bquote(
|
||
|
|
paste(Y, " ~ ", Ising[.(q)](theta(pi)))
|
||
|
|
), side = 3, line = 0, outer = TRUE)
|
||
|
|
mtext(bquote(
|
||
|
|
paste("Sample size ", n == .(length(Y)))
|
||
|
|
), side = 3, line = -1.5, outer = TRUE)
|