Question

我希望灵活数量的对数滑块闪亮，但我遇到了一些问题。通过Internet搜索时，我发现一个滑块可以通过脚本更改为对数，例如：

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)})"

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

代码：

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可以帮到你。

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

1 个答案: