html - 可折叠的checkboxGroupInput Shiny

我已经使用renderUI和checkboxGroupInput创建了一组复选框。结果如下：
 

我现在想获得的是这样的：



仅显示最高结果的地方，可以扩展复选框列表。

关于如何获得此建议？

复选框的代码如下：

Server.R：

    my_checkboxGroupInput <- function(variable, label,choices, selected, colors,perc){
    my_names <- choices
    log_funct("my_names",my_names,   verbose=T)
    if(length(names(choices))>0) my_names <- names(choices)
    log_funct("names(my_names)",my_names,   verbose=T)
    log_funct("choices",choices,   verbose=T)
     log_funct("selected",selected,   verbose=T)
    div(id=variable,class="form-group shiny-input-checkboxgroup shiny-input-container shiny-bound-input",
        HTML(paste0('<label class="control-label" for="',variable,'">',label,'</label>')),
        div( class="shiny-options-group",
             HTML(paste0('<div class="checkbox">',
                         '<label style="width: 100%">',
                         '<input type="checkbox" name="', variable,
                         '" value="', choices,
                         '"', ifelse(choices %in% selected, 'checked="checked"', ''),
                         '/>',
                         #'<span ', ifelse(choices %in% selected, paste0('style=" background-color:',colors ,'; display: inline-block; white-space: nowrap; width: ',perc, '%;"'),''), '>',my_names,'</span>',
                         '<span ', paste0('style=" background-color:',colors ,'; display: inline-block; white-space: nowrap; width: ',perc, '%;"'),'>',my_names,'</span>',
                         '</label>',
                         '</div>', collapse = " "))
        )
    )
  }

  output$checkbox_cond <- renderUI({

    my_checkboxGroupInput("variable", "Variable:",choices = cond_plot()$Var1,
                          selected=c(as.character(cond_plot()$Var1)[1],as.character(cond_plot()$Var1)[2]),
                          colors=c('#4e71ba'),
                          perc= cond_plot()$perc)
  })

该代码是以下代码的修改版本：
how to make the checkboxgroupinput color-coded in Shiny

编辑

我已针对可能的情况调整了斯蒂芬的答案。这里是工作代码：

my_checkboxGroupInput <- function(variable, label,choices, selected, colors,perc){
    my_names <- choices

    if(length(names(choices))>0) my_names <- names(choices)

    div(id=variable,class="form-group shiny-input-checkboxgroup shiny-input-container shiny-bound-input",
        HTML(paste0('<label class="control-label" for="',variable,'">',label,'</label>')),
        div( class="shiny-options-group",
             HTML(paste0('<div class="checkbox">',
                         '<label style="width: 100%">',
                         '<input type="checkbox" name="', variable,
                         '" value="', choices,
                         '"', ifelse(choices %in% selected, 'checked="checked"', ''),
                         '/>',
                         #'<span ', ifelse(choices %in% selected, paste0('style=" background-color:',colors ,'; display: inline-block; white-space: nowrap; width: ',perc, '%;"'),''), '>',my_names,'</span>',
                         '<span ', paste0('style=" background-color:',colors ,'; display: inline-block; white-space: nowrap; width: ',perc, '%;"'),'>',my_names,'</span>',
                         '</label>',
                         '</div>', collapse = " "))
        )
    )
  }

