rshinyshinydashboardshinyapps
PickerInput label issue when inline is TRUE
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:
Solution
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)
- Determining as to whether the function call is stored in a variable
- How to increase resolution of ggplots without using ggsave in officer?
- How to apply a function within a for loop for a set of existing variables of a predifined structure in R?
- How to change the number of decimal places of the mean in a data frame
- Forestplot in R superscript in tabletext matrix
- Converting colnames from character to numeric when extracting them from a dataframe
- With different seeds can Random States repeat in R
- How to Stack Painted Phylogenetic Trees in R Like ggdensitree but with Colored Regimes
- How to import/rbind multiple files with different indexed columns?
- Pivot wider in R return list instead of data frame
- R workspace doesn't load anything in Visual Studio Code
- Search for multiple occurrences of substring within string
- Looking for faster way to implement logSumExp across multidimensional array
- How to get \bm{} to work in an R markdown (to HTML) file?
- Leaving a space in geom_bar with stat='bin', position='dodge' and zeroes
- Where are the 1st stage F statistics located in a "fixest" object?
- Collapsing data per family
- How to set default template for new ".R" files in rstudio
- Adding two-way fixed effects for zero inflated Poisson model
- How to Move R Code and Output to the Right in a Quarto PDF Document?
- What does runif() mean when used inside if_else()?
- Remove columns from dataframe where ALL values are NA
- How to pass unquoted argument to filter() within user defined function
- Optimizing the distribution of random integers across data frame rows
- R dplyr conditional join with "join_by" not working
- How to hide a reappearing hover label for a trace in R-Plotly within Shiny?
- Estimating non-monotonic bi-exponential curve fit
- Problem minimising a function using L-BFGS-B method in R?
- trying to obtain TRUE/FALSE response to the question "is argument name x valid for function y?"
- Retrieve whole lyrics from URL