是否可以將 Shiny 應用程序中的工具提示添加到使用 ggalluvial 創建的 Sankey 圖中？

Question

我正在開發一個包含交互式桑基圖的 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)

Answer 1

這是我自己的問題的答案。 我正在使用示例數據的稍微修改版本，它更好地說明了我的初衷。 在此示例數據中，行被分組以便具有相同集群 ID 和相同軌跡的行彼此相鄰。

與原始問題的另一個不同之處在於，目前，如果設置了參數knot.pos = 0 ，我只能從ggalluvial提取流多邊形的坐標，從而導致直線而不是由樣條構造的平滑曲線。

但是，我能夠獲得工具提示以提供正確的行為。 在這個測試應用程序中，當用戶將鼠標懸停在沖積層（流動多邊形）上時，會出現一個顯示流動的工具提示。 當用戶將鼠標懸停在層（節點）上時，會出現一個顯示其名稱和流經它的流數的工具提示。

工具提示代碼是從這個 GitHub 問題在 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()呈現工具提示。