Location of hover message when there are multiple plots goes wrong

Question

In the hunt for custom build hover messages, and making sure they stay on the screen I managed to fix the css position updating with this question: SO question, but in my real a

Answer 1

I had to replace dataTableOutput with DT::dataTableOutput, otherwise the tooltips were empty.

The tooltips seem to be well positioned by doing:

offX <- if(hover$left  > 350) {-90} else {0}
offY <- if(hover$top  > 350) {-270} else {30 }

runjs(paste0( "$('[id=FP1PlotDoubleplot]').off('mousemove.x').on('mousemove.x', function(e) {",
              "$('#my_tooltip').show();",
              "$('#my_tooltip').css({",
              "top: (e.offsetY +", offY, " ) + 'px',",
              "left: (e.offsetX + e.target.offsetLeft +", offX, ") + 'px'",
              "});",
              "});") )

---

Edit

Here is a way to automatically calculate the offsets:

offX <- if(hover$left  > 270) {1000} else {0} # 270 = 540/2 (540 is the width of FP1PlotDoubleplot)
offY <- if(hover$top  > 350) {1000} else {30}

runjs(paste0( "$('[id=FP1PlotDoubleplot]').off('mousemove.x').on('mousemove.x', function(e) {",
              "  $('#my_tooltip').show();",
              "  var tooltip = document.getElementById('my_tooltip');",
              "  var rect = tooltip.getBoundingClientRect();",
              "  var offX = ", offX, ";",
              "  var offY = ", offY, ";",
              "  offX = offX === 1000 ? -rect.width : offX;",
              "  offY = offY === 1000 ? -rect.height+30 : offY;",
              "  $('#my_tooltip').css({",
              "    top: e.offsetY + offY + 'px',",
              "    left: e.offsetX + e.target.offsetLeft + offX + 'px'",
              "  });",
              "});") )

---

Edit

A better way, which does not require to enter the dimensions of the plots:

  observeEvent(hoverPos(), {
    req(hoverPos())
    hover <- hoverPos()
    if(is.null(hover)) return(NULL)

    runjs(paste0( "$('[id=FP1PlotDoubleplot]').off('mousemove.x').on('mousemove.x', function(e) {",
                  "  $('#my_tooltip').show();",
                  "  var tooltip = document.getElementById('my_tooltip');",
                  "  var rect = tooltip.getBoundingClientRect();",
                  "  var hoverLeft = ", hover$left, ";",
                  "  var hoverTop = ", hover$top, ";",
                  "  var imgWidth = e.target.width;",
                  "  var imgHeight = e.target.height;",
                  "  var offX = 2*hoverLeft > imgWidth ? -rect.width : 0;",
                  "  var offY = 2*hoverTop > imgHeight ? -rect.height+30 : 30;",
                  "  $('#my_tooltip').css({",
                  "    top: e.offsetY + offY + 'px',",
                  "    left: e.offsetX + e.target.offsetLeft + offX + 'px'",
                  "  });",
                  "});") )

  })

---

Edit

To be sure the tooltip does not go outside the plotting area:

runjs(paste0( "$('[id=FP1PlotDoubleplot]').off('mousemove.x').on('mousemove.x', function(e) {",
              "  $('#my_tooltip').show();",
              "  var tooltip = document.getElementById('my_tooltip');",
              "  var rect = tooltip.getBoundingClientRect();",
              "  var hoverLeft = ", hover$left, ";",
              "  var hoverTop = ", hover$top, ";",
              "  var imgWidth = e.target.width;",
              "  var imgHeight = e.target.height;",
              "  var offX = 2*hoverLeft > imgWidth ? -rect.width : 0;",
              "  var offY = 2*hoverTop > imgHeight ? -rect.height+30 : 30;",
              "  var shiftY = e.offsetY + offY;",
              "  shiftY = shiftY + rect.height > imgHeight ? 20 + imgHeight - rect.height : shiftY;",
              "  shiftY = Math.max(20, shiftY);",
              "  $('#my_tooltip').css({",
              "    top: shiftY + 'px',",
              "    left: e.offsetX + e.target.offsetLeft + offX + 'px'",
              "  });",
              "});") )

