I'd like to have my pickerInput only update on close. Apparently, this is an already-requested feature with a SO solution.
The issue I'm having is integrating that solution with my existing module structure. My current app structure has a module that updates the next picker in a hierarchy when the picker above it is changed.
I tried adding a second condition for my observeEvent in the moduleController as well as adding another observeEvent condition to the server, neither of which worked.
I know I need to use the input$..._open element, but because I'm generating the select inputs via a module I'm struggling to explicitly ID it in the observeEvent.
Is there a way to programmatically list all input ids with a certain phrase or pattern and include the update logic in the moduleController and moduleRootController functions?
Overall I’d like ALL pickers created by moduleController and moduleRootController to only update on close.
library(shiny)
library(dplyr)
library(shinyWidgets)
library(highcharter)
# module UI
moduleUI <- function(id, label, choices = NULL) {
ns <- NS(id)
tagList(virtualSelectInput(ns("select"), label= label, choices = choices,
selected = choices, multiple = TRUE))
}
# module server root
moduleRootController <- function(id) {
moduleServer(id, function(input, output, session) {
return(reactive({input$select}))
})
}
# module server
moduleController <- function(id, data, selector, input_val, output_val) {
moduleServer(id, function(input, output, session) {
observeEvent(selector(), {
choices=data %>%
filter({{input_val}} %in% selector()) %>%
distinct({{output_val}}) %>%
arrange({{output_val}}) %>%
pull({{output_val}})
updateVirtualSelect("select", choices = choices, selected = choices)
}, ignoreNULL = FALSE)
return(reactive({input$select}))
})
}
ui_heirarchy <- function(id){
ns <- NS(id)
tagList(moduleUI(ns("ModuleRoot"), label = "Root Label", choices=c("A", "B", "C", "D")),
moduleUI(ns("Module1"), label = "Test Label 1"),
moduleUI(ns("Module2"), label = "Test Label 2"),
moduleUI(ns("Module3"), label = "Test Label 3"))
}
server_heirarchy <- function(id, data) {
moduleServer(id, function(input, output, session) {
mod0 <- moduleRootController("ModuleRoot")
mod1 <- moduleController("Module1", data, reactive({mod0()}), level1, level2)
mod2 <- moduleController("Module2", data, reactive({mod1()}), level2, level3)
mod3 <- moduleController("Module3", data, reactive({mod2()}), level3, level4)
return(list(mod0 = mod0, mod1 = mod1, mod2 = mod2, mod3 = mod3))
})
}
# ui / server / app
ui <- fixedPage(
tags$style(type="text/css", ".recalculating {opacity: 0.05;}"),
ui_heirarchy("heirarchy"),
highchartOutput("plot")
)
server <- function(input, output, session) {
x <- tibble(level1 = c(rep("A", 100), rep("B", 100), rep("C", 100), rep("D", 100)),
level2 = c(rep("A1", 50), rep("A2", 50), rep("B1", 50), rep("B2", 50),
rep("C1", 50), rep("C2", 50), rep("D1", 50), rep("D2", 50)),
level3 = c(rep("A21", 25), rep("A22", 25), rep("A23", 25), rep("A24", 25),
rep("B21", 25), rep("B22", 25), rep("B23", 25), rep("B24", 25),
rep("C21", 25), rep("C22", 25), rep("C23", 25), rep("C24", 25),
rep("D21", 25), rep("D22", 25), rep("D23", 25), rep("D24", 25)),
level4 = c(rep("A31", 10), rep("A32", 10), rep("A33", 10), rep("A34", 10), rep("A35", 10),
rep("A36", 10), rep("A37", 10), rep("A38", 10), rep("A39", 10), rep("A310", 10),
rep("B31", 10), rep("B32", 10), rep("B33", 10), rep("B34", 10), rep("B35", 10),
rep("B36", 10), rep("B37", 10), rep("B38", 10), rep("B39", 10), rep("B310", 10),
rep("C31", 10), rep("C32", 10), rep("C33", 10), rep("C34", 10), rep("C35", 10),
rep("C36", 10), rep("C37", 10), rep("C38", 10), rep("C39", 10), rep("C310", 10),
rep("D31", 10), rep("D32", 10), rep("D33", 10), rep("D34", 10), rep("D35", 10),
rep("D36", 10), rep("D37", 10), rep("D38", 10), rep("D39", 10), rep("D310", 10))) %>%
mutate(value = runif(400, 0, 100))
out <- server_heirarchy("heirarchy", x)
# Do this to make pickers
y <- reactive({
req(out$mod3())
x %>%
filter(level1 %in% out$mod0()) %>%
filter(level2 %in% out$mod1()) %>%
filter(level3 %in% out$mod2()) %>%
filter(level4 %in% out$mod3())
})
debounced_y <- debounce(y, 1000)
# Then query picker output
query <- reactive({
req(debounced_y())
Sys.sleep(5) #mimics query time
debounced_y()
})
# Then plot query
output$plot <- renderHighchart({
hc <- hchart(
query()$value,
color = "#B71C1C", name = "Weight"
)
})
}
shinyApp(ui, server)
shinywidgets now has an option for update on close for virtualSelectInput.