如何确保在pickerInput选项中每个组中至少选择一个项
如何确保在pickerInput选项中每个组中至少选择一个项
提问于 2020-06-29 02:46:38
我一直未能找到这个问题的答案。下面的代码
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的答案适用于第一个元素。我仍然能够取消选择顺序，颜色和形状从第二个元素开始在治疗的例子上面。请参阅下面的输出：
output2
回答 3
Stack Overflow用户
回答已采纳
发布于 2020-06-29 13:50:38
尝尝这个。如果选项是唯一选定的选项，则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)Stack Overflow用户
发布于 2020-06-29 09:23:11
您基本上是在寻找一个相当于minOptions的maxOptions。不幸的是，pickerInput (bootstrap-select)的底层插件没有这个特性，很可能这样的特性不会被嵌入(关于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)Stack Overflow用户
发布于 2020-06-30 01:01:55
@TimTeaFan，这是个好主意。在看到@Stephane出色的javascript回答之前，这就是我的思路。斯蒂芬恩的答案适用于一个群体，但不适用于多维群体。至少我还没能让它为我的应用程序工作。我稍微修改了@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) }
})
}
})我现在就这么做，直到我能找到更好的解决办法。
update：@StephaneLaurent更新了javascript以解决这个问题，并列出了另一个问题这里。我将使用这两种答案，因为我不确定根据我的js是如何设置的，我是否能够在我的pickerInputs中使用ShinyApp。许多许多人都感谢“斯蒂芬尼洛朗”和“蒂莫蒂凡”。
Update2:我用来解决这个问题的最后答案是@Stephane的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开头，或者适当地调整上面的代码。在我闪闪发亮的应用程序中，所有的十个情节都如预期的那样工作。
页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/62630479
复制相关文章
相似问题
腾讯云开发者
