PickerInput label issue when inline is TRUE - r

Question

I have a r shiny app in which users have numerous choices they need to pick prior to plotting. In the pickerInput, the label text goes behind the choices. The code 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(
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)
gives the following output:
How can I expand it so that the label Plac
ebo_NotDrug is fully visible to the left of the last dropdown in the image above? Secondly, if the labels happen to have space, then the display gets messy with labels placed in random places as shown in the output below:

Answer 1

update
I found an easy way to rewrite pickerInput in such a way that it takes a new ratio argument, where you can specify the ration of the label and the actual dropdown menu for the case that inline = TRUE. I think this is the most convenient approach. The downside is that you can only choose numbers adding up to 12, where in your case a split up 55% / 45% would suffice.
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)
old answer
I figured out, why your code wasn't working for some of us. You are using R >= 4.0 and therefor do not need to set stringsAsFactors = FALSE when defining your data d. Adding this attribute will help run your code on systems with R <= 4.0.
I guess I figured out whats going on. Your pickerInputs have a very narrow width 275px and you have long label names. You can either (i) set the width higher, or (ii) you need to change how pickerInput is splitting up the width between label and dropdown menue. Under the hood it relies on grid.less css classes .col-sm-10 for the dropdown menue and .col-sm-2 for its label. Here it attributes about 17% width to the label (in your case this is too small) and 83% to the dropdown menue (in your case this is too much). You could (A) rewrite the pickerInput function and define your own css classes and then add a custom css where those classes are defined with enough width to display properly (this is what I recommend). Or you can (B) overwrite the default values of gird.less.css with inline CSS adding !important. This is my approach below, just because it is the quickest way to fix this issue. However, it is not a good way, since other elements in your dashboard may rely on those css classes.
Note that I also streamlined myfun. It should still work as expected.
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)