有没有办法 select 来自shinyWidgets 的pickerInput 上的一整组选择？

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 JavaScript specialist):

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

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.