output$checkbox_cond <- renderUI({
    inputId="collapsibleCheckbox"
    label="Options:"
    i=3
    choices = cond_plot()$Var1
    selected=c(as.character(cond_plot()$Var1)[1])
    colors=c('#4e71ba')
    perc= cond_plot()$perc
    input <- my_checkboxGroupInput(inputId, label,choices = cond_plot()$Var1,
                                   selected=c(as.character(cond_plot()$Var1)[1],as.character(cond_plot()$Var1)[2]),
                                   colors=c('#4e71ba'),
                                   perc= cond_plot()$perc)
    checkboxes <- input[[3]][[2]][[3]][[1]]
    id_btn <- paste0(inputId, "_btn")
    id_div <- paste0(inputId, "_collapsible")
    btn <- actionButton(id_btn, "More...",
                        icon = icon("collapse-up", lib = "glyphicon"),
                        class = "btn-primary btn-sm",
                        `data-toggle`="collapse",
                        `data-target` = paste0("#", id_div))

    checkboxelements<-paste(strsplit(input$children[[2]]$children[[1]],"</label></div>")[[1]],"</label></div>",sep="")
    checkboxes_1_i=paste0(checkboxelements[1:i],collapse = "")



   checkboxes_i_end=paste0(checkboxelements[(i+1):length(checkboxelements)],collapse = "")
    children <- HTML(paste0(checkboxes_1_i, "<div id=",id_div," class='collapse'>",checkboxes_i_end,"</div>", btn,collapse=""))
    input[[3]][[2]][[3]][[1]] <- children
    script <- sprintf('$(document).ready(function(){
      $("#%s_collapsible").on("hide.bs.collapse", function(){
        $("#%s_btn").html("<span class=\\\"glyphicon glyphicon-collapse-down\\\"></span> More...");
      });
      $("#%s_collapsible").on("show.bs.collapse", function(){
        $("#%s_btn").html("<span class=\\\"glyphicon glyphicon-collapse-up\\\"></span> Less...");
      });
    });', inputId, inputId, inputId, inputId)
    tagList(tags$html(input), tags$script(HTML(script)))
  })

最佳答案

library(shiny)

collapsibleCheckboxGroupInput <-
  function(inputId, label, i, choices = NULL, selected = NULL, width = NULL,
           choiceNames = NULL, choiceValues = NULL){
    input <- checkboxGroupInput(inputId, label, choices = choices,
                                selected = selected, width = width,
                                choiceNames = choiceNames,
                                choiceValues = choiceValues)
    checkboxes <- input[[3]][[2]][[3]][[1]]
    id_btn <- paste0(inputId, "_btn")
    id_div <- paste0(inputId, "_collapsible")
    btn <- actionButton(id_btn, "More...",
                        icon = icon("collapse-up", lib = "glyphicon"),
                        class = "btn-primary btn-sm",
                        `data-toggle`="collapse",
                        `data-target` = paste0("#", id_div))
    collapsible <- div(id = id_div, class = "collapse")
    collapsible$children <- checkboxes[(i+1):length(checkboxes)]
    children <- c(checkboxes[1:i], list(btn), list(collapsible))
    input[[3]][[2]][[3]][[1]] <- children
    script <- sprintf('$(document).ready(function(){
      $("#%s_collapsible").on("hide.bs.collapse", function(){
        $("#%s_btn").html("<span class=\\\"glyphicon glyphicon-collapse-down\\\"></span> More...");
      });
      $("#%s_collapsible").on("show.bs.collapse", function(){
        $("#%s_btn").html("<span class=\\\"glyphicon glyphicon-collapse-up\\\"></span> Less...");
      });
    });', inputId, inputId, inputId, inputId)
    tagList(input, tags$script(HTML(script)))
  }

ui <- fluidPage(
  collapsibleCheckboxGroupInput(
    "checkboxes", "Make your choice:", i = 2,
    choiceNames = list("Choice A", "Choice B", "Choice C", "Choice D", "Choice E"),
    choiceValues = list("A", "B", "C", "D", "E")
  ),
  br(),
  verbatimTextOutput("choices")
)

server <- function(input, output){
  output[["choices"]] <- renderPrint({
    input[["checkboxes"]]
  })
}

shinyApp(ui, server)

shinyWidgets更时尚：

library(shiny)
library(shinyWidgets)

