In running the below R Shiny code, the user changing the sliderInput()
(object input$periods
) resets all of the variable user input tables that are generated by the block of code that begins lapply(1:numVars, function(i) {varInputId <- paste0("var_", i, "_input")…})
, and as illustrated in the image below.
That block of code generates 2 user input tables ("X/Y tables") using rhandsontable
, each with 2 columns with headers “X” and “Y”. Any change in input$periods
resets both of the X/Y tables. How can the code be modified so that the only tables that are reset upon a change in input$periods
are those tables where the maximum value in its leftmost “X” column exceeds the new, reset value of input$periods
?
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
.
If it's possible to do this in js
, I prefer it in js
. When I make changes in R it's easy to lose key functionality of this App such as (a) the independence of the X/Y tables, were a change to a input$base_input
value (top table) only resets the linked X/Y table and not all the X/Y tables, (b) the requirement that there be no less than 1 row in an X/Y table, and (c) the upper/lower bound limits on the column X inputs in the X/Y tables. In the more complete code this is extracted from (where there are many more input validation checks using js
), additions to js
are less disruptive to functionality than base R changes. But I'll take whatever I can get.
Code:
library(shiny)
library(rhandsontable)
library(htmlwidgets)
jsCode <- c(
"function(el, x) {",
" var hot = this.hot;",
" Handsontable.hooks.add('beforeRemoveRow', function(index, amount){",
" var nrows = hot.countRows();",
" if(nrows === 1) {",
" return false;",
" }",
" }, hot);",
"}"
)
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 # Number of variables to model
varValues <- lapply(1:numVars, function(i) { reactiveValues(data = 20) })
lastGoodFirstRows <- lapply(1:numVars, function(i) { reactiveVal() })
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]}
})
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) %>%
onRender(jsCode) %>%
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)
The below works but using base R and without using js. I'll keep this query open in hopes that someone has an efficient js solution. My understanding is that js will be more efficient because processing is on the client side without having to process back and forth with the server side.
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("parentTbl"),
uiOutput("childTbl")
)
server <- function(input, output, session) {
numVars <- 2 # Number of variables to model
parentVars <- lapply(1:numVars, function(i) { reactiveValues(data = 20) })
# Builds parent parentTbl table
output$parentTbl <- renderRHandsontable({
rhandsontable(
data.frame(Inputs = sapply(parentVars, function(x) x$data)),
readOnly = FALSE,
colHeaders = c('Inputs'),
rowHeaders = paste0("Var ", LETTERS[1:numVars]),
contextMenu = FALSE
)
})
observeEvent(input$parentTbl, {
newValues <- hot_to_r(input$parentTbl)$Inputs
for (i in 1:numVars) {
parentVars[[i]]$data <- newValues[i]
}
})
# Create reactive home for reviseTable
reviseTbl <- lapply(1:numVars, function(i) { reactiveVal() })
# Observe changes to input$periods and update reviseTbl
observeEvent(input$periods, {
for (i in 1:numVars) {
varInputId <- paste0("var_", i, "_input")
reviseTable <- tryCatch({
hot_to_r(input[[varInputId]])
}, error = function(e) {
reviseTbl[[i]]()
})
reviseTable <- subset(reviseTable, X <= input$periods)
reviseTbl[[i]](reviseTable) # Update the corresponding reactiveVal
}
}, ignoreInit = TRUE)
# Builds child X/Y tables
lapply(1:numVars, function(i) {
varInputId <- paste0("var_", i, "_input")
output[[varInputId]] <- renderRHandsontable({
# Always base the Y value of the first row on the current parentVars[[i]]$data
df <- data.frame(X = 1, Y = parentVars[[i]]$data)
# If reviseTbl[[i]]() has been updated, use that data instead,
# but keep the Y value of the first row in sync with parentVars[[i]]$data
if (!is.null(reviseTbl[[i]]())) {
df <- reviseTbl[[i]]()
if (nrow(df) > 0) {
df[1, "Y"] <- parentVars[[i]]$data # Ensure the Y value of the first row is updated
}
}
rhandsontable(df, contextMenu = TRUE, minRows = 1, rowHeaders = FALSE) %>%
hot_validate_numeric(col = 1, min = 1, max = input$periods)
})
})
output$childTbl <- 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)