Click on the image to zoom. Then click your browser back button to return to reading the post.

Introduction

Chord diagrams are an elegant way to represent inter-relationships between variables. I recently found myself wanting to visualize something like this using Mathematica, and after searching high and low for built-in capabilities/ stack-exchange answers*, I decided to code one up. Hopefully this will be useful to someone else in the future!

Getting the Data

A simple way to get a dataset to visualize in the required format, is to use the WeightedAdjacencyMatrix of an (edge-)weighted graph from ExampleData. I used the "EurovisionVotes" dataset, not least because it's dear to my heart, but also because it has a manageable number of vertices and adjacency matrix density (for aesthetic reasons which will become apparent later).

ExampleData[{"NetworkGraph", "EurovisionVotes"}, "LongDescription"]

Eurovision Song Contest voting network. An edge from s to t means that the country s has given 10 or more points to a song by t. The number of occasions is stored in the EdgeWeight edge property.

In-fact, for the same aesthetic reasons, I trimmed the dataset slightly by dropping weak dependencies (edge weights less than 3), and re-ordered the vertices based on their VertexDegree:

eurovisionGraph = 
 ExampleData[{"NetworkGraph", "EurovisionVotes"}, "FullGraph"]
trimmedGraph = 
  Block[{g = eurovisionGraph, 
    ones = Position[
      WeightedAdjacencyMatrix[eurovisionGraph]["NonzeroValues"], 
      a_ /; a < 3]},
   Graph[VertexList[g], Delete[EdgeList[g], ones], 
    EdgeWeight -> 
     Delete[WeightedAdjacencyMatrix[g]["NonzeroValues"], ones]]];
orderedGraph = 
  Block[{g = trimmedGraph, 
    zeros = Length[Cases[VertexDegree[trimmedGraph], 0]]}, 
   Graph[Drop[VertexList[g][[Ordering[VertexDegree[g]]]], zeros], 
    EdgeList[g], 
    EdgeWeight -> WeightedAdjacencyMatrix[g]["NonzeroValues"]]];

Poincare Arcs

The hardest (and most elegant) part of the visualization is making the asymmetric ribbon to connect two nodes. After playing around with Bezier curves for a bit, I eventually settled on using Poincare arcs, code shamelessly adapted by the excellent Mathworld Article (relevant part reproduced below):

