R Shiny：滑块锚在末端重叠

在深入研究了Ion.RangeSlider和sliderInput的内部 struct 后，我找到了一个(相当粗糙的)解决方法.

事实证明，对于min/max的某些组合，滴答声的数量被故意设置为非整数.在您的情况下，您可以通过在浏览器中打开开发者工具(Ctrl+Shift+I适用于Windows中的Chrome)并键入以下代码来验证这一点:

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

在某些情况下，这会导致勾号标签重叠.因此，我们的 idea 是

1. 检测最后一个记号标签和上一个记号标签之间是否有重叠.
2. 如果是这样的话，将记号标签的数量四舍五入到下一个整数，这样记号之间的空间就更大了.

因此，需要包含一些javascript，用于重叠检测和调整网格点的数量.最后一点是在"正确"的时间拨打Javascript.也就是说，一旦刷新了被动会话.我们可以用session$onFlushed.为了调用自定义Javascript函数，我们使用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)

使现代化

在阅读了this question on the Rstudio blog之后，我找到了缺失的部分，以遵循我最初的 idea ，运行滴答号自适应，以响应事件，而不是依赖onFlushed.这样就不需要设置shiny<->；JavaScript接口，可轻松适用于多个react 滑块:

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)