rshinyshiny-reactivity
How to manage reactivity flow in this Shiny example?
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)
Solution
This seems to work:
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("matricesInputs")
),
mainPanel(tableOutput("table2"))
)
server <- function(input, output, session) {
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]
}
}
})
Var1 <- reactiveVal(matrix(c(10, 0), 1, 2, dimnames = list(NULL, c("X", "Y"))))
Var2 <- reactiveVal(matrix(c(10, 20), 1, 2, dimnames = list(NULL, c("X", "Y"))))
output$matricesInputs <- renderUI({
varNames <- c("Var_1","Var_2")
tagList(
h5(strong(paste("Adjust", varNames[1], "(Y) at time X:"))),
matInputFlex(
"var_1_input", input$periods, Var1()[2]
),
h5(strong(paste("Adjust", varNames[2], "(Y) at time X:"))),
matInputFlex(
"var_2_input", input$periods, Var2()[2]
)
)
}) |> bindEvent(input$periods)
observeEvent(input$resetVectorBtn, {
updateMatrixInput(
session,
"var_1_input",
value = matrix(c(input$periods,input$base_input[1,1]),1,2,dimnames=list(NULL,c("X","Y")))
)
updateMatrixInput(
session,
"var_2_input",
value = matrix(c(input$periods,input$base_input[2,1]),1,2,dimnames=list(NULL,c("X","Y")))
)
})
output$table2 <- renderTable(
cbind(matStretch("Var_1", input$periods, input$var_1_input),
matStretch("Var_2", input$periods, input$var_2_input)
)
)
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)
Var1(uploaded_values$var_1_input)
Var2(uploaded_values$var_2_input)
}, ignoreNULL = TRUE)
observe({
v1 <- matrix(c(input$periods, Var1()[2]), 1, 2, dimnames=list(NULL, c("X","Y")))
v2 <- matrix(c(input$periods, Var2()[2]), 1, 2, dimnames=list(NULL, c("X","Y")))
updateMatrixInput(session, "var_1_input", value = v1)
updateMatrixInput(session, "var_2_input", value = v2)
Var1(matrix(c(input$periods, input$base_input[1, 1]),1,2,dimnames = list(NULL,c("X","Y"))))
Var2(matrix(c(input$periods, input$base_input[2, 1]),1,2,dimnames = list(NULL,c("X","Y"))))
}) |> bindEvent(input$periods, ignoreInit = TRUE)
}
shinyApp(ui, server)
- Rcpp Rf_warningcall compiler warnings
- Modify the name of factor variables in lm function(summary function)
- Extreme value analysis and quantile estimation using log Pearson type 3 (Pearson III) distribution - R vs Python
- How to hide NAs when using xlsx::saveWorkbook?
- How do I retrieve a simple numeric value from a named numeric vector in R?
- Matching pair-wise columns from left to right across rows in one dataframe to another dataframe and adding new columns with matching values
- Income to outcome flow chart in Sankey plotly R
- color mapping in geom_conn_bundle not showing correctly
- Print R package startup message AFTER automatic package conflict messages instead of before
- Summing a set of R dataframe rows (column-wise), while retaining the first n columns
- Added variable / partial regression plots for groups in an interaction?
- how to make a topoplot in R with coordinates variable distribution
- List of all functions in base R?
- Plotting multiple plots for different initial conditions in one graph
- Printing repetitively on the same line in R
- Generating UI/Server based on initial selection
- Subset dataframe based on pickerInput
- How to let user pick the data in R-shiny?
- Couldn't show my simple bar charts separately on Shiny R dashboardBody
- How to programmatically filter contents of a second shiny app displayed via iframe
- How to select specific interesting groups for the boxplot in R Shiny app?
- Crosstable and Plot grouping with reactive values
- Is there a way to make multiple Shiny picker inputs where the selections must be disjoint?
- Delay/avoid duplication of shiny server side functions until after credentials
- Predictions only returns value "1"
- How to display a busy indicator in a shiny app?
- Append doesn't work when writing to CSV in R
- Changing the start date of a gantt chart in DiagrammeR
- Check for installed packages before running install.packages()
- Compare two columns element-wise