是否可以将 Shiny 应用程序中的工具提示添加到使用 ggalluvial 创建的 Sankey 图中？

Posted 2023-02-16

【中文标题】是否可以将 Shiny 应用程序中的工具提示添加到使用 ggalluvial 创建的 Sankey 图中？

【英文标题】：Is it possible to add tooltips in a Shiny app to a Sankey plot created with ggalluvial?

【发布时间】：2021-02-05 11:26:33

【问题描述】：

我正在开发一个包含交互式桑基图的 Shiny 应用程序。我的困惑是：我更喜欢使用 ggalluvial 包生成的图的美感（尤其是通过某些因素轻松为链接着色的能力），但它本身不支持工具提示，用户可以在其中看到有关链接或节点的详细信息。单击或悬停在其上（如 networkd3 或 googleVis Sankey 图）。 Plotly 不支持 geom_alluvium 和 geom_stratum，因此在这种情况下 ggplotly() 似乎不是一个选项。

我基本上没有 javascript 经验，所以如果这个问题过于模糊和开放，我深表歉意。我想知道在 Shiny 的 ggalluvial 图上启用工具提示需要什么。

更具体地说，这里是一个闪亮的应用程序的一些示例代码，其中包含一个基本的桑基图。我想要的行为是在用户悬停（或单击）两个节点之间的链接时启用工具提示，该链接提供有关流 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)

【问题讨论】：

您了解过这些解决方案吗？ ***.com/questions/27965931/… 和 ebailey78.github.io/shinyBS/docs/Tooltips_and_Popovers.html 也许这是为您定制的

这些解决方案中的任何一个都可能适用于我的情况，但我仍然希望在实施它们时获得一些指导。我不确定从哪里开始

我已经根据此问题中的代码在这方面取得了一些进展：github.com/rstudio/shiny/issues/2239 和@starja 发布的问题中的答案：***.com/a/31099437/2854608。希望我很快就会在这里发布答案

【参考方案1】：

这是我自己的问题的答案。我使用的是示例数据的略微修改版本，它更好地说明了我的初衷。在此示例数据中，对行进行了分组，以便具有相同集群 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 中内置的情节交互。通过将参数hover = hoverOpts(id = "plot_hover") 添加到plotOutput()，input 对象现在包含悬停鼠标的坐标以绘图坐标为单位，从而可以很容易地定位鼠标在绘图上的位置是。

服务器函数绘制 ggalluvial 图，然后手动重新创建代表冲积层的多边形的边界。这是通过构建 ggplot2 对象并从中提取 data 元素，然后将其从 ggalluvial 源代码 (data_to_xspline) 传递给未导出的函数来完成的。接下来是检测鼠标是否悬停在节点或链接上的逻辑，或者两者都没有。节点很简单，因为它们是矩形，但是使用sp::point.in.polygon() 检测鼠标是否在链接上。如果鼠标悬停在链接上，则从输入数据框中提取与所选链接的特征匹配的所有行 ID。最后使用htmltools::renderTags()函数渲染工具提示。

【讨论】：

这很整洁。一个限制（当我重现应用程序时）是悬停在重叠流或冲积层上只会显示与（我假设）最后呈现的元素相关联的文本。例如，是否有可能在最多三个元素重叠时显示连接文本，否则会显示“重叠过多”消息？

嗨@CoryBrunson 感谢您的浏览。我故意将其设置为显示最后在悬停时呈现的元素。如果您查看第 134 行，会检测到与鼠标光标重叠的所有多边形，然后在第 137 行提取最上面的多边形的 ID。因此您只需修改该位。

对脚本做了一个小修改，所以现在上面注释中的行是 135 和 138