Mark
Reputation: 2889
Location of hover message when there are multiple plots goes wrong
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 app, the nr op plots can be set by the user, who will be autoscaled: 1-20 plots 1-4 columns
On hover, both plots produce px values of vertical and horizontal position, and both plots seem to give similar values.
This then triggers the calculation of offset correction depending on which part of the plot the coordinates are in (move up/down, left/right depending on which quarter of the plot)
offX <- if(hover$left > 350) {-90} else {50}
offY <- if(hover$top > 350) {-270} else {30 }
The demo app shows that both plots produce the same correction values, which should be added to the e.offsetY and e.offsetX
The plots are called FP1Plot1 and FP1Plot2 , the last nr indicating the sequence nr, the first part the page of my app they are on.
This block should send the new coordinates for the tooltip, but they seem to always be linked to the 1st plot on the left. This because it is linking it to the grouped output object 'FP1PlotDoubleplot'. I can't figure out how to link it to the actual single plot the hover is currently over:
runjs(paste0( "$('[id^=FP1Plot]').off('mousemove.x').on('mousemove.x', function(e) {",
"$('#my_tooltip').show();",
"$('#my_tooltip').css({",
"top: (e.offsetY +", offY, " ) + 'px',",
"left: (e.offsetX +", offX, ") + 'px'",
"});",
"});") )
Problem with multiple plots
require('shiny')
require('ggplot2')
require('DT')
require('shinyjs')
library('shinyBS')
ui <- pageWithSidebar(
headerPanel("Hover off the page"),
sidebarPanel(width = 2,
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('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$FP1PlotDoubleplot<- renderUI({
plot_output_list <- list()
for(i in 1:2) {
plot_output_list <- append(plot_output_list,list(
div(id = paste0('div', 'FP1Plot', i),
wellPanel(
plotOutput(paste0('FP1Plot', i),
width = 500,
height = 600,
hover = hoverOpts(id = paste('FP1Plot', i, "hover", sep = '_'), delay = 0)
),
style = paste('border-color:#339fff; border-width:2px; background-color: #fff; width:', 540, 'px; height:', 680, 'px', sep = '')),
style = paste('display: inline-block; margin: 2px; width:', 540, 'px; height:', 680, '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:2)
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)
offX <- if(hover$left > 350) {-90} else {50}
offY <- if(hover$top > 350) {-270} else {30 }
output$leftPix <- renderPrint({ offX[1]})
output$topPix <- renderPrint({ offY[1]})
runjs(paste0( "$('[id^=FP1Plot]').off('mousemove.x').on('mousemove.x', function(e) {",
"$('#my_tooltip').show();",
"$('#my_tooltip').css({",
"top: (e.offsetY +", offY, " ) + 'px',",
"left: (e.offsetX +", 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(
dataTableOutput('GGHoverTable'),
style = 'background-color: #FFFFFFE6;padding:10px; width:400px;border-color:#339fff; width:auto')
})
}
shinyApp(ui, server)
Working nicely with 1 plot
require('shiny')
require('ggplot2')
require('DT')
require('shinyjs')
library('shinyBS')
ui <- pageWithSidebar(
headerPanel("Hover off the page"),
sidebarPanel(width = 2
),
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
}
')
),
plotOutput('FP1Plot1' ,
width = 1000,
height = 800,
hover = hoverOpts(id = 'FP1Plot_1_hover', delay = 0)
),
uiOutput('my_tooltip'),
style = 'width:1250px'
)
)
server <- function(input, output, session) {
output$FP1Plot1 <- renderPlot({
ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() #+
})
# 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)
})
observeEvent(hoverPos(), {
req(hoverPos())
hover <- hoverPos()
if(is.null(hover)) return(NULL)
offX <- if(hover$left > 350) {-400} else {30}
offY <- if(hover$top > 350) {-290} else {10 }
runjs(paste0( "$('[id^=FP1Plot]').mousemove(function(e) {",
"$('#my_tooltip').show();",
"$('#my_tooltip').css({",
"top: (e.offsetY +", offY, " ) + 'px',",
"left: (e.offsetX +", 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, autowidth = T))
}
}
})
output$my_tooltip <- renderUI({
req(hoverData())
req(nrow(hoverData())>0 )
wellPanel(
dataTableOutput('GGHoverTable'),
style = 'background-color: #FFFFFFE6;padding:10px; width:400px;border-color:#339fff')
})
}
shinyApp(ui, server)
PS follow up to make the offset smarter
I attempted to write some javascript to grab object sizes to base the offset flip point based on that, but so far not working
sizejs <- function(ID){
sprintf(paste(
"var element = document.getElementById({id: %s);",
"var positionInfo = element.getBoundingClientRect();",
"var height = positionInfo.height;",
"var width = positionInfo.width;",
" Shiny.setInputValue(objectHeight, height);",
" Shiny.setInputValue(objectWidth, width);",
sep = "\n"
), ID)
}
and then:
runjs(sizejs('TooltipDiv'))
to get the size of the tooltip (renamed to div('TooltipDiv'... instead of wellPanel
but hopefully also to check the size of the plots (in a dynamic layout this changes with nr of plots)
EDIT: Current best working version
moving to a new question for the details about multi column/rows and not going outside the limits So far I have this for 2 plot scenario
require('shiny')
require('ggplot2')
require('DT')
require('shinyjs')
library('shinyBS')
ui <- pageWithSidebar(
headerPanel("Hover off the page"),
sidebarPanel(width = 2,
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('FP1PlotDoubleplot'),
uiOutput('my_tooltip'),
style = 'width:1250px'
)
)
server <- function(input, output, session) {
# ranges <- reactiveValues()
output$FP1Plot_1 <- renderPlot({
ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point()
})
output$FP1Plot_2 <- renderPlot({
ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point()
})
output$FP1PlotDoubleplot<- renderUI({
plot_output_list <- list()
for(i in 1:2) {
plot_output_list <- append(plot_output_list,list(
div(id = paste0('div', 'FP1Plot_', i),
wellPanel(
plotOutput(paste0('FP1Plot_', i),
width = 500,
height = 600,
hover = hoverOpts(id = paste('FP1Plot', i, "hover", sep = '_'), delay = 0)
),
style = paste('border-color:#339fff; border-width:2px; background-color: #fff; width:', 540, 'px; height:', 680, 'px', sep = '')),
style = paste('display: inline-block; margin: 2px; width:', 540, 'px; height:', 680, '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:2)
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)
offX <- if(hover$left > 350) {-125} else {10}
offY <- if(hover$top > 350) {-290} else {10 }
output$leftPix <- renderPrint({ offX[1]})
output$topPix <- renderPrint({ offY[1]})
runjs(paste0( "$('[id=FP1PlotDoubleplot]').off('mousemove.x').on('mousemove.x', function(e) {",
"$('#my_tooltip').show();",
"$('#my_tooltip').css({",
"top: (e.offsetY + e.target.offsetTop+", offY, " ) + 'px',",
"left: (e.offsetX + e.target.offsetLeft +", 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)
UPDATE 4
This code is simplified to avoid unnecessary steps and seems to work quite well:
runjs(paste0( "$('[id=FP1PlotMSPggplot]').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('FP1PlotMSPggplot');",
" 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 +15: 35;",
" var offY = 2 * hoverTop > imgHeight ? -rect.height + 80 : 90;",
" var shiftY = e.offsetY + e.target.offsetTop + offY;",
" var shiftX = e.offsetX + e.target.offsetLeft + offX;",
" shiftY = shiftY < 0 ? e.offsetY + e.target.offsetTop + 10 : shiftY;",
" $('#my_tooltip').css({",
" top: shiftY + 'px',",
" left: shiftX + 'px'",
" });",
"});") )
The only hardcoded value still gives a bit of an issue:
" var offX = 2 * hoverLeft > imgWidth ? -rect.width +15: 35;",
" var offY = 2 * hoverTop > imgHeight ? -rect.height + 80 : 90;",
the +15, 35, 80 and 90 in here seem to depend on where on the page (screen)
the main div is placed (which is not exactly the same everywhere in my app.
I wonder if there is another e.target... we can use.
In the app above this update, this refers to changes in the positioning of uiOutput('FP1PlotDoubleplot') that affects these numbers.
Upvotes: 0
Views: 331
Answers (1)
Stéphane Laurent
Reputation: 84519
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)
Upvotes: 2
Related Questions
- How to customize hovertext for ggplotly() object that contains two (or more) geoms?
- R: Updating Hover Text
- Change hover message in ggplotly map
- how change hover text in plotly
- R: overlapping tooltips when hovering in ggplotly
- How to add custom hover function to plotOutput so it can be used for many plots
- ggplot hoverOpts not working as expected compared to old style hover
- Hover text on plot incorrect
- R: ggplot for hover text
- Duplicate hover Info in plotly with ggplot2