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

如何解决是否可以在Shiny应用程序中将工具提示添加到由ggalluvial创建的Sankey图中？

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

我基本上没有JavaScript经验，因此对于这个问题过于模糊和开放性，我深表歉意。我想知道在Shiny的冲积积图中启用工具提示的必要条件。

更具体地说，这是其中包含基本Sankey图的闪亮应用程序的一些示例代码。我期望的行为是当用户在两个节点之间的链接上悬停（或单击）时提供工具提示，从而提供有关流ID的一些信息。例如，在下面的屏幕截图中，当用户将鼠标悬停在箭头指示的左上方区域时，我希望其中出现一个1,3的框，而当用户将鼠标悬停在箭头左下。这些是7,9列中的值，它们与它们所徘徊的流相对应。

有关如何执行此操作的任何指导？

屏幕截图

箭头指示应在何处显示工具提示。

代码

ID

解决方法

这是我自己的问题的答案。我正在使用示例数据的略微修改版本，以更好地说明我的初衷。在此示例数据中，对行进行了分组，以使具有相同群集ID和相同轨迹的行彼此相邻。

与原始问题的另一个不同之处在于，到目前为止，如果设置了参数ggalluvial，我只能从knot.pos = 0提取流多边形的坐标，从而得到直线而不是由样条曲线构建的平滑曲线。

但是，我能够获得提示以给出正确的行为。在此测试应用中，当用户将鼠标悬停在冲积层（流动多边形）上时，将显示一个显示流动的工具提示。当用户将鼠标悬停在一个层（节点）上时，将显示一个工具提示，其中显示了其名称以及流经该节点的流量数量。

工具提示代码已从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,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,"n =",node_n,style = paste0(
              "position: absolute; ","top: ",hover$coords_css$y + offset,"px; ","left: ",hover$coords_css$x + offset,"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','grp3')]
          IDs_show <- example_data$ID[apply(example_data[,'grp3')],1,function(x) all(x == data_row))]
          
          renderTags(
            tags$div(
              "Flows:",paste(IDs_show,collapse = ','),style = paste0(
                "position: absolute; ","color: white; "
              )
            )
          )$html
        }
      }
    }
  )

}

shinyApp(ui = ui,server = server)

其他说明

这利用了Shiny中的内置绘图交互功能。通过将参数hover = hoverOpts(id = "plot_hover")添加到plotOutput()，input对象现在包括了以绘图坐标为单位的悬停鼠标的坐标，这使得定位非常容易鼠标在情节上的位置。

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