Sankey Charts for treatment transition

Charts using ggplot2 package

Load required libraries

library(tidyverse)
library(ggalluvial)
library(dplyr)
library(tidyr)
library(forcats)
library(writexl)
library(plotly)
library(readxl)
library(extrafont)
library(RColorBrewer)

Load data

Sankey_data <- read_excel("D:/Part_time_CECAREUS/Trial graphs/Data/Data for KM Curve.xlsx", sheet = "Sankey")

Data Preparation

#pivoting the data
Sankey_data_pivot <- Sankey_data %>% group_by(`1st Treatment`, `2nd Treatment`, `3rd Treatment`)%>% summarise(n = n())
colnames(Sankey_data_pivot)[4] <- "number"

# Load the fonts into R
loadfonts(device = "win")

# Choose a color palette; here we use RColorBrewer for a palette similar to your example
color_palette <- brewer.pal("Paired", n = min(length(unique(Sankey_data$`1st Treatment`)), 12))
full_palette <- adjustcolor(color_palette, alpha.f = 0.8)
# Defining color palettes
num_treatments <- length(unique(Sankey_data$`1st Treatment`))
color_palette <- brewer.pal("Paired", n = min(num_treatments, 12))
full_palette <- rep(color_palette, length.out = num_treatments)

Create the chart

# Create the Sankey plot with adjusted block widths and opaque colors
ggplot(Sankey_data_pivot, aes(axis1 = `1st Treatment`, axis2 = `2nd Treatment`, axis3 = `3rd Treatment`, weight = number)) +
  geom_alluvium(aes(fill = `1st Treatment`), width = 1/5) +  # Adjust to visually approximate 2 cm
  geom_stratum(width = 1/15, aes(fill = `1st Treatment`)) +   # Adjust to visually approximate 2 cm
  geom_text(stat = "stratum", aes(label = after_stat(stratum)), size = 3, color = "black", family = "Times New Roman", fontface='bold') +
  scale_fill_manual(values = rep(full_palette)) +
  theme_void() +
  theme(text = element_text(family = "Times New Roman", size = 8),
        axis.text.x = element_blank(),
        axis.ticks.x = element_blank(),
        axis.title.x = element_blank(),
        legend.position = "none")

$Alluvial plot on ggplot$

Alluvial plot on ggplot

Using NetworkD3 Package

library(networkD3)
data <- read_excel("D:/Part_time_CECAREUS/Trial graphs/Data/Data for KM Curve.xlsx", sheet = "Sankey")
colnames(data) <- c("Patient_ID" ,"First_Treatment", "Second_Treatment", "Third_Treatment")

Preparing links table

transition_1to2_link <- data %>% group_by(First_Treatment, Second_Treatment)%>% summarise(number = n())
transition_2to3_link <- data %>% group_by(Second_Treatment, Third_Treatment)%>% summarise(number = n())
colnames(transition_1to2_link) <- c("Source", "Target", "Value")
colnames(transition_2to3_link) <- c("Source", "Target", "Value")
all_link <- rbind(transition_1to2_link, transition_2to3_link)
links_network <- data.frame(
  source= c(all_link$Source), 
  target= c(all_link$Target),
  value= c(all_link$Value))

Preparing nodes table

nodes <-
  links_network %>% 
  pivot_longer(c(source, target), names_to = NULL, values_to = "name") %>% 
  summarise(value = sum(value), .by = name) %>% 
  arrange(desc(value))
nodes <- as.data.frame(nodes)

links_network$source_id <- match(links_network$source, nodes$name) - 1
links_network$target_id <- match(links_network$target, nodes$name) - 1

# Apply colors to Nodes and Links based on a property 
nodes$group <- as.factor(nodes$name)
links_network$group <- as.factor(links_network$source)
# Define a color palette with a sufficient number of colors
num_groups <- length(unique(nodes$group))

# Generate a color palette that has enough unique colors
node_colors <- colorRampPalette(brewer.pal(min(num_groups, 12), "Paired"))(num_groups)

# Assign colors to nodes based on their group
nodes$color <- node_colors[as.integer(as.factor(nodes$group))]

# Define a color palette for links, repeated if necessary
num_links <- length(unique(links_network$source)) # Replace 'group' with the actual grouping column
link_colors <- colorRampPalette(RColorBrewer::brewer.pal(min(8, num_links), "Dark2"))(num_links)
# Assign colors to links by their group
links_network$color <- setNames(link_colors, unique(links_network$group))[links_network$group]

Plot the chart and enhancing aesthetics

