In running the below R Shiny code, the user changing the sliderInput()
(object input$periods
) resets all of the variable user input tables called "X/Y child tables" as shown in the code with a comment before the lapply()
block that generates them and as illustrated in the image below. Note that these X/Y child tables reactively receive values from a parent table base_input
also commented in the code as such and also shown in the image below. The reactivity must always flow and changing a base_input
value always correctly completely resets the applicable linked X/Y child table.
The idea is to eliminate any rows in an X/Y child table with an X column value > a new value of input$periods
, while retaining the parent-child reactivity flows.
The block of code after comment # Observe changes to input$periods and print revised X/Y child tables
partly gets me there via object reviseTable
. That section of code removes any dataframe rows where its column X value > a revised input$periods
value. How do I replace the tables generated by the lapply()
block that generates X/Y tables with the reviseTable
object, without wrapping that lapply()
block in an observer? Wrapping with an observeEvent()
stops the parent-child reactivity flows that need to be maintained.
The input$periods
serves as the upper limit for the overall time window. The variables in column X represent the time period in which to change variable Y. So X must always <= input$periods
.
Code:
library(shiny)
library(rhandsontable)
ui <- fluidPage(
sliderInput("periods", "Time window (W):", min = 1, max = 10, value = 5),
h5(strong("Variable (Y) over window (W):")),
rHandsontableOutput("base_input"),
uiOutput("Vectors")
)
server <- function(input, output, session) {
numVars <- 2
varValues <- lapply(1:numVars, function(i) {reactiveValues(data = 20)})
# Parent table "base_input"
output$base_input <- renderRHandsontable({
rhandsontable(
data.frame(Inputs = sapply(varValues, function(x) x$data)),
readOnly = FALSE,
colHeaders = c('Inputs'),
rowHeaders = paste0("Var ", LETTERS[1:numVars]),
contextMenu = FALSE
)
})
observeEvent(input$base_input, {
newValues <- hot_to_r(input$base_input)$Inputs
for (i in 1:numVars) {
varValues[[i]]$data <- newValues[i]
}
})
# Observe changes to input$periods and print revised X/Y child tables
observeEvent(input$periods, {
for (i in 1:numVars) {
varInputId <- paste0("var_", i, "_input")
reviseTable <- hot_to_r(input[[varInputId]])
reviseTable <- subset(reviseTable, X <= input$periods)
print(paste("Revised X/Y table for Var", LETTERS[i], "after updating input$periods:"))
print(reviseTable)
}
}, ignoreInit = TRUE)
# Builds X/Y child tables
lapply(1:numVars, function(i) {
varInputId <- paste0("var_", i, "_input")
output[[varInputId]] <- renderRHandsontable({
df <- data.frame(X = 1, Y = varValues[[i]]$data)
rhandsontable(df, contextMenu = TRUE, minRows = 1, rowHeaders = FALSE) %>%
hot_validate_numeric(col = 1, min = 1, max = input$periods)
})
})
output$Vectors <- renderUI({
lapply(1:numVars, function(i) {
varInputId <- paste0("var_", i, "_input")
list(
h5(strong(paste("Adjust Var ", LETTERS[i], " (Y) at time X:"))),
rHandsontableOutput(varInputId)
)
})
})
}
shinyApp(ui, server)
Seems to work fine:
library(shiny)
library(rhandsontable)
library(htmlwidgets)
js <- "function(el, x) {
var hot = this.hot;
Shiny.addCustomMessageHandler('removeRows', function(indices) {
for(var i of indices) {
hot.alter('remove_row', i, 1);
}
});
}"
ui <- fluidPage(
sliderInput("periods", "Time window (W):", min = 1, max = 10, value = 5),
h5(strong("Variable (Y) over window (W):")),
rHandsontableOutput("base_input"),
uiOutput("Vectors")
)
server <- function(input, output, session) {
numVars <- 2
varValues <- lapply(1:numVars, function(i) {reactiveValues(data = 20)})
# Parent table "base_input"
output$base_input <- renderRHandsontable({
rhandsontable(
data.frame(Inputs = sapply(varValues, function(x) x$data)),
readOnly = FALSE,
colHeaders = c('Inputs'),
rowHeaders = paste0("Var ", LETTERS[1:numVars]),
contextMenu = FALSE
)
})
observeEvent(input$base_input, {
newValues <- hot_to_r(input$base_input)$Inputs
for (i in 1:numVars) {
varValues[[i]]$data <- newValues[i]
}
})
# Observe changes to input$periods and remove rows
observeEvent(input$periods, {
for (i in 1:numVars) {
varInputId <- paste0("var_", i, "_input")
reviseTable <- hot_to_r(input[[varInputId]])
toRemove <- which(reviseTable$X > input$periods)
if(length(toRemove)) {
session$sendCustomMessage("removeRows", as.list(rev(toRemove) - 1))
}
}
}, ignoreInit = TRUE)
# Builds X/Y child tables
lapply(1:numVars, function(i) {
varInputId <- paste0("var_", i, "_input")
output[[varInputId]] <- renderRHandsontable({
df <- data.frame(X = 1, Y = varValues[[i]]$data)
rhandsontable(df, contextMenu = TRUE, minRows = 1, rowHeaders = FALSE) %>%
hot_validate_numeric(col = 1, min = 1, max = input$periods) %>%
onRender(js)
})
})
output$Vectors <- renderUI({
lapply(1:numVars, function(i) {
varInputId <- paste0("var_", i, "_input")
list(
h5(strong(paste("Adjust Var ", LETTERS[i], " (Y) at time X:"))),
rHandsontableOutput(varInputId)
)
})
})
}
shinyApp(ui, server)
To solve the problem mentioned in the comments, remove max = input$periods
in the validator, and use this JS code:
js <- "function(el, x) {
var hot = this.hot;
Shiny.addCustomMessageHandler('removeRows', function(indices) {
for(var i of indices) {
hot.alter('remove_row', i, 1);
}
});
Handsontable.hooks.add('afterValidate', function(isValid, value, row, prop){
if(value > $('#periods').val()) {
return false;
}
});
}"