inline 为 TRUE 时的 PickerInput 标签问题
PickerInput label issue when inline is TRUE
我有一个 r shiny 应用程序，用户在绘图之前需要在其中进行多种选择。在 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(
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))
)
dat <- reactive(d)
myfun <- function(df, var1) {
# Rename column of interest
df <- df %>% rename(tempname := !!var1)
df <- df %>% mutate(newvar = tempname) # create newvar
df <- df %>% rename(UQ(var1) := tempname)
}
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 = paste(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)
给出以下输出：
我怎样才能展开它，使标签 Plac
ebo_NotDrug 在上图中最后一个下拉菜单的左侧完全可见？其次，如果标签碰巧有 space，那么显示会变得混乱，标签随机放置，如下面的输出所示：
更新
我找到了一种重写 pickerInput 的简单方法，它采用新的 ratio 参数，您可以在其中指定标签的比例和案例的实际下拉菜单inline = TRUE。我认为这是最方便的方法。缺点是您只能选择加起来为 12 的数字，在您的情况下，拆分 55% / 45% 就足够了。
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(shinyjs)
library(magrittr)
library(dplyr)
pickerInput2 <- function (inputId, label = NULL, choices, selected = NULL, multiple = FALSE,
options = list(), choicesOpt = NULL, width = NULL, inline = FALSE, ratio = c(2,10))
{
if (ratio[1] + ratio[2] != 12) stop("`ratio` has to add up 12.")
choices <- shinyWidgets:::choicesWithNames(choices)
selected <- restoreInput(id = inputId, default = selected)
if (!is.null(options) && length(options) > 0)
names(options) <- paste("data", names(options), sep = "-")
if (!is.null(width))
options <- c(options, list(`data-width` = width))
if (!is.null(width) && width %in% c("fit"))
width <- NULL
options <- lapply(options, function(x) {
if (identical(x, TRUE))
"true"
else if (identical(x, FALSE))
"false"
else x
})
maxOptGroup <- options[["data-max-options-group"]]
selectTag <- tag("select", shinyWidgets:::dropNulls(options))
selectTag <- tagAppendAttributes(tag = selectTag, id = inputId,
class = "selectpicker form-control")
selectTag <- tagAppendChildren(tag = selectTag, shinyWidgets:::pickerSelectOptions(choices,
selected, choicesOpt, maxOptGroup))
if (multiple)
selectTag$attribs$multiple <- "multiple"
divClass <- "form-group shiny-input-container"
labelClass <- "control-label"
if (inline) {
divClass <- paste(divClass, "form-horizontal")
selectTag <- tags$div(class = paste0("col-sm-", ratio[2]), selectTag)
labelClass <- paste(labelClass, paste0("col-sm-", ratio[1]))
}
pickerTag <- tags$div(class = divClass, style = if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"), if (!is.null(label))
tags$label(class = labelClass, `for` = inputId, label),
selectTag)
shinyWidgets:::attachShinyWidgetsDep(pickerTag, "picker")
}
ui <- dashboardPage(
dashboardHeader(title = "PickerInput Query",
titleWidth=450
),
dashboardSidebar( width = 300,
useShinyjs(),
sidebarMenu(id = "tabs")
),
dashboardBody(
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) # people with R < 4.0 need this line to execute your code correctly
dat <- reactive(d)
myfun <- function(df, var1) { # I have simplified your function
df %>% mutate(newvar = !!sym(var1)) # create newvar
}
output$groupvar<-renderUI({
bc<-colnames(dat()[sapply(dat(),class)=="character"])
tagList(
pickerInput2(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")
tagList(lapply(1:ngrp, function(i){
pickerInput2(paste0("line.vars.",i),
label = paste(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,
ratio = c(7,5),
options = list('max-options-group' = 1, `style` = "btn-primary"))
}))
}
})
}, ignoreInit = TRUE)
}
shinyApp(ui, server)
旧答案
我想通了，为什么您的代码对我们中的一些人不起作用。您正在使用 R >= 4.0，因此在定义数据 d 时不需要设置 stringsAsFactors = FALSE。添加此属性将有助于 运行 您在 R <= 4.0.
系统上的代码
我想我明白是怎么回事了。您的 pickerInput 的宽度 275px 非常窄，并且您的标签名称很长。您可以 (i) 将宽度设置得更高，或者 (ii) 您需要更改 pickerInput 如何拆分标签和下拉菜单之间的宽度。在引擎盖下，它依赖于 grid.less css 类 .col-sm-10 作为下拉菜单和 .col-sm-2 作为其标签。在这里，它为标签分配了大约 17% 的宽度（在您的情况下这太小了），为下拉菜单分配了 83% 的宽度（在您的情况下这太多了）。您可以 (A) 重写 pickerInput 函数并定义您自己的 css 类，然后添加一个自定义 css，其中 类 的定义宽度足以正确显示（这是我推荐的）。或者您可以 (B) 使用内联 CSS 添加 !important 覆盖 gird.less.css 的默认值。这是我下面的方法，只是因为它是解决此问题的最快方法。但是，这不是一个好方法，因为仪表板中的其他元素可能依赖于那些 css 类.
注意我也精简了myfun。它应该仍能按预期工作。
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(
# custom CSS to overwrite grid.less defaults
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) # people with R < 4.0 need this line to execute your code correctly
dat <- reactive(d)
myfun <- function(df, var1) { # I have simplified your function
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")
tagList(lapply(1:ngrp, function(i){
pickerInput(paste0("line.vars.",i),
label = paste(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)
我有一个 r shiny 应用程序，用户在绘图之前需要在其中进行多种选择。在 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(
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))
)
dat <- reactive(d)
myfun <- function(df, var1) {
# Rename column of interest
df <- df %>% rename(tempname := !!var1)
df <- df %>% mutate(newvar = tempname) # create newvar
df <- df %>% rename(UQ(var1) := tempname)
}
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 = paste(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)
给出以下输出：
我怎样才能展开它，使标签 Plac ebo_NotDrug 在上图中最后一个下拉菜单的左侧完全可见？其次，如果标签碰巧有 space，那么显示会变得混乱，标签随机放置，如下面的输出所示：
更新
我找到了一种重写 pickerInput 的简单方法，它采用新的 ratio 参数，您可以在其中指定标签的比例和案例的实际下拉菜单inline = TRUE。我认为这是最方便的方法。缺点是您只能选择加起来为 12 的数字，在您的情况下，拆分 55% / 45% 就足够了。
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(shinyjs)
library(magrittr)
library(dplyr)
pickerInput2 <- function (inputId, label = NULL, choices, selected = NULL, multiple = FALSE,
options = list(), choicesOpt = NULL, width = NULL, inline = FALSE, ratio = c(2,10))
{
if (ratio[1] + ratio[2] != 12) stop("`ratio` has to add up 12.")
choices <- shinyWidgets:::choicesWithNames(choices)
selected <- restoreInput(id = inputId, default = selected)
if (!is.null(options) && length(options) > 0)
names(options) <- paste("data", names(options), sep = "-")
if (!is.null(width))
options <- c(options, list(`data-width` = width))
if (!is.null(width) && width %in% c("fit"))
width <- NULL
options <- lapply(options, function(x) {
if (identical(x, TRUE))
"true"
else if (identical(x, FALSE))
"false"
else x
})
maxOptGroup <- options[["data-max-options-group"]]
selectTag <- tag("select", shinyWidgets:::dropNulls(options))
selectTag <- tagAppendAttributes(tag = selectTag, id = inputId,
class = "selectpicker form-control")
selectTag <- tagAppendChildren(tag = selectTag, shinyWidgets:::pickerSelectOptions(choices,
selected, choicesOpt, maxOptGroup))
if (multiple)
selectTag$attribs$multiple <- "multiple"
divClass <- "form-group shiny-input-container"
labelClass <- "control-label"
if (inline) {
divClass <- paste(divClass, "form-horizontal")
selectTag <- tags$div(class = paste0("col-sm-", ratio[2]), selectTag)
labelClass <- paste(labelClass, paste0("col-sm-", ratio[1]))
}
pickerTag <- tags$div(class = divClass, style = if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"), if (!is.null(label))
tags$label(class = labelClass, `for` = inputId, label),
selectTag)
shinyWidgets:::attachShinyWidgetsDep(pickerTag, "picker")
}
ui <- dashboardPage(
dashboardHeader(title = "PickerInput Query",
titleWidth=450
),
dashboardSidebar( width = 300,
useShinyjs(),
sidebarMenu(id = "tabs")
),
dashboardBody(
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) # people with R < 4.0 need this line to execute your code correctly
dat <- reactive(d)
myfun <- function(df, var1) { # I have simplified your function
df %>% mutate(newvar = !!sym(var1)) # create newvar
}
output$groupvar<-renderUI({
bc<-colnames(dat()[sapply(dat(),class)=="character"])
tagList(
pickerInput2(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")
tagList(lapply(1:ngrp, function(i){
pickerInput2(paste0("line.vars.",i),
label = paste(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,
ratio = c(7,5),
options = list('max-options-group' = 1, `style` = "btn-primary"))
}))
}
})
}, ignoreInit = TRUE)
}
shinyApp(ui, server)
旧答案
我想通了，为什么您的代码对我们中的一些人不起作用。您正在使用 R >= 4.0，因此在定义数据 d 时不需要设置 stringsAsFactors = FALSE。添加此属性将有助于 运行 您在 R <= 4.0.
我想我明白是怎么回事了。您的 pickerInput 的宽度 275px 非常窄，并且您的标签名称很长。您可以 (i) 将宽度设置得更高，或者 (ii) 您需要更改 pickerInput 如何拆分标签和下拉菜单之间的宽度。在引擎盖下，它依赖于 grid.less css 类 .col-sm-10 作为下拉菜单和 .col-sm-2 作为其标签。在这里，它为标签分配了大约 17% 的宽度（在您的情况下这太小了），为下拉菜单分配了 83% 的宽度（在您的情况下这太多了）。您可以 (A) 重写 pickerInput 函数并定义您自己的 css 类，然后添加一个自定义 css，其中 类 的定义宽度足以正确显示（这是我推荐的）。或者您可以 (B) 使用内联 CSS 添加 !important 覆盖 gird.less.css 的默认值。这是我下面的方法，只是因为它是解决此问题的最快方法。但是，这不是一个好方法，因为仪表板中的其他元素可能依赖于那些 css 类.
注意我也精简了myfun。它应该仍能按预期工作。
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(
# custom CSS to overwrite grid.less defaults
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) # people with R < 4.0 need this line to execute your code correctly
dat <- reactive(d)
myfun <- function(df, var1) { # I have simplified your function
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")
tagList(lapply(1:ngrp, function(i){
pickerInput(paste0("line.vars.",i),
label = paste(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)