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))
# [...]
}
}
}
)
}
# [...]