对数滑块在呈现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是对数。但是，通过renderUI函数在slider.R中初始化slider时，它不起作用。一些帮助？

代码：

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()，第二个具有insertUI和removeUI涉及observeEvent()在一起。但是，我遇到了让Shiny和JQuery一起工作的问题。也许@ dean-attali可以帮助你。