The code at the bottom almost works perfectly except for one pesky bug I can't figure out. In some way I have botched the flow of reactives. The image below shows how this App works. Basically, the user can input into the top matrix (base_input) generated by function matInputBase() and can then input into more detailed time scenarios in the next 2 input matrixes (var_1_input and var_2_input) generated by function matInputFlex(). Importantly, this code allows the user to save and upload matrix input scenarios. The issue I am having is if the user has set the sliderInput() for the time window (input$periods) to some value in the current session, and then tries uploading a saved scenario that has a different value for input$periods, it takes 2 upload attempts: in the first upload attempt, the current session input$periods is correctly reset to the uploaded input$periods, but not the values for var_1_input and var_2_input matrixes; but in the 2nd upload attempt, the values for var_1_input and var_2_input matrixes are then correctly uploaded. It takes 2 upload attempts, I would like the upload to work correctly in one upload attempt, in those circumstances where current session input$periods <> upload input$periods. How can this be fixed?
Caveats. This has been a game a whack-a-mole. I have resolved the above issue using observers, but then another issue arises where it takes 2 moves of the sliderInput() to reset those 2 input matrixes (should take only one move of sliderInput() to reset the matrixes, as it does in this version of code, which is correct).
Code:
library(shiny)
library(shinyMatrix)
matInputBase <- function(name) {
matrixInput(
name,
value = matrix(c(0.20),2,1,dimnames = list(c("Var_1", "Var_2"), NULL)),
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric"
)
}
matInputFlex <- function(name, x,y) {
matrixInput(
name,
value = matrix(c(x, y), 1, 2, dimnames = list(NULL,c("X","Y"))),
rows = list(extend = TRUE, names = FALSE),
cols = list(extend = TRUE, delta = 0, names = TRUE, editableNames = FALSE),
class = "numeric"
)
}
matStretch <- function(col_name,time_window,mat) {
mat[, 1] <- pmin(mat[, 1], time_window)
df <- data.frame(matrix(nrow = time_window, ncol = 1, dimnames = list(NULL, col_name)))
df[, col_name] <- ifelse(
seq_along(df[, 1]) %in% mat[, 1], mat[match(seq_along(df[, 1]), mat[, 1]), 2],
0 )
return(df)
}
ui <- fluidPage(
sidebarPanel(
actionButton('modal_upload', 'Upload'),
downloadButton("save_btn", "Save"),
sliderInput("periods","Time window (W):", min = 1, max = 10, value = 10),
h5(strong("Var (Y) over time window:")),
matInputBase("base_input"),
actionButton("resetVectorBtn", "Reset"),
uiOutput("Vectors")
),
mainPanel(tableOutput("table2"))
)
server <- function(input, output, session) {
observeEvent(input$periods, {
lapply(1:2, function(i) {
updateMatrixInput(
session,
paste0("var_", i, "_input"),
value = matrix(c(input$periods, input$base_input[i, 1]),1,2,dimnames = list(NULL,c("X","Y")))
)
})
}, ignoreInit = TRUE)
updateVariableInput <- function(i, current_input, session) {
matrix_name <- paste0("var_", i, "_input")
updateMatrixInput(
session, matrix_name,
value = matrix(c(input$periods, current_input),1,2,dimnames = list(NULL,c("X","Y")))
)
}
prev_base_input <- reactiveValues(data = matrix(NA, nrow = 2, ncol = 1))
observeEvent(input$base_input, {
for (i in 1:2) {
if (is.na(prev_base_input$data[i,1]) || input$base_input[i,1] != prev_base_input$data[i,1]){
updateMatrixInput(
session,
paste0("var_", i, "_input"),
value = matrix(c(input$periods,input$base_input[i,1]),1,2,dimnames=list(NULL,c("X","Y")))
)
prev_base_input$data[i, 1] <- input$base_input[i, 1]
}
}
})
output$Vectors <- renderUI({
input$resetVectorBtn
varNames <- c("Var_1","Var_2")
tagList(
lapply(1:2, function(i) {
list(
h5(strong(paste("Adjust", varNames[i], "(Y) at time X:"))),
matInputFlex(paste0("var_", i, "_input"), input$periods, isolate(input$base_input[i, 1]))
)
})
)
})
output$save_btn <- downloadHandler(
filename = function() paste0("scenario", ".rds"),
content = function(file) saveRDS(
list(periods = input$periods,
var_1_input = input$var_1_input,
var_2_input = input$var_2_input
), file)
)
observeEvent(input$modal_upload, {
showModal(modalDialog(fileInput("upload_file_input", "Upload:", accept = c('.rds'))))
})
observeEvent(input$upload_file_input, {
uploaded_values <- readRDS(input$upload_file_input$datapath)
updateSliderInput(session, "periods", value = uploaded_values$periods)
updateMatrixInput(session, "var_1_input", value = uploaded_values$var_1_input)
updateMatrixInput(session, "var_2_input", value = uploaded_values$var_2_input)
output$Vectors <- renderUI({
input$resetVectorBtn
tagList(
h5(strong("Adjust Var_1 (Y) at time X:")),
matInputFlex("var_1_input", uploaded_values$periods, isolate(input$base_input[1, 1])),
h5(strong("Adjust Var_2 (Y) at time X:")),
matInputFlex("var_2_input", uploaded_values$periods, isolate(input$base_input[2, 1]))
)
})
output$table2 <- renderTable(
cbind(matStretch("Var_1", uploaded_values$periods, uploaded_values$var_1_input),
matStretch("Var_2", uploaded_values$periods, uploaded_values$var_2_input)
)
)
}, ignoreNULL = TRUE)
observeEvent(input$var_1_input, {
output$table2 <- renderTable({
cbind(matStretch("Var_1", input$periods, input$var_1_input),
matStretch("Var_2", input$periods, input$var_2_input)
)
})
}, ignoreNULL = FALSE)
}
shinyApp(ui, server)
This seems to work: