nested-chord-diagram.R

# https://jokergoo.github.io/2020/06/08/multiple-group-chord-diagram/
library(circlize)
library(tidyverse)

choices <- tribble(
  ~A, ~B, ~C, ~D, ~E, ~F,
  NA,  2, NA,  3,  1, NA,
  NA,  1,  3, NA, NA,  2,
  NA,  1,  2, NA, NA,  3,
  NA,  2, NA,  3,  1, NA,
  NA,  2,  1, NA,  3, NA,
   1, NA,  2, NA,  3, NA,
  NA,  1,  2, NA,  3, NA,
   3, NA, NA, NA,  2,  1,
   3, NA,  2, NA,  1, NA,
  NA,  1,  2, NA, NA,  3,
  NA,  1,  2, NA, NA,  3,
  NA,  3, NA,  1,  2, NA,
   2, NA, NA,  1,  3, NA,
  NA, NA,  2, NA,  1,  3,
  NA,  3, NA,  1,  2, NA,
  NA,  3, NA,  1,  2, NA
)

choices_mat <- choices |>
  # Prepend colnames to values
  map2_dfc(names(choices), \(x, y) ifelse(is.na(x), x, paste0(y, x))) |>
  as.matrix()

# Co-occurence matrix
cooc_mat <- rep(seq_len(nrow(choices_mat)), ncol(choices_mat)) |>
  table(choices_mat) |>
  crossprod()

# Project choice frequencies for ordering sectors in diagram
proj_order <- choices |>
  map_int(\(x) sum(!is.na(x))) |>
  enframe("project", "n") |>
  arrange(-n) |>
  pull(project)

# Order coop_mat rows by rank and frequency
choices_order <- colnames(cooc_mat) |>
  enframe(name = NULL, value = "choice") |>
  transmute(
    project = str_sub(choice, end = -2),
    rank = str_sub(choice, start = -1)
  ) |>
  # Order by frequency
  left_join(x = tibble(project = proj_order), by = "project") |>
  arrange(rank) |>
  transmute(choice = paste0(project, rank)) |>
  pull() |>
  rev()

cooc_mat <- cooc_mat[match(choices_order, rownames(cooc_mat)),
                     match(choices_order, colnames(cooc_mat))]

# Reduce to triangular matrix
cooc_mat[upper.tri(cooc_mat, diag = TRUE)] <- 0

# Grouping variable for chord diagram
subgroups <- choices_order |>
  sort() |>
  set_names() |>
  gsub(pattern = "\\d$", replacement = "") |>
  factor(levels = proj_order)

# Colouring variable
grid.col <- (as.integer(as.factor(subgroups)) + 1) |>
  set_names(names(subgroups))

circos.clear()

chordDiagram(
  cooc_mat,
  group = subgroups,
  grid.col = grid.col,
  annotationTrack = "grid",
  preAllocateTracks = list(
    track.height = mm_h(4)
  ),
  transparency = .3
)

# Label ranked choices
circos.track(track.index = 2, panel.fun = \(x, y) {
  sector.index <- get.cell.meta.data("sector.index") |>
    str_subset("\\d$")
  xlim <- get.cell.meta.data("xlim")
  ylim <- get.cell.meta.data("ylim")
  circos.text(
    mean(xlim), mean(ylim),
    str_sub(sector.index, start = -1),
    col = "white",
    cex = .9,
    family = "Oswald",
    font = 2
  )
}, bg.border = NA)

# Label projects
walk(proj_order, \(x) {
  highlight.sector(
    names(subgroups[subgroups == x]),
    track.index = 1,
    col = "white",
    text = x,
    text.col = "grey15",
    cex = 1.2,
    family = "Oswald"
  )
})