Skip to content

Commit

Permalink
Added dependency on dimension of data and handling of increases/decre…
Browse files Browse the repository at this point in the history 
…ases in the dimension.
  • Loading branch information
@AEBilgrau
AEBilgrau committed Jan 10, 2019
1 parent aa68ff9 commit 8a09c27
Showing 1 changed file with 71 additions and 20 deletions.
91 changes: 71 additions & 20 deletions inst/shiny/server.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,7 @@ shinyServer(function(input, output, session) {

# Reactive values concering the data.frame ----
user_data <- reactiveVal()
rv <- reactiveValues(d = 4, m = 3)
rv <- reactiveValues(d = NULL, m = NULL)

# FILE INPUT ____________________________________________________________ ----

Expand Down Expand Up @@ -203,7 +203,6 @@ shinyServer(function(input, output, session) {
in_pie <- reactiveVal()
in_mu <- reactiveVal()


# Randomize start theta
observeEvent(input$full_random_theta, {
cat("Randomize theta clicked!\n")
Expand All @@ -223,25 +222,44 @@ shinyServer(function(input, output, session) {
in_pie(rt$pie)
})

# Observe full_m change ----
observeEvent(input$full_m, {
# Observe d/m change ----
observeEvent({
input$full_m
rv$d
},{
rv$m <- input$full_m # Write to reactive value
req(rv$m)
req(rv$d)

# Update in_pie()
in_pie(rep(1/rv$m , times = rv$m))

# Update in mu()
mu <- in_mu()
if (!is.null(mu)) {

# Create new cols if needed
if (rv$m > ncol(mu)) {
mu <- do.call("cbind", c(list(mu), replicate(rv$m - ncol(mu), NA_real_,
simplify = FALSE)))
colnames(mu) <- paste0("comp", seq_len(rv$m))
}
# Remove cols if needed
if (rv$m < ncol(mu)) {
mu <- mu[, seq_len(rv$m)]
}
# Create new rows if needed
if (rv$d > nrow(mu)) {
mu <- do.call("rbind", c(list(mu), replicate(rv$d - nrow(mu), NA_real_,
simplify = FALSE)))
rownames(mu) <- paste0("dim", seq_len(rv$d))
}
# Remove rows if needed
if (rv$d < nrow(mu)) {
mu <- mu[seq_len(rv$d), ]
}

# Update mu
in_mu(mu)
}
})
Expand Down Expand Up @@ -357,27 +375,37 @@ shinyServer(function(input, output, session) {


# mu input functionality -----
# Update in_mu reactiveVal upon edit event
observeEvent(input$rhandson_mu, {
req(input$rhandson_mu)
in_mu(hot_to_r(input$rhandson_mu))
})

# Create rhandson table ----
output$rhandson_mu <- renderRHandsontable({
req(rv$d)
req(rv$m)
cat("Rendering rhandson_mu\n")


if (is.null(in_mu())) {
mu <- replicate(n = rv$m, rep(NA_real_, rv$d), simplify = TRUE)
colnames(mu) <- paste0("comp", seq_len(rv$m))
} else {
mu <- in_mu()
}
rownames(mu) <- paste0("dim", seq_len(rv$d))

# Add col/row names
colnames(mu) <- paste0("comp", seq_len(ncol(mu)))
rownames(mu) <- paste0("dim", seq_len(nrow(mu)))

rhandsontable(mu, contextMenu = FALSE)
})

# Update in_mu reactiveVal upon edit event
observeEvent(input$rhandson_mu, {
req(input$rhandson_mu)
in_mu(hot_to_r(input$rhandson_mu))
})

# Make mu box ----
output$full_mu_box <- renderUI({
req(rv$m)
req(rv$d)

# Mixture props box and content
box(
# Args
Expand All @@ -403,11 +431,12 @@ shinyServer(function(input, output, session) {

# sigma input functionality -----
# Update full_start_theta reactiveVal upon edit event

observe({
req(rv$m)
req(rv$d)
#req(full_start_theta())

# Make sure component are deleted when m is reduced.
# Make sure components are deleted if m is reduced
if (!is.null(full_start_theta())) {
theta <- full_start_theta()
theta$sigma <- theta$sigma[seq_len(rv$m)]
Expand All @@ -417,7 +446,7 @@ shinyServer(function(input, output, session) {
# Create all rhandsontables
lapply(seq_len(rv$m), function(k) {
output[[paste0("rhandson_sigma", k)]] <- renderRHandsontable({
cat("making rhandson_sigma", k, "\n", sep = "")
cat("Creating rhandson_sigma", k, "\n", sep = "")
# req(full_start_theta())
#https://github.com/jrowen/rhandsontable/tree/master/inst/examples/rhandsontable_corr

Expand All @@ -428,6 +457,17 @@ shinyServer(function(input, output, session) {
mat <- full_start_theta()$sigma[[k]]
}

# If d has changed:
stopifnot(nrow(mat) == ncol(mat))
if (ncol(mat) < rv$d) {
tmp_mat <- diag(rv$d)
tmp_mat[seq_len(nrow(mat)), seq_len(ncol(mat))] <- mat
mat <- tmp_mat
}
if (ncol(mat) > rv$d) {
mat <- mat[seq_len(rv$d), seq_len(rv$d)]
}

# Colnames are needed for hot_to_r to work
if (is.null(rownames(mat))) {
colnames(mat) <- paste0("dim", seq_len(nrow(mat)))
Expand All @@ -448,7 +488,9 @@ shinyServer(function(input, output, session) {

# Make observers for each sigma change (edit of table)
observe({
rv$m
req(rv$m)
req(rv$d)

lapply(seq_len(rv$m), function(k) {

observeEvent(input[[paste0("rhandson_sigma", k)]], {
Expand All @@ -465,6 +507,8 @@ shinyServer(function(input, output, session) {

# Make sigma box ----
output$full_sigma_box <- renderUI({
req(rv$m)
req(rv$d)

# Mixture props box and content
box(
Expand All @@ -476,8 +520,10 @@ shinyServer(function(input, output, session) {

# Show starting sigmas
lapply(seq_len(rv$m), function(k) {
list(tags$b(paste("Component", k)),
rHandsontableOutput(paste0("rhandson_sigma", k)))
list(
tags$b(paste("Component", k)),
rHandsontableOutput(paste0("rhandson_sigma", k))
)
})
)
})
Expand All @@ -501,6 +547,9 @@ shinyServer(function(input, output, session) {

# DEBUG ----
output$DEBUG <- renderPrint({
req(rv$d)
req(rv$m)

cat("str(full_start_theta())\n")
cat(str(full_start_theta()))

Expand All @@ -510,8 +559,8 @@ shinyServer(function(input, output, session) {
print(in_pie())


cat("\n\nprint(hot_to_r(input$rhandson_mu)\n")
print(hot_to_r(input$rhandson_mu))
cat("\n\nprint(str(input$rhandson_mu)\n")
print(str(input$rhandson_mu))

cat("\n\nprint(in_mu())\n")
print(in_mu())
Expand Down Expand Up @@ -541,8 +590,10 @@ shinyServer(function(input, output, session) {
user_data_pre(Uhat(ifelse(input$meta_large_vals, 1, -1) * user_data()))
})

# Subset to selected cols, set d
observeEvent(input$model_cols, {
user_data_pre(user_data()[, input$model_cols])
rv$d <- ncol(user_data_pre())
})

# observe button push and fit model ----
Expand Down

0 comments on commit 8a09c27

Please sign in to comment.