如何确保在选取器输入选项中，每个组至少选择一个项目 [英] How to ensure that in pickerInput choices at least one item is selected in each group
本文介绍了如何确保在选取器输入选项中，每个组至少选择一个项目的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我在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的答案适用于第一个元素。我仍然可以从上面的处理示例中的第二个元素开始取消选择顺序、颜色和形状。请参见下面的输出：
output2
推荐答案
试试这个。如果某个选项是唯一选择的选项，则该代码防止取消选择该选项。
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)
这篇关于如何确保在选取器输入选项中，每个组至少选择一个项目的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
