Dev Faq
1
votes

Comment s'assurer que dans les choix de sélection d'entrée, au moins un élément est sélectionné dans chaque groupe

Je n'ai pas pu trouver de réponse à ce problème sur SO. Le code ci-dessous 

library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(shinyjs)
library(magrittr)
library(dplyr)

ui <- dashboardPage(
  dashboardHeader(title = "PickerInput Query", titleWidth=450),
  dashboardSidebar( width = 300,
                    useShinyjs(),
                    sidebarMenu(id = "tabs")
  ),
  dashboardBody(
    tags$head(
      tags$style(HTML("
                  .col-sm-10 {
                  width: 45% !important;
                  }

                  .col-sm-2 {
                  width: 55% !important;
                  }

                  "))),
    uiOutput('groupvar'),
    uiOutput('shapetype')
  ))

server <- function(input, output, session) {
  sx <- c("M","F")
  #arm <- c(rep("DrugA",2),rep("DrugB",2),rep("Placebo_NotDrug",1))
  arm <- c(rep("Drug A",2),rep("Drug B",2),rep("Placebo NotDrug",1))
  d <- data.frame(
    subjectID = c(1:100),
    sex = c(rep("F",9),rep(sx,43),rep("M",5)),
    treatment = c(rep(arm,20)),
    race = c(rep("W",76),rep("B",15),rep("O",5),rep("H",1),rep("A",3)),
    baseline_result = c(rnorm(50, 4, 3), rnorm(50, 3, 3)),
    postbase_result = c(rnorm(50, 5, 3), rnorm(50, 4, 2)),
    stringsAsFactors = FALSE)

  dat <- reactive(d)
  myfun <- function(df, var1) {
    df %>% mutate(newvar = !!sym(var1))      # create newvar
  }

  output$groupvar<-renderUI({
      bc<-colnames(dat()[sapply(dat(),class)=="character"])
      tagList(
        pickerInput(inputId = 'group.var',
                    label = 'Select group by variable. Then select order, color and shape',
                    choices = c("NONE",bc[1:length(bc)]), selected="NONE",
                    width = "350px",
                    options = list(`style` = "btn-warning"))
      )
  })

  ###  pick order, color and shape
  observeEvent(input$group.var, {
    output$shapetype<-renderUI({
      req(input$group.var,dat())
      if(is.null(input$group.var)){
        return(NULL)
      }else if(sum(input$group.var=="NONE")==1){
        return(NULL)
      }else{

        mydf <- subset(dat(), dat()[input$group.var] != "")
        mydf2 <- myfun(mydf,input$group.var)   ## create a new variable named newvar
        mygrp <- as.character(unique(mydf2$newvar))
        ngrp <- length(mygrp)
        myorder <- (1:ngrp)
        mycolor <- c("red", "blue", "green", "brown", "orange", "maroon")
        myshape <- c("circle", "triangle", "plus", "cross", "diamond", "downtriangle")
        lapply(1:ngrp, function(i){
          pickerInput(paste0("line.vars.",i),
                      label = paste0(mygrp[i], ":" ),
                      choices = list(DisplayOrder = myorder,
                                     ShapeColor = mycolor,
                                     ShapeType = myshape,
                                     Group = mygrp),  ## how do we hide or disable this 4th item
                      selected = list( i, mycolor[i], myshape[i], mygrp[i] ),
                      multiple = T,
                      inline = TRUE,
                      width = "275px" , #mywidth,
                      options = list('max-options-group' = 1,
                                     `style` = "btn-primary"))
        })

      }
    })
  }, ignoreInit = TRUE)

}

shinyApp(ui, server)

donne le résultat suivant:

output

Il donne la possibilité à l'utilisateur de Choisissez l'ordre, la couleur et la forme pour chacune des valeurs de groupe disponibles dans leurs données. Cependant, lorsque les utilisateurs cliquent à nouveau accidentellement sur leur choix sélectionné, il désélectionne ce choix. Dans l'image ci-dessus, j'ai désélectionné l'ordre, la couleur et la forme du médicament A. Cela ne devrait pas permettre à un utilisateur de désélectionner un groupe. Je m'attends à ce que si la couleur ait le choix entre le rouge et le bleu, ils devraient pouvoir choisir l'une ou l'autre des couleurs mais pas aucune.

La réponse de @Stephane Laurent fonctionne pour le premier élément. Je suis toujours en mesure de désélectionner l'ordre, la couleur et la forme à partir du deuxième élément dans l'exemple de traitement ci-dessus. Veuillez consulter la sortie ci-dessous:

output2

0 commentaires

3 Réponses :

1
votes

Vous recherchez essentiellement un minOptions équivalent à maxOptions . Malheureusement, le plugin sous-jacent de pickerInput ( bootstrap-select ) n'a pas cette fonctionnalité et il est probable qu'une telle fonctionnalité ne sera pas implémentée (voir ici et ici pour les demandes de fonctionnalités similaires sur GitHub).

Une option serait de créer votre propre solution de contournement via shiny. Vous devrez vérifier côté serveur, si l'utilisateur a choisi une option dans chaque groupe, et sinon, afficher un message d'erreur, peut-être avec validate / need . Je joins un exemple simple ci-dessous.

Une autre option serait de supprimer le pickerInput et d'utiliser radioGroupButtons , mais cela pourrait sembler un peu compliqué, étant donné que vous avez plusieurs entrées.

Exemple: vérifier via le serveur et valider / besoin 

library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(shinyjs)
library(magrittr)
library(dplyr)

ui <- dashboardPage(
  dashboardHeader(title = "PickerInput Query", titleWidth=450),
  dashboardSidebar( width = 300,
                    useShinyjs(),
                    sidebarMenu(id = "tabs")
  ),
  dashboardBody(
    tags$head(
      tags$style(HTML("
                  .col-sm-10 {
                  width: 45% !important;
                  }

                  .col-sm-2 {
                  width: 55% !important;
                  }

                  "))),
    textOutput("text"),
    uiOutput('groupvar'),
    uiOutput('shapetype')
  ))

server <- function(input, output, session) {
  sx <- c("M","F")
  #arm <- c(rep("DrugA",2),rep("DrugB",2),rep("Placebo_NotDrug",1))
  arm <- c(rep("Drug A",2),rep("Drug B",2),rep("Placebo NotDrug",1))
  d <- data.frame(
    subjectID = c(1:100),
    sex = c(rep("F",9),rep(sx,43),rep("M",5)),
    treatment = c(rep(arm,20)),
    race = c(rep("W",76),rep("B",15),rep("O",5),rep("H",1),rep("A",3)),
    baseline_result = c(rnorm(50, 4, 3), rnorm(50, 3, 3)),
    postbase_result = c(rnorm(50, 5, 3), rnorm(50, 4, 2)),
    stringsAsFactors = FALSE)
  
  dat <- reactive(d)
  myfun <- function(df, var1) {
    df %>% mutate(newvar = !!sym(var1))      # create newvar
  }
  
  output$groupvar<-renderUI({
    bc<-colnames(dat()[sapply(dat(),class)=="character"])
    tagList(
      pickerInput(inputId = 'group.var',
                  label = 'Select group by variable. Then select order, color and shape',
                  choices = c("NONE",bc[1:length(bc)]), selected="NONE",
                  width = "350px",
                  options = list(`style` = "btn-warning"))
    )
  })
  
  ###  pick order, color and shape
  observeEvent(input$group.var, {
    output$shapetype<-renderUI({
      
      req(input$group.var,dat())
      if(is.null(input$group.var)){
        return(NULL)
      }else if(sum(input$group.var=="NONE")==1){
        return(NULL)
      }else{
        
        mydf <- subset(dat(), dat()[input$group.var] != "")
        mydf2 <- myfun(mydf,input$group.var)   ## create a new variable named newvar
        mygrp <- as.character(unique(mydf2$newvar))
        ngrp <- length(mygrp)
        myorder <- (1:ngrp)
        mycolor <- c("red", "blue", "green", "brown", "orange", "maroon")
        myshape <- c("circle", "triangle", "plus", "cross", "diamond", "downtriangle")
        lapply(1:ngrp, function(i){
          pickerInput(paste0("line.vars.",i),
                      label = paste0(mygrp[i], ":" ),
                      choices = list(DisplayOrder = myorder,
                                     ShapeColor = mycolor,
                                     ShapeType = myshape,
                                     Group = mygrp),  ## how do we hide or disable this 4th item
                      selected = list( i, mycolor[i], myshape[i], mygrp[i] ),
                      multiple = T,
                      inline = TRUE,
                      width = "275px" , #mywidth,
                      options = list('max-options-group' = 1,
                                     `style` = "btn-primary"))
          
          
        })
        
      }
    })
  }
  , ignoreInit = TRUE)
  
  output$text <- renderText({
    validate(
      need(length(input$line.vars.1) == 4,
           "Please choose one option in every category to proceed.")
    )

    paste(input$line.vars.1, collapse = ", ")
    })
  
}

shinyApp(ui, server)

3 commentaires

Vous avez raison de dire que je recherche minOptions . La vérification côté serveur devient compliquée et ne fonctionne pas car l'entrée a 4 choix, mais le nombre de variables est le nombre d'éléments uniques pour la variable de groupe sélectionnée par l'utilisateur. Cela pourrait même être 21 ou plus car il existe un vaccin avec 21 sérotypes. Donc, j'ai dû ajuster la logique pour faire défiler les couleurs et les formes s'il y a plus d'éléments que le nombre de choix que je donne. Aujourd'hui, je vais vérifier si je peux utiliser autre chose que pickerInput . Peut-être que radioGroupButtons ou selectizeInput pourrait fonctionner.

Je crée un dataframe à partir de cette entrée et le passe à un programme qui trace le tracé sélectionné. la couleur et la forme des points de dispersion et l'ordre de la légende utilisent cette entrée.

J'ai mis à jour ma réponse avec un exemple de jouet de valider / besoin pour le premier de vos pickerInputs . Je génère un textOutput à titre d'exemple et un message s'affiche pour indiquer à l'utilisateur de sélectionner une option de chaque groupe. Ce n'est pas aussi agréable qu'une solution Javascript, mais il est facile à mettre en œuvre et à maintenir.

1
votes

Essayez ceci. Le code JavaScript empêche de désélectionner une option s'il s'agit de l'option sélectionnée unique. 

library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(dplyr)

js <- "
$(document).ready(function(){
  $('#shapetype').on('show.bs.select', 'select[id^=linevars]', function(){
    $('a[role=option]').on('click', function(e){
      var classes = $(this).parent().attr('class').split(/\\s+/);
      if(classes.length === 2){
        var group = classes[0];
        var selections = $('.' + group + '.selected');
        if(selections.length === 1){
          e.stopImmediatePropagation();
        }
      }
    });
  }).on('hide.bs.select', function(){
    $('a[role=option]').off('click');
  });
});"

ui <- dashboardPage(
  dashboardHeader(title = "PickerInput Query", titleWidth=450),
  dashboardSidebar( width = 300,
                    sidebarMenu(id = "tabs")
  ),
  dashboardBody(
    tags$head(
      tags$style(HTML("
                      .col-sm-10 {
                      width: 45% !important;
                      }
                      
                      .col-sm-2 {
                      width: 55% !important;
                      }
                      
                      ")),
      tags$script(HTML(js))
    ),
    uiOutput('groupvar'),
    uiOutput('shapetype')
      ))

server <- function(input, output, session) {
  sx <- c("M","F")
  #arm <- c(rep("DrugA",2),rep("DrugB",2),rep("Placebo_NotDrug",1))
  arm <- c(rep("Drug A",2),rep("Drug B",2),rep("Placebo NotDrug",1))
  d <- data.frame(
    subjectID = c(1:100),
    sex = c(rep("F",9),rep(sx,43),rep("M",5)),
    treatment = c(rep(arm,20)),
    race = c(rep("W",76),rep("B",15),rep("O",5),rep("H",1),rep("A",3)),
    baseline_result = c(rnorm(50, 4, 3), rnorm(50, 3, 3)),
    postbase_result = c(rnorm(50, 5, 3), rnorm(50, 4, 2)),
    stringsAsFactors = FALSE)
  
  dat <- reactive(d)
  myfun <- function(df, var1) {
    df %>% mutate(newvar = !!sym(var1))      # create newvar
  }
  
  output$groupvar<-renderUI({
    bc<-colnames(dat()[sapply(dat(),class)=="character"])
    tagList(
      pickerInput(inputId = 'group.var',
                  label = 'Select group by variable. Then select order, color and shape',
                  choices = c("NONE",bc[1:length(bc)]), selected="NONE",
                  width = "350px",
                  options = list(`style` = "btn-warning"))
    )
  })
  
  ###  pick order, color and shape
  observeEvent(input$group.var, {
    output$shapetype<-renderUI({
      req(input$group.var,dat())
      if(is.null(input$group.var)){
        return(NULL)
      }else if(sum(input$group.var=="NONE")==1){
        return(NULL)
      }else{
        
        mydf <- subset(dat(), dat()[input$group.var] != "")
        mydf2 <- myfun(mydf,input$group.var)   ## create a new variable named newvar
        mygrp <- as.character(unique(mydf2$newvar))
        ngrp <- length(mygrp)
        myorder <- (1:ngrp)
        mycolor <- c("red", "blue", "green", "brown", "orange", "maroon")
        myshape <- c("circle", "triangle", "plus", "cross", "diamond", "downtriangle")
        lapply(1:ngrp, function(i){
          pickerInput(paste0("linevars",i),
                      label = paste0(mygrp[i], ":" ),
                      choices = list(DisplayOrder = myorder,
                                     ShapeColor = mycolor,
                                     ShapeType = myshape,
                                     Group = mygrp),  ## how do we hide or disable this 4th item
                      selected = list( i, mycolor[i], myshape[i], mygrp[i] ),
                      multiple = T,
                      inline = TRUE,
                      width = "275px" , #mywidth,
                      options = list('max-options-group' = 1,
                                     `style` = "btn-primary"))
        })
        
      }
    })
  }, ignoreInit = TRUE)
  
}

shinyApp(ui, server)

EDIT

Je vois que vous utilisez pickerInput avec groupes d'options. Voici le code JS pour cette situation: 

js <- "
$(document).ready(function(){
  $('#groups').on('show.bs.select', function(){
    $('a[role=option]').on('click', function(e){
      var classes = $(this).parent().attr('class').split(/\\s+/);
      if(classes.length === 2){
        var group = classes[0];
        var selections = $('.' + group + '.selected');
        if(selections.length === 1){
          e.stopImmediatePropagation();
        }
      }
    });
  }).on('hide.bs.select', function(){
    $('a[role=option]').off('click');
  });
});"

ui <- fluidPage(
  tags$head(tags$script(HTML(js))),
  pickerInput(
    inputId = "groups",
    label = "Select one from each group below:",
    choices = list(
      Group1 = c("1", "2", "3", "4"),
      Group2 = c("A", "B", "C", "D")
    ),
    multiple = TRUE
  ),
  verbatimTextOutput(outputId = "res_grp")
)

server <- function(input, output) {
  output$res_grp <- renderPrint(input$groups)
}

shinyApp(ui, server)

EDIT

Pour votre cas: 

js <- "
$(document).ready(function(){
  $('#somevalue').on('show.bs.select', function(){
    $('a[role=option]').on('click', function(e){
      var selections = $('#somevalue').val();
      if(selections.length === 1 && $(this).hasClass('selected')){
        e.stopImmediatePropagation();
      };
    });
  }).on('hide.bs.select', function(){
    $('a[role=option]').off('click');
  });
});"

ui <- fluidPage(
  tags$head(tags$script(HTML(js))),
  pickerInput(
    inputId = "somevalue",
    label = "A label",
    choices = c("a", "b"), 
    multiple = TRUE
  ),
  verbatimTextOutput("value")
)

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

shinyApp(ui, server)

p>

9 commentaires

Oui, @Stephane Laurent, vous l'avez. Cela fonctionne parfaitement sur votre exemple, lorsque je définis choix sélectionnés et maxOptions . Cependant, cela ne fonctionne pas sur mon exemple ci-dessus. Est-ce parce que mon pickerInput est côté serveur? De plus, c'est à l'intérieur de observeEvent et de output $ shapetype , est-ce que ce serait un problème? Enfin, j'aurai n variables input $ line.vars.i , où i vaut 1: n et n est le nombre unique de valeurs de variable de groupe.

Veuillez noter que dans l'exemple ci-dessus, le traitement a 3 valeurs. Pour chaque traitement, je donne à l'utilisateur la possibilité de sélectionner l'ordre (à afficher dans la légende), la couleur et la forme des points de dispersion qu'il souhaite voir leur tracé. Par défaut, je sélectionne une valeur pour chaque valeur de traitement. Les utilisateurs devraient avoir la possibilité de le modifier mais pas de le désélectionner complètement dans le pickerInput. La désélection peut être effectuée lorsqu'ils cliquent sur la sortie tracée.

@YBS Voir ma modification. Est-ce que c'est bon ? Notez que j'ai supprimé les points dans les ids line.vars.i , sinon cela ne fonctionnait pas. En général, vous devez toujours éviter les points dans un identifiant.

Cela ne fonctionne toujours pas. Je suis d'accord, les périodes ne sont d'aucune utilité pour moi dans les identifiants. Même sans règles, cela ne fonctionne pas. J'ai mis les balises js au-dessus de ui et $ head () dans le dashboardbody () . Peut-être devrais-je le mettre ailleurs?

@YBS Si vous copiez-collez mon code, ça marche? Pour moi, ça marche.

Votre adaptation fonctionne parfaitement. Merci beaucoup. Comment adapter ce javascript à plusieurs entrées de sélection? Je ne suis pas familier avec javascript. Puis-je simplement ajouter les différents noms et identifiants de sortie avec une virgule? Par exemple, ajoutez une deuxième information d'entrée de sélection comme $ ('# shapetype', '# shapetype2'). On ('show.bs.select', 'select [id ^ = linevars]', 'select [id ^ = linevars2] ', function () {? Veuillez noter que dans mon application, j'ai plus de 10 parcelles différentes, et chaque parcelle avec 1 à 4 entrées de sélection.

@YBS Je ne me souviens pas si c'est $ ('# shapetype', '# shapetype2) ou $ (' # shapetype, # shapetype2) . Essayez les deux. Vous pouvez également utiliser $ ('div [id ^ = shapetype]') . Ceci sélectionne tous les éléments div dont l'id commence par shapetype .

Dans votre javascript, pouvons-nous le modifier pour qu'un utilisateur ne puisse pas modifier le 4ème élément présélectionné? Cela signifie que les utilisateurs doivent pouvoir choisir l'ordre, la couleur et la forme, mais pas la valeur du traitement qui provient de la trame de données. J'ai posé cette question séparément ici: stackoverflow.com/questions/62507235/...

@YBS J'ai vérifié à nouveau et pour moi le code que j'ai fourni fonctionne bien pour chaque pickerInput. Avez-vous changé quelque chose?

1
votes

@TimTeaFan, c'est une excellente idée. C'était ma façon de penser avant de voir l'excellente réponse javascript de @Stephane Laurent. La réponse de Stéphane fonctionne pour un groupe, mais pas pour des groupes multidimensionnels. Au moins, je n'ai pas pu le faire fonctionner pour mon application. J'ai légèrement modifié la réponse de @ TimTeaFan et l'ai adaptée à tous les pickerInputs . Je le rend avec renderUI . Dans votre code, output $ text est modifié comme indiqué ci-dessous. Évidemment, textOutput devrait être remplacé par uiOutput dans ui.

js <- "
$(document).ready(function(){
  $('div[id^=shapetype]').on('show.bs.select', 'select[id^=linevars]', function(){
    $('a[role=option]').on('click', function(e){
      var classes = $(this).parent().attr('class').split(/\\s+/);
      if(classes.length === 2){
        var group = classes[0];
        var $ul = $(this).parent().parent();
        var selections = $ul.find('.' + group + '.selected');
        if(selections.length === 1){
          e.stopImmediatePropagation();
        }
      }else if(classes.length === 1){
        var group = classes[0];
        var $ul = $(this).parent().parent();
        var groupname = $ul.find('li.dropdown-header.' + group + '>span').text();
        if(groupname === 'Group'){
          e.stopImmediatePropagation();
        }
      }
    });
  }).on('hide.bs.select', 'select[id^=linevars]', function(){
    $('a[role=option]').off('click');
  });
});"

Je vais y aller pour le moment , jusqu'à ce que je puisse obtenir une meilleure solution.

mise à jour : @StephaneLaurent a mis à jour le javascript pour résoudre ce problème et un autre problème répertorié ici . J'utiliserai ces deux réponses car je ne suis pas sûr de pouvoir utiliser js dans tous mes pickerInputs en fonction de la configuration de mon ShinyApp. Un grand merci à @StephaneLaurent et @TimTeaFan.

Update2: La réponse finale que j'ai utilisée pour résoudre ce problème est le javascript de @Stephane Laurent. Pour être complet, je l'ai joint ci-dessous. 

output$text <- renderUI({
    if(is.null(input$group.var)){
      return(NULL)
    }else if(sum(input$group.var=="NONE")==1){
      return(NULL)
    }else{
      lapply(1:ngrp(), function(i){
        q1 <- paste0("line.vars.",i)
        uivar  <- expr('$'(input,!!q1))
        req(uivar)
        fval <- eval_tidy(uivar)
        if (length(fval) < 4) {
          tagList(
            p("ERROR: Please choose one option in every category to proceed.", style = "color:red")
          )
        }else{ return(NULL) }
      })
    }
  })

La seule mise en garde est que tous les noms de sortie doivent commencer par shapetype, et les ID de variables doivent commencer par des lignes ou ajuster le code ci-dessus de manière appropriée . Les dix graphiques de mon application brillante fonctionnent comme prévu.

0 commentaires

Articles qui pourrait vous intéresser :

Comment créer une barre de couleur dégradée discrète avec geom_contour_filled?
Variable de bande dans R
Mélanger le vecteur dans R, mais les éléments identiques doivent avoir une distance minimale
Pour imprimer la valeur de l'année bissextile suivante en utilisant la variable dans la programmation R