Is it possible to add tooltips in a Shiny app to a Sankey plot created with ggalluvial?

Question

I am working on a Shiny app that includes an interactive Sankey diagram. My quandary is this: I prefer the aesthetics of the plots generated with the ggalluvial package (especially the ability to easily color links by some factor), but it does not natively support tooltips where the user can see details about the link or node when they click or hover on it (as in networkd3 or googleVis Sankey diagrams). Plotly does not support geom_alluvium and geom_stratum, so ggplotly() does not appear to be an option in this case.

I have essentially no JavaScript experience, so I apologize if this question is too vague and open-ended. I would like to know what is necessary to enable tooltips on ggalluvial plots in Shiny.

To be more specific, here is some example code for a shiny app with a basic Sankey diagram in it. My desired behavior would be to enable a tooltip to appear when the user hovers (or alternatively clicks) on a link between two nodes that gives some information about the IDs of the flows. For example in the screenshot below, I would like a box with 1,3 in it to appear when the user hovers over the area in upper left indicated with the arrow, and 7,9 when they hover over the arrow in lower left. Those are the values in the ID column that correspond to the flows they are hovering over.

Any guidance on how to do this?

screenshot

Arrows indicate examples of where tooltips should appear.

code

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

Here is an answer to my own question. I am using a slightly modified version of the example data which better illustrates my original intention. In this example data, the rows are grouped so that rows with the same cluster ID and the same trajectory are next to each other.

Another difference from the original question is that for now, I was only able to extract the coordinates of the flow polygons from ggalluvial if the argument knot.pos = 0 is set, resulting in straight lines instead of the smooth curves constructed from splines.

However, I was able to get the tooltips to give the correct behavior. In this test app, when the user hovers over an alluvium (flow polygon), a tooltip showing the flows appears. When the user hovers over a stratum (node), a tooltip showing its name and the number of flows going through it appears.

The tooltip code was modified from this GitHub issue on shiny. Also note I use an unexported function, ggalluvial:::data_to_xspline.

Screenshots

Hovering over an alluvium

Hovering over a stratum

Code

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)

Additional explanation

This takes advantage of the built-in plot interaction in Shiny. By adding the argument hover = hoverOpts(id = "plot_hover") to plotOutput(), the input object now includes the coordinates of the hovering mouse in units of plot coordinates, making it very easy to locate where on the plot the mouse is.

The server function draws the ggalluvial plot and then manually recreates the boundaries of the polygons representing the alluvia. This is done by building the ggplot2 object and extracting the data element from it, then passing that to the unexported function from the ggalluvial source code (data_to_xspline). Next there is logic that detects whether the mouse is hovering over a node or a link, or neither. The nodes are easy since they are rectangles but whether the mouse is over a link is detected using sp::point.in.polygon(). If the mouse is over a link, all the row IDs from the input dataframe that match the characteristics of the selected link are extracted. Finally the tooltip is rendered with the function htmltools::renderTags().