当有多个情节时悬停消息的位置出错 [英] Location of hover message when there are multiple plots goes wrong
本文介绍了当有多个情节时悬停消息的位置出错的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
在寻找自定义构建悬停消息时，并确保它们停留在屏幕上，我设法解决了css位置更新的问题:
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
悬停时，两个图都会产生垂直位置和水平位置的px值，并且两个图似乎都给出相似的值.
然后，这会根据坐标所在的绘图部分(上/下，向左/向右，取决于绘图的哪四分之一)触发偏移校正的计算
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 }
演示应用程序显示，两个图均产生相同的校正值，应将其添加到e.offsetY和e.offsetX
The demo app shows that both plots produce the same correction values, which should be added to the e.offsetY and e.offsetX
这些绘图分别称为FP1Plot1和FP1Plot2，最后一个nr指示序列nr，第一部分显示它们所在的应用程序页面.
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.
此块应为工具提示发送新坐标，但它们似乎始终与左侧的第一个图链接.这是因为它将其链接到分组的输出对象'FP1PlotDoubleplot'.我不知道如何将其链接到悬停当前所在的实际单个图上:
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'",
"});",
"});") )
多个图的问题
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)
与1个地块完美配合
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跟踪以使偏移更智能
我试图编写一些JavaScript来获取对象大小，以基于该大小为偏移翻转点，但到目前为止无法正常工作
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)
}
，然后:
runjs(sizejs('TooltipDiv'))
获取工具提示的大小(重命名为div('TooltipDiv'...而不是wellPanel
但也希望检查图的大小(在动态布局中，这会随着图的nr改变)
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)
当前最佳工作版本
移动到有关多列/行的详细信息的新问题，并且不会超出限制 到目前为止，我有2种情节场景
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)
更新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;",
此处的+15、35、80和90似乎取决于页面(屏幕)上的位置
主div被放置(在我的应用程序中到处都是不完全相同的.
我想知道是否还有另一个我们可以使用的e.target....
在此更新上方的应用中，这是指影响这些数字的uiOutput('FP1PlotDoubleplot')位置更改.
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.
推荐答案
我必须将dataTableOutput替换为DT::dataTableOutput，否则工具提示为空.
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)
这篇关于当有多个情节时悬停消息的位置出错的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
