259 lines
8.5 KiB
R
259 lines
8.5 KiB
R
|
# 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)
|