Reactivity in shiny modules for hierarchal pickers

shiny
, ,
1

I am trying to create a shiny module that uses pickers to represent hierarchy inputs so that the selection of level 1 only shows the appropriate subset for level 2, and level 2 will show the subset for level 3, etc.

I have that working but have two issues.

1- I would like to have empty pickers result in empty pickers for subsequent levels, right now those levels remain populated with the previous state values.
2- If I have a long process (represented below with Sys.sleep), the processing reruns for each update to the hierarchy. So a single change at the top level would result in the processing running 4 times. I think I need something like isolate or freezeReactiveValue, but struggling with the implementation.

library(shiny)
library(dplyr)
library(shinyWidgets)
library(plotly)

# mock dataset

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))

# module UI

moduleUI <- function(id, label, choices = NULL) {
  ns <- NS(id)
  tagList(pickerInput(ns("select"), label= label, choices = choices,
                      selected = choices, multiple = TRUE, 
                      options = list(`actions-box` = TRUE, `live-search`=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}})
      updatePickerInput(session, "select", choices = choices, selected = choices)
    })
    
    return(reactive({input$select}))
    
  })
}

# ui / server / app

ui <- fixedPage(
  moduleUI("ModuleRoot", label = "Root Label", choices=c("A", "B", "C", "D")),
  moduleUI("Module1", label = "Test Label 1"),
  moduleUI("Module2", label = "Test Label 2"),
  moduleUI("Module3", label = "Test Label 3"),
  plotlyOutput("plot")
)

server <- function(input, output, session) {
  mod0 <- moduleRootController("ModuleRoot")
  mod1 <- moduleController("Module1", x, reactive({mod0()}), level1, level2)
  mod2 <- moduleController("Module2", x, reactive({mod1()}), level2, level3)
  mod3 <- moduleController("Module3", x, reactive({mod2()}), level3, level4)
  
  # plot
  
  output$plot <- renderPlotly({
    
    y <- x %>%
      filter(level1 %in% mod0()) %>%
      filter(level2 %in% mod1()) %>%
      filter(level3 %in% mod2()) %>%
      filter(level4 %in% mod3())
    
    ## Long Process Here
    Sys.sleep(2)
    
    y %>%
      plot_ly(x = ~value, type = 'histogram') %>%
      layout(title = 'A Figure Displaying Itself',
             plot_bgcolor='#e5ecf6', 
             xaxis = list( 
               zerolinecolor = '#ffff', 
               zerolinewidth = 2, 
               gridcolor = 'ffff'), 
             yaxis = list( 
               zerolinecolor = '#ffff', 
               zerolinewidth = 2, 
               gridcolor = 'ffff'))
  })

}

shinyApp(ui, server)
2

I'll give you the easy part which is for your module observeEvent to run when the trigger is null set ignoreNULL to FALSE

observeEvent(selector(), {

      choices=data %>%
        filter({{input_val}} %in% selector()) %>%
        distinct({{output_val}}) %>%
        arrange({{output_val}}) %>%
        pull({{output_val}})

      updatePickerInput(session, "select", choices = choices, selected = choices)
    },ignoreNULL = FALSE)
3

That fixes point 1, thank you! Subsequent pickers are nulled out when a previous selection is set to null.

I was able to solve point 2 by further modularizing the code and having the processing being done in its own reactive element.


library(shiny)
library(dplyr)
library(shinyWidgets)
library(plotly)

# mock dataset

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))

# module UI

moduleUI <- function(id, label, choices = NULL) {
  ns <- NS(id)
  tagList(pickerInput(ns("select"), label= label, choices = choices,
                      selected = choices, multiple = TRUE, 
                      options = list(`actions-box` = TRUE, `live-search`=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}})
      updatePickerInput(session, "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) {
  
  moduleServer(id, function(input, output, session) {
    
    mod0 <- moduleRootController("ModuleRoot")
    mod1 <- moduleController("Module1", x, reactive({mod0()}), level1, level2)
    mod2 <- moduleController("Module2", x, reactive({mod1()}), level2, level3)
    mod3 <- moduleController("Module3", x, reactive({mod2()}), level3, level4)
    
    return(list(mod0 = mod0, mod1 = mod1, mod2 = mod2, mod3 = mod3))
    
  })
}

# ui / server / app

ui <- fixedPage(
  ui_heirarchy("test"),
  plotlyOutput("plot")
)

server <- function(input, output, session) {
  
  out <- server_heirarchy("test")
  
  process <- reactive({Sys.sleep(5)})
  
  output$plot <- renderPlotly({
    
    req(out$mod3())
    
    process()
    
    x %>%
      filter(level1 %in% out$mod0()) %>%
      filter(level2 %in% out$mod1()) %>%
      filter(level3 %in% out$mod2()) %>%
      filter(level4 %in% out$mod3()) %>%
      plot_ly(x = ~value, type = 'histogram') %>%
      layout(title = 'A Figure Displaying Itself',
             plot_bgcolor='#e5ecf6', 
             xaxis = list( 
               zerolinecolor = '#ffff', 
               zerolinewidth = 2, 
               gridcolor = 'ffff'), 
             yaxis = list( 
               zerolinecolor = '#ffff', 
               zerolinewidth = 2, 
               gridcolor = 'ffff'))
  })
  
}

shinyApp(ui, server)
4

This topic was automatically closed 7 days after the last reply. New replies are no longer allowed.

If you have a query related to it or one of the replies, start a new topic and refer back with a link.