在 R 中呈现的 UI 中创建分类滑块输入

Question

我正在尝试使用sliderInput. 感谢 Dean Atali 的回答（对数刻度上的闪亮滑块），我能够创建滑块。

不过，我需要建立在滑块server，并通过它传递给UIrenderUI和uiOutput。但是，当我在服务器端sliderInput进行renderUI呼叫时，它不再起作用。这里有两个示例：第一个显示分类滑块的工作原理（不使用renderUI/ 时uiOutput），第二个显示分类滑块的不起作用（使用renderUI/ 时uiOutput）。

工作示例（在 UI 中创建的滑块）

library(shiny)
JScode <-
  "$(function() {
setTimeout(function(){
var names = ['Unrated', 'Emerging', '&nbsp;',  'Formative', '&nbsp;', '&nbsp;', 'Developed', '&nbsp;'];
var vals = [];
for (i = 0; i < names.length; i++) {
var val = names[i];
vals.push(val);
}
$('#pvalue').data('ionRangeSlider').update({'values':vals})
}, 7)})"

runApp(shinyApp(
  ui = fluidPage(
    tags$head(tags$script(HTML(JScode))),
    textOutput('texty'),
    sliderInput("pvalue",
                "PValue:",
                min = 0,
                max = 7,
                value = 0
    )
  ),
  server = function(input, output, session) {

    output$texty <- renderText({
      input$pvalue
    })
  }
))

非工作示例（在 中创建的滑块server）

library(shiny)
JScode <-
  "$(function() {
setTimeout(function(){
var names = ['Unrated', 'Emerging', '&nbsp;',  'Formative', '&nbsp;', '&nbsp;', 'Developed', '&nbsp;'];
var vals = [];
for (i = 0; i < names.length; i++) {
  var val = names[i];
  vals.push(val);
}
$('#pvalue').data('ionRangeSlider').update({'values':vals})
}, 7)})"

runApp(shinyApp(
  ui = fluidPage(
    tags$head(tags$script(HTML(JScode))),
    textOutput('texty'),
    uiOutput('uu')
  ),
  server = function(input, output, session) {

    output$texty <- renderText({
      input$pvalue
    })
    output$uu <- renderUI({
      sliderInput("pvalue",
                  "PValue:",
                  min = 0,
                  max = 7,
                  value = 0
      )
    })
  }
))

在 中生成滑块时，如何使滑块显示类别（而不是数字）server？

Answer 1

将包含 JavaScript 的行移动到renderUI（并将其div与输入元素一起包装在 a 中，以便两者都返回到 UI）似乎可以解决问题，下面的工作示例。我不是 JavaScript 专家，但我认为这是因为在您的情况下，DOM 元素尚不存在，因此未附加 JavaScript 代码 - 但如果我在这个假设中错了，请有人纠正我。

我在下面添加了两段代码，一段带有@agenis 在评论中建议的带有交互式标签的分类滑块，另一段对您的代码进行了稍微调整以使您的示例工作。

希望这可以帮助！

1.交互式分类滑块

library(shiny)

runApp(shinyApp(
  ui = fluidPage(
    numericInput('nlabs','number of labels:', min=3,max=10,value=3),
    checkboxInput('rev','Reverse?',value=FALSE),
    textOutput('texty'),
    uiOutput('uu')
  ),
  server = function(input, output, session) {

    output$texty <- renderText({
      input$pvalue
    })

    output$uu <- renderUI({

      # Create labels
      my_labs = sort(LETTERS[1:input$nlabs],decreasing = input$rev)
      my_labs = paste(sapply(my_labs,function(x){paste0("'",x,"'")}),collapse=",")
      # Create the JS code
      JScode <-paste0(
        "$(function() {
setTimeout(function(){
var names = [",
        my_labs,
        "];
var vals = [];
for (i = 0; i < names.length; i++) {
var val = names[i];
vals.push(val);
}
$('#pvalue').data('ionRangeSlider').update({'values':vals})
}, 7)})")

      # Return the div with the JS Code and the sliderInput.
      div(
        tags$head(tags$script(HTML(JScode))),
        sliderInput("pvalue",
                    "PValue:",
                    min = 0,
                    max = 7,
                    value = 0
        )
      )
    })
  }
))

2. 代码的工作版本

library(shiny)
JScode <-
  "$(function() {
setTimeout(function(){
var names = ['Unrated', 'Emerging', '&nbsp;',  'Formative', '&nbsp;', '&nbsp;', 'Developed', '&nbsp;'];
var vals = [];
for (i = 0; i < names.length; i++) {
var val = names[i];
vals.push(val);
}
$('#pvalue').data('ionRangeSlider').update({'values':vals})
}, 7)})"

runApp(shinyApp(
  ui = fluidPage(
    textOutput('texty'),
    uiOutput('uu')
  ),
  server = function(input, output, session) {

    output$texty <- renderText({
      input$pvalue
    })
    output$uu <- renderUI({
      div(
        tags$head(tags$script(HTML(JScode))),
        sliderInput("pvalue",
                    "PValue:",
                    min = 0,
                    max = 7,
                    value = 0
        )
      )
    })
  }
))