Разборный флажок GroupInput в блестящем

Question

Я создал набор флажков, используя 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)
  })

Код является модифицированной версией кода в: как сделать так, чтобы флажок группы входного цвета в Shiny

EDIT

Я адаптировал ответ Стефана к случаю мая. Вот рабочий код:

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)))
  })

Answer 1

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)