UI 用户输入等 table 的美观改进

Question

我正在创建一个闪亮的应用程序，我希望用户在其中 select 输入看起来像 table 的内容。我的代码有效，但它看起来不太漂亮，因为滑块没有与其相关信息对齐。几个问题：

有什么方法可以让滑动条与关联的文本正确对齐吗？
滑动条上的所有输入都是一样的，我可以只显示用户当前悬停的标签吗？或者也许只是顶部或底部滑块？
如何强制设置，以便在 window 最小化时“table”不会 resize/wrap 本身？

显示“table”滑块不正确排列的不良外观以及屏幕最小化时“环绕”外观的屏幕截图。

library(shiny)
library(shinyWidgets)

ui <- fluidPage(
  # App title ----
  titlePanel("Overall Title"),
  # Sidebar layout with input and output definitions ----
  sidebarLayout(
    # Sidebar panel for inputs ----
    sidebarPanel(
      h4(strong("Set lake N concentrations (ppb)")),
      fluidRow(
        column(3,
               h5(strong("Lake")),
               h5("Okareka"),
               h5("Tikitapu")
        ),
        column(3,
               h5(strong("Existing N")),
               h5("190.98"),
               h5("173.88")
        ),

        column(4,
               h5(strong("Improvement/Degradation")),
               sliderTextInput(
                 inputId = "DegImp_1",
                 label = "",
                 grid = TRUE,
                 force_edges = TRUE,
                 choices = c("-20%", "-10%", "No change", "10%", "20%"),
                 selected = "No change"
               ),

               sliderTextInput(
                 inputId = "DegImp_8",
                 label = "",
                 grid = TRUE,
                 force_edges = TRUE,
                 choices = c("-20%", "-10%", "No change", "10%", "20%"),
                 selected = "No change"
               )
        ),
        column(2,
               h5(strong("Value")),
               textOutput("DegImp_1value"),
               textOutput("DegImp_8value")
        )
      )
    ),
    # Main panel for displaying outputs ----
    mainPanel(
      # Output: Data file ----
      tableOutput("contents")
    )
  )
)

# server ----
server <- function(input, output) {
  
  DI_1value <- reactive ({ switch(input$DegImp_1, "-20%" = 190.98*0.8, "-10%" = 190.98*0.9, "No change" = 190.98, "10%" = 190.98*1.1, "20%" = 190.98*1.2)})
  DI_8value <- reactive ({ switch(input$DegImp_8, "-20%" = 173.88*0.8, "-10%" = 173.88*0.9, "No change" = 173.88, "10%" = 173.88*1.1, "20%" = 173.88*1.2)})
  
  output$DegImp_1value <- renderPrint({ round(DI_1value(),2) })
  output$DegImp_8value <- renderPrint({ round(DI_8value(),2) })
  
}

# Create Shiny app ----
shinyApp(ui, server)

Answer 1

您可以使用 splitLayout 逐行进行。结果还不错：

library(shiny)
library(shinyWidgets)

shinyApp(ui = fluidPage(

  splitLayout(
    h5(strong("Lake")),
    h5(strong("Existing N")),
    h5(strong("Improvement"))
  ),
  
  splitLayout(
    h5("Okareka"),
    h5(190.18),
    sliderTextInput(
      inputId = "DegImp_1",
      label = "",
      grid = TRUE,
      force_edges = TRUE,
      choices = c("-20%", "-10%", "No change", "10%", "20%"),
      selected = "No change"
    )
  ),
  
  splitLayout(
    h5("Tikitapu"),
    h5(173.88),
    sliderTextInput(
      inputId = "DegImp_8",
      label = "",
      grid = TRUE,
      force_edges = TRUE,
      choices = c("-20%", "-10%", "No change", "10%", "20%"),
      selected = "No change"
    )
  )
    
), 

server = function(input, output, session) {
  
})

这是一个更紧凑的版本：

fluidPage(

  div(
    style = "width: 500px;",
    
    splitLayout(
      h5(strong("Lake")),
      h5(strong("Existing N")),
      h5(strong("Improvement")),
      cellWidths = c("20%", "20%", "60%")
    ),
    
    splitLayout(
      h5("Okareka"),
      h5(190.18),
      sliderTextInput(
        inputId = "DegImp_1",
        label = "",
        grid = TRUE,
        force_edges = TRUE,
        choices = c("-20%", "-10%", "No change", "10%", "20%"),
        selected = "No change",
        width = "200px"
      ),
      cellWidths = c("20%", "20%", "60%")
    ),
    
    splitLayout(
      h5("Tikitapu"),
      h5(173.88),
      sliderTextInput(
        inputId = "DegImp_8",
        label = "",
        grid = TRUE,
        force_edges = TRUE,
        choices = c("-20%", "-10%", "No change", "10%", "20%"),
        selected = "No change",
        width = "200px"
      ),
      cellWidths = c("20%", "20%", "60%")
    )
  
  )
    
)

您可以通过将滑块包含在具有负上边距的 div 中来向上移动滑块：

splitLayout(
  h5("Okareka"),
  h5(190.18),
  div(
    style = "margin-top: -15px;",
    sliderTextInput(
      inputId = "DegImp_1",
      label = "",
      grid = TRUE,
      force_edges = TRUE,
      choices = c("-20%", "-10%", "No change", "10%", "20%"),
      selected = "No change",
      width = "200px"
    )
  ),
  cellWidths = c("20%", "20%", "60%")
),

splitLayout(
  h5("Tikitapu"),
  h5(173.88),
  div(
    style = "margin-top: -15px;",
    sliderTextInput(
      inputId = "DegImp_8",
      label = "",
      grid = TRUE,
      force_edges = TRUE,
      choices = c("-20%", "-10%", "No change", "10%", "20%"),
      selected = "No change",
      width = "200px"
    )
  ),
  cellWidths = c("20%", "20%", "60%")
)

或者，更好的是，设置 label = NULL，而不是 label = ""：

splitLayout(
  h5("Okareka"),
  h5(190.18),
  sliderTextInput(
    inputId = "DegImp_1",
    label = NULL,
    grid = TRUE,
    force_edges = TRUE,
    choices = c("-20%", "-10%", "No change", "10%", "20%"),
    selected = "No change",
    width = "200px"
  ),
  cellWidths = c("20%", "20%", "60%")
),

splitLayout(
  h5("Tikitapu"),
  h5(173.88),
  sliderTextInput(
    inputId = "DegImp_8",
    label = NULL,
    grid = TRUE,
    force_edges = TRUE,
    choices = c("-20%", "-10%", "No change", "10%", "20%"),
    selected = "No change",
    width = "200px"
  ),
  cellWidths = c("20%", "20%", "60%")
)

UI 用户输入等 table 的美观改进

Shiny UI aesthetic improvements for table like user inputs

user-interface

r

slider

shiny