tensor_predictors/vis/ising_small/app.R

259 lines
8.5 KiB
R
Raw Normal View History

# usage: R -e "shiny::runApp(port = 8080)"
# usage: R -e "shiny::runApp(host = '127.0.0.1', port = 8080)"
library(shiny)
library(mvbernoulli)
library(tensorPredictors)
# configuration
# color.palet <- hcl.colors(64, "YlOrRd", rev = TRUE)
color.palet <- hcl.colors(64, "Blue-Red 2", rev = FALSE)
# GMLM parameters
n <- 250
p <- c(2, 3)
q <- c(1, 1)
eta1 <- 0 # intercept
# 270 deg (90 deg clockwise) rotation of matrix layout
#
# Used to get proper ploted matrices cause `image` interprets the `z` matrix as
# a table of `f(x[i], y[j])` values, so that the `x` axis corresponds to row
# number and the `y` axis to column number, with column 1 at the bottom,
# i.e. a 90 degree counter-clockwise rotation of the conventional printed layout
# of a matrix. By first calling `rot270` on a matrix before passing it to
# `image` the plotted matrix layout now matches the conventional printed layout.
rot270 <- function(A) {
t(A)[, rev(seq_len(nrow(A))), drop = FALSE]
}
plot.mat <- function(mat, add.values = FALSE, zlim = range(mat)) {
par(oma = rep(0, 4), mar = rep(0, 4))
img <- rot270(mat)
image(x = seq_len(nrow(img)), y = seq_len(ncol(img)), z = img,
zlim = zlim, col = color.palet, xaxt = "n", yaxt = "n", bty = "n")
if (add.values) {
text(x = rep(seq_len(nrow(img)), ncol(img)),
y = rep(seq_len(ncol(img)), each = nrow(img)),
round(img, 2), adj = 0.5, col = "black")
}
}
AR <- function(rho, dim) {
rho^abs(outer(seq_len(dim), seq_len(dim), `-`))
}
AR.inv <- function(rho, dim) {
A <- diag(c(1, rep(rho^2 + 1, dim - 2), 1))
A[abs(.row(dim(A)) - .col(dim(A))) == 1] <- -rho
A / (1 - rho^2)
}
# User Interface (page layout)
ui <- fluidPage(
titlePanel("Ising Model Simulation Data Generation"),
sidebarLayout(
sidebarPanel(
h2("Settings"),
h4("c1 (influence of eta_y1"),
sliderInput("c1", "", min = 0, max = 1, value = 1, step = 0.01),
h4("c2 (influence of eta_y2"),
sliderInput("c2", "", min = 0, max = 1, value = 1, step = 0.01),
sliderInput("y", "y", min = -1, max = 1, value = 0, step = 0.05,
animate = animationOptions(
interval = 250,
loop = TRUE,
playButton = NULL,
pauseButton = NULL
)),
fluidRow(
column(6,
radioButtons("alphaType", "Type: alphas",
choices = list(
"linspace" = "linspace", "poly" = "poly", "QR" = "QR"
),
selected = "linspace"
)
),
column(6,
radioButtons("OmegaType", "Type: Omegas",
choices = list(
"Identity" = "identity", "AR(rho)" = "AR", "AR(rho)^-1" = "AR.inv"
),
selected = "AR"
)
)
),
sliderInput("rho", "rho", min = -1, max = 1, value = -0.55, step = 0.01),
actionButton("reset", "Reset")
),
mainPanel(
fluidRow(
column(4, h3("eta_y1"), plotOutput("eta_y1") ),
column(4, h3("eta_y2"), plotOutput("eta_y2") ),
column(4, h3("Theta_y"), plotOutput("Theta_y") )
),
fluidRow(
column(4, offset = 2,
h3("Expectation E[X | Y = y]"), plotOutput("expectationPlot"),
),
column(4,
h3("Covariance Cov(X | Y = y)"), plotOutput("covariancePlot"),
textOutput("covRange"),
)
),
fluidRow(
column(8, offset = 4, h3("iid samples") ),
column(4, "Conditional Expectations", plotOutput("cond_expectations") ),
column(4, "observations sorted by y_i", plotOutput("sample_sorted_y") ),
column(4, "observations sorted by X_i", plotOutput("sample_sorted_X") ),
),
fluidRow(
column(6, h3("Sample Mean"), plotOutput("sampleMean") ),
column(6, h3("Sample Cov"), plotOutput("sampleCov") )
)
)
)
)
# Server logic
server <- function(input, output, session) {
Fun_y <- function(y) { array(sin(pi * y), dim = q) }
Fy <- reactive({ Fun_y(input$y) })
alphas <- reactive({
switch(input$alphaType,
"linspace" = Map(function(pj, qj) {
data <- linspace <- seq(-1, 1, len = pj)
for (k in seq_len(qj - 1)) {
linspace <- rev(linspace)
data <- c(data, linspace)
}
matrix(data, nrow = pj)
}, p, q),
"poly" = Map(function(pj, qj) {
data <- linspace <- seq(-1, 1, len = pj)
for (k in (seq_len(qj - 1) + 1)) {
data <- c(data, linspace^k)
}
matrix(data, nrow = pj)
}, p, q),
"QR" = Map(function(pj, qj) {
qr.Q(qr(matrix(rnorm(pj * qj), pj, qj)))
}, p, q)
)
})
Omegas <- reactive({
switch(input$OmegaType,
"identity" = Map(diag, p),
"AR" = Map(AR, list(input$rho), dim = p),
"AR.inv" = Map(AR.inv, list(input$rho), dim = p)
)
})
eta_y1 <- reactive({
input$c1 * (mlm(Fy(), alphas()) + c(eta1))
})
eta_y2 <- reactive({
input$c2 * Reduce(`%x%`, rev(Omegas()))
})
# compute Ising model parameters from GMLM parameters given single `Fy`
theta_y <- reactive({
vech(diag(c(eta_y1())) + (1 - diag(nrow(eta_y2()))) * eta_y2())
})
E_y <- reactive({
mvbernoulli::ising_expectation(theta_y())
})
Cov_y <- reactive({
mvbernoulli::ising_cov(theta_y())
})
random_sample <- reactive({
c1 <- input$c1
c2 <- input$c2
eta_y_i2 <- eta_y2()
y <- sort(runif(n, -1, 1))
X <- sapply(y, function(y_i) {
Fy_i <- Fun_y(y_i)
eta_y_i1 <- c1 * (mlm(Fy_i, alphas()) + c(eta1))
theta_y_i <- vech(diag(c(eta_y_i1)) + (1 - diag(nrow(eta_y_i2))) * eta_y_i2)
ising_sample(1, theta_y_i)
})
attr(X, "p") <- prod(p)
as.mvbmatrix(X)
})
cond_expectations <- reactive({
c1 <- input$c1
c2 <- input$c2
eta_y_i2 <- eta_y2()
y <- seq(-1, 1, length.out = 50)
t(sapply(y, function(y_i) {
Fy_i <- Fun_y(y_i)
eta_y_i1 <- c1 * (mlm(Fy_i, alphas()) + c(eta1))
theta_y_i <- vech(diag(c(eta_y_i1)) + (1 - diag(nrow(eta_y_i2))) * eta_y_i2)
ising_expectation(theta_y_i)
}))
})
output$eta_y1 <- renderPlot({
plot.mat(eta_y1(), add.values = TRUE, zlim = c(-2, 2))
}, res = 108)
output$eta_y2 <- renderPlot({
plot.mat(eta_y2())
})
output$Theta_y <- renderPlot({
plot.mat(vech.pinv(theta_y()))
})
output$expectationPlot <- renderPlot({
plot.mat(matrix(E_y(), p[1], p[2]), add.values = TRUE, zlim = c(0, 1))
}, res = 108)
output$covariancePlot <- renderPlot({
plot.mat(Cov_y())
})
output$covRange <- renderText({
paste(round(range(Cov_y()), 3), collapse = " - ")
})
output$cond_expectations <- renderPlot({
plot.mat(cond_expectations(), zlim = 0:1)
})
output$sample_sorted_y <- renderPlot({
plot.mat(random_sample())
})
output$sample_sorted_X <- renderPlot({
X <- random_sample()
plot.mat(X[do.call(order, as.data.frame(X)), ])
})
output$sampleMean <- renderPlot({
Xmean <- matrix(colMeans(random_sample()), p[1], p[2])
plot.mat(Xmean, add.values = TRUE, zlim = c(0, 1))
}, res = 108)
output$sampleCov <- renderPlot({
plot.mat(cov(random_sample()))
})
observeEvent(input$reset, {
updateNumericInput(session, "c1", value = 1)
updateNumericInput(session, "c2", value = 1)
updateNumericInput(session, "y", value = 0)
updateNumericInput(session, "rho", value = -0.55)
updateRadioButtons(session, "OmegaType", selected = "AR")
updateRadioButtons(session, "alphaType", selected = "poly")
})
}
# launch Shiny Application (start server)
shinyApp(ui = ui, server = server)