2

I wanted to get flexible number of logarithmic sliders in shiny, but I got some problems. When searching through Internet I found that one slider can be changed to logarithmic by script for example like this:

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

Then initialized in ui.R by the tags before rendering slider: tags$head(tags$script(HTML(sliderLogarithm))) and then slider called range1 is logarithmic. But it doesn't work when slider is initialized in server.R by renderUI function. Some help?

Code:

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)
byrolew
  • 21
  • 2
  • Where does `testInput` come from? Can you provide a [reproducible example](http://stackoverflow.com/questions/5963269/how-to-make-a-great-r-reproducible-example)? – Samuel Sep 16 '17 at 14:05
  • Yes, sorry, my mistake. It should be ok now. – byrolew Sep 17 '17 at 20:11

1 Answers1

0

I could quite make it. This is what I have so far:

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)

I experimented with two approaches: the first involving renderUI() and the second involving observeEvent() together with insertUI and removeUI. However, I'm having a problem getting Shiny and JQuery work together. Maybe @dean-attali can help you.

Samuel
  • 2,895
  • 4
  • 30
  • 45
  • Unfortunately, both work only sometimes. The first one only for one slider and the second one only before changing the input number. – byrolew Sep 18 '17 at 08:56