有没有办法从shinyWidgets 的pickerInput 上选择一整组选项？

Question

这是一个简单的可重现示例：

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)

我想要的是点击 A 并让 pickerInput 自动选择 1、2、3、4 和 5。或者如果我们点击 B，它会自动选择 6、7、8、9 和 10。

点击“A”后想要的输出：

感谢您的帮助。

Answer 1

您可以使用一些JS 来获得结果：

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)

说明

想法是您为标题行设置一个onClick 事件，在其中设置一个input 变量，您可以在Shiny 中做出反应。

整个 MutationObserver 构造是一个粗略的解决方法，因为我无法让（委托的）事件侦听器正常工作。

我观察到的是（不带JavaScriptspecialist）：

• 在第一次点击之前没有生成下拉菜单的内容。因此，像 $('.dropdown-header').on() 这样的直接事件侦听器将不起作用，因为该元素尚不存在。
• $(document).on('click', '.dropdown-header', ...) 的事件委托也不起作用。我假设某处有一个stopPropagation 防止事件冒泡。

因此，我使用MutationObserver 在创建时添加('.drodown-header') 侦听器。不是最漂亮的解决方案，也不是资源保护解决方案，但至少是一个可行的解决方案。也许，您可以了解如何正确设置不带MutationObsever 的事件侦听器。

---

更新

如果您想保留所有现有的选择，您可以更改observeEvent，如下所示：

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

Answer 2

好的，这里是使用jsTreeR 为您的情况拍摄的一些内容。该代码可以正常工作并执行我认为您正在寻找的工作，但它不如shinyWidgets 漂亮。我想有一种方法可以结合这种方法（主要取自文档中的 jsTreeR 示例）和the approach to create bindings in this post，以创建看起来不错并具有您正在寻找的功能的东西。

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)

请注意，节点上没有附加数据 - 这只是获得正确的 UI 功能。您必须将值附加到可用于下游计算的节点。