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