How to prevent ggplot hoverOpts messages to go off screen with css

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

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)