---

Edit

I have tried with four plots arranged on two rows. Here is my solution.

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

ui <- pageWithSidebar(

  headerPanel("Hover off the page"),
  sidebarPanel(),
  mainPanel(
    shinyjs::useShinyjs(),
    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
                 }
                 ')
    ),

    uiOutput('FP1PlotDoubleplot'),

    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() 
  })

  output$FP1Plot2 <- renderPlot({
    ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() 
  })

  output$FP1Plot3 <- renderPlot({
    ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() 
  })

  output$FP1Plot4 <- renderPlot({
    ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() 
  })

  output$FP1PlotDoubleplot<- renderUI({

    tagList(
      fluidRow(
        column(6, 
               wellPanel(
                 plotOutput('FP1Plot1',
                            width = 500,
                            height = 400,
                            hover = hoverOpts(id = paste('FP1Plot', 1, "hover", sep = '_'), delay = 0)
                 ),
                 style = 'border-color:#339fff; border-width:2px; background-color: #fff;'
               )
        ),
        column(6, 
               wellPanel(
                 plotOutput('FP1Plot2',
                            width = 500,
                            height = 400,
                            hover = hoverOpts(id = paste('FP1Plot', 2, "hover", sep = '_'), delay = 0)
                 ),
                 style = 'border-color:#339fff; border-width:2px; background-color: #fff;'
               )
        )
      ),
      fluidRow(
        column(6, 
               wellPanel(
                 plotOutput('FP1Plot3',
                            width = 500,
                            height = 400,
                            hover = hoverOpts(id = paste('FP1Plot', 3, "hover", sep = '_'), delay = 0)
                 ),
                 style = 'border-color:#339fff; border-width:2px; background-color: #fff;'
               )
        ),
        column(6, 
               wellPanel(
                 plotOutput('FP1Plot4',
                            width = 500,
                            height = 400,
                            hover = hoverOpts(id = paste('FP1Plot', 4, "hover", sep = '_'), delay = 0)
                 ),
                 style = 'border-color:#339fff; border-width:2px; background-color: #fff;'
               )
        )
      )
    )
  })


  # turn the hovers into 1 single reactive containing the needed information
  hoverReact <- reactive({
    eg <- expand.grid(c('FP1Plot'), 1:4)
    plotids <- sprintf('%s_%s', eg[,1], eg[,2])
    names(plotids) <- plotids

    hovers <- lapply(plotids, function(key) input[[paste0(key, '_hover')]])

    notNull <- sapply(hovers, Negate(is.null))
    if(any(notNull)){
      plotid <- names(which(notNull))
      plothoverid <- paste0(plotid, "_hover")

      hover <- input[[plothoverid]]
      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)
  })




  observeEvent(hoverPos(), {
    req(hoverPos())
    hover <- hoverPos()
    if(is.null(hover)) return(NULL)

    runjs(paste0( "$('[id=FP1PlotDoubleplot]').off('mousemove.x').on('mousemove.x', function(e) {",
                  "  $('#my_tooltip').show();",
                  "  var tooltip = document.getElementById('my_tooltip');",
                  "  var rect = tooltip.getBoundingClientRect();",
                  "  var hoverLeft = ", hover$left, ";",
                  "  var hoverTop = ", hover$top, ";",
                  "  var imgWidth = e.target.width;",
                  "  var imgHeight = e.target.height;",
                  "  var offX = 2*hoverLeft > imgWidth ? -rect.width : 0;",
                  "  var offY = 2*hoverTop > imgHeight ? -rect.height+20 : 0;",
                  "  var shiftY = e.offsetY + offY;",
                  "  shiftY = shiftY + rect.height > imgHeight ? imgHeight - rect.height : shiftY;",
                  "  shiftY = Math.max(0, shiftY);",
                  "  $('#my_tooltip').css({",
                  "    top: shiftY + e.target.getBoundingClientRect().top - document.getElementById('FP1PlotDoubleplot').getBoundingClientRect().top + 'px',",
                  "    left: e.clientX + offX + 'px'",
                  "  });",
                  "});") )

  })

  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))
      }
    }
  })


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

}

shinyApp(ui, server)