R Shiny: Slider anchors overlap at the end

Question

On the UI, there are two sliders where the range of the second slider is dependent on the first slider's input. However, certain values on Slider 1 can lead to the anchors on slider 2 overlapping at the end. Is there any way to un-overlap them?

Thank you for your help.

library(shiny)
library(plotly) 

ui <- fluidPage(
  

  titlePanel("Overlapping anchor"),
  
  sidebarLayout(
   
    sidebarPanel(
      sliderInput("firstSlider", "The first slider", min=0, max=1,value=.7),
      uiOutput("sliderange")
    ),
    
    mainPanel(
      
      tableOutput("values")
      
    )
  )
)

server <- function(input, output) {
  
  sliderValues <- reactive({
    
    data.frame(
      Name = c("First"),
      Value = as.character(c(input$firstSlider)),
      Name = c("Second"),
      Value = as.character(c(input$secondSlider)),
      stringsAsFactors = FALSE)
  })
  
  output$sliderange <- renderUI({
    sliderInput("secondSlider", "The second slider", min = 0, max = round((min(2*input$firstSlider, 2*(1-input$firstSlider))),2), 
                value = min(.1,input$firstSlider, (1-input$firstSlider)), round = -2, step = 0.01)})
  
  output$values <- renderTable({
    sliderValues()
  })
  
}

shinyApp(ui = ui, server = server)

Answer 1

After digging into the internals of Ion.RangeSlider and sliderInput I found a (rather crude) workaround.

It turns out that for certain combinations of min/max the number of ticks is deliberately set to a non-integer. In your case you can verifiy that by opening the developer tools in the browser (Ctrl+Shift+I for Chrome in Windows) and type the following code:

$('#secondSlider').data("ionRangeSlider").options.grid_num

This results in certain cases in overlapping tick labels. Thus, the idea is to

1. Detect if there is an overlap between the last and the previous last tick label.
2. And if so, round down the number of tick labels to the next integer, which results in more space between the ticks.

You need hence to include some javascript for overlap detection and for adjustment of the number of grid points. Last point is to call the Javascript at the "right" time. That is, once the reactive session is flushed. We can use session$onFlushed for that. In order to call custom Javascript functions, we use the ShinyaddCustomMessageHandler pattern.

library(shiny)

js <- paste("function doesOverlap() {",
            "   var $lastLabel = $('#sliderange .irs-grid-text:last');",
            "   var $prevLastLabel = $lastLabel.prevAll('.irs-grid-text').first();",
            "   return $lastLabel.offset().left < $prevLastLabel.offset().left + $prevLastLabel.width();",
            "}\n",
            "Shiny.addCustomMessageHandler('regrid', function(force) {",
            "   if (doesOverlap() | force) {",
            "      console.log('Overlap detected - adjusting tick number');",
            "      var $sld = $('#secondSlider').data('ionRangeSlider');",
            "      var ticks_n = $sld.options.grid_num;",
            "      $sld.update({grid_num: Math.round(ticks_n)});",
            "   }",
            "});", sep = "\n")

ui <- fluidPage(
   tags$head(tags$script(HTML(js), type = "text/javascript")),
   titlePanel("Overlapping anchor"),
   sidebarLayout(
      sidebarPanel(
         sliderInput("firstSlider", "The first slider", min=0, max=1,value=.7),
         uiOutput("sliderange")
      ),
      mainPanel(
         tableOutput("values")
      )
   )
)

server <- function(input, output, session) {
   session$onFlushed(function() {
      session$sendCustomMessage("regrid", FALSE);
   }, FALSE);
   
   sliderValues <- reactive({
      data.frame(
         Name = c("First"),
         Value = as.character(req(input$firstSlider)),
         Name = c("Second"),
         Value = as.character(req(input$secondSlider)),
         stringsAsFactors = FALSE)
   })
   
   output$sliderange <- renderUI({
      sliderInput("secondSlider", "The second slider", 
                  min = 0, max = round(min(2 * input$firstSlider, 
                                           2 * (1 - input$firstSlider)), 2), 
                  value = min(.1, input$firstSlider, (1 - input$firstSlider)), 
                  round = -2, step = 0.01)
   })
   
   output$values <- renderTable({
      sliderValues()
   })
   
}

shinyApp(ui = ui, server = server)

Update

After reading this question on the Rstudio blog I found the missing piece to follow my initial idea to run the tick number adaptation in a response to an event rather than relying on onFlushed. This removes the necessity to set up a shiny <-> JavaScript interface and can be easily adpated to more than one reactive slider:

library(shiny)

js <- "
function doesOverlap($sld) {
   var $lastLabel = $sld.parents('.shiny-input-container').find('.irs-grid-text:last');
   var $prevLastLabel = $lastLabel.prevAll('.irs-grid-text').first();
   return $lastLabel.offset().left < $prevLastLabel.offset().left + $prevLastLabel.width();
}

$(document).on({
  'shiny:value': function(event) {
     if (event.name === 'sliderange') { // react upon changes of #sliderange
       // need to defer to next tick to avoid race condition
       setTimeout(function() {
         var $slds = $('.js-range-slider').not('#firstSlider');
         $slds.each(function() {
           if (doesOverlap($(this))) {
              console.log('Overlap detected for element <#' + this.id + '>');
              var $sld = $(this).data('ionRangeSlider');
              var ticks_n = $sld.options.grid_num;
              $sld.update({grid_num: Math.round(ticks_n)});
           }
         });
       }, 0);
     }   
  }
});
"

ui <- fluidPage(
   tags$head(tags$script(HTML(js), type = "text/javascript")),
   titlePanel("Overlapping anchor"),
   sidebarLayout(
      sidebarPanel(
         sliderInput("firstSlider", "The first slider", min=0, max=1,value=.7),
         uiOutput("sliderange")
      ),
      mainPanel(
         tableOutput("values")
      )
   )
)

server <- function(input, output, session) {
   sliderValues <- reactive({
      data.frame(
         Name = c("First"),
         Value = as.character(req(input$firstSlider)),
         Name = c("Second"),
         Value = as.character(req(input$secondSlider)),
         stringsAsFactors = FALSE)
   })
   
   output$sliderange <- renderUI({
      sliderInput("secondSlider", "The second slider", 
                  min = 0, max = round(min(2 * input$firstSlider, 
                                           2 * (1 - input$firstSlider)), 2), 
                  value = min(.1, input$firstSlider, (1 - input$firstSlider)), 
                  round = -2, step = 0.01)
   })
   
   output$values <- renderTable({
      sliderValues()
   })
   
}

shinyApp(ui = ui, server = server)