How to prevent ggplot hoverOpts messages to go off

Question

When running the demo App below, the problem I run into is that hover messages for the bottom part of the plot end up running off the screen.

Does anybody know if there is a way to adjust the position so that the entire message always falls within the screen boundaries (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

Here is a solution with the JS library 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)

Answer 2

@ stephane, I came up with another solution using 'sending css' code to update the position of the hover message. The only problem I still run into, is that the position doesn't update until the message content changes for the second time to a point in a quadrant.

there are 2 values for x offset and 2 for y offset, splitting the plot in 4 quadrants in fact. Switching to another quadrant puts the message in the last quadrants configuration, and doesn't correct this until I hover on a second point in the new quadrant.

Do you have any idea to push the css change more effectively? perhaps with sendcustommessage or so? I tried to do it that way, but couldn't get it to work at all with that approach. Here is my code attempt so far:

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

ui <- pageWithSidebar(

  headerPanel("Hover off the page"),
  sidebarPanel(width = 2
  ),
  mainPanel(
    tags$head(
      tags$style('
                 #my_tooltip {
                 position: absolute;
                 pointer-events:none;
                 width: 10;
                 z-index: 100;
                 padding: 0;
                 font-size:10px;
                 line-height:0.6em
                 }
                 ')
    ),

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

    uiOutput("my_tooltip"),
    uiOutput("my_tooltip_style"),
    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 = '')]]
      # )          
  })




  # turn the hovers into 1 single reactive containing the needed information
  hoverReact <- reactive({
    ## in my real app I observer hover of all sub plots of all stages (7 pages with a multilot object)
    ## followed by code to store the page ID and plot NR as elements in hoverReact()
    hover <-  input[['FP1Plot_1_hover']]

    if(is.null(hover)) return(NULL)
     hover

  })

  ## debounce the reaction to calm down shiny
  hoverReact_D <- hoverReact %>% debounce(100)  ## attempt to stop hoverData <- reactive({}) from firing too often, which is needed when you have 10k point scatter plots.....

  hoverData <- reactive({
    hover <- hoverReact_D() 
    if(is.null(hover)) return(NULL)
    ## in my multi plot multi data frame I look up which dataframe to grab based on hover$plot_id as well as which x and y parameter are plotted
    hoverDF <- nearPoints(mtcars, coordinfo = hover, threshold = 15, maxpoints = 1, xvar = 'wt', yvar = 'mpg')
    hoverDF
  })



  hoverPos <- reactive({
    ## here I look up the position information of the hover whenevver hoverReact_D and hoverData change 
    hover <- hoverReact_D()
    hoverDF <- hoverData()

    if(is.null(hover)) return(NULL)
    if(nrow(hoverDF) == 0) return(NULL)

    ## in my real app the data is already 
    X <- hoverDF$wt[1]
    Y <- hoverDF$mpg[1]

    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 

    list(top = top_px, left = left_px)
  })



  output$my_tooltip_style <- renderUI({
    req(hoverPos())
    hover <- hoverPos()
    if(is.null(hover)) return(NULL)

    print(hover$top)
    offX <- if(hover$left  > 350) {-400} else {30}
    offY <- if(hover$top  > 350) {-290} else {10 }

    print(paste(offX, offY))

    cssMessage <- paste( "
                    $(document).ready(function() {
                         setTimeout(function(){
                         $('[id^=FP1Plot]').mousemove(function(e) {  
                         $('#my_tooltip').show();         
                         $('#my_tooltip').css({             
                         top: (e.offsetY +", offY, " ) + 'px',            
                         left: (e.offsetX +", offX, ") + 'px'        
                         });     
                         });     
                         })});", sep = '')

    tags$script(cssMessage)

})




  output$GGHoverTable <- DT::renderDataTable({  
    df <- hoverData()
    if(!is.null(df)) {
      if(nrow(df)){
        df <- df[1,]
        DT::datatable(t(df), colnames = rep("", nrow(df)),
                      options = list(dom='t',ordering=F, autowidth = T))
      }
    }
  })


  output$my_tooltip <- renderUI({
    req(hoverData())
    wellPanel(
      dataTableOutput('GGHoverTable'),
      style = 'background-color: #FFFFFFE6;padding:10px; width:400px;border-color:#339fff')
  })


}

shinyApp(ui, server)