How to prevent ggplot hoverOpts messages to go off screen with css
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)
Flexibel location of hover message while preventing message to reach beyond object limits
OK, I managed to get it working with some more modification:
It now includes an if statement to check if the result doesn't cause coordinates for the anchor point to be either <0 or >object height
The only thing I would still want to change (if possible is the references to FP1PlotMultiplot inside the javascript because I want to apply this script to 7 different objects where their names are only listed in the first line of the javascript like this:
$('[id=FP1PlotMultiplot], [id=FP2PlotMultiplot],[id=CRFPlotMultiplot]').off('mousemove.x').on('mousemove.x', ......
so, to replace the name based approach by something similar to 'e.target' but then for the main output object's ID
runjs(paste0( "$('[id=FP1PlotMultiplot]').off('mousemove.x').on('mousemove.x', function(e) {",
" $('#my_tooltip').show();",
" var tooltip = document.getElementById('my_tooltip');",
" var rect = tooltip.getBoundingClientRect();",
" var FrameID = document.getElementById('FP1PlotMultiplot');",
" var frame = FrameID.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 -10 : 10;",
" var offY = 2 * hoverTop > imgHeight ? -rect.height + 10 : 10;",
" var shiftY = e.offsetY + e.target.offsetTop + offY;",
" if (offY === 10) {",
" shiftY = shiftY + rect.height > frame.height ? -rect.height + 10 + e.offsetY + e.target.offsetTop : shiftY",
" } else {",
" shiftY = shiftY < 0 ? e.offsetY + e.target.offsetTop + 10 : shiftY",
" };",
" $('#my_tooltip').css({",
" top: shiftY + 'px',",
" left: e.offsetX + e.target.offsetLeft + offX + 'px'",
" });",
"});") )
UPDATE: current version, last remaining issues
Below is the current best working version. There are a few issues I'm still trying to improve.
1) When the code decides to flip the message upward, but there is only 1 plot, the shiftY value can currently result in a position that is above the top edge of the total plot object such as here: 
and then deciding to put it downwards, with 1 plot it can reach beyond the bottom. 
The cause of this is that the message doesn't fit upward or downward from the current hover place, and somehow the javascript needs another rule to figure this out, and if so, place the message i.e. 10 pixels below the top of total object. I tried various things, but I either ended up with messages always in the same place, or no result, as I couldn't quite figure out how to calculate whether the message ends up above, or below the total plot area after the current if (offY ... statement to determin shiftY.
2) The second major issue is that the app seems to get hung up on calculating new tables if the user moves the mouse a lot (in a plot with a few thousand data points this becomes more evident). So, if the mouse went from point A to point, the code reacts to a lot of hover positions between A and B causing a long queue of calculations to be triggered before finally showing the actual information of point B where the mouse 'stopped' or paused. I have been playing with delay and debounce, but did not find a working solution to stop the app from going through unnecessary calculations, which in my real app are more intensive /demanding on R than the test app.
Current version demo app:
require('shiny')
require('ggplot2')
require('DT')
require('shinyjs')
library('shinyBS')
ui <- pageWithSidebar(
headerPanel("Hover off the page"),
sidebarPanel(width = 2,
sliderInput(inputId = 'NrOfPlots', label = 'Nr of Plots', min = 1, max = 20, value = 1),
verbatimTextOutput('leftPix'),
verbatimTextOutput('topPix')
),
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('FP1PlotMultiplot'),
uiOutput('my_tooltip'),
style = 'width:1250px'
)
)
server <- function(input, output, session) {
observe({
lapply(1:input$NrOfPlots, function(i) {
output[[paste0('FP1Plot_', i)]] <- renderPlot({
ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() +
theme(legend.position = "none")
})
})
})
output$FP1PlotMultiplot<- renderUI({
n <- input$NrOfPlots
n_cols <- if(n == 1) {
1
} else if (n %in% c(2,4)) {
2
} else if (n %in% c(3,5,6,9)) {
3
} else {
4
}
Pwidth <- 1000/n_cols
Pheight <- 450/ceiling(n/n_cols) # calculate number of rows
Pwidth2 <- Pwidth+40
Pheight2 <- Pheight+80
plot_output_list <- list()
for(i in 1:input$NrOfPlots) {
plot_output_list <- append(plot_output_list,list(
div(id = paste0('div', 'FP1Plot_', i),
wellPanel(
plotOutput(paste0('FP1Plot_', i),
width = Pwidth,
height = Pheight,
hover = hoverOpts(id = paste('FP1Plot', i, "hover", sep = '_'), delay = 0)
),
style = paste('border-color:#339fff; border-width:2px; background-color: #fff; width:', Pwidth2, 'px; height:', Pheight2, 'px', sep = '')),
style = paste('display: inline-block; margin: 2px; width:', Pwidth2, 'px; height:', Pheight2, 'px', sep = ''))
))
}
do.call(tagList, plot_output_list)
})
# turn the hovers into 1 single reactive containing the needed information
hoverReact <- reactive({
eg <- expand.grid(c('FP1Plot'), 1:input$NrOfPlots)
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=FP1PlotMultiplot]').off('mousemove.x').on('mousemove.x', function(e) {",
" $('#my_tooltip').show();",
" var tooltip = document.getElementById('my_tooltip');",
" var rect = tooltip.getBoundingClientRect();",
" var FrameID = document.getElementById('FP1PlotMultiplot');",
" var frame = FrameID.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 -10 : 10;",
" var offY = 2 * hoverTop > imgHeight ? -rect.height + 10 : 10;",
" var shiftY = e.offsetY + e.target.offsetTop + offY;",
" if (offY === 10) {",
" shiftY = shiftY + rect.height > frame.height ? -rect.height + 10 + e.offsetY + e.target.offsetTop : shiftY",
" } else {",
" shiftY = shiftY < 0 ? e.offsetY + e.target.offsetTop + 10 : shiftY",
" };",
" $('#my_tooltip').css({",
" top: shiftY + 'px',",
" left: e.offsetX + e.target.offsetLeft + offX + 'px'",
" });",
"});") )
})
output$GGHoverTable <- renderTable({
df <- hoverData()
if(!is.null(df)) {
if(nrow(df)){
df <- df[1,]
t(df)
}
}
})
output$my_tooltip <- renderUI({
req(hoverData())
req(nrow(hoverData())>0 )
wellPanel(
tableOutput('GGHoverTable'),
style = 'background-color: #FFFFFFE6;padding:10px; width:400px;border-color:#339fff; width:auto')
})
}
shinyApp(ui, server)
Location of hover message when there are multiple plots goes wrong
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)
Related Topics
Efficient Way to Place Orphaned Element(S) at Top/Beginning Using CSS Flexbox
How to Change The Color of The Text Cursor in an Input Field in Ie
CSS Column-Count Not Respected
How to Disable Inline CSS in Gatsby
CSS - Use a Horizontal Scrollbar Only
Is a CSS Reset Still Necessary
Characters from Embedded Google Fonts Not Showing Up in Firefox 4 and Ie9
Select: Last-Child with Especific Class Name (With Only CSS)
Page Scroll Under Position: Fixed Content
CSS Target Just Class Name Starts with and Ends with String
Why Do Non-Floating Parents of Floating Elements Collapse
Vh/% Units and Keyboard on Mobile Devices
Custom Classname Semantic UI React