我在这里构建了一个虚拟应用程序，它为 ggplot 生成悬停消息，并确保它们保持在屏幕边界内，我编写了一些计算来确定所需的 CSS 更正并将其发送到服务器。
它基于将悬停消息保留在此处的第一次尝试：SO问题 https://stackoverflow.com/questions/57039988/how-to-prevent-ggplot-hoveropts-messages-to-go-off-screen-with-css/57054202#57054202从那时起，我已更改为发送修改后的 css 代码来更改工具提示的偏移量。
然而，问题似乎是，表格是在 css 发送到服务器之前构建的，而且我似乎找不到一种方法来更改这两件事发生的顺序。
require('shiny')
require('ggplot2')
require('DT')
require('shinyjs')
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) {
# ranges <- reactiveValues()
output$FP1Plot1 <- renderPlot({
ggplot(mtcars, aes(wt, mpg, color = as.factor(cyl))) + geom_point() #+
# coord_cartesian(xlim = ranges[[paste('FP1Plot1', 'x', sep = '')]],
# ylim = ranges[[paste('FP1Plot1', 'y', sep = '')]]
# )
})
# 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 }
print('sending css')
print(offY)
runjs(paste0( "$(document).ready(function() {",
"setTimeout(function(){",
"$('[id^=FP1Plot]').mousemove(function(e) {",
"$('#my_tooltip').show();",
"$('#my_tooltip').css({",
"top: (e.offsetY +", offY, " ) + 'px',",
"left: (e.offsetX +", offX, ") + 'px'",
"});",
"});",
"})});") )
}, priority = -1)
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 )
print('sending table')
wellPanel(
dataTableOutput('GGHoverTable'),
style = 'background-color: #FFFFFFE6;padding:10px; width:400px;border-color:#339fff')
})
}
shinyApp(ui, server)
