13

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

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”后所需的输出：

在此处输入图像描述

任何帮助表示赞赏，谢谢。

4

2 回答 2

5

您可以使用一些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构造是一个粗略的解决方法，因为我无法让（委托的）事件侦听器工作。

我观察到的是（不带JavaScript专家）：

  • 下拉菜单的内容在第一次点击之前不会生成。因此，像$('.dropdown-header').on()woudl 这样的直接事件侦听器不起作用，因为该元素尚不存在。
  • 事件委托$(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)
})
于 2021-06-28T09:58:05.307 回答
2

好的，这是针对您的情况使用jsTreeR. 该代码可以正常工作并执行我认为您正在寻找的内容，但它不如shinyWidgets. 我想有一种方法可以结合这种方法（主要取自文档中的 jsTreeR 示例）和本文中创建绑定的方法，以创建看起来不错并具有您正在寻找的功能的东西。

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 功能。您必须将值附加到可以用于下游计算的节点。

于 2021-06-10T16:57:20.780 回答