css - 如何防止 ggplot hoverOpts 消息使用 css 离开屏幕

Question

当运行下面的演示应用程序时，我遇到的问题是绘图底部的悬停消息最终从屏幕上消失了。

有谁知道是否有办法调整位置，使整个消息始终落在屏幕边界 (l,r,t,b) 内？

require('shiny')
require('ggplot2')
library(DT)

ui <- pageWithSidebar(

  headerPanel("Hover off the page"),
  sidebarPanel(width = 2
  ),
  mainPanel(
    tags$head(
      tags$style('
                 #my_tooltip {
                 position: absolute;
                 pointer-events:none;
                 z-index: 1;
                 padding: 0;
                 }'),
      tags$script('
                  $(document).ready(function() {
                  setTimeout(function(){
                  $("[id^=FP1Plot]").mousemove(function(e) { 
                  $("#my_tooltip").show();         
                  $("#my_tooltip").css({             
                  top: (e.offsetY) + "px",             
                  left: (e.pageX -300) + "px"         
                  });     
                  });     
                  },1000)});')
    ),

                   plotOutput('FP1Plot1' ,
                              width = 1000,
                              height = 800,
                              hover = hoverOpts(id = 'FP1Plot1_hover', delay = 0)          
      ),

    uiOutput("my_tooltip"),
    style = 'width:1250px'
      )
    )

server <- function(input, output, session) {

  ranges <- reactiveValues()


      output$FP1Plot1 <- renderPlot({
        ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() +
          coord_cartesian(xlim = ranges[[paste('FP1Plot1',  'x', sep = '')]], 
                          ylim = ranges[[paste('FP1Plot1',  'y', sep = '')]]
          )          
      })





  tooltipTable <- reactive({
      y <- nearPoints(mtcars, input$FP1Plot1_hover, 
                      threshold = 15)
      if(nrow(y)){
        datatable(t(y), colnames = rep("", nrow(y)), 
                  options = list(dom = 't'))
      }
  })

  output$my_tooltip <- renderUI({
    req(tooltipTable())
    wellPanel(DTOutput("vals"), 
              style = 'background-color:#fff; padding:10px; width:400px;border-color:#339fff')
  })

  output$vals <- renderDT({
    tooltipTable()
  })  


}

shinyApp(ui, server)

Answer 1

这是 JS 库的解决方案 qTip2 .

library(shiny)
library(ggplot2)
library(DT)

js_qTip <- "
$('#hoverinfo').qtip({
  overwrite: true,
  content: {
    text: $('#tooltip').clone()
  },
  position: {
    my: '%s',
    at: '%s',
    target: [%s,%s],
    container: $('#FP1Plot1')
  },
  show: {
    ready: true
  },
  hide: {
    target: $('#FP1Plot1')
  },
  style: {
    classes: 'qtip-light'
  }
});
"

ui <- fluidPage(
  tags$head(
    tags$link(rel = "stylesheet", href = "jquery.qtip.min.css"),
    tags$script(src = "jquery.qtip.min.js"),
    tags$script(
      HTML(
        'Shiny.addCustomMessageHandler("jsCode", function(mssg){setTimeout(function(){eval(mssg.value);},10);})'
      )
    )
  ),
  plotOutput('FP1Plot1' ,
             width = 1000,
             height = 700,
             hover = hoverOpts(id = 'FP1Plot1_hover')),
  tags$div(id = "hoverinfo", style = "position: absolute;"),
  tags$div(DTOutput("tooltip"), style = "visibility: hidden;") # put this div at the very end of the UI
)

server <- function(input, output, session){
  output$FP1Plot1 <- renderPlot({
    ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point(size = 2)
  })

  tooltipTable <- eventReactive(input[["FP1Plot1_hover"]], { 
    hover <- input[["FP1Plot1_hover"]]
    if(is.null(hover)) return(NULL)
    dat <- mtcars
    point <- nearPoints(dat, hover, threshold = 15, maxpoints = 1)
    if(nrow(point) == 0) return(NULL)
    X <- point[["wt"]]
    Y <- point[["mpg"]]
    left_pct <- 
      (X - hover$domain$left) / (hover$domain$right - hover$domain$left)
    top_pct <- 
      (hover$domain$top - Y) / (hover$domain$top - hover$domain$bottom)  
    left_px <- 
      (hover$range$left + left_pct * (hover$range$right - hover$range$left)) / 
      hover$img_css_ratio$x 
    top_px <- 
      (hover$range$top + top_pct * (hover$range$bottom - hover$range$top)) / 
      hover$img_css_ratio$y 
    pos <- ifelse(left_pct<0.5,
                  ifelse(top_pct<0.5, 
                         "top left",
                         "bottom left"),
                  ifelse(top_pct<0.5,
                         "top right",
                         "bottom right"))
    list(data = t(point), pos = pos, left_px = left_px+10, top_px = top_px)
  }) # end of eventReactive

  output[["tooltip"]] <- renderDT({
    req(tooltipTable())
    datatable(tooltipTable()$data, colnames = NULL, 
              options = list(dom = "t", ordering = FALSE))
  }, server = FALSE)

  observeEvent(tooltipTable(), {
    tt <- tooltipTable()
    session$sendCustomMessage(
      type = "jsCode", 
      list(value = sprintf(js_qTip, tt$pos, tt$pos, tt$left_px, tt$top_px))
    )
  })
}

shinyApp(ui, server)