问题
I am trying to develop a shinydashboard application. As users select their dataset and variables, I provide the option to select the order, color and shape. However, in the pickerInput I am also providing another (4th) item which is the value of the variable selected for which the order, color and shape has been assigned. I need this 4th item/variable for further processing, such as, subsetting data. I would like to hide this 4th item or disable the option for users of the app to select, as it is already displayed on the left. If I disable it now, it is not available for further processing. A sample code is given 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)) ## 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
the following output. The last item displayed, under Group, is what I would like the user to not have a chance to pick.
The user should still be able to pick the order, color and shape for each of the elements of treatment.
回答1:
Try this:
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)
回答2:
I am not sure what you want to achieve. Just remove the last group of choices called Group for each pickerInput?
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), ## 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)
来源：https://stackoverflow.com/questions/62507235/how-to-hide-or-disable-one-item-in-pickerinput-selection-of-multiple-items