Message Boards Message Boards

Visualizing data with Chord Diagrams

Posted 1 year ago
7181 Views
|
7 Replies
|
22 Total Likes
|

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


enter image description here

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[]}]

enter image description here

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]

enter image description here

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]

enter image description here

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:
7 Replies
Posted 1 year ago

This is really great! I think it also contains useful information to design a Sankey diagram function. Are you considering to document your function and make it available through the Function Repository? I think it would be a nice fit. Thanks for sharing!

https://www.wolframcloud.com/obj/resourcesystem/published/FunctionRepository/category/visualization-graphics

Thanks for the Function Repository suggestion. I admit I hadn't thought of doing that, no. Here is the function, hope it's useful: https://resources.wolframcloud.com/FunctionRepository/resources/ChordDiagram

Dear George,

Thanks for the interesting post. How do I plot a chord diagram for the following data?

Thanks for your help.

OBSTR = {0.28`, 0.3`, 0.34`, 0.36`, 0.4`, 0.42`, 0.46`, 0.48`, 0.52`, 
   0.54`, 0.58`, 0.6`, 0.64`, 0.66`, 0.7`, 0.72`, 0.76`, 0.78`, 0.82`,
    0.84`, 0.88`, 0.9`, 0.94`, 0.96`, 1.`, 1.02`, 1.06`, 1.08`, 1.12`,
    1.14`, 1.18`, 1.2`, 1.24`, 1.26`, 1.3`, 1.32`, 1.36`, 1.38`, 
   1.42`, 1.44`, 1.48`, 1.5`, 1.54`, 1.56`, 1.6`, 1.62`, 1.66`, 1.68`,
    1.72`, 1.74`, 1.78`, 1.8`, 1.84`, 1.86`, 1.9`, 1.92`, 1.96`, 
   1.98`, 2.1`, 2.2`, 2.4`, 2.5`, 2.7`, 2.8`, 3.`, 3.1`, 3.3`, 3.4`, 
   3.6`, 3.7`, 3.9`, 4.`, 4.2`, 4.3`, 4.6`, 4.7`, 4.9`, 5.`, 5.2`, 
   5.3`, 5.5`, 5.6`, 5.8`, 5.9`, 6.1`, 6.2`, 6.4`, 6.5`, 6.7`, 6.8`, 
   7.`, 7.1`, 7.3`, 7.4`, 7.6`, 7.7`, 7.9`, 8.`, 8.2`, 8.3`, 8.5`, 
   8.6`, 8.8`, 8.9`, 9.1`, 9.2`, 9.4`, 9.5`, 9.7`, 9.8`, 10.`};

GBMTR = {0.440068324`, 0.526537202`, 0.420201041`, 0.447249413`, 
   0.549021446`, 0.534985717`, 0.410690475`, 0.481946551`, 
   0.441498005`, 0.46469476`, 0.593707331`, 0.621250386`, 
   0.667377559`, 0.690184059`, 0.73657374`, 0.746508284`, 
   0.778186083`, 0.797128376`, 0.851814002`, 0.841308178`, 
   0.905080927`, 0.90929277`, 0.955438964`, 0.989558895`, 
   1.005382648`, 1.036311278`, 1.070007107`, 1.087352693`, 
   1.158893156`, 1.1709878`, 1.21766573`, 1.193631042`, 1.232870086`, 
   1.250205496`, 1.322763813`, 1.302429007`, 1.338244852`, 
   1.36445857`, 1.46376193`, 1.473258322`, 1.511989847`, 1.527549955`,
    1.599875186`, 1.514615786`, 1.565078803`, 1.600496362`, 
   1.652361456`, 1.700245231`, 1.671387062`, 2.036974348`, 
   1.886783947`, 1.794121464`, 1.830711416`, 1.790774944`, 
   1.767614751`, 1.893033742`, 1.912107926`, 1.870079105`, 
   2.362326909`, 2.288473656`, 2.549939649`, 2.334404048`, 
   2.648551758`, 3.255954901`, 3.071647302`, 3.703538756`, 
   3.375289378`, 4.554499843`, 3.703538756`, 3.506285467`, 
   4.618374937`, 4.077280878`, 4.565830244`, 3.395286813`, 
   4.970536284`, 5.149180917`, 4.500856106`, 5.790897173`, 
   5.650981933`, 6.387504101`, 4.812200957`, 6.491026294`, 
   6.379698839`, 7.583151893`, 6.222763493`, 6.274143137`, 
   6.557285481`, 6.060387581`, 6.407122791`, 6.661658222`, 
   6.184305176`, 7.253657359`, 7.799117017`, 6.962843534`, 
   7.18309262`, 7.717689641`, 7.849817406`, 8.20377598`, 8.075499672`,
    8.715964412`, 8.993966835`, 8.268618231`, 6.222763493`, 
   8.107761559`, 8.561475983`, 8.227847404`, 9.140343811`, 
   8.839799405`, 8.857524197`, 8.126884151`, 7.933412873`};

