javascript - 在 R 闪亮的渲染 UI 中创建分类滑块输入

Question

我正在尝试使用闪亮创建一个分类（而不是数字）滑块sliderInput。感谢 Dean Atali 在这里的回答（Shiny slider on logarithmic scale），我能够创建滑块。

但是，我需要在其中创建滑块server并通过 和 将其传递给renderUIUI 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（并将其与输入元素一起包装在 adiv中，以便两者都返回到 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
        )
      )
    })
  }
))

Answer 2

您可以使用sliderTextInput包中的功能shinyWidgets：

library(shiny)
library(shinyWidgets)

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

    output$texty <- renderText({
      input$pvalue
    })
    output$uu <- renderUI({
      sliderTextInput(
        inputId = "pvalue",
        label = "PValue:",
        grid = TRUE,
        choices = c("Unrated", "Emerging", "Formative", "Developed")
      )
    })
  }
))