Question

在我的sliderTextInput()中，我选择了要使用确切的变量名称进行绘制的变量，但是我希望在滑块上具有外观更好的标签（即，如果所选变量是mean2018，我想在其上显示2018滑块）。有可能吗？

Answer 1

shinyWidgets::sliderTextInput中似乎没有自定义标签的选项。这是一个潜在的选择。您也可以考虑使用switch代替paste0，以获得更大的灵活性。 -

library("shiny")
library("shinyWidgets")

ui <- fluidPage(
  br(),
  sliderTextInput(
    inputId = "mySliderText",
    label = "Select Year:",
    choices = 2018:2020
  ),
  verbatimTextOutput(outputId = "result")
)

server <- function(input, output, session) {
  output$result <- renderPrint({
    paste0("mean", input$mySliderText) # use this to select appropriate year columns
  })
}

shinyApp(ui = ui, server = server)

Answer 2

可能比OP要求的要多。我编写了一个函数allow_named_choices(...)，该函数扩展了sliderTextInput()之类的小部件，使其表现为好像它们支持命名输入一样。

通过包装widget-inputs和widget-updater函数并在服务器端保留值名称查找表来工作。客户端将仅包含文本名称，而不包含值。

基于忠实于sliderTextInput（）的闪亮应用

library(shiny)
library(shinyWidgets)


#sliderTextInput is useful in shiny for time sliders and it looks nice.
#however sliderTextInput do not allow named inputs so the underlying time
#type is lost when formatted as text.

#If working with multiple time types, it is messy to convert
#to a text that looks nice and is unambiguous* and 
#computationally fast time type on the back-end.

#this function extends a widget to allow named choices.
#the interface is almost the same as the widget
#instead of using input$inputID to read, use returned_list$read()
#instead of using e.g. updateSliderTextInput(), use returned_list$update(...)
source("allow_named_choices.R")



##and here an example NOT involving time types for simplicity


#some values named in Danish
named_vec_breaks <- c(ti=10L, tyve=20L, femogtredive=35L, halvtreds=50L)

ui <- bootstrapPage(
  
  #sliderTextInput, does not support named inputs, but we fix that in server
  sliderTextInput(
    "n_breaks",
    label = "Number of breaks in histogram (named in Danish for no reason):",
    choices = names(named_vec_breaks),     #init with names not values
    selected =  names(named_vec_breaks)[2] #init with name selection
  ),
  
  #pressing this action button will test update of choices
  actionButton(
    inputId = "i_act_add_more_named_numbers",
    label = "add random numbers randomly named to choices"
  ),

  plotOutput(outputId = "o_main_plot", height = "300px")
)


server <- function(input, output, session) {
  
  #extend sliderTextInput to allow named choices
  #rw_breaks (read_write) provide functions for reading selected and updating named choices
  rw_breaks <- allow_named_choices(
    inputId = "n_breaks", #id of widget to extend
    update_function = updateSliderTextInput, #widget updater function
    input    = input,
    session  = session,
    init_choices  = named_vec_breaks,   #named choices, not only names
    init_selected = named_vec_breaks[2] #named select , not only name
  )
  
  
  #for testing: print named selection in R terminal on server
  observeEvent(rw_breaks$read(),ignoreInit = TRUE,{
    str(rw_breaks$read())
  })
  
  #change named choices to 10 values of 1-100 with random 6 char names + current selected
  #set new selected to random one of named choices
  observeEvent(input$i_act_add_more_named_numbers,ignoreInit = TRUE,{
    new_vals = sample(1:100,10)
    new_names = replicate(10,{paste(sample(letters,6,replace = TRUE),collapse="")})
    names(new_vals) = new_names
    new_choices = c(
      rw_breaks$read(),
      new_vals
    )

    rw_breaks$update(
      selected = sample(new_choices,1),
      choices  = sort(new_choices)
    )
    
  })

  #render a plot reading the value with read()
  output$o_main_plot <- renderPlot({
  
    #cannot read before widget extension is initialized
    req(length(rw_breaks$read())>=1) 
    
    hist(faithful$eruptions,
         probability = TRUE,
         breaks = rw_breaks$read(),
         xlab = "Duration (minutes)",
         main = "Geyser eruption duration"
    )
  })
  
  
}


shinyApp(ui, server)

提供允许命名的选择

#' Allow named choices
#'

#' @param inputId  id of input widget
#' @param update_function  to handle updates to widget
#' @param input
#' @param session 
#' @param init_choices  named choices to initialize extended widget
#' @param init_selected named select  to initialize extended widget
#' @param ...    any other param to do initial update, probably not used
#'
#' @return a list of functions:
#' read() reads a named input from widget
#' update() update widget with named choices og selection (by name)
#' 
#' @export
#'
#' @examples
allow_named_choices <- function(
  inputId,
  update_function,
  input,
  session,
  init_choices,
  init_selected = NULL,
  ...
){
  
  #named choices is stored here
  rv_named_choices <- reactiveVal()

  #define function for updating named choices
  writer_fun <- function(
    selected      = NULL,
    choices       = NULL,
    ...
  ){
    #store choices and names of choices
    if(!is.null(choices)) rv_named_choices(choices)
    
    #update, send only names of choices to client
    update_function(
      session       = session,
      inputId       = inputId,
      selected      = names(selected),
      choices       = names(choices),
      ...
    )
    invisible(choices)
  }
  
  
  #define reactive reading stored choices by client selected names
  r_reader = reactive({
    rv_named_choices()[input[[inputId]]]
  })
  
  
  
  #update now, to make sure client side choices match server side
  writer_fun(
    selected = init_selected,
    choices  = init_choices,
    ...
  )
  
  #return 'update' and 'read' functions in a list
  list(
    update = writer_fun,
    read   = r_reader
  )  
}

带有不同值标签的闪亮sliderTextInput或sliderInput

2 个答案: