Flexibel Location Of Hover Message While Preventing Message To Reach Beyond Object Limits
Solution 1:
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
} elseif (n %in% c(2,4)) {
2
} elseif (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)
Post a Comment for "Flexibel Location Of Hover Message While Preventing Message To Reach Beyond Object Limits"