Inline为True时出现PickerInput标签问题 [英] PickerInput label issue when inline is TRUE

问题描述

我有一个闪亮的应用程序，其中用户有许多选择，他们需要在绘图之前选择。在选择器输入中，标签文本位于选项后面。下面的代码

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)

提供以下输出：

如何将其展开以放置标签 EBO_NotDrug在上图最后一个下拉列表的左侧完全可见？其次，如果标签恰好有空格，则显示将乱放在随机位置的标签，如下面的输出所示：

推荐答案

更新

我找到了一种简单的方法来重写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拆分标签和下拉菜单之间的宽度的方式。在幕后，它依赖于无网格的css类.col-sm-10作为下拉菜单，.col-sm-2作为标签。这里，标签的宽度约为17%(在您的示例中，宽度太小)，下拉菜单的宽度属性为83%(在您的示例中，宽度太大)。您可以(A)重写pickerInput函数并定义您自己的css类，然后添加一个定制的css，其中定义的这些类具有足够的宽度以正确显示(这是我推荐的)。或者，您可以(B)使用内联css添加!important来覆盖grd.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)

这篇关于Inline为True时出现PickerInput标签问题的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！