这是我自己的问题的答案。我使用的是示例数据的略微修改版本，它更好地说明了我的初衷。在此示例数据中，对行进行分组，以便具有相同集群 ID 和相同轨迹的行彼此相邻。
ggalluvial与原始问题的另一个区别是，目前，如果设置了参数，我只能从中提取流多边形的坐标knot.pos = 0，从而得到直线而不是由样条构造的平滑曲线。
但是，我能够获得工具提示以提供正确的行为。在这个测试应用程序中，当用户将鼠标悬停在冲积层（流多边形）上时，会出现一个显示流的工具提示。当用户将鼠标悬停在层（节点）上时，会出现一个工具提示，显示其名称和通过它的流数。
工具提示代码是从闪亮的这个 GitHub 问题中修改的。另请注意，我使用未导出的函数ggalluvial:::data_to_xspline.
截图
悬停在冲积层上
悬停在地层上
代码
library(tidyverse)
library(ggalluvial)
library(shiny)
library(sp)
library(htmltools)
### Function definitions
### ====================
# Slightly modified version of a function from ggalluvial
# Creates polygon coordinates from subset of built ggplot data
draw_by_group <- function(dat) {
first_row <- dat[1, setdiff(names(dat),
c("x", "xmin", "xmax",
"width", "knot.pos",
"y", "ymin", "ymax")),
drop = FALSE]
rownames(first_row) <- NULL
curve_data <- ggalluvial:::data_to_xspline(dat, knot.prop = TRUE)
data.frame(first_row, curve_data)
}
### Data
### ====
example_data <- data.frame(weight = rep(1, 12),
ID = 1:12,
cluster = c(rep(c(1,2), 5),2,2),
grp1 = rep(c('1a','1b'), c(6,6)),
grp2 = rep(c('2a','2b','2a'), c(3,4,5)),
grp3 = rep(c('3a','3b'), c(5,7)))
example_data <- example_data[order(example_data$cluster), ]
offset <- 5 # Maybe needed so that the tooltip doesn't disappear?
### UI function
### ===========
ui <- fluidPage(
titlePanel("Shiny ggalluvial reprex"),
fluidRow(tags$div(
style = "position: relative;",
plotOutput("sankey_plot", height = "800px",
hover = hoverOpts(id = "plot_hover")),
htmlOutput("tooltip")))
)
### Server function
### ===============
server <- function(input, output, session) {
# Make and build plot.
p <- ggplot(example_data, aes(y = weight, axis1 = grp1, axis2 = grp2, axis3 = grp3)) +
geom_alluvium(aes(fill = factor(cluster)), knot.pos = 0) + # color for connections
geom_stratum(width = 1/8, reverse = TRUE) + # plot the boxes over the connections
geom_text(aes(label = after_stat(stratum)),
stat = "stratum",
reverse = TRUE,
size = rel(1.5)) + # plot the text
theme_bw() # black and white theme
pbuilt <- ggplot_build(p)
# Use built plot data to calculate the locations of the flow polygons
data_draw <- transform(pbuilt$data[[1]], width = 1/3)
groups_to_draw <- split(data_draw, data_draw$group)
polygon_coords <- lapply(groups_to_draw, draw_by_group)
output$sankey_plot <- renderPlot(p, res = 200)
output$tooltip <- renderText(
if(!is.null(input$plot_hover)) {
hover <- input$plot_hover
x_coord <- round(hover$x)
if(abs(hover$x - x_coord) < 1/16) {
# Display node information if mouse is over a node "box"
box_labels <- c('grp1', 'grp2', 'grp3')
# Determine stratum (node) name from x and y coord, and the n.
node_row <- pbuilt$data[[2]]$x == x_coord & hover$y > pbuilt$data[[2]]$ymin & hover$y < pbuilt$data[[2]]$ymax
node_label <- pbuilt$data[[2]]$stratum[node_row]
node_n <- pbuilt$data[[2]]$n[node_row]
renderTags(
tags$div(
"Category:", box_labels[x_coord], tags$br(),
"Node:", node_label, tags$br(),
"n =", node_n,
style = paste0(
"position: absolute; ",
"top: ", hover$coords_css$y + offset, "px; ",
"left: ", hover$coords_css$x + offset, "px; ",
"background: gray; ",
"padding: 3px; ",
"color: white; "
)
)
)$html
} else {
# Display flow information if mouse is over a flow polygon: what alluvia does it pass through?
# Calculate whether coordinates of hovering mouse are inside one of the polygons.
hover_within_flow <- sapply(polygon_coords, function(pol) point.in.polygon(point.x = hover$x, point.y = hover$y, pol.x = pol$x, pol.y = pol$y))
if (any(hover_within_flow)) {
# Find the alluvium that is plotted on top. (last)
coord_id <- rev(which(hover_within_flow == 1))[1]
# Get the corresponding row ID from the main data frame
flow_id <- example_data$ID[coord_id]
# Get the subset of data frame that has all the characteristics matching that alluvium
data_row <- example_data[example_data$ID == flow_id, c('cluster', 'grp1', 'grp2', 'grp3')]
IDs_show <- example_data$ID[apply(example_data[, c('cluster', 'grp1', 'grp2', 'grp3')], 1, function(x) all(x == data_row))]
renderTags(
tags$div(
"Flows:", paste(IDs_show, collapse = ','),
style = paste0(
"position: absolute; ",
"top: ", hover$coords_css$y + offset, "px; ",
"left: ", hover$coords_css$x + offset, "px; ",
"background: gray; ",
"padding: 3px; ",
"color: white; "
)
)
)$html
}
}
}
)
}
shinyApp(ui = ui, server = server)
附加说明
这利用了 Shiny 中内置的情节交互。通过将参数添加hover = hoverOpts(id = "plot_hover")到plotOutput()，对象现在包括以绘图坐标为单位input的悬停鼠标的坐标，从而可以很容易地定位鼠标在绘图上的位置。
服务器函数绘制 ggalluvial 图，然后手动重新创建代表冲积层的多边形的边界。这是通过构建 ggplot2 对象并从中提取元素，然后将其从源代码 ( )data传递给未导出的函数来完成的。接下来是检测鼠标是否悬停在节点或链接上的逻辑，或者两者都没有。节点很简单，因为它们是矩形，但鼠标是否在链接上可以使用. 如果鼠标悬停在链接上，则从输入数据框中提取与所选链接的特征匹配的所有行 ID。最后，工具提示使用函数呈现。ggalluvialdata_to_xsplinesp::point.in.polygon()htmltools::renderTags()
