下拉复选框输入闪亮

Question

是否可以在Shiny中有一个下拉列表,您可以在其中选择多个值？我知道selectInput可以选择设置,multiple = T但我不喜欢它所有选择的选项在屏幕上都可见,特别是因为我有40以上.同样适用checkboxGroupInput(),我更喜欢但仍然显示所有选定的值.是不是可以像我从下面的Excel中复制的那样下拉,而不是Shinys selectInput及其checkboxGroupInput()后的例子？

Answer 1

编辑:此功能(和其他)在包中提供shinyWidgets

嗨我写了这个dropdownButton函数一次,它创建了一个bootstrap下拉按钮(doc here),结果如下:

这是代码:

# func --------------------------------------------------------------------

dropdownButton <- function(label = "", status = c("default", "primary", "success", "info", "warning", "danger"), ..., width = NULL) {

  status <- match.arg(status)
  # dropdown button content
  html_ul <- list(
    class = "dropdown-menu",
    style = if (!is.null(width)) 
      paste0("width: ", validateCssUnit(width), ";"),
    lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px;")
  )
  # dropdown button apparence
  html_button <- list(
    class = paste0("btn btn-", status," dropdown-toggle"),
    type = "button", 
    `data-toggle` = "dropdown"
  )
  html_button <- c(html_button, list(label))
  html_button <- c(html_button, list(tags$span(class = "caret")))
  # final result
  tags$div(
    class = "dropdown",
    do.call(tags$button, html_button),
    do.call(tags$ul, html_ul),
    tags$script(
      "$('.dropdown-menu').click(function(e) {
      e.stopPropagation();
});")
  )
  }

一个例子:

# app ---------------------------------------------------------------------

library("shiny")
ui <- fluidPage(
  tags$h1("Example dropdown button"),
  br(),
  fluidRow(
    column(
      width = 6,
      dropdownButton(
        label = "Check some boxes", status = "default", width = 80,
        checkboxGroupInput(inputId = "check1", label = "Choose", choices = paste(1:26, ") Choice ", LETTERS))
      ),
      verbatimTextOutput(outputId = "res1")
    ),
    column(
      width = 6,
      dropdownButton(
        label = "Check some boxes", status = "default", width = 80,
        actionButton(inputId = "a2z", label = "Sort A to Z", icon = icon("sort-alpha-asc")),
        actionButton(inputId = "z2a", label = "Sort Z to A", icon = icon("sort-alpha-desc")),
        br(),
        actionButton(inputId = "all", label = "(Un)select all"),
        checkboxGroupInput(inputId = "check2", label = "Choose", choices = paste(1:26, ") Choice ", LETTERS))
      ),
      verbatimTextOutput(outputId = "res2")
    )
  )
)
server <- function(input, output, session) {
  output$res1 <- renderPrint({
    input$check1
  })

  # Sorting asc
  observeEvent(input$a2z, {
    updateCheckboxGroupInput(
      session = session, inputId = "check2", choices = paste(1:26, ") Choice ", LETTERS), selected = input$check2
    )
  })
  # Sorting desc
  observeEvent(input$z2a, {
    updateCheckboxGroupInput(
      session = session, inputId = "check2", choices = paste(26:1, ") Choice ", rev(LETTERS)), selected = input$check2
    )
  })
  output$res2 <- renderPrint({
    input$check2
  })
  # Select all / Unselect all
  observeEvent(input$all, {
    if (is.null(input$check2)) {
      updateCheckboxGroupInput(
        session = session, inputId = "check2", selected = paste(1:26, ") Choice ", LETTERS)
      )
    } else {
      updateCheckboxGroupInput(
        session = session, inputId = "check2", selected = ""
      )
    }
  })
}
shinyApp(ui = ui, server = server)

奖金我把升序/降序排序东西放在第二个下拉按钮中.

编辑于2016年3月22日

要将您的复选框分成多个列,您可以使用fluidRow和columns和多个复选框进行拆分,您只需要绑定服务器端的值.要实现滚动,请将复选框放入div中style='overflow-y: scroll; height: 200px;'.

看看这个例子:

library("shiny")
ui <- fluidPage(
  tags$h1("Example dropdown button"),
  br(),
  fluidRow(
    column(
      width = 6,
      dropdownButton(
        label = "Check some boxes", status = "default", width = 450,
        tags$label("Choose :"),
        fluidRow(
          column(
            width = 4,
            checkboxGroupInput(inputId = "check1a", label = NULL, choices = paste0(1:10, ") ", LETTERS[1:10]))
          ),
          column(
            width = 4,
            checkboxGroupInput(inputId = "check1b", label = NULL, choices = paste0(11:20, ") ", LETTERS[11:20]))
          ),
          column(
            width = 4,
            checkboxGroupInput(inputId = "check1c", label = NULL, choices = paste0(21:26, ") ", LETTERS[21:26]))
          )
        )
      ),
      verbatimTextOutput(outputId = "res1")
    ),
    column(
      width = 6,
      tags$style(".container { border:2px solid steelblue; width: 100%; height: 200px; overflow-y: scroll; }"),
      dropdownButton(
        label = "Check some boxes", status = "default", width = 120,
        tags$div(
          class = "container",
          checkboxGroupInput(inputId = "check2", label = "Choose", choices = paste0(1:26, ") ", LETTERS))
        )
      ),
      verbatimTextOutput(outputId = "res2")
    )
  )
)
server <- function(input, output, session) {

  valuesCheck1 <- reactiveValues(x = NULL)
  observeEvent(input$check1a, valuesCheck1$x <- unique(c(valuesCheck1$x, input$check1a)))
  observeEvent(input$check1b, valuesCheck1$x <- unique(c(valuesCheck1$x, input$check1b)))
  observeEvent(input$check1c, valuesCheck1$x <- unique(c(valuesCheck1$x, input$check1c)))

  output$res1 <- renderPrint({
    valuesCheck1$x
  })

  output$res2 <- renderPrint({
    input$check2
  })

}
shinyApp(ui = ui, server = server)

Answer 2

首先,非常感谢这个dropdownButton函数.这非常有用!

其次,我试图将它用于闪亮的仪表板sidebarmenu,但默认字符的样式是"颜色:白色"(因为深色背景).这花了我几个小时的时间来理解可以在你的函数内部改变,更准确地说是html_ul的东西.这是感兴趣的线,颜色:黑色:

lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px; color:black")

非常简单......但是当你不知道它时(R是我所知道的唯一语言)...所以,我希望这能帮助像我这样的任何其他css-ignorant(和/或HTML？)!

干杯!