Shiny app: logarithmic slider and updateSliderInput

2021-05-27

I am currently working on a R shiny app for an exposition by a colleague from the Museum für Naturkunde in Magdeburg (more on that later when it'll be finished). I stumbled onto a very specific issue that took me a while to solve so I thought I'll share my solution here, for future reference.

The app allows the user to fiddle with the parameters of Raup's mollusk model, with the result being shown as a rgl 3D plot. One of the parameter (W, the Whorl Expansion Rate) needed to be represented as a logarithmic scale (as values range from 1 to 100 000, with most of the changes happening between 1 and 10). As this is not a native option in shiny, I had to use some javascript to sort it out, as per this StackOverflow answer:

library(shiny)
library(mwshiny)
JS.logify <-"function logifySlider (sliderId) {
    // regular number style
    $('#'+sliderId).data('ionRangeSlider').update({
      'prettify': function (num) { return (Math.pow(10, num).toFixed(2)); }
    })
}"
JS.onload <-"$(document).ready(function() {
  setTimeout(function() {
    logifySlider('W')
  }, 5)})"
ui_win <- list() #Here we are using mwshiny, as we need the controller and the plot on two different screens.
ui_win[["Controller"]] <- fluidPage(
	  tags$head(tags$script(HTML(JS.logify))),
	  tags$head(tags$script(HTML(JS.onload))),
	  sidebarLayout(
	    sidebarPanel(
	      sliderInput(input="W",
	                  label="Whorl Expansion Rate",
	                  min = 0, max = 5, value = 0.301, step = .0001),width=8)))
#[...]

Overall it's a good solution and work as expected. However problems arise when using, server-side, the updateSliderInput. In this case, we have a series of preselected forms: when clicking on one of them, the values of that form replace the current values on the various sliders.

ui_win[["Controller"]] <- fluidPage(
  tags$head(tags$script(HTML(JS.logify))),
  tags$head(tags$script(HTML(JS.onload))),
  sidebarLayout(
    sidebarPanel(
      sliderInput(input="W",
                  label="Whorl Expansion Rate",
                  min = 0, max = 5, value = 0.301, step = .0001),
      width=8
    ),
    mainPanel(
      radioButtons(inputId="preselect", label="Preselection:",
                   choiceNames=list("None","Nautilus","Ammonite","Tower shell","Roman snail","Mussel","Tusk shell"),
                   choiceValues=list("nul","nau","amm","tow","rom","mus","tus")),
      width=4)
  )
)

serv_calc <- list()
presel <- data.frame(species=c("nau","amm","tow","rom","mus","tus"),
                     RT=c(0,0,12,2,0.2,0),
                     D=c(0,0.5,0,0,0,0.9),
                     W=c(3.2,1.9,1.2,2,10000,10000),
                     S=c(1.3,1,0.8,0.9,2,1),
                     turns=c(2,5,10,5,1,1))

serv_calc[[1]] <- function(input,session){
  observeEvent(input$preselect,{
    x <- input$preselect
    if(!is.null(x)){
      if(x!="nul"){
        ps <- presel[presel$species==x,]
        updateSliderInput(session, "W", value=round(log(ps$W,10),4))
        # [...]
      }
    }
  }
  )
}
# [...]

And so, when it does, the slide becomes "de-logified" (i.e., ranging from 0 to 5 instead of 10^1 to 10^5). I knew from the start that the issue was that, while the JS script was run on page load, it was not rerun on update. The solution, which took me a while to find, was to use shinyjs's runjs together with the shiny server's onFlushed:

library(shiny)
library(mwshiny)
library(shinyjs)
JS.logify <-"function logifySlider (sliderId) {
    // regular number style
    $('#'+sliderId).data('ionRangeSlider').update({
      'prettify': function (num) { return (Math.pow(10, num).toFixed(2)); }
    })
}"
JS.onload <-"$(document).ready(function() {
  setTimeout(function() {
    logifySlider('W')
  }, 5)})"
ui_win <- list()
ui_win[["Controller"]] <- fluidPage(
  useShinyjs(), # <- Note that useShinyjs is needed to instantiate shinyJS before its use.
  tags$head(tags$script(HTML(JS.logify))),
  tags$head(tags$script(HTML(JS.onload))),
  sidebarLayout(
    sidebarPanel(
      sliderInput(input="W",
                  label="Whorl Expansion Rate",
                  min = 0, max = 5, value = 0.301, step = .0001),
      width=8
    ),
    mainPanel(
      radioButtons(inputId="preselect", label="Preselection:",
                   choiceNames=list("None","Nautilus","Ammonite","Tower shell","Roman snail","Mussel","Tusk shell"),
                   choiceValues=list("nul","nau","amm","tow","rom","mus","tus")),
      width=4)
  )
)

serv_calc <- list()
presel <- data.frame(species=c("nau","amm","tow","rom","mus","tus"),
                     RT=c(0,0,12,2,0.2,0),
                     D=c(0,0.5,0,0,0,0.9),
                     W=c(3.2,1.9,1.2,2,10000,10000),
                     S=c(1.3,1,0.8,0.9,2,1),
                     turns=c(2,5,10,5,1,1))

serv_calc[[1]] <- function(input,session){
  session$onFlushed(function()runjs("logifySlider('W');"),once=FALSE) # <- The key line
  observeEvent(input$preselect,{
    x <- input$preselect
    if(!is.null(x)){
      if(x!="nul"){
        ps <- presel[presel$species==x,]
        updateSliderInput(session, "W", value=round(log(ps$W,10),4))
        # [...]
      }
    }
  }
  )
}
# [...]