Is there a way to select an entire group of choices on a pickerInput from shinyWidgets?

Question

Here is a simple reproducible example:

library(shiny)
library(shinyWidgets)

ui <- fluidPage(
    pickerInput("test",choices=list("A"=c(1,2,3,4,5),"B"=c(6,7,8,9,10)),multiple=TRUE),
    textOutput("testOutput")
)

server <- function(input, output) {
    output$testOutput <- renderText({paste(input$test)})
}

shinyApp(ui = ui, server = server)

What I'd like is to click A and have the pickerInput automatically select 1,2,3,4 and 5. Or if we click B, it automatically selects 6,7,8,9, and 10.

Desired output after clicking "A":

Any help is appreciated, thanks.

Answer 1

You can use some JS to get the result:

library(shiny)
library(shinyWidgets)

js <- HTML("
$(function() {
  let observer = new MutationObserver(callback);

  function clickHandler(evt) {
    Shiny.setInputValue('group_select', $(this).children('span').text());
  }

  function callback(mutations) {
    for (let mutation of mutations) {
      if (mutation.type === 'childList') {
        $('.dropdown-header').on('click', clickHandler).css('cursor', 'pointer');
        
      }
    }
  }

  let options = {
    childList: true,
  };

  observer.observe($('.inner')[0], options);
})
")

choices <- list("A" = c(1, 2, 3, 4, 5), "B" = c(6, 7, 8, 9, 10))

ui <- fluidPage(
   tags$head(tags$script(js)),
   pickerInput("test", choices = choices, multiple = TRUE),
   textOutput("testOutput")
)

server <- function(input, output, session) {
   output$testOutput <- renderText({paste(input$test)})
   
   observeEvent(input$group_select, {
      req(input$group_select)
      updatePickerInput(session, "test", selected = choices[[input$group_select]])
   })
}

shinyApp(ui = ui, server = server)

Explanation

Idea is that you set an onClick event for the header line, where you set an input variable, upon which you can react in Shiny.

The whole MutationObserver construct is a crude workaround, because I could not get a (delegated) event listener working.

What I observed is that (not bring an JavaScriptspecialist):

• The content of the dropdown is not generated before the first click. Hence, a direct event listener like $('.dropdown-header').on() woudl not work, because the element is not yet existing.
• Event delegation a la $(document).on('click', '.dropdown-header', ...) did not work either. I assume that somewhere there is a stopPropagation preventing that the event is bubbling up.

Thus, I used the MutationObserver to add the ('.drodown-header') listener the moment it is created. Not the most beautiful nor a resource preserving solution, but at least a working one. Maybe, you can find out how to properly set the event listener w/o the MutationObsever.

---

Update

If you want to keep all existing selections, you would change the observeEvent as follows:

observeEvent(input$group_select, {
   req(input$group_select)
   sel <- union(input$test, choices[[input$group_select]])
   updatePickerInput(session, "test", selected = sel)
})

---

More Background 2022

As this answer was referenced by another question and there was a question in the comments, why we need the MutationObserver in the first place, I finally did look up the source code of the input bootstrap-select.js and my intuition was right, clicks on the .dropdown-header are actively prevented from bubbling up:

this.$menuInner.on('click', '.divider, .dropdown-header', function (e) {
  e.preventDefault();
  e.stopPropagation();
  if (that.options.liveSearch) {
    that.$searchbox.trigger('focus');
  } else {
    that.$button.trigger('focus');
  }
});

Answer 2

Ok here's a shot at something for your situation using jsTreeR. The code works and does what I think you're looking for, but it's not as pretty as shinyWidgets. I imagine there's a way of combining this approach (largely taken from the jsTreeR example in the documentation), and the approach to create bindings in this post to create something that looks nice and has the functionality you're looking for.

library(shiny)
library(jsTreeR)
library(jsonlite)

#create nodes
nodes <- list(
  list(
    text="List A",
    type="root",
    children = list(
      list(
        text = "Option 1",
        type = "child"
      ),
      list(
        text = "Option 2",
        type = "child"
      ),
      list(
        text = "Option 3",
        type = "child"
      ),
      list(
        text = "Option 4",
        type = "child"
      ),
      list(
        text = "Option 5",
        type = "child"
      )
    )
  ),
  list(
    text="List B",
    type="root",
    children = list(
      list(
        text = "Option 6",
        type = "child"
      ),
      list(
        text = "Option 7",
        type = "child"
      ),
      list(
        text = "Option 8",
        type = "child"
      ),
      list(
        text = "Option 9",
        type = "child"
      ),
      list(
        text = "Option 10",
        type = "child"
      )
    )
  )
)

types <- list(
  root = list(
    icon = "none"
  ),
  child = list(
    icon = "none"
  )
)

#Use in shiny context - example taken from documentation for jsTreeR
ui <- fluidPage(
  br(),
  fluidRow(
    column(width = 4,
           jstreeOutput("jstree")
    ),
    column(width = 4,
           tags$fieldset(
             tags$legend("Selections - JSON format"),
             verbatimTextOutput("treeSelected_json")
           )
    ),
    column(width = 4,
           tags$fieldset(
             tags$legend("Selections - R list"), 
             verbatimTextOutput("treeSelected_R")
           )
    )
  )
)

server <- function(input, output) {
  output[["jstree"]] <- renderJstree(
    jstree(nodes, checkboxes = TRUE, multiple=TRUE, types=types)
  ) 
  
  output[["treeSelected_json"]] <- renderPrint({
    toJSON(input[["jstree_selected"]], pretty = TRUE, auto_unbox = TRUE)
  })
  
  output[["treeSelected_R"]] <- renderPrint({
    input[["jstree_selected"]]
  })
  
}


shinyApp(ui, server)

Note that there's no data attached to the nodes - this just gets the right UI functionality. You'll have to attach values to the nodes that could then be used in downstream calculations.