How to ensure that in pickerInput choices at least one item is selected in each group

Question

I have not been able to find an answer to this issue on SO. The code below

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)

gives the following output:

It gives the option for the user to pick the order, color and shape for each of the available group value in their data. However, when users accidentally click on their selected choice again, it deselects that choice. In the image above, I have deselected order, color and shape for Drug A. It should not allow a user to deselect any group. My expectation is that if color has a choice of red and blue, they should be able to pick either color but not none.

@Stephane Laurent's answer works for the first element. I am still able to deselect order, color and shape from the second element onwards in the treatment example above. Please see the output below:

output2

user_1100107 · Answer

Try this. The JavaScript code prevents to deselect an option if it is the unique selected option.

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)

EDIT

I see that you are using pickerInput with groups of options. Here is the JS code for this 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

For your case:

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)

user_9349302 · Answer

You are basically looking for a minOptions equivalent to maxOptions. Unfortunately, the underlying plugin of pickerInput (bootstrap-select) does not have this feature and it is likely that such a feature will not be implmented (see here and here for similar feature requests on GitHub).

One option would be build your own workaround via shiny. You would need to check on the server side, whether the user has chosen one option in each group, and if not, display an error message, maybe with validate/need. I attach a simple example below.

Another option would be to drop the pickerInput and use radioGroupButtons, but this could look a bit messy, given that you have several inputs.

Example: check via server side and validate / need

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)

user_13333279 · Answer

@TimTeaFan, that is a great idea. That was my line of thinking before seeing @Stephane Laurent's excellent javascript answer. Stephane's answer works for one group, but not multi-dimensional groups. At least I have not been able to make it work for my app. I have modified @TimTeaFan's answer slightly and adapted it to all pickerInputs. I render it with renderUI. In your code output$text is modified as shown below. Obviously, textOutput should be changed to uiOutput in ui.

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

I will go with this for now, until I can get a better solution.

update: @StephaneLaurent has updated the javascript to solve this problem and another problem listed here. I will be using both these answers as I am not sure that I will be able to use js in all my pickerInputs based on how my ShinyApp has been setup. Many many many thanks to both @StephaneLaurent and @TimTeaFan.

Update2: The final answer I used to solve this issue is javascript from @Stephane Laurent. For completeness I have attached it below.

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

The only caveat is that all the output names should start with shapetype, and variable IDs should start with linevars or adjust the above code appropriately. All ten plots in my shiny app work as expected.

How to ensure that in pickerInput choices at least one item is selected in each group

3 Answers

EDIT

EDIT