poincareArc[l0_List] := Module[{l = Sort[l0], dt, t, t1, t2, r, R, c},
  dt = Abs[l[[1]] - l[[2]]];
  If[dt > \[Pi], l = Sort[l + {0, -2 \[Pi]}]];
  dt = Abs[l[[1]] - l[[2]]];
  t = Plus @@ l/2;
  If[dt == Pi, 
   Line[{{Cos[l[[1]]], Sin[l[[1]]]}, {Cos[l[[2]]], Sin[l[[2]]]}}],
   c = {Cos[t], Sin[t]};
   r = Tan[dt/2];
   R = Sec[dt/2];
   t1 = ArcTan @@ ({Cos[l[[2]]], Sin[l[[2]]]} - R c);
   t2 = ArcTan @@ ({Cos[l[[1]]], Sin[l[[1]]]} - R c);
   If[t2 < t1, t2 += 2 Pi];
   (*Circle[R c, r, {t1, t2}]*)
   (r {Cos[#], Sin[#]}) + (R c) & /@ Subdivide[t1, t2, 500]
   ]]

Essentially, this construction guarantees the arc joining two points on our outer circle, will have perpendicular ends to the outer circle. This in-turn ensures that ribbons made out of Poincare arcs will not be crowded in the center, and will always form a convex shape.

Graphics[{Thread[{RandomColor[50], 
    poincareArc /@ RandomReal[{0, 2 \[Pi]}, {50, 2}]}], Circle[]}]

Static Picture

We now proceed to post-process our WeightedAdjacencyMatrix (WAM) dataset to hold the starting and ending angles of each ribbon. We essentially want two things:

1. Each node should be represented by a wedge with width proportional to the total flow out of it (row-sums of WAM)
2. Each edge should be represented by two Poincare arcs connecting the starting and ending points of the two node wedges

To do this, we rescale the WAM by going around the circle, leaving ~1° between each wedge.

countries = VertexList[orderedGraph];
flags = CountryData[#, "Flag"] & /@ countries;
cols = Most@*Blend@*DominantColors /@ flags;
Thread[{countries, cols}]

wam = Normal[WeightedAdjacencyMatrix[orderedGraph]];
wedgesWidth = Total[wam, {2}];
angles = Partition[
   Rescale[Accumulate[
      Append[Prepend[Riffle[wedgesWidth, 1.], 0], 1.]]] 2 \[Pi], 2];
wedges = Thread[{cols, Annulus[{0, 0}, {10, 11}, #] & /@ angles}];
innerCircle = Thread[{cols, Circle[{0, 0}, 9.9, #] & /@ angles}];
subPartitionAngles = 
  MapThread[
   Partition[Rescale[Accumulate[Prepend[#1, 0]], {0, #2}, #3], 2, 
     1] &, {wam, wedgesWidth, angles}];

The ribbons joining two nodes are then created using a Polygon (tried using FilledCurve too w/ little success, would appreciate any pointers as to how to make that work), colored by the starting vertex:

Clear[ribbon]
ribbon[a_, b_] := 
 ribbon[a, b] = 
  Block[{\[Theta]1 = subPartitionAngles[[a, b]], \[Theta]2 = 
     subPartitionAngles[[b, a]], pacs, circle1, circle2, coordinates, 
    primitives, curve},
   pacs = poincareArc /@ Transpose[{\[Theta]1, Reverse[\[Theta]2]}];
   circle1 = {Cos[#], Sin[#]} & /@ 
     Subdivide[\[Theta]1[[1]], \[Theta]1[[2]], 500] ;
   circle2 = 
    DeleteDuplicates[{Cos[#], Sin[#]} & /@ 
      Subdivide[\[Theta]2[[1]], \[Theta]2[[2]], 500] ];
   coordinates = Join @@ {pacs[[1]], circle1, pacs[[2]], circle2};
   {cols[[a]], 
    GeometricTransformation[Polygon[coordinates], 
     ScalingTransform[{9.9, 9.9}]]}]

nonzeroPositions = Position[wam, Except[0], {2}, Heads -> False];
backgroundChords = {Opacity[0.25], 
   ribbon @@@ DeleteDuplicates[Sort /@ nonzeroPositions]};

Putting everything together:

Graphics[{innerCircle, backgroundChords, wedges}, ImageSize -> 750]

Interactive Diagram

It's relatively straightforward to make this interactive using Mouseover:

dynamicLabels = 
  Table[Mouseover[
    Rotate[Text[Style[CountryData[countries[[i]], "CountryCode"], 12],
       11.5 {Cos[Mean[angles[[i]]]], Sin[Mean[angles[[i]]]]}], 
     If[3 \[Pi]/2 > Mean[angles[[i]]] > \[Pi]/2, 
      Mean[angles[[i]]] - \[Pi], Mean[angles[[i]]]]],
    {Rotate[
      Text[Style[CountryData[countries[[i]], "CountryCode"], 12, 
        Bold], 11.5 {Cos[Mean[angles[[i]]]], Sin[Mean[angles[[i]]]]}],
       If[3 \[Pi]/2 > Mean[angles[[i]]] > \[Pi]/2, 
       Mean[angles[[i]]] - \[Pi], Mean[angles[[i]]]]], {Opacity[0.75],
       ribbon @@@ Select[nonzeroPositions, #[[1]] == i &]}}
    ], {i, Length[countries]}];

Which would then be displayed as follows (picture shows a screenshot with mouse over Greece):

interactiveChordDiagram = 
 Graphics[{innerCircle, backgroundChords, wedges, dynamicLabels}, 
  ImageSize -> 750]

Conclusions

Eurovision-politics aside, this was an interesting exercise which I hope will be beneficial to others in the future (full notebook attached)! The visualization can greatly be improved by obtaining the vertex order which minimizes ribbon crossings and coloring the ribbons using a gradient between each node (e.g. using Polygon's VertexColors), both of which are left as an exercise for the reader :)

*I found an implementation for a variant of this called no-ribbon chord diagram in 'Mathematica Data Visualization' by Nazmus Saquib, please do point me to the right direction if I missed anything else!

Attachments:

mma-chord-diagram.nb