web-dev-qa-db-fra.com

entrée de la liste déroulante en brillant

Est-il possible d'avoir une liste déroulante dans Shiny où vous pouvez sélectionner plusieurs valeurs? Je sais que selectInput a la possibilité de définir multiple = T Mais je n'aime pas que toutes les options sélectionnées soient visibles à l'écran, d'autant plus que j'en ai plus de 40. Il en va de même pour la fonction checkboxGroupInput(), que j'aime plus mais toutes les valeurs sélectionnées sont toujours affichées. N'est-il pas simplement possible d'obtenir une liste déroulante comme celle que j'ai copiée d'Excel ci-dessous, plutôt que les exemples de Shinys selectInput et checkboxGroupInput() par la suite?

Excelshiny1shiny2shiny3

rdrop-down-menushiny
18
Tim_Utrecht

[~ # ~] edit [~ # ~] : Cette fonction (et d'autres) est disponible dans le package shinyWidgets

Salut, j'ai écrit cette fonction dropdownButton une fois, cela crée un bootstrap déroulant (doc ici ), le résultat ressemble à:

dropdown button

Voici le code:

# 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();
});")
  )
  }

Et un exemple:

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

En bonus, j'ai mis le truc de tri croissant/décroissant dans les seconds boutons déroulants.

EDIT 22 mars 16

Pour diviser vos cases à cocher en plusieurs colonnes, vous pouvez effectuer le fractionnement vous-même avec fluidRow et columns et plusieurs cases à cocher, il vous suffit de lier les valeurs côté serveur. Pour implémenter le défilement, placez vos cases à cocher dans un div avec style='overflow-y: scroll; height: 200px;'.

Regardez cet exemple:

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)
34
Victorp

Tout d'abord, merci beaucoup pour cette fonction dropdownButton. C'est très utile!

Deuxièmement, j'ai essayé de l'utiliser dans le menu latéral du tableau de bord brillant, mais le style des caractères par défaut est "couleur: blanc" (à cause du fond sombre). Cela me prend quelques heures pour comprendre que cela peut être changé à l'intérieur de votre fonction, plus précisément dans html_ul stuff. Voici la ligne d'intérêt, avec couleur: noir:

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

Assez simple ... Mais quand vous ne le connaissez pas (R est le seul langage que je connaisse) ... Donc, j'espère que cela aidera tout autre ignorant les CSS (et/ou HTML?) Comme moi!

À votre santé!

6
Alex D

Il y a quelques questions dans les commentaires concernant le dropdownButton (qui a très bien fonctionné pour moi, merci) sur la façon de créer un barre de défilement sur le menu déroulant. Désolé je n'ai pas la réputation de répondre directement dans les commentaires.

Essayez de modifier l'ID correspondant dans votre styles.css, quel que soit l'objet que vous placez dans le menu déroulant. Ainsi, pour l'exemple, l'ID checkboxGroupInput doit avoir:

#check1
{
   height: 200px;
   overflow: auto;
}

Modifier:

Pour appeler le styles.css dans l'ui.R:

navbarPage("Superzip", id="nav",

  tabPanel("Interactive map",
    div(class="outer",

      tags$head(
        # Include our custom CSS
        includeCSS("styles.css")
      ),

      leafletOutput("map", width="100%", height="100%"), 
      ...

Et le styles.css, avec le débordement automatique pour l'ID d'entrée ttype et chain:

input[type="number"] {


max-width: 80%;
}

div.outer {
  position: fixed;
  top: 41px;
  left: 0;
  right: 0;
  bottom: 0;
  overflow: hidden;
  padding: 0;
}

/* Customize fonts */
body, label, input, button, select { 
  font-family: 'Helvetica Neue', Helvetica;
  font-weight: 200;
}
h1, h2, h3, h4 { font-weight: 400; }

#controls {
  /* Appearance */
  background-color: white;
  padding: 0 20px 20px 20px;
  cursor: move;
  /* Fade out while not hovering */
  opacity: 0.65;
  zoom: 0.9;
  transition: opacity 500ms 1s;
}
#controls:hover {
  /* Fade in while hovering */
  opacity: 0.95;
  transition-delay: 0;
}

#data_inputs {
  /* Appearance */
  background-color: white;
  padding: 0 20px 20px 20px;
  cursor: move;
  /* Fade out while not hovering */
  opacity: 0.65;
  zoom: 0.9;
  transition: opacity 500ms 1s;
}
#data_inputs:hover {
  /* Fade in while hovering */
  opacity: 0.95;
  transition-delay: 0;
}

/* Position and style citation */
#cite {
  position: absolute;
  bottom: 10px;
  left: 10px;
  font-size: 12px;
}

#cite {
  position: absolute;
  bottom: 10px;
  left: 10px;
  font-size: 12px;
}

#ttype
{
   height: 200px;
   overflow: auto;
}

#chain
{
   height: 200px;
   overflow: auto;
}



."form-group shiny-input-checkboxgroup shiny-input-container"
{
   height: 50px;
   overflow: auto;
}

/* If not using map tiles, show a white background */
.leaflet-container {
  background-color: white !important;
}
3
Newshirt