【问题标题】：How to ensure that in pickerInput choices at least one item is selected in each group如何确保在 pickerInput 选项中每个组中至少选择一个项目
【发布时间】：2020-10-19 03:57:31
【问题描述】：

我无法在 SO 上找到此问题的答案。下面的代码

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)

给出以下输出：

它为用户提供了为其数据中每个可用组值选择顺序、颜色和形状的选项。但是，当用户不小心再次单击他们选择的选项时，它会取消选择该选项。在上图中，我取消了药物 A 的顺序、颜色和形状。它不应允许用户取消选择任何组。我的期望是，如果颜色可以选择红色和蓝色，他们应该可以选择任何一种颜色，但不能没有。

@Stephane Laurent 的回答适用于第一个元素。在上面的处理示例中，我仍然可以从第二个元素开始取消选择顺序、颜色和形状。请看下面的输出：

输出2

【问题讨论】：

标签： r shiny shinydashboard

【解决方案1】：

试试这个。如果某个选项是唯一选定的选项，则 JavaScript 代码会阻止取消选择该选项。

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)

编辑

我看到您正在使用带有选项组的pickerInput。下面是针对这种情况的JS代码：

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)

编辑

对于您的情况：

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)

【讨论】：

是的，@Stephane Laurent，你明白了。当我定义selected choices 和maxOptions 时，它在您的示例中完美运行。但是，它不适用于我上面的示例。是因为我的pickerInput 在服务器端吗？此外，它在observeEvent 和output$shapetype 内部，这会是个问题吗？最后，我将拥有n 变量input$line.vars.i，其中i 是1:n，n 是组变量值的唯一数量。
请注意，在上面的例子中，治疗有 3 个值。对于每种处理，我让用户选择他们希望查看其绘图的散点的顺序（显示在图例中）、颜色和形状。默认情况下，我为每个处理值选择一个值。用户应该可以选择更改它，但不能在 pickerInput 中完全取消选择它。当他们点击 plotly 输出时可以取消选择。
@YBS 查看我的编辑。可以吗？请注意，我删除了 ids line.vars.i 中的句点，否则这不起作用。一般来说，您应该始终避免在 id 中使用句点。
还是不行。我同意，在 ID 中句号对我没有任何用处。即使没有期间，它也不起作用。我把js 上面的ui 和tags$head() 放在dashboardbody() 里面。也许我应该把它放在别的地方？
@YBS 如果您复制粘贴我的代码，它可以工作吗？对我来说它有效。

【解决方案2】：

您基本上是在寻找与maxOptions 等效的minOptions。不幸的是，pickerInput (bootstrap-select) 的底层插件没有这个功能，并且很可能不会实现这样的功能（参见here 和here GitHub 上的类似功能请求）。

一种选择是通过闪亮构建自己的解决方法。您需要在服务器端检查用户是否在每个组中选择了一个选项，如果没有，则显示错误消息，可能带有validate/need。下面我附上一个简单的例子。

另一种选择是删除pickerInput 并使用radioGroupButtons，但考虑到您有多个输入，这可能看起来有点混乱。

示例：通过服务器端检查并验证/需要

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)

【讨论】：

你是对的，我正在寻找minOptions。在服务器端检查变得混乱并且不起作用，因为输入有 4 个选项，但变量的数量是用户选择的组变量的唯一项目数。它甚至可能是 21 种或更多，因为有一种具有 21 种血清型的疫苗。因此，如果项目数量多于我提供的选择数量，我必须调整逻辑以循环显示颜色和形状。今天我会检查我是否可以使用pickerInput以外的东西。也许radioGroupButtons 或selectizeInput 可能会起作用。
我用这个输入创建了一个数据框，并将它传递给一个绘制所选图的程序。散点的颜色和形状，图例的顺序正在使用这个输入。
我用validate/need 的玩具示例更新了我的答案，作为您的第一个pickerInputs。我生成一个textOutput 作为示例，将显示一条消息，告诉用户选择每个组的一个选项。它不如 Javascript 解决方案好，但它易于实现和维护。

【解决方案3】：

@TimTeaFan，这是个好主意。这是我在看到@Stephane Laurent 出色的 javascript 答案之前的想法。 Stephane 的答案适用于一组，但不适用于多维组。至少我无法让它适用于我的应用程序。我稍微修改了@TimTeaFan 的答案，并将其改编为所有pickerInputs。我用renderUI 渲染它。在您的代码中output$text 被修改如下所示。显然，textOutput 应该在ui 中改为uiOutput。

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

我会先解决这个问题，直到找到更好的解决方案。

更新：@StephaneLaurent 已更新 javascript 以解决此问题，并列出了here 中的另一个问题。我将使用这两个答案，因为我不确定我是否能够根据我的 ShinyApp 的设置方式在我的所有pickerInputs 中使用js。非常感谢@StephaneLaurent 和@TimTeaFan。

Update2： 我用来解决这个问题的最终答案是来自@Stephane Laurent 的 javascript。为了完整起见，我将其附在下面。

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

唯一需要注意的是，所有输出名称都应以 shapetype 开头，变量 ID 应以 linevars 开头或适当调整上述代码。我闪亮的应用程序中的所有十个图都按预期工作。

【讨论】：