rshinyshinywidgets

Only update input on close


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)

Solution

  • shinywidgets now has an option for update on close for virtualSelectInput.