collapsibleAwesomeCheckboxGroupInput <-
  function(inputId, label, i, choices = NULL, selected = NULL,
           status = "primary", width = NULL){
    input <- awesomeCheckboxGroup(inputId, label, choices = choices,
                                  selected = selected, width = width,
                                  status = status)
    checkboxes <- input[[3]][[2]][[3]][[1]]
    id_btn <- paste0(inputId, "_btn")
    id_div <- paste0(inputId, "_collapsible")
    btn <- actionButton(id_btn, "More...",
                        style = "margin-bottom: 12px",
                        icon = icon("collapse-up", lib = "glyphicon"),
                        class = "btn-primary btn-sm",
                        `data-toggle`="collapse",
                        `data-target` = paste0("#", id_div))
    collapsible <- div(id = id_div, class = "collapse")
    collapsible$children <- checkboxes[(i+1):length(checkboxes)]
    children <- c(checkboxes[1:i], list(btn), list(collapsible))
    input[[3]][[2]][[3]][[1]] <- children
    script <- sprintf('$(document).ready(function(){
      $("#%s_collapsible").on("hide.bs.collapse", function(){
        $("#%s_btn").html("<span class=\\\"glyphicon glyphicon-collapse-down\\\"></span> More...");
      });
      $("#%s_collapsible").on("show.bs.collapse", function(){
        $("#%s_btn").html("<span class=\\\"glyphicon glyphicon-collapse-up\\\"></span> Less...");
      });
    });', inputId, inputId, inputId, inputId)
    tagList(input, tags$script(HTML(script)))
  }

ui <- fluidPage(
  collapsibleAwesomeCheckboxGroupInput(
    "checkboxes", "Make your choice:", i = 2,
    choices = list("Choice A" = "A", "Choice B" = "B", "Choice C" = "C",
                   "Choice D" = "D", "Choice E" = "E")
  ),
  br(),
  verbatimTextOutput("choices")
)

server <- function(input, output){
  output[["choices"]] <- renderPrint({
    input[["checkboxes"]]
  })
}

shinyApp(ui, server)

使用shintWidgets::actionBttn更时尚：

library(shiny)
library(shinyWidgets)

collapsibleAwesomeCheckboxGroupInput <-
  function(inputId, label, i, choices = NULL, selected = NULL,
           status = "primary", width = NULL){
    input <- awesomeCheckboxGroup(inputId, label, choices = choices,
                                  selected = selected, width = width,
                                  status = status)
    checkboxes <- input[[3]][[2]][[3]][[1]]
    id_btn <- paste0(inputId, "_btn")
    id_div <- paste0(inputId, "_collapsible")
    btn <- actionBttn(id_btn, "More...", color = "primary", size = "sm",
                      style = "minimal", icon = icon("collapse-up", lib = "glyphicon"))
    collapsible <- div(id = id_div, class = "collapse")
    collapsible$children <- checkboxes[(i+1):length(checkboxes)]
    children <- c(checkboxes[1:i], list(btn), list(collapsible))
    input[[3]][[2]][[3]][[1]] <- children
    script <- sprintf('$(document).ready(function(){
      $("#%s_btn").attr("data-target", "#%s_collapsible").attr("data-toggle", "collapse").css("margin-bottom", "11px");
      $("#%s_collapsible").on("hide.bs.collapse", function(){
        $("#%s_btn").html("<span class=\\\"glyphicon glyphicon-collapse-down\\\"></span> More...");
      });
      $("#%s_collapsible").on("show.bs.collapse", function(){
        $("#%s_btn").html("<span class=\\\"glyphicon glyphicon-collapse-up\\\"></span> Less...");
      });
    });', inputId, inputId, inputId, inputId, inputId, inputId)
    tagList(input, tags$script(HTML(script)))
  }

ui <- fluidPage(
  collapsibleAwesomeCheckboxGroupInput(
    "checkboxes", "Make your choice:", i = 2,
    choices = list("Choice A" = "A", "Choice B" = "B", "Choice C" = "C",
                   "Choice D" = "D", "Choice E" = "E")
  ),
  br(),
  verbatimTextOutput("choices")
)

server <- function(input, output){
  output[["choices"]] <- renderPrint({
    input[["checkboxes"]]
  })
}

shinyApp(ui, server)