由 renderUI 渲染时闪亮的对数滑块

Question

我想获得灵活数量的闪亮对数滑块，但我遇到了一些问题。通过互联网搜索时，我发现可以通过脚本将一个滑块更改为对数，例如：

sliderLogarithm <- "$(function() {
setTimeout(function(){
var vals = [0];
var powStart = -2.0;
var powStop = 0.01;
for (i = powStart; i <= powStop; i=i+0.01) {
var val = Math.pow(10, i);
val = parseFloat(val.toFixed(3));
vals.push(val);
}
$('#range1').data('ionRangeSlider').update({'values':vals})
}, 5)})"

然后在 ui.R 中由渲染滑块之前的标签初始化：tags$head(tags$script(HTML(sliderLogarithm)))，然后称为 range1 的滑块是对数的。但是当滑块在 server.R 中通过 renderUI 函数初始化时它不起作用。有什么帮助吗？

代码：

library(shiny)

server <- shinyServer(function(input, output, session) { 
  output$sliders <- renderUI({
    tags$head(tags$script(HTML(sliderLogarithm)))
    lapply(seq(input$number), function(i) {
      sliderInput(inputId = "range1",
                  label = paste('Some range', i),
                  min = 0, max = 1, value = 0.1)
    })
  })
})

sliderLogarithm <-
"$(function() {
setTimeout(function(){
  var vals = [0];
  var powStart = -2.0;
  var powStop = 0.01;
  for (i = powStart; i <= powStop; i=i+0.01) {
    var val = Math.pow(10, i);
    val = parseFloat(val.toFixed(3));
    vals.push(val);
  }
  $('#range1').data('ionRangeSlider').update({'values':vals})
}, 5)})"

ui <- fluidPage(
  numericInput('number', 'Number', 1),
  tags$head(tags$script(HTML(sliderLogarithm))),
  uiOutput('sliders')
)

shinyApp(ui = ui, server = server)

Answer 1

我完全可以做到。这是我目前所拥有的：

library(shiny)

sliderLogarithm <-
  "$(function() {
    setTimeout(function() {
      var vals = [0];
      var powStart = 5;
      var powStop = 2;
      for (i = powStart; i >= powStop; i--) {
        var val = Math.pow(10, -i);
        val = parseFloat(val.toFixed(8));
        vals.push(val);
      }
      $('*[id^=range]').data('ionRangeSlider').update({'values':vals})
}, 5)})"

ui <- fluidPage(
  numericInput('number', 'Number', 1),
  # actionButton('insertBtn', 'Insert'),
  # actionButton('removeBtn', 'Remove'),
  tags$head(tags$script(HTML(sliderLogarithm))),
  tags$head(tags$script(HTML('Shiny.addCustomMessageHandler("jsCode", function(message) { eval(message.value); });'))),
  uiOutput('sliders')
  # tags$div(id = 'placeholder')
  )

server <- shinyServer(function(input, output, session) {

  # observeEvent(input$insertBtn, {  # Alternative I
  #   session$sendCustomMessage(type = 'jsCode', list(value = sliderLogarithm))
  #   insertUI(
  #     selector = '#placeholder',
  #     ui = sliderInput(
  #       inputId = 'range1',
  #       label = 'Some range',
  #       min = 0,
  #       max = 1e-2,
  #       value = c(0, 1e-2))
  #   )
  # })
  # observeEvent(input$removeBtn, {
  #   removeUI(
  #     selector = 'div:has(> #range1)'
  #   )
  # })

  output$sliders <- renderUI({  # Alternative II
    session$sendCustomMessage(type = 'jsCode', list(value = sliderLogarithm))
    lapply(1:input$number, function(i) {
      print(i)
      sliderInput(
        inputId = paste0('range', i),
        label = paste('Some range', i),
        min = 0,
        max = 1e-2,
        value = c(0, 1e-2)
      )
    })
  })

})

shinyApp(ui = ui, server = server)

我尝试了两种方法：第一种涉及renderUI()，第二种涉及observeEvent() 以及insertUI 和removeUI。但是，我在让 Shiny 和 JQuery 一起工作时遇到了问题。也许@dean-attali 可以帮助你。