7
$\begingroup$

The Sunday, January 27, 2019 New York Times has a superb info-graphic describing the path from citizen to Member of the House of Representatives for the current members, including steps such as college, ivy-league college, law school, business, and so on.

enter image description here

Each path (red for Republican, blue for Democrat) starts at the starting node and then passes through an appropriate sequence of circular regions ("milestone disks") associated with each of these milestones.

The simplest approximation would be to create a traditional multi-graph (Graph), but that would miss several key features of this info-graphic:

  • Each path must remain continuous and visible through each circular "milestone disk"
  • Each path stays separate from the others and none cross needlessly, particularly within each "milestone disk"

Of course this info-graphic structure can be used for many applications, but as an illustration consider the input data of the following form:

{{"Jay Smith", "Democrat", "College", "Law School", "Military", "Congress"}, 
 {"Mary Jones", "Republican", "Ivy-league college", "Graduate school", "Business", Congress"}}

Presumably the designer can place the centers of the "milestone disks" which would be automatically scaled in size (based on the number of paths through it) and the paths would conform appropriately.

Special credit would be to be able to mouseover or click-highlight a single path and have the representative's name, college and so on appear, and to force all blue paths to pass through the top of a milestone disk and red paths to pass through the bottom of a milestone disk (to enable better comparison between Democrats and Republicans.

$\endgroup$
8
$\begingroup$

Version 2

Get some node data to work with...:

BlockRandom[
  people = RandomEntity["Person", 1000]; 
  names = DeleteMissing@EntityValue[people, "FullName"];
  numPeeps = Length@names;
  mainCategory = RandomWord[2];
  wordChoices = TakeList[RandomWord[25], RandomInteger[{2, 5}, 5]];
  nodes =
   Join[
    List /@ names,
    List /@ RandomChoice[mainCategory, numPeeps],
    Transpose[RandomChoice[#, numPeeps] & /@ wordChoices],
    ConstantArray["End", {Length@names, 1}] ,
    2
    ]
  ];

And here's an updated single function to generate the graphics:

regroupArrows[arrowGroups_, graphPaths_] :=
  Module[
   {
    shrinkingArrows = arrowGroups,
    paths = graphPaths,
    arrow,
    arrows,
    arrowGroup
    },
   arrows =
    Table[
     Table[
      arrowGroup = shrinkingArrows[pair[[1]], pair[[2]]];
      If[MissingQ[arrowGroup], 
       pair = Reverse[pair];
       arrowGroup = shrinkingArrows[pair[[1]], pair[[2]]]
       ];
      Which[
       MissingQ[arrowGroup],
       {arrowGroup, pair},
       Length@arrowGroup > 0,
       arrow = arrowGroup[[1]];
       shrinkingArrows[pair[[1]], pair[[2]] ] = Rest[arrowGroup];
       arrow,
       True,
       {$Failed, pair}
       ],
      {pair, path}
      ],
     {path, Values@paths}
     ];
   AssociationThread[
    Keys[paths],
    arrows
    ]
   ];
joinBezier[arrows_] :=
  With[
   {
    bezzz = Cases[arrows, _BezierCurve, \[Infinity]],
    setBacks = arrows[[{1, -1}, -1]]
    },
   If[Length[bezzz] == Length[arrows],
    ReplacePart[
     arrows[[-1]], 
     {
      1 ->
       BezierCurve[
        Join @@ bezzz[[All, 1]]
        ],
      If[AllTrue[setBacks, NumericQ],
       -1 -> 0(*setBacks*),
       Nothing
       ]
      }
     ],
    arrows
    ]
   ];
makeStreamGraph // Clear
makeStreamGraph[
   nodes : {_, _, _, __} ..,
   embedding : _String : "LayeredDigraphEmbedding",
   colorFunction : _Function : (If[EvenQ[#2[[1]]], Hue[.666, .6, .6], 
       Hue[0, 1, .8]] &),
   diskStyles : 
    Except[_?OptionQ | {__String}, _Directive | _List] : {GrayLevel[
      1, .5], EdgeForm[Black]},
   useDynamics : True | False : False,
   labeledNodes : {___String} : {},
   ops : OptionsPattern[]
   ] :=
  Module[
   {
    mainCategory,
    mainCategoryColors,
    namedNodes,
    baseGraphs,
    baseWeights,
    choiceWeights,
    coreGraph,
    choicePositions,
    coreGraphics,
    arrows,
    disks,
    gComplexPositions,
    arrowGroups,
    graphPaths,
    arrowGroupings,
    endNodes
    },
   mainCategory = DeleteDuplicates@nodes[[All, 2]];
   endNodes = DeleteDuplicates@nodes[[All, -1]];
   mainCategoryColors =
    AssociationThread[mainCategory,
     MapIndexed[colorFunction, mainCategory]
     ];
   namedNodes = Association@Map[#[[1 ;; 2]] -> #[[3 ;;]] &, nodes];
   baseGraphs =
    MapThread[DirectedEdge, {Most[#], Rest[#]}] & /@ namedNodes;
   baseGraphs =
    KeySortBy[baseGraphs, #[[2]] &];
   baseWeights =
    Counts /@
     Transpose[Values[namedNodes]];
   If[Length@endNodes == 1, 
    baseWeights[[-1]] =
     AssociationThread[
      Keys[baseWeights[[-1]]], 
      {Mean@Flatten@Values@baseWeights}/2
      ]
    ];
   choiceWeights =
    Join @@ (N@baseWeights/Max[baseWeights]);
   choiceWeights =
    Thread[
     Keys[choiceWeights] ->
      Rescale[Rescale[Values@choiceWeights], {0, 1}, {.2, 1}]
     ];
   coreGraph =
    Graph[
     Flatten@Values[baseGraphs],
     GraphLayout -> embedding,
     VertexSize -> choiceWeights,
     VertexStyle -> White
     ];
   choicePositions =
    AssociationThread[
     VertexList[coreGraph],
     GraphEmbedding[coreGraph, embedding]
     ];
   coreGraphics = Show@coreGraph;
   If[Head@coreGraphics[[1]] =!= GraphicsComplex,
    Return[
     Failure["NotImplemented", <|
       "MessageTemplate" -> 
        "Not gonna work for this embedding for whatever reason"
       |>], Module]
    ];
   arrows = 
    Cases[coreGraphics, 
     a_Arrow :> (Cases[a, _Integer, \[Infinity]][[{1, -1}]] -> 
        a), \[Infinity]]; 
   disks = Cases[coreGraphics, _Disk, \[Infinity]];
   gComplexPositions =
    KeySelect[! MissingQ[#] &]@
       AssociationThread[# -> Range[Length[#]]] &@
     Lookup[
      AssociationMap[Reverse, choicePositions],
      Key /@ coreGraphics[[1, 1]]
      ];
   arrowGroups =
    GroupBy[arrows, #[[1, 1]] & -> (#[[1, 2]] -> #[[2]] &), 
     GroupBy[First -> Last]];
   graphPaths =
    Lookup[gComplexPositions, List @@ #] & /@ # & /@ baseGraphs;
   arrowGroupings = regroupArrows[arrowGroups, graphPaths];
   DynamicModule[
    {
     colors = mainCategoryColors,
     blends = Blend[{#, White}] & /@ mainCategoryColors
     },
    Graphics[
     GraphicsComplex[
      coreGraphics[[1, 1]],
      {
       {
        Arrowheads[0.],
        KeyValueMap[
         Which[useDynamics,
          {
            Tooltip[
             Dynamic[
              {
               If[CurrentValue["MouseOver"],
                Sequence @@
                 {
                  colors[#[[2]]],
                  AbsoluteThickness[8]
                  },
                Sequence @@ {
                  blends[#[[2]]],
                  AbsoluteThickness[1]
                  }
                ],
               #2
               }
              ],
              #[[1]]
             ]
            } &,
          Length@labeledNodes > 0,
          Tooltip[
            {

             Sequence @@

              If[MemberQ[labeledNodes, #[[1]]],
               {colors[#[[2]]], AbsoluteThickness[8]},
               {blends[#[[2]]], AbsoluteThickness[1]}
               ], 
             #2
             }, 
            #[[1]]
            ] &,
          True,
          Tooltip[
            {
             colors[#[[2]]], AbsoluteThickness[1], #2
             }, 
            #[[1]]
            ] &
          ],
         (*joinBezier/@*)
         KeySortBy[
          arrowGroupings,
          { MemberQ[labeledNodes, #[[1]]] &}
          ]
         ]
        },
       {
        Sequence @@ Flatten@{diskStyles},
        MapThread[Tooltip, { disks, VertexList[coreGraph]}]
        }
       }
      ],
     ops
     ]
    ]
   ];

Now we can use it like normal:

makeStreamGraph[nodes, ImageSize -> {200, Automatic}]

enter image description here

Or try a different embedding:

makeStreamGraph[nodes, "SpringEmbedding", 
 ImageSize -> {Automatic, 250}]

enter image description here

Label some specific nodes:

makeStreamGraph[nodes, "SpringEmbedding", nodes[[;; 5, 1]], 
 ImageSize -> {Automatic, 250}]

enter image description here

Or have a Dynamic implementation where we can mouse over a path and see it (note that this is preliminary and slow):

makeStreamGraph[nodes, "SpringEmbedding", True, 
 ImageSize -> {Automatic, 250}]

enter image description here

Version 1

Implementation

Here's a place to start, although I don't have time to do the final annoying bits to get it to actually work.

We'll start with some core data of the form you provided:

BlockRandom[
  people = RandomEntity["Person", 1000]; 
  names = DeleteMissing@EntityValue[people, "FullName"];
  numPeeps = Length@names;
  mainCategory = RandomWord[2];
  wordChoices = Partition[RandomWord[15], 5];
  nodes =
   Join[
    List /@ names,
    List /@ RandomChoice[mainCategory, numPeeps],
    Transpose[RandomChoice[#, numPeeps] & /@ wordChoices],
    2
    ]
  ];

Then we'll extract each subgraph we want to build off of these:

namedNodes =
  Association@
   Map[#[[1 ;; 2]] -> #[[3 ;;]] &, nodes];
baseGraphs =
  MapThread[UndirectedEdge, {Most[#], Rest[#]}] & /@ namedNodes;

Then we sort this so everything looks nice in the end:

baseGraphs = KeySortBy[baseGraphs, #[[2]] &];

Next we assign weights for each node:

choiceWeights =
  Join @@
    With[
     {
      base =
       Counts /@
        Transpose[nodes[[All, 3 ;;]]]
      },
     N@base/Max[base]
     ] // Thread[Keys[#] ->
      Rescale[Rescale[Values@#], {0, 1}, {.2, 1}]
     ] &;

And we extract the vertex coordinates of the best looking multigraph I could find:

coreGraph =
  Graph[
   Flatten@Values[baseGraphs]
   ];
choicePositions =
  AssociationThread[
   VertexList[coreGraph],
   GraphEmbedding[coreGraph, "LayeredDigraphEmbedding"]
   ];

Now here comes the hard part. We can't disambiguate each multigraph edge, so we really need to build this code ourselves. First we extract all the arrows and group them by their coordinates:

coreGraphics = Show@coreGraph;
postProcessArrow[a_Arrow] := 
  Cases[a, _Integer, \[Infinity]][[{1, -1}]] -> a;
arrows = Cases[coreGraphics, 
   a_Arrow :> postProcessArrow[a], \[Infinity]];
disks = Cases[coreGraphics, _Disk, \[Infinity]];

Then we try to rebuild our arrow paths:

arrowGroups =
  GroupBy[arrows, #[[1, 1]] & -> (#[[1, 2]] -> #[[2]] &), 
   GroupBy[First -> Last]];

graphPaths =
  Lookup[gComplexPositions, List @@ #] & /@ # & /@ baseGraphs;

arrowGroupings =
  Module[
   {
    shrinkingArrows = arrowGroups,
    paths = graphPaths,
    arrow,
    arrows,
    arrowGroup
    },
   arrows =
    Table[
     Table[
      arrowGroup = shrinkingArrows[pair[[1]], pair[[2]]];
      If[MissingQ[arrowGroup], 
       pair = Reverse[pair];
       arrowGroup = shrinkingArrows[pair[[1]], pair[[2]]]
       ];
      Which[
       MissingQ[arrowGroup],
       {arrowGroup, pair},
       Length@arrowGroup > 0,
       arrow = arrowGroup[[1]];
       shrinkingArrows[pair[[1]], pair[[2]] ] = Rest[arrowGroup];
       arrow,
       True,
       {$Failed, pair}
       ],
      {pair, path}
      ],
     {path, Values@paths}
     ];
   AssociationThread[
    Keys[paths],
    arrows
    ]
   ];

And finally remake our info graphic:

GraphicsComplex[
  coreGraphics[[1, 1]],
  {
   Arrowheads[0.],
   KeyValueMap[
    {If[#[[2]] === mainCategory[[2]], Hue[0, 1, .8], 
       Hue[.666, .6, .6]], Tooltip[#2, #[[1]]]} &,
    arrowGroupings
    ],
   {
    White, EdgeForm[Black],
    MapThread[Tooltip, { disks, VertexList[coreGraph]}]
    }
   }
  ] // Graphics[#, ImageSize -> 1000] &

enter image description here

Now I haven't made sure all the paths are clean, but for non-random data we might get that more-or-less for free. Oh yeah and I have tooltips on there.

One nice thing about this approach is we can really get everything directly from coreGraph so we don't need to rebuild all the Graphics architecture ourselves.

$\endgroup$
  • $\begingroup$ Wow... thanks for all the work... great start (+1). But as you recognize, the hard part is what is yet to be done. $\endgroup$ – David G. Stork Jan 28 at 2:43
  • $\begingroup$ @DavidG.Stork Thinking about it more you could pre-sort the arrowGroups so that the higher "radius" stuff is always at the bottom of the list. If you also presort your baseGraphs by mainCategory we should actually be doing just fine. $\endgroup$ – b3m2a1 Jan 28 at 2:52
  • $\begingroup$ @DavidG.Stork how does it look now? All it took was a bit of sorting :) $\endgroup$ – b3m2a1 Jan 28 at 2:56
  • $\begingroup$ Superb work... thanks so very much. Nevertheless, the requirement that the lines be visible within each disk. There are a few other desiderata. Let me give the rest of answerers a chance to address these.... Again: great work! $\endgroup$ – David G. Stork Jan 28 at 5:13
  • 1
    $\begingroup$ Oh I'm very much interested. To get an interactive figure like this in Mathematica would be a great benefit to many people: nytimes.com/interactive/2019/01/26/opinion/sunday/… $\endgroup$ – David G. Stork Jan 28 at 6:27

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.