时间戳

首页 > 解决方案 > groupCheckboxInput 的组标题

r - groupCheckboxInput 的组标题

问题描述

shinywidgets::pickerInput您可以传递一个命名的数据列表（此处为nms）以从pickerInput列表中创建标题和选项。

例如：

library(shiny)
library(shinyWidgets)
  
nms = list('Consumers' = c('a', 'b'), 
             'Firms' = c('c', 'd'))
  
ui <- fluidPage(
  pickerInput(
    inputId = "somevalue",
    label = "A label",
    choices = nms,
    selected = 'a',
    multiple=T
    ),
    verbatimTextOutput("value")
  )
  
server <- function(input, output) {
   output$value <- renderPrint(input$somevalue)
}
  
shinyApp(ui, server)

我希望使用复制此标题/选择功能shinyWidgets::awesomeCheckboxGroup。以前我发布了这个问题以寻求答案，并被告知Map可以这样做。但是，Map创建了两个输入对象；我不需要这个。用户的选择都需要输入到单个输入对象中。awesomeCheckboxGroup是否可以在保留单个输入对象的同时创建标题？

标签： rshiny

解决方案

我查看了源代码并修改awesomeCheckboxGroup了底层函数generateAwesomeOptions以使其工作。现在我们可以使用命名列表，这将创建子标签，以及未命名的向量，这将产生正常的复选框。我们仍然可以稍微优化代码，我也不确定标签应该是什么样子。但基本上你可以给它们一个特殊的类属性，然后使用 CSS 来改变标签的外观。

library(shiny)
library(shinyWidgets)

generateAwesomeOptions2 <- function (inputId, choices, selected, inline, status, flag = FALSE) {

  # if input is a list, flag will be set to `TRUE` by the calling function
  if (flag) {

  options <-  mapply(choices, names(choices), FUN = function(lchoices, lname) {

    lchoices <- shinyWidgets:::choicesWithNames(lchoices)

    tags$div(
      tags$label(lname, style = "margin-bottom: 10px;"),

    mapply(lchoices, names(lchoices), FUN = function(value, name) {

    inputTag <- tags$input(type = "checkbox", name = inputId,
                           value = value, id = paste0(inputId, value))
    if (value %in% selected)
      inputTag$attribs$checked <- "checked"
    if (inline) {
      tags$div(class = paste0("awesome-checkbox checkbox-inline checkbox-",
                              status), inputTag, tags$label(name, `for` = paste0(inputId,
                                                                                 value)))
    }
    # flag is not set `TRUE` this will create the normal checkboxes
    else {
      tags$div(class = paste0("awesome-checkbox checkbox-",
                              status), inputTag, tags$label(name, `for` = paste0(inputId,
                                                                                 value)))
    }
  }, SIMPLIFY = FALSE, USE.NAMES = FALSE)
  )

  }, SIMPLIFY = FALSE, USE.NAMES = FALSE)} else {

    options <- mapply(choices, names(choices), FUN = function(value,
                                                              name) {
      inputTag <- tags$input(type = "checkbox", name = inputId,
                             value = value, id = paste0(inputId, value))
      if (value %in% selected)
        inputTag$attribs$checked <- "checked"
      if (inline) {
        tags$div(class = paste0("awesome-checkbox checkbox-inline checkbox-",
                                status), inputTag, tags$label(name, `for` = paste0(inputId,
                                                                                   value)))
      }
      else {
        tags$div(class = paste0("awesome-checkbox checkbox-",
                                status), inputTag, tags$label(name, `for` = paste0(inputId,
                                                                                   value)))
      }
    }, SIMPLIFY = FALSE, USE.NAMES = FALSE)


    }

  tags$div(class = "shiny-options-group", options)


}

awesomeCheckboxGroup2 <- function (inputId, label, choices, selected = NULL, inline = FALSE,
                                   status = "primary", width = NULL) {
  if(!is.list(choices)) {

  choices <- shinyWidgets:::choicesWithNames(choices)
  selected <- shiny::restoreInput(id = inputId, default = selected)
  if (!is.null(selected))
    selected <- shinyWidgets:::validateSelected(selected, choices, inputId)
  options <- generateAwesomeOptions2(inputId, choices, selected,
                                     inline, status = status)

  } else {
    choices2 <- unlist(unname(choices))
    choices2 <- shinyWidgets:::choicesWithNames(choices2)
    selected <- shiny::restoreInput(id = inputId, default = selected)

    if (!is.null(selected))
      selected <- shinyWidgets:::validateSelected(selected, choices2, inputId)
    options <- generateAwesomeOptions2(inputId, choices, selected,
                                       inline, status = status, flag = TRUE)
  }

  divClass <- "form-group shiny-input-container shiny-input-checkboxgroup awesome-bootstrap-checkbox"
  if (inline)
    divClass <- paste(divClass, "shiny-input-container-inline")
  awesomeTag <- tags$div(id = inputId, style = if (!is.null(width))
    paste0("width: ", validateCssUnit(width), ";"), class = divClass,
    tags$label(label, `for` = inputId, style = "margin-bottom: 10px;"),
    options)
  shinyWidgets:::attachShinyWidgetsDep(awesomeTag, "awesome")
}


nms = list('Consumers' = c('a', 'b'),
           'Firms' = c('c', 'd'))

nms1 = c("Test", "Test2")

ui <- fluidPage(
  awesomeCheckboxGroup2(
    inputId = "somevalue",
    label = "Make a choice:",
    choices = nms
  ),
  verbatimTextOutput("value")
)

server <- function(input, output) {
  output$value <- renderPrint(input$somevalue)
}

shinyApp(ui, server)

推荐阅读