PickerInput label issue when inline is TRUE

折月煮酒 提交于 2021-02-08 06:06:22

问题


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:


回答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)


来源:https://stackoverflow.com/questions/62520164/pickerinput-label-issue-when-inline-is-true

易学教程内所有资源均来自网络或用户发布的内容,如有违反法律规定的内容欢迎反馈
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!