sn <- sankeyNetwork(
  Links = links_network, 
  Nodes = nodes,
  Source = "source_id",
  Target = "target_id",
  Value = "value",
  NodeID = "name",
  fontSize = 12, # Increase font size for better visibility
  NodeGroup = "color", # This should match a property in your nodes
  LinkGroup = "color", # This should match a property in your links
  nodeWidth = 30,# Adjust width of nodes
  units = n,
  iterations = 0
)
sn <- htmlwidgets::onRender(
  sn,
  'function(el) { d3.selectAll(".node text").style("font-weight", "bold"); }
  '
)
# JavaScript code to enhance hover interaction
customJS <- "
function(el, x) {
  // Function to handle mouseover on the links
  function mouseoverLink(d) {
    // Define what information to display
    var info = 'Value: ' + d.value + '<br>' +
               'Source: ' + d.source.name + '<br>' +
               'Target: ' + d.target.name;
    // Show the tooltip with the information
    d3.select('#sankey-tooltip')
      .html(info)
      .style('opacity', 0.9)
      .style('left', (d3.event.pageX) + 'px')
      .style('top', (d3.event.pageY - 28) + 'px');
    
    // Make the font bold for the link
    d3.select(this).style('font-weight', 'bold');
  }
  
  // Function to handle mouseout on the links
  function mouseoutLink() {
    // Hide the tooltip
    d3.select('#sankey-tooltip')
      .style('opacity', 0);
    
    // Revert the font weight back to normal for the link
    d3.select(this).style('font-weight', 'normal');
  }
  
  // Create a tooltip div
  var tooltip = d3.select(el).append('div')
      .attr('id', 'sankey-tooltip')
      .style('position', 'absolute')
      .style('text-align', 'center')
      .style('width', '120px')
      .style('height', '50px')
      .style('padding', '2px')
      .style('font', '12px sans-serif')
      .style('background', 'lightsteelblue')
      .style('border', '0px')
      .style('border-radius', '8px')
      .style('pointer-events', 'none')
      .style('opacity', 0);
  
  // Attach the mouseover and mouseout event listeners to the links
  d3.selectAll('.link')
    .on('mouseover', mouseoverLink)
    .on('mouseout', mouseoutLink);

  // Make the font bold for all node and link texts
  d3.selectAll('.node text')
    .style('font-weight', 'bold');
  d3.selectAll('.link text')
    .style('font-weight', 'bold');
}
"
sn <- htmlwidgets::onRender(sn, customJS)
sn

Sankey on NetworkD3

Using Plotly Package

Data Preparation

#defining links dataset
get_links <- function(df, source_col, target_col) {
  df %>%
    count(!!sym(source_col), !!sym(target_col)) %>%
    filter(!is.na(!!sym(source_col)) & !is.na(!!sym(target_col))) %>%
    rename(Source = !!sym(source_col), Target = !!sym(target_col), Value = n)
}

#creating links and nodes datasets
links <- bind_rows(
  get_links(data, 'First_Treatment', 'Second_Treatment'),
  get_links(data, 'Second_Treatment', 'Third_Treatment')
  # Add more lines if there are more treatment columns
)
# Extract unique node names
nodes <- data_frame(name = unique(c(links$Source, links$Target))) %>%
  mutate(ID = row_number() - 1)

# Convert node names in links to IDs
links <- links %>%
  left_join(nodes, by = c("Source" = "name")) %>%
  rename(Source_ID = ID) %>%
  select(-Source) %>%
  left_join(nodes, by = c("Target" = "name")) %>%
  rename(Target_ID = ID) %>%
  select(-Target)

Plotting the chart

plot_ly(
  type = 'sankey',
  domain = list(
    x = c(0,1),
    y = c(0,1)
  ),
  orientation = "h",
  valueformat = ".0f",
  valuesuffix = "Patients",
  
  node = list(
    label = nodes$name,
    pad = 15,
    thickness = 20,
    line = list(
      color = "black",
      width = 0.5
    )
  ),
  
  link = list(
    source = links$Source_ID,
    target = links$Target_ID,
    value = links$Value
  )
)

Sankey on Plotly

Using Highcharter Package

library(highcharter)

Data Preparation and plotting the chart

data_highcarter <- data[,-1]
hchart(data_to_sankey(data_highcarter), "sankey", name = "Treatment Transitions")

Sankey on Highcharter

Using FlipPlots Package

library(flipPlots)

colnames(Sankey_data_pivot) <- c("Source", "Target", "Destination", "number")
Sankey_data_pivot$Source <- as.factor(Sankey_data_pivot$Source)
Sankey_data_pivot$Target <- as.factor(Sankey_data_pivot$Target)
Sankey_data_pivot$Destination <- as.factor(Sankey_data_pivot$Destination)

SankeyDiagram(Sankey_data_pivot[, -4],
              link.color = "Source", 
              weights = Sankey_data_pivot$number)