Group headings for groupCheckboxInput

Question

In shinywidgets::pickerInput you can pass a named list of data (here, nms) to pickerInput to create headings and choices from the list.

For example:

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)

I wish to replicate this heading/choices functionality using shinyWidgets::awesomeCheckboxGroup. Previously I posted this question seeking an answer and was advised that Map could do this. However, Map creates two input objects; I do not require this. The user's choices all need to be fed into a single input object. Is it possible to create headings in awesomeCheckboxGroup while retaining a single input object?

Answer 1

I looked at the source code and modified awesomeCheckboxGroup and the underlying function generateAwesomeOptions to make it work. Now we can use named lists, which will create sub labels, and unnamed vectors, which will produce the normal checkboxes. We could still optimize the code a bit, and I am also not sure how the labels should look like. But basically you can give them a special class attribute and then use CSS to change the appearance of the labels.

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)