是否可以将 Shiny 应用程序中的工具提示添加到使用 ggalluvial 创建的 Sankey 图？
Is it possible to add tooltips in a Shiny app to a Sankey plot created with ggalluvial?
我正在开发一个包含交互式 Sankey 图的 Shiny 应用程序。我的窘境是：我更喜欢用 ggalluvial 包生成的图的美感（尤其是通过某些因素轻松着色 links 的能力），但它本身不支持用户可以看到详细信息的工具提示link 或节点，当他们点击或悬停在它上面时（如 networkd3 或 googleVis Sankey 图表）。 Plotly 不支持 geom_alluvium 和 geom_stratum，因此在这种情况下 ggplotly() 似乎不是一个选项。
我基本上没有 JavaScript 经验，所以如果这个问题过于模糊和开放式，我深表歉意。我想知道在 Shiny 的 ggalluvial 地块上启用工具提示需要什么。
更具体地说，这是一个闪亮的应用程序的一些示例代码，其中包含一个基本的 Sankey 图。我想要的行为是当用户将鼠标悬停（或单击）在两个节点之间的 link 上时显示工具提示，以提供有关流 ID 的一些信息。例如在下面的屏幕截图中，我希望当用户将鼠标悬停在左上角用箭头指示的区域上时出现一个带有 1,3 的框，当他们将鼠标悬停在箭头上时显示 7,9左下方。这些是 ID 列中的值，它们对应于他们悬停的流。
关于如何执行此操作的任何指导？
截图
箭头指示工具提示应出现的位置示例。
代码
library(shiny)
library(ggplot2)
library(ggalluvial)
### Data
example_data <- data.frame(weight = rep(1, 10),
ID = 1:10,
cluster = rep(c(1,2), 5),
grp1 = rep(c('1a','1b'), c(6,4)),
grp2 = rep(c('2a','2b','2a'), c(3,4,3)),
grp3 = rep(c('3a','3b'), c(5,5)))
# weight ID cluster grp1 grp2 grp3
# 1 1 1 1 1a 2a 3a
# 2 1 2 2 1a 2a 3a
# 3 1 3 1 1a 2a 3a
# 4 1 4 2 1a 2b 3a
# 5 1 5 1 1a 2b 3a
# 6 1 6 2 1a 2b 3b
# 7 1 7 1 1b 2b 3b
# 8 1 8 2 1b 2a 3b
# 9 1 9 1 1b 2a 3b
# 10 1 10 2 1b 2a 3b
### UI
ui <- fluidPage(
titlePanel("Shiny ggalluvial reprex"),
fluidRow(plotOutput("sankey_plot", height = "800px"))
)
### Server
server <- function(input, output) {
output$sankey_plot <- renderPlot({
ggplot(example_data, aes(y = weight, axis1 = grp1, axis2 = grp2, axis3 = grp3)) +
geom_alluvium(aes(fill = factor(cluster))) + # color for connections
geom_stratum(width = 1/8, reverse = TRUE, show.legend = FALSE) + # 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
}, res = 200)
}
shinyApp(ui = ui, server = server)
这是对我自己的问题的回答。我正在使用示例数据的稍微修改版本，它更好地说明了我的初衷。在这个示例数据中，行被分组，使得具有相同簇 ID 和相同轨迹的行彼此相邻。
与原始问题的另一个区别是，目前，如果设置了参数 knot.pos = 0，我只能从 ggalluvial 中提取流动多边形的坐标，从而得到直线由样条构成的平滑曲线。
但是，我能够获得工具提示以提供正确的行为。在此测试应用程序中，当用户将鼠标悬停在冲积层（流动多边形）上时，会出现一个显示流动的工具提示。当用户将鼠标悬停在层（节点）上时，会出现一个工具提示，显示其名称和通过它的流数。
工具提示代码修改自 this GitHub issue on shiny。另请注意，我使用了未导出的函数 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 中的 built-in 情节互动。通过将参数 hover = hoverOpts(id = "plot_hover") 添加到 plotOutput()，input 对象现在包含悬停鼠标的坐标 ，以绘图坐标 为单位，使其非常很容易找到鼠标在图上的位置。
服务器函数绘制 ggalluvial 图，然后手动重新创建代表冲积层的多边形边界。这是通过构建 ggplot2 对象并从中提取 data 元素，然后将其传递给来自 ggalluvial 源代码 (data_to_xspline) 的未导出函数来完成的。接下来是检测鼠标是否悬停在节点或 link 上或两者都不是的逻辑。这些节点很简单，因为它们是矩形，但是使用 sp::point.in.polygon() 检测鼠标是否在 link 上。如果鼠标悬停在 link 上，则提取输入数据框中与所选 link 的特征匹配的所有行 ID。最后使用函数 htmltools::renderTags().
呈现工具提示
我正在开发一个包含交互式 Sankey 图的 Shiny 应用程序。我的窘境是：我更喜欢用 ggalluvial 包生成的图的美感（尤其是通过某些因素轻松着色 links 的能力），但它本身不支持用户可以看到详细信息的工具提示link 或节点，当他们点击或悬停在它上面时（如 networkd3 或 googleVis Sankey 图表）。 Plotly 不支持 geom_alluvium 和 geom_stratum，因此在这种情况下 ggplotly() 似乎不是一个选项。
我基本上没有 JavaScript 经验，所以如果这个问题过于模糊和开放式，我深表歉意。我想知道在 Shiny 的 ggalluvial 地块上启用工具提示需要什么。
更具体地说，这是一个闪亮的应用程序的一些示例代码，其中包含一个基本的 Sankey 图。我想要的行为是当用户将鼠标悬停（或单击）在两个节点之间的 link 上时显示工具提示，以提供有关流 ID 的一些信息。例如在下面的屏幕截图中，我希望当用户将鼠标悬停在左上角用箭头指示的区域上时出现一个带有 1,3 的框，当他们将鼠标悬停在箭头上时显示 7,9左下方。这些是 ID 列中的值，它们对应于他们悬停的流。
关于如何执行此操作的任何指导？
截图
箭头指示工具提示应出现的位置示例。
代码
library(shiny)
library(ggplot2)
library(ggalluvial)
### Data
example_data <- data.frame(weight = rep(1, 10),
ID = 1:10,
cluster = rep(c(1,2), 5),
grp1 = rep(c('1a','1b'), c(6,4)),
grp2 = rep(c('2a','2b','2a'), c(3,4,3)),
grp3 = rep(c('3a','3b'), c(5,5)))
# weight ID cluster grp1 grp2 grp3
# 1 1 1 1 1a 2a 3a
# 2 1 2 2 1a 2a 3a
# 3 1 3 1 1a 2a 3a
# 4 1 4 2 1a 2b 3a
# 5 1 5 1 1a 2b 3a
# 6 1 6 2 1a 2b 3b
# 7 1 7 1 1b 2b 3b
# 8 1 8 2 1b 2a 3b
# 9 1 9 1 1b 2a 3b
# 10 1 10 2 1b 2a 3b
### UI
ui <- fluidPage(
titlePanel("Shiny ggalluvial reprex"),
fluidRow(plotOutput("sankey_plot", height = "800px"))
)
### Server
server <- function(input, output) {
output$sankey_plot <- renderPlot({
ggplot(example_data, aes(y = weight, axis1 = grp1, axis2 = grp2, axis3 = grp3)) +
geom_alluvium(aes(fill = factor(cluster))) + # color for connections
geom_stratum(width = 1/8, reverse = TRUE, show.legend = FALSE) + # 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
}, res = 200)
}
shinyApp(ui = ui, server = server)
这是对我自己的问题的回答。我正在使用示例数据的稍微修改版本，它更好地说明了我的初衷。在这个示例数据中，行被分组，使得具有相同簇 ID 和相同轨迹的行彼此相邻。
与原始问题的另一个区别是，目前，如果设置了参数 knot.pos = 0，我只能从 ggalluvial 中提取流动多边形的坐标，从而得到直线由样条构成的平滑曲线。
但是，我能够获得工具提示以提供正确的行为。在此测试应用程序中，当用户将鼠标悬停在冲积层（流动多边形）上时，会出现一个显示流动的工具提示。当用户将鼠标悬停在层（节点）上时，会出现一个工具提示，显示其名称和通过它的流数。
工具提示代码修改自 this GitHub issue on shiny。另请注意，我使用了未导出的函数 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 中的 built-in 情节互动。通过将参数 hover = hoverOpts(id = "plot_hover") 添加到 plotOutput()，input 对象现在包含悬停鼠标的坐标 ，以绘图坐标 为单位，使其非常很容易找到鼠标在图上的位置。
服务器函数绘制 ggalluvial 图，然后手动重新创建代表冲积层的多边形边界。这是通过构建 ggplot2 对象并从中提取 data 元素，然后将其传递给来自 ggalluvial 源代码 (data_to_xspline) 的未导出函数来完成的。接下来是检测鼠标是否悬停在节点或 link 上或两者都不是的逻辑。这些节点很简单，因为它们是矩形，但是使用 sp::point.in.polygon() 检测鼠标是否在 link 上。如果鼠标悬停在 link 上，则提取输入数据框中与所选 link 的特征匹配的所有行 ID。最后使用函数 htmltools::renderTags().