【发布时间】：2019-01-04 19:15:47
【问题描述】：
您好，感谢您提前提供的任何帮助。
我正在为 EDA 开发一个闪亮的应用程序，并希望将悬停工具提示添加到 ggplot 散点图中。
This example 工作正常，直到轴被对数转换，因为工具提示坐标超出了绘图范围。
Example 3 in this answer 适用于日志转换散点图，但是当我在 Shiny 模块中使用它时，tags$style 和 tags$script 元素不会传递给工具提示 UI 对象 my_tooltip 和实际文本在工具提示中。我的怀疑是当my_tooltip 在tags$style 中被引用时，命名空间被忽略了，所以my_tooltip 从不使用HTML 元素。
我没有足够的 HTML 来编辑示例 3。下面我提供了三个可重现的示例，这些示例是根据上面引用的两个来源修改的，它们都完成了我想要实现的部分目标。任何帮助将不胜感激。谢谢。
可重现的示例 1：适用于对数刻度，但不适用于 Shiny 模块
library(shiny)
library(ggplot2)
ui <- fluidPage(
selectInput("logX", "Log scale",
choices=coordoptions,
selected="identity"),
selectInput("logY", "Log scale",
choices=coordoptions,
selected="identity"),
tags$head(tags$style('
#my_tooltip {
position: absolute;
width: 300px;
z-index: 100;
padding: 0;
}
')),
tags$script('
$(document).ready(function() {
// id of the plot
$("#distPlot").mousemove(function(e) {
// ID of uiOutput
$("#my_tooltip").show();
$("#my_tooltip").css({
top: (e.pageY + 5) + "px",
left: (e.pageX + 5) + "px"
});
});
});
'),
selectInput("var_y", "Y-Axis", choices = names(iris)),
plotOutput("distPlot", hover = "plot_hover", hoverDelay = 0),
uiOutput("my_tooltip")
)
server <- function(input, output) {
output$distPlot <- renderPlot({
req(input$var_y)
ggplot(iris, aes_string("Sepal.Width", input$var_y)) +
geom_point() +
scale_x_continuous(trans=input$logX) +
scale_y_continuous(trans=input$logY)
})
output$my_tooltip <- renderUI({
hover <- input$plot_hover
y <- nearPoints(iris, input$plot_hover)[input$var_y]
req(nrow(y) != 0)
verbatimTextOutput("vals")
})
output$vals <- renderPrint({
hover <- input$plot_hover
y <- nearPoints(iris, input$plot_hover)[input$var_y]
req(nrow(y) != 0)
y
})
}
shinyApp(ui = ui, server = server)
可重现的示例 2：无需转换即可工作，但工具提示超出了日志转换的范围
library("shiny")
library("ggplot2")
ui <- pageWithSidebar(
headerPanel("Tooltips in ggplot2 + shiny"),
sidebarPanel(
selectInput("logX", "Log scale",
choices=coordoptions,
selected="identity"),
selectInput("logY", "Log scale",
choices=coordoptions,
selected="identity"),
width = 3
),
mainPanel(
# this is an extra div used ONLY to create positioned ancestor for tooltip
# we don't change its position
div(
style = "position:relative",
plotOutput("scatterplot",
hover = hoverOpts("plot_hover", delay = 100, delayType = "debounce")),
uiOutput("hover_info")
),
width = 7
)
)
server <- function(input, output) {
output$scatterplot <- renderPlot({
ggplot(mtcars, aes(x = mpg, y = hp)) +
geom_point() +
scale_x_continuous(trans=input$logX) +
scale_y_continuous(trans=input$logY)
})
output$hover_info <- renderUI({
hover <- input$plot_hover
point <- nearPoints(mtcars, hover, threshold = 5, maxpoints = 1, addDist = TRUE)
if (nrow(point) == 0) return(NULL)
# calculate point position INSIDE the image as percent of total dimensions
# from left (horizontal) and from top (vertical)
left_pct <- (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left)
top_pct <- (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom)
# calculate distance from left and bottom side of the picture in pixels
left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left)
top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top)
# create style property fot tooltip
# background color is set so tooltip is a bit transparent
# z-index is set so we are sure are tooltip will be on top
style <- paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); ",
"left:", left_px + 2, "px; top:", top_px + 2, "px;")
# actual tooltip created as wellPanel
wellPanel(
style = style,
p(HTML(paste0("<b> Car: </b>", rownames(point), "<br/>",
"<b> mpg: </b>", point$mpg, "<br/>",
"<b> hp: </b>", point$hp, "<br/>",
"<b> Distance from left: </b>", left_px, "<b>, from top: </b>", top_px)))
)
})
}
runApp(list(ui = ui, server = server))
可重现的示例 3：适用于对数刻度并在模块中使用，但 tags$style 不适用于 my_tooltip（不浮动在绘图上）
library(shiny)
library(ggplot2)
AUI<-function(id){
ns<-NS(id)
fluidPage(
selectInput(ns("logX"), "Log scale",
choices=coordoptions,
selected="identity"),
selectInput(ns("logY"), "Log scale",
choices=coordoptions,
selected="identity"),
tags$head(tags$style('
#my_tooltip {
position: absolute;
width: 300px;
z-index: 100;
padding: 0;
}
')),
tags$script('
$(document).ready(function() {
// id of the plot
$("#distPlot").mousemove(function(e) {
// ID of uiOutput
$("#my_tooltip").show();
$("#my_tooltip").css({
top: (e.pageY + 5) + "px",
left: (e.pageX + 5) + "px"
});
});
});
'),
selectInput(ns("var_y"), "Y-Axis", choices = names(iris)),
plotOutput(ns("distPlot"), hover = ns("plot_hover"), hoverDelay = 0),
uiOutput(ns("my_tooltip"))
)
}
A <- function(input, output, session) {
ns<-session$ns
output$distPlot <- renderPlot({
req(input$var_y)
ggplot(iris, aes_string("Sepal.Width", input$var_y)) +
geom_point() +
scale_x_continuous(trans=input$logX) +
scale_y_continuous(trans=input$logY)
})
output$my_tooltip <- renderUI({
hover <- input$plot_hover
y <- nearPoints(iris, input$plot_hover)[input$var_y]
req(nrow(y) != 0)
verbatimTextOutput(ns("vals"))
})
output$vals <- renderPrint({
hover <- input$plot_hover
y <- nearPoints(iris, input$plot_hover)[input$var_y]
req(nrow(y) != 0)
y
})
}
ui<-AUI("id")
server <- function(input, output, session){
callModule(A, "id")
}
shinyApp(ui = ui, server = server)
【问题讨论】：
标签： html shiny hover tooltip modular