GLMTR = {1.04955856`, 1.068992586`, 0.91298729`, 0.901193396`, 
   0.896296542`, 0.852930063`, 0.835232522`, 0.795771099`, 
   0.802679332`, 0.832287641`, 0.813191688`, 0.823461204`, 
   0.837455435`, 0.830076631`, 0.858418197`, 0.881470583`, 
   0.857149904`, 0.882800621`, 0.948347123`, 0.929455855`, 
   0.917715604`, 0.932554499`, 1.045656536`, 1.070314483`, 
   1.085087828`, 1.094709436`, 1.213942`, 1.176271008`, 1.144491984`, 
   1.204735184`, 1.264340542`, 1.205803082`, 1.229957158`, 
   1.244335511`, 1.20799278`, 1.230187815`, 1.239262724`, 
   1.240912175`, 1.471887915`, 1.357745929`, 1.413734902`, 
   1.367052147`, 1.324399197`, 1.560484902`, 1.918402041`, 
   1.884566574`, 1.896756311`, 1.829278106`, 1.971024489`, 
   2.247116503`, 1.755544688`, 2.277140774`, 2.263080424`, 
   2.331213027`, 2.06407623`, 2.181000042`, 1.708180067`, 
   2.098010484`, 2.266002911`, 2.41830423`, 2.609381641`, 
   2.423296357`, 2.659080081`, 3.611694982`, 2.798655558`, 
   3.089143973`, 3.742634454`, 4.746099931`, 3.593943845`, 
   3.654479414`, 4.022739344`, 3.605777673`, 4.566342764`, 
   3.454771576`, 4.643358659`, 5.827653685`, 3.319268016`, 
   8.182438724`, 8.830212735`, 7.126887741`, 3.756550702`, 
   10.12108166`, 7.228518612`, 5.768577623`, 5.197085917`, 
   4.792838383`, 5.756301703`, 7.498170689`, 5.097038029`, 
   6.106271398`, 10.80219377`, 10.16063823`, 10.08597237`, 
   5.096031917`, 4.198122127`, 9.435050027`, 4.850030059`, 
   5.456298146`, 4.166390487`, 4.178570589`, 7.809040686`, 
   10.03005879`, 3.72673567`, 6.786743937`, 10.57622259`, 
   6.870747819`, 7.995324653`, 6.524812144`, 7.012741696`, 
   8.393082457`, 7.997878709`};

DRFTR = {0.455440002`, 0.322080009`, 0.381240005`, 0.37864001`, 
   0.426480003`, 0.417439994`, 0.454440005`, 0.483519993`, 
   0.512719988`, 0.54024001`, 0.57291999`, 0.607720017`, 0.63279999`, 
   0.66408002`, 0.706559991`, 0.711080018`, 0.74819999`, 0.772999985`,
    0.845719991`, 0.816199979`, 0.86631999`, 0.885679982`, 
   0.973079997`, 1.012239985`, 1.013239996`, 1.022359985`, 
   1.071079967`, 1.072960017`, 1.164040002`, 1.180279988`, 
   1.20099997`, 1.205600028`, 1.216999999`, 1.261039997`, 
   1.331039974`, 1.291480032`, 1.324880013`, 1.314159997`, 
   1.45703998`, 1.449200027`, 1.464480011`, 1.515359998`, 
   1.441479969`, 1.55319996`, 1.643400012`, 1.669599997`, 
   1.695599977`, 1.699599964`, 1.829680015`, 1.960520018`, 
   1.773319984`, 1.898199974`, 1.947760021`, 1.993360015`, 
   1.860399981`, 1.925639978`, 1.853560024`, 1.954040009`, 
   2.360159938`, 2.470040045`, 2.53072007`, 2.341120001`, 
   2.816400053`, 3.746799932`, 3.152640025`, 3.60139992`, 
   4.116999948`, 4.55660003`, 3.745799916`, 3.762120037`, 
   3.641680076`, 4.062480016`, 4.515999864`, 3.791520138`, 
   5.032999924`, 5.718199873`, 4.418040061`, 5.816400003`, 
   5.450999907`, 5.844600118`, 5.19524002`, 6.27859993`, 6.429400098`,
    6.959000024`, 6.195399948`, 6.379999888`, 6.491200032`, 
   6.373799986`, 6.732599884`, 6.875800096`, 7.073600013`, 
   6.956799928`, 7.327600119`, 7.091400036`, 7.13439993`, 
   7.711799899`, 7.659800048`, 7.817199997`, 8.064799899`, 
   8.316600081`, 8.270599984`, 8.327200265`, 7.470600091`, 
   7.570399752`, 8.422600253`, 8.29299987`, 8.597999751`, 
   8.857999985`, 8.748799877`, 8.962000118`, 8.64220001`};

Hello,

I'm not sure I understand the format of your data. You've posted four arrays of length 111 each - what do these represent?

In general chord diagrams visualize inter-relationships between two entities. Perhaps the first example in the Function Repository is instructive to understand the expected inputs:

wg = Graph[{1 \[DirectedEdge] 3, 1 \[DirectedEdge] 2, 2 \[DirectedEdge] 1, 3 \[DirectedEdge] 2, 3 \[DirectedEdge] 1}, EdgeWeight -> {1, 2, 1, 3, 2}];

Here, there are three entities (vertices 1,2,3), and their inter-relationships are represented by the EdgeWeight of the graph. For example, the first edge (1->3) has a weight of 1, while the last edge (3 ->1) has a weight of 2 - hence the asymmetry in widths of the ribbon connecting 1 and 3.

The raw data can be inspected using the WeightedAdjacencyMatrix as follows:

WeightedAdjacencyMatrix[wg] // MatrixForm

Hope this helps

Thanks for useful explains George.

The data shows the observed values (OBSTR) and output of four simulation models named DLTR, GBMTR, GLMTR, and DRFTR. I thought it would be useful if I add a Chord diagram in my article.

Regards,

enter image description here - Congratulations! This post is now featured in our Staff Pick column as distinguished by a badge on your profile of a Featured Contributor! Thank you, keep it coming, and consider contributing your work to the The Notebook Archive!

Very nice! There is one line may need modification in your example. I notice that without Line mapped to the points there is error message.

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

modification

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract