如何使用 css 防止 ggplot hoverOpts 消息离开屏幕
How to prevent ggplot hoverOpts messages to go off screen with css
当 运行 运行下面的演示应用程序时，我 运行 遇到的问题是绘图底部的悬停消息最终 运行 离开屏幕。
有谁知道是否有办法调整位置，使整个消息始终落在屏幕边界 (l,r,t,b) 内？
require('shiny')
require('ggplot2')
library(DT)
ui <- pageWithSidebar(
headerPanel("Hover off the page"),
sidebarPanel(width = 2
),
mainPanel(
tags$head(
tags$style('
#my_tooltip {
position: absolute;
pointer-events:none;
z-index: 1;
padding: 0;
}'),
tags$script('
$(document).ready(function() {
setTimeout(function(){
$("[id^=FP1Plot]").mousemove(function(e) {
$("#my_tooltip").show();
$("#my_tooltip").css({
top: (e.offsetY) + "px",
left: (e.pageX -300) + "px"
});
});
},1000)});')
),
plotOutput('FP1Plot1' ,
width = 1000,
height = 800,
hover = hoverOpts(id = 'FP1Plot1_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 = '')]]
)
})
tooltipTable <- reactive({
y <- nearPoints(mtcars, input$FP1Plot1_hover,
threshold = 15)
if(nrow(y)){
datatable(t(y), colnames = rep("", nrow(y)),
options = list(dom = 't'))
}
})
output$my_tooltip <- renderUI({
req(tooltipTable())
wellPanel(DTOutput("vals"),
style = 'background-color:#fff; padding:10px; width:400px;border-color:#339fff')
})
output$vals <- renderDT({
tooltipTable()
})
}
shinyApp(ui, server)
这是一个使用 JS 库的解决方案 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)
@stephane，我想出了另一个解决方案，使用 'sending css' 代码来更新悬停消息的位置。我仍然 运行 遇到的唯一问题是，在消息内容第二次更改为象限中的某个点之前，位置不会更新。
x 偏移有 2 个值，y 偏移有 2 个值，实际上将绘图分成 4 个象限。切换到另一个象限会将消息置于最后一个象限配置中，并且直到我将鼠标悬停在新象限中的第二个点时才会更正此消息。
您有什么想法可以更有效地推动 css 更改吗？也许与 sendcustommessage 左右？我试着那样做，但用那种方法根本无法让它工作。
到目前为止，这是我的代码尝试：
require('shiny')
require('ggplot2')
require('DT')
ui <- pageWithSidebar(
headerPanel("Hover off the page"),
sidebarPanel(width = 2
),
mainPanel(
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"),
uiOutput("my_tooltip_style"),
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)
})
output$my_tooltip_style <- renderUI({
req(hoverPos())
hover <- hoverPos()
if(is.null(hover)) return(NULL)
print(hover$top)
offX <- if(hover$left > 350) {-400} else {30}
offY <- if(hover$top > 350) {-290} else {10 }
print(paste(offX, offY))
cssMessage <- paste( "
$(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'
});
});
})});", sep = '')
tags$script(cssMessage)
})
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())
wellPanel(
dataTableOutput('GGHoverTable'),
style = 'background-color: #FFFFFFE6;padding:10px; width:400px;border-color:#339fff')
})
}
shinyApp(ui, server)
当 运行 运行下面的演示应用程序时，我 运行 遇到的问题是绘图底部的悬停消息最终 运行 离开屏幕。
有谁知道是否有办法调整位置，使整个消息始终落在屏幕边界 (l,r,t,b) 内？
require('shiny')
require('ggplot2')
library(DT)
ui <- pageWithSidebar(
headerPanel("Hover off the page"),
sidebarPanel(width = 2
),
mainPanel(
tags$head(
tags$style('
#my_tooltip {
position: absolute;
pointer-events:none;
z-index: 1;
padding: 0;
}'),
tags$script('
$(document).ready(function() {
setTimeout(function(){
$("[id^=FP1Plot]").mousemove(function(e) {
$("#my_tooltip").show();
$("#my_tooltip").css({
top: (e.offsetY) + "px",
left: (e.pageX -300) + "px"
});
});
},1000)});')
),
plotOutput('FP1Plot1' ,
width = 1000,
height = 800,
hover = hoverOpts(id = 'FP1Plot1_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 = '')]]
)
})
tooltipTable <- reactive({
y <- nearPoints(mtcars, input$FP1Plot1_hover,
threshold = 15)
if(nrow(y)){
datatable(t(y), colnames = rep("", nrow(y)),
options = list(dom = 't'))
}
})
output$my_tooltip <- renderUI({
req(tooltipTable())
wellPanel(DTOutput("vals"),
style = 'background-color:#fff; padding:10px; width:400px;border-color:#339fff')
})
output$vals <- renderDT({
tooltipTable()
})
}
shinyApp(ui, server)
这是一个使用 JS 库的解决方案 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)
@stephane，我想出了另一个解决方案，使用 'sending css' 代码来更新悬停消息的位置。我仍然 运行 遇到的唯一问题是，在消息内容第二次更改为象限中的某个点之前，位置不会更新。
x 偏移有 2 个值，y 偏移有 2 个值，实际上将绘图分成 4 个象限。切换到另一个象限会将消息置于最后一个象限配置中，并且直到我将鼠标悬停在新象限中的第二个点时才会更正此消息。
您有什么想法可以更有效地推动 css 更改吗？也许与 sendcustommessage 左右？我试着那样做，但用那种方法根本无法让它工作。 到目前为止，这是我的代码尝试：
require('shiny')
require('ggplot2')
require('DT')
ui <- pageWithSidebar(
headerPanel("Hover off the page"),
sidebarPanel(width = 2
),
mainPanel(
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"),
uiOutput("my_tooltip_style"),
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)
})
output$my_tooltip_style <- renderUI({
req(hoverPos())
hover <- hoverPos()
if(is.null(hover)) return(NULL)
print(hover$top)
offX <- if(hover$left > 350) {-400} else {30}
offY <- if(hover$top > 350) {-290} else {10 }
print(paste(offX, offY))
cssMessage <- paste( "
$(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'
});
});
})});", sep = '')
tags$script(cssMessage)
})
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())
wellPanel(
dataTableOutput('GGHoverTable'),
style = 'background-color: #FFFFFFE6;padding:10px; width:400px;border-color:#339fff')
})
}
shinyApp(ui, server)