Orsdxy

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.

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.

Final result:

Single Function

Here's this whole boondoggle in a single function:

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

    ]

   ];

makeStreamGraph[

  nodes : {_, _, _, __} ..,

  colorFunction : 

   Except[_?

     OptionQ] : (If[EvenQ[#2[[1]]], Hue[.666, .6, .6], 

      Hue[0, 1, .8]] &),

  diskStyles : Except[_?OptionQ] : {White, EdgeForm[Black]},

  ops : OptionsPattern

  ] :=

 Module[

  {

   mainCategory,

   mainCategoryColors,

   namedNodes,

   baseGraphs,

   choiceWeights,

   coreGraph,

   choicePositions,

   coreGraphics,

   arrows,

   disks,

   gComplexPositions,

   arrowGroups,

   graphPaths,

   arrowGroupings

   },

  mainCategory = DeleteDuplicates@nodes[[All, 2]];

  mainCategoryColors =

   AssociationThread[mainCategory,

    MapIndexed[colorFunction, mainCategory]

    ];

  namedNodes = Association@Map[#[[1 ;; 2]] -> #[[3 ;;]] &, nodes];

  baseGraphs =

   MapThread[UndirectedEdge, {Most[#], Rest[#]}] & /@ namedNodes;

  baseGraphs =

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

  choiceWeights =

   Join @@

     With[

      {

       base =

        Counts /@

         Transpose[nodes[[All, 3 ;;]]]

       },

      N@base/Max[base]

      ] // Thread[Keys[#] ->

       Rescale[Rescale[Values@#], {0, 1}, {.2, 1}]

      ] &;

  coreGraph =

   Graph[

    Flatten@Values[baseGraphs],

    GraphLayout -> "LayeredDigraphEmbedding",

    VertexSize -> choiceWeights,

    VertexStyle -> White

    ];

  choicePositions =

   AssociationThread[

    VertexList[coreGraph],

    GraphEmbedding[coreGraph, "LayeredDigraphEmbedding"]

    ];

  coreGraphics = Show@coreGraph;

  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];

  Graphics[

   GraphicsComplex[

    coreGraphics[[1, 1]],

    {

     Arrowheads[0.],

     KeyValueMap[

      {mainCategoryColors[#[[2]]], Tooltip[#2, #[[1]]]} &,

      arrowGroupings

      ],

     {

      Sequence @@ Flatten@{diskStyles},

      MapThread[Tooltip, { disks, VertexList[coreGraph]}]

      }

     }

    ],

   ops

   ]

  ]

Then you call it like:

makeStreamGraph[nodes, ImageSize -> 1000]

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] &

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.