如何在选取器中隐藏或禁用一项输入多项选择 [英] How to hide or disable one item in pickerInput selection of multiple items

问题描述

我正在尝试开发一个shinydashboard应用程序。当用户选择他们的数据集和变量时，我提供了选择顺序、颜色和形状的选项。但是，在PickerInput中，我还提供了另一个(第4个)项，这是为其分配了顺序、颜色和形状的选定变量的值。我需要这第4项/变量进行进一步处理，例如，设置数据子集。我想隐藏这第四项或禁用选项的应用程序的用户选择，因为它已经显示在左边。如果我现在禁用它，它将无法进行进一步处理。示例代码如下：

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))  ##  content issue if longer than 6 characters
  arm <- c(rep("Drug A",2),rep("Drug B",2),rep("Placebo NotDrug",1))  ##  space issue in pickerintput label
  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)
  myfn <- 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 <- myfn(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)


I would appreciate any help to resolve this issue.  

**UPDATE:** On running the code above I get

以下输出。 在Group下显示的最后一个项目是我希望用户没有机会选择的项目。

用户仍应能够为每个护理元素选择顺序、颜色和形状。

推荐答案

试试：

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


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)

这篇关于如何在选取器中隐藏或禁用一项输入多项选择的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！