R Shiny：滑块锚点在末尾重叠

Question

在 UI 上有两个滑块，其中第二个滑块的范围取决于第一个滑块的输入。但是，滑块 1 上的某些值可能导致滑块 2 上的锚点在末尾重叠。有什么方法可以取消重叠吗？

感谢您的帮助。

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

在深入研究 Ion.RangeSlider and sliderInput 的内部结构后，我发现了一个（相当粗糙的）解决方法。

事实证明，对于 min/max 的某些组合，刻度数被故意设置为 non-integer。在您的情况下，您可以通过在浏览器中打开开发人员工具（Ctrl+Shift+I for Chrome in Windows）并键入以下代码来验证这一点：

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

在某些情况下，这会导致刻度标签重叠。因此，想法是

检测最后一个和上一个最后一个刻度标签之间是否有重叠。
如果是这样，将刻度标签的数量向下舍入到下一个整数，这会导致刻度之间的 space。

因此您需要包含一些 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 后，我发现缺少的部分遵循我最初的想法运行事件响应中的滴答数自适应而不是依赖 onFlushed。这消除了设置 shiny <-> JavaScript 界面的必要性，并且可以轻松地适应多个反应式滑块：

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)

R Shiny：滑块锚点在末尾重叠

R Shiny: Slider anchors overlap at the end

r

shiny

visualization

更新