# How to Make a Sankey Diagram

I have two lists

start = {{1},{1},{1},{2},{3},{1}}

end   = {{1},{2},{2},{3},{3},{1}}


And I want to create a Sankey diagram. Which looks something like So, lines should join the start value to the corresponding end value.

I tried using Graph[] but it didn't work very well - producing this oddly phallic shape.

start = Flatten[start]
end = Flatten[end]

f[x_, y_] := Module[{},
Return[{x <-> y}]]

Graph[result] Here's the start of a SankeyDiagram function:

Options[SankeyDiagram] = Join[
{ColorFunction -> {"Start" -> ColorData, "End" -> ColorData["GrayTones"]}},
Options[Graphics]
];

SankeyDiagram[rules_, opts:OptionsPattern[]]:=Module[
{
startcolors, svalues, slens, startsplit,
endcolors, evalues, elens, endsplit,
len, endpos, linecolors
},

len = Length[rules];
endpos = Ordering @ Ordering @ Sort[rules][[All, 2]];

startcolors = OptionValue[ColorFunction->"Start"];
endcolors = OptionValue[ColorFunction->"End"];

{svalues, slens} = Through @ {Map[First], Map[Length]} @ Split[Sort @ rules[[All, 1]]];
startsplit = Accumulate @ Prepend[-slens, len-.5];
linecolors = Flatten @ Table[
ConstantArray[startcolors[i], slens[[i]]],
{i, Length[slens]}
];

{evalues, elens} = Through @ {Map[First], Map[Length]} @ Split[Sort @ rules[[All, 2]]];
endsplit = Accumulate @ Prepend[-elens, len-.5];

Graphics[
{
Table[
{
startcolors[i],
Rectangle[Offset[{-40, 0}, {0, startsplit[[i]]}], Offset[{-10, 0}, {0, startsplit[[i+1]]}]]
},
{i, Length[startsplit]-1}
],
Table[
{
endcolors[(i-1)/(Length[endsplit]-1)],
Rectangle[Offset[{40, 0}, {1, endsplit[[i]]}], Offset[{10, 0}, {1, endsplit[[i+1]]}]]
},
{i, Length[endsplit]-1}
],
Table[
{
White,
Text[
svalues[[i]],
Offset[{-23, 0}, {0, (startsplit[[i]]+startsplit[[i+1]])/2}],
{0, 0},
{0, 1}
]
},
{i, Length[slens]}
],
Table[
{
LightGreen,
Text[
evalues[[i]],
Offset[{23, 0}, {1, (endsplit[[i]]+endsplit[[i+1]])/2}],
{0, 0},
{0, -1}
]
},
{i, Length[elens]}
],
Thickness[.03], Opacity[.7],
Table[
{linecolors[[i]], Line[connector[len-i, len-endpos[[i]]]]},
{i, len}
]
},
opts,
AspectRatio->1
]
]

connector[y1_, y2_] := Table[
{t, y1+(y2-y1) LogisticSigmoid[Rescale[t, {0,1}, {-10,10}]]},
{t, Subdivide[0, 1, 30]}
]


Here is a fair approximation of your desired diagram:

SankeyDiagram[{
1->1,1->2,1->3,1->4,1->5,
2->1,2->2,2->3,2->4,2->5,
3->1,3->2,3->3,3->4,3->5
}] ## EDIT 01:

Found some time to package these in a function (see end of post for code).

It accepts an association as input, with the following key-value pairs:

• "nodes": Association with integer keys (one per column of nodes) and a list of nodes for that column
• "ribbons": List of ribbons to plot of the form source->target, given as a two element list of the form {node column,node name}
• "values": List of ribbon thicknesses (same order as above)

The example by OP can be expressed as:

sankeyAssociation = <|

"nodes" -> <|
1 -> {"A", "B", "C"},
2 -> {1, 2, 3, 4, 5}
|>,

"ribbons" -> {
{1, "A"} -> {2, 1}, {1, "A"} -> {2, 2}, {1, "A"} -> {2, 3},
{1, "A"} -> {2, 4}, {1, "A"} -> {2, 5},
{1, "B"} -> {2, 1}, {1, "B"} -> {2, 2}, {1, "B"} -> {2, 3},
{1, "B"} -> {2, 4}, {1, "B"} -> {2, 5},
{1, "C"} -> {2, 1}, {1, "C"} -> {2, 2}, {1, "C"} -> {2, 3},
{1, "C"} -> {2, 4}, {1, "C"} -> {2, 5}},

"values" -> Normalize[RandomReal[{0, 1}, 15], Total],

"ribbon-color-order" -> {"source"},
"node-colors" -> {ColorData /@ Reverse[Range],
ColorData["GrayTones"] /@ Subdivide}

|>;

parseSankeyAssociation[sankeyAssociation] // Graphics Note I pass a normalized list of 15 random values (to illustrate ribbon widths which were not given by OP).

We can also use more than two sets of nodes, change the ribbon width (to do this use a value of the form {sourceWidth,targetWidth}), as well as color by either the source or target node's color (random colors if none provided):

sankeyAssociation = <|

"nodes" -> <|
1 -> {"i", "ii", "iii"},
2 -> {1, 2, 3},
3 -> {"A", "B", "C"},
4 -> {"male", "female"}|>,

"ribbons" -> {
{1, "i"} -> {2, 1}, {1, "i"} -> {2, 2}, {1, "i"} -> {2, 3},
{1, "ii"} -> {2, 1}, {1, "ii"} -> {2, 2}, {1, "ii"} -> {2, 3},
{1, "iii"} -> {2, 1}, {1, "iii"} -> {2, 2}, {1, "iii"} -> {2, 3},
{2, 1} -> {3, "A"}, {2, 2} -> {3, "C"}, {2, 3} -> {3, "B"},
{3, "A"} -> {4, "male"}, {3, "A"} -> {4, "female"},
{3, "B"} -> {4, "male"}, {3, "B"} -> {4, "female"},
{3, "C"} -> {4, "male"}, {3, "C"} -> {4, "female"}},

"values" -> {
0.15, 0.05, 0.1, 0.2, 0.1, 0.1, 0.2, 0.05, 0.05,
{0.55, 0.75}, {0.2, 0.75}, {0.25, 0.5},
0.6, 0.15, 0.4, 0.35, 0.2, 0.3},

"ribbon-color-order" -> {"source", "source", "target"}
|>;

parseSankeyAssociation[sankeyAssociation] // Graphics ## Original Post

I recently had to do something similar, and figured I'd share my method - hopefully it's useful for people stumbling on this question.

As this was project-specific, I didn't really bother making this take a general directed acyclic graph as input. I will try and revisit this when I find time to do so.

Also, just for fun, let's make two 'mirrored' sankey diagrams which meet in the middle (to illustrate changing ribbon thickness). This will produce a curious mix of a Sankey Diagram with a Sorted Stream Graph.

## Data Manipulations

Let's get to it. Our starting point will be trimmed down census data containing the populations by gender for 1900 and 2000. The values are normalized by the total 1900 population (i.e. the ribbons on our left-hand-side Sankey diagram will add up to 1)

node[1900,"age"]=<|4-><|1->0.05414804941453713,2->0.04790029993776391|>,3-><|1->0.07281198003415058,2->0.06573204261615237|>,5-><|1->0.03583588915495271,2->0.03247471005563773|>,6-><|1->0.020838909171744382,2->0.020032303814200632|>,7-><|1->0.009479822415695848,2->0.009255964974073015|>,2-><|1->0.0928803564714712,2->0.09161891611641274|>,0-><|1->0.11913179817987588,2->0.11774648357159513|>,1-><|1->0.10270423906820861,2->0.10232367354992021|>,8-><|1->0.0022480547893710882,2->0.0023741975136220045|>,9-><|1->0.0001988386975614238,2->0.00026347045305339544|>|>;
node[2000,"age"]=<|1-><|1->0.2727495747895295,2->0.2585164401406027|>,0-><|1->0.26602118481822223,2->0.2541248506923183|>,2-><|1->0.25426292583643084,2->0.24707650140558005|>,3-><|1->0.28429398120481275,2->0.2852627625720795|>,4-><|1->0.2785794928829082,2->0.2851957312200659|>,5-><|1->0.19625573515042147,2->0.2076031386250451|>,6-><|1->0.12557917310716843,2->0.13733749765170633|>,7-><|1->0.0879170205361273,2->0.1251002634691418|>,8-><|1->0.037672288571648824,2->0.06822530207740414|>,9-><|1->0.004409789666710598,2->0.013959370844674104|>|>;


We compute control points for each of our ribbon by:

• adding a 1/50 space in b/w nodes
• accumulating results to the range 0 to 1+(1/50)*(num_nodes -1)
• shift results to be centered around 0
• equally space nodes along horizontal direction

positions[1900,"gender"]=(DeleteCases[Partition[Prepend[Accumulate[Flatten[Riffle[Transpose[Values/@Values[node[1900,"age"]]],1/50]]],0.],2,1],{start_,end_}/;end-start==1/50]-(1+1/50 )/2)/.{start_,end_}:>{{0,start},{0,end}}


And do the same for the 1900 age-group positions (second-from-left nodes). We need to make sure we transpose the results so that the order agrees with the gender nodes:

positions[1900,"age"]=(DeleteCases[Partition[Prepend[Accumulate[Flatten[Riffle[Values/@Values[node[1900,"age"]],1/50]]],0.],2,1],{start_,end_}/;end-start==1/50]-(1+1/50 (Length[node[1900,"age"]]-1))/2)/.{start_,end_}:>{{4,start},{4,end}};
positions[1900,"age-transposed"]=Join@@(Partition[positions[1900,"age"],2]^\[Transpose]);


We check this is correct by visually debugging:

With[{gendered1900=TakeDrop[Thread[{positions[1900,"gender"],positions[1900,"age-transposed"]}],ageBinsLength]},Graphics[{{Opacity[0.25],Blue,Polygon[Flatten[#,1],{1,3,4,2,1}]&/@gendered1900[]},{Opacity[0.25],Red,Polygon[Flatten[#,1],{1,3,4,2,1}]&/@gendered1900[]}},ImageSize->1250]] We do the same for the year 2000:

positions[2000,"age"]=(DeleteCases[Partition[Prepend[Accumulate[Flatten[Riffle[Values/@Values[node[2000,"age"]],1/50]]],0.],2,1],{start_,end_}/;end-start==1/50]-(totalPopulations/totalPopulations+1/50 (Length[node[2000,"age"]]-1))/2)/.{start_,end_}:>{{8+1/4,start},{8+1/4,end}};
positions[2000,"age-transposed"]=Join@@(Partition[positions[2000,"age"],2]^\[Transpose]);
positions[2000,"gender"]=(DeleteCases[Partition[Prepend[Accumulate[Flatten[Riffle[Transpose[Values/@Values[node[2000,"age"]]],1/50]]],0.],2,1],{start_,end_}/;end-start==1/50]-(totalPopulations/totalPopulations+1/50 )/2)/.{start_,end_}:>{{12+1/4,start},{12+1/4,end}};


Finally, we need the aggregate age group information (i.e. adding male and female populations for each age group)

permutation=Flatten[Position[Keys[node[1900,"age"]],#]&/@Keys[node[2000,"age"]]];
positions[1900,"aggregate"]=MapAt[1/8+#&,Drop[Flatten[#,1],{2,3}]&/@Partition[positions[1900,"age"],2][[permutation]],{All,All,1}];
positions[2000,"aggregate"]=MapAt[#-1/8&,Drop[Flatten[#,1],{2,3}]&/@Partition[positions[2000,"age"],2],{All,All,1}];


## Parallel Sets Visualization

As hinted by the visual debugging above, the obvious starting point would be a parallel sets sort of visualization:

parallelSets=With[{
Graphics[{
{Opacity[0.25],Blue,Polygon[Flatten[#,1],{1,3,4,2,1}]&/@Join[gendered2000[],gendered1900[]]},
{Opacity[0.25],Red,Polygon[Flatten[#,1],{1,3,4,2,1}]&/@Join[gendered2000[],gendered1900[]]},
{Opacity[0.25],Black,Polygon[Flatten[#,1],{1,3,4,2,1}]&/@streamPolygons},
{Opacity,Blue,Rectangle@@{positions[1900,"gender"][[1,1]]+{-1/8,0},positions[1900,"gender"][[10,2]]}},
{Opacity,Red,Rectangle@@{positions[1900,"gender"][[11,1]]+{-1/8,0},positions[1900,"gender"][[20,2]]}},
{Opacity,Blue,Rectangle@@{positions[2000,"gender"][[1,1]],positions[2000,"gender"][[10,2]]+{1/8,0}}},
{Opacity,Red,Rectangle@@{positions[2000,"gender"][[11,1]],positions[2000,"gender"][[20,2]]+{1/8,0}}},
{Opacity,Black,Map[Rectangle@@(#+{{-1/8,0},{0,0}})&,positions[1900,"aggregate"]]},
{Opacity,Black,Map[Rectangle@@(#+{{1/8,0},{0,0}})&,positions[2000,"aggregate"]]}
},ImageSize->1250]] ## Sankey Diagram

This already looks decent, but let's see if we can adapt this to make a sankey diagram. The tricky thing is ensuring ribbons of constant thickness (or in-fact varying thickness too as we will show). We will use this excellent answer here to solve the issue at hand:

"We" define a function which takes a function f and adds a multiple of th along the unit normal to the curve

thickness[f_, th_] := Block[{x}, {x, f} + Normalize[{-D[f, x], 1}] th]


For the purposes of our diagram, we only need basic functionality from the quoted answer, namely an example with constant thickness:

ParametricPlot[Evaluate@thickness[2 Sin[x],0.075 t],{x,0,3 Pi},{t,-1,1},Mesh->None,BoundaryStyle->None] and an example with varying thickness linearly with x:

ParametricPlot[Evaluate@thickness[2 Sin[x],0.075t(1+x/5) ],{x,0,3 Pi},{t,-1,1},Mesh->None,BoundaryStyle->None] That's it really! We define a sankeyRibbonFunction to define a sigmoid curve using the centroid of the same node control points we defined above:

sankeyRibbonFunction[{{sourceMin_, sourceMax_}, {targetMin_, targetMax_}}, width_ : 10] := With[{
sourceCentroid = Last@Mean[{sourceMin, sourceMax}],
targetCentroid = Last@Mean[{targetMin, targetMax}],
midpoint = First@ Mean[{sourceMin, targetMin}]},

(targetCentroid - sourceCentroid)/(1 + E^(-width (-midpoint + x))) +
sourceCentroid
]


and another function to ParametricPlot the sankey ribbon function with the appropriate thickness. If the target thickness is different than the source thickness, we use another sigmoid function to vary the thickness smoothly:

sankeyRibbonGraphics[{{sourceMin_, sourceMax_}, {targetMin_, targetMax_}}, colDirective_, width_ : 10] := With[
{heightSource = Last[sourceMax - sourceMin]/2,
heightTarget = Last[targetMax - targetMin]/2},
First[
ParametricPlot[
Evaluate@
thickness[
sankeyRibbonFunction[{{sourceMin, sourceMax}, {targetMin,
targetMax}}, width],
If[heightSource == heightTarget, heightSource t,
heightSource t + (heightTarget -
heightSource) t LogisticSigmoid[
5 (x - (First[sourceMin] + First[targetMin])/2)]
]],

{x, First[sourceMin], First[targetMin]}, {t, -1, 1},
PlotPoints -> {25, 3}, MaxRecursion -> 4, Mesh -> None,
BoundaryStyle -> None, PlotStyle -> colDirective]]]


We can then simply replace lines of the sort:

{Opacity[0.25],Blue,Polygon[Flatten[#,1],{1,3,4,2,1}]&/@Join[gendered2000[],gendered1900[]]}


in the parallel sets visualization above, with lines of the sort:

{sankeyRibbonGraphics[#,Directive[Opacity[0.25],Blue],7.5/2]&/@Join[gendered2000[],gendered1900[]]}


Here's the minified code:

sankeyDiagram=With[{gendered2000=TakeDrop[Thread[{positions[2000,"age-transposed"],positions[2000,"gender"]}],ageBinsLength],gendered1900=TakeDrop[Thread[{positions[1900,"gender"],positions[1900,"age-transposed"]}],ageBinsLength],streamPolygons=Thread[{positions[1900,"aggregate"],positions[2000,"aggregate"]}]},Graphics[{{sankeyRibbonGraphics[#,Directive[Opacity[0.25],Blue],7.5/2]&/@Join[gendered2000[],gendered1900[]]},{sankeyRibbonGraphics[#,Directive[Opacity[0.25],Red],7.5/2]&/@Join[gendered2000[],gendered1900[]]},{sankeyRibbonGraphics[#,Directive[Opacity[0.15],Black], 7.5/2]&/@streamPolygons},{Opacity,Blue,Rectangle@@{positions[1900,"gender"][[1,1]]+{-1/8,0},positions[1900,"gender"][[10,2]]}},{Opacity,Red,Rectangle@@{positions[1900,"gender"][[11,1]]+{-1/8,0},positions[1900,"gender"][[20,2]]}},{Opacity,Blue,Rectangle@@{positions[2000,"gender"][[1,1]],positions[2000,"gender"][[10,2]]+{1/8,0}}},{Opacity,Red,Rectangle@@{positions[2000,"gender"][[11,1]],positions[2000,"gender"][[20,2]]+{1/8,0}}},{Opacity,Black,Map[Rectangle@@(#+{{-1/8,0},{0,0}})&,positions[1900,"aggregate"]]},{Opacity,Black,Map[Rectangle@@(#+{{1/8,0},{0,0}})&,positions[2000,"aggregate"]]}},ImageSize->1250]]


Of-course, one could style this further in Mathematica, but in this case I exported the above as an svg, and added finishing touches like labels in a vector graphics software like Inkscape. The final result looks something like this: Pardon the long post, hopefully someone (perhaps me when I find time?) can generalize this to accept a general directed acyclic graph or similar.

## EDIT 01:

Code dump:

thickness[f_, th_] := Block[{x}, {x, f} + Normalize[{-D[f, x], 1}] th]

sankeyRibbonFunction[{{sourceMin_, sourceMax_}, {targetMin_,
targetMax_}}, width_ : 10] := With[{
sourceCentroid = Last@Mean[{sourceMin, sourceMax}],
targetCentroid = Last@Mean[{targetMin, targetMax}],
midpoint = First@ Mean[{sourceMin, targetMin}]},

(targetCentroid - sourceCentroid)/(1 + E^(-width (-midpoint + x))) +
sourceCentroid
]

sankeyRibbonGraphics[{{sourceMin_, sourceMax_}, {targetMin_,
targetMax_}}, colDirective_, width_ : 10] := With[
{heightSource = Last[sourceMax - sourceMin]/2,
heightTarget = Last[targetMax - targetMin]/2},
First[
ParametricPlot[
Evaluate@
thickness[
sankeyRibbonFunction[{{sourceMin, sourceMax}, {targetMin,
targetMax}}, width],
If[heightSource == heightTarget, heightSource t,
heightSource t + (heightTarget -
heightSource) t LogisticSigmoid[
width (x - (First[sourceMin] + First[targetMin])/2)]
]],

{x, First[sourceMin], First[targetMin]}, {t, -1, 1},
PlotPoints -> {25, 3}, MaxRecursion -> 4, Mesh -> None,
BoundaryStyle -> None, PlotStyle -> colDirective]]]

spaceAndNormalizeList[list_, spacer_ : 1/32] :=
DeleteCases[
Partition[Prepend[Accumulate[Flatten[Riffle[list, spacer]]], 0], 2,
1], {start_, end_} /;
end - start == spacer] - (Total[Flatten[list]] +
spacer*(Length[list] - 1))/2

parseSankeyAssociation[sankeyAssociation_Association] := Block[
{nodes, ribbons, values, groupedBySourceNodes, groupedByTargetNodes,
targetNodesTotals, sourceNodesTotals, nodeSpacers,
sourceTargetQ, lhs, rhs, middle, nodeWidth, ribbonWidth,
horizontalAnchors, verticalAnchors, ribbonPairs,
nodeColors, nodeColorsPrePartiotioned, ribbonColors,
ribbonColorOrder, ribbonPrimitives, nodePrimitives, nodePositions,
nodeAnchors},

{nodes, ribbons, values} =
Lookup[sankeyAssociation, {"nodes", "ribbons", "values"}];

(*Make all values length 2*)

values = If[Length[#] == 0, {#, #}, #] & /@ values;

groupedBySourceNodes =
KeySort[Map[First@*Last,
values}], {#[[1, 1, 1]] &, #[[1, 1, 2]] &}], {3}]];
groupedByTargetNodes =
KeySort[Map[Last@*Last,
values}], {#[[1, 2, 1]] &, #[[1, 2, 2]] &}], {3}]];
sourceNodesTotals = Map[Total, groupedBySourceNodes, {2}];
targetNodesTotals = Map[Total, groupedByTargetNodes, {2}];

(*x positions of ribbon control points*)

nodeWidth = Lookup[sankeyAssociation, "node-width", 1/8];
ribbonWidth = Lookup[sankeyAssociation, "ribbon-width", 4];
horizontalAnchors =
Accumulate[
Most[Riffle[ConstantArray[nodeWidth, Length[nodes]],
ribbonWidth]]];

(*y positions of ribbon control points*)

verticalAnchors =
Riffle[Values[groupedBySourceNodes],
Values[groupedByTargetNodes]];
verticalAnchors = spaceAndNormalizeList@*Values /@ verticalAnchors;

(*match ribbons*)

ribbonPairs =
Partition[
verticalAnchors[[i]], {2}], {i, Length[verticalAnchors]}], 2];
ribbonColorOrder =
Lookup[sankeyAssociation, "ribbon-color-order",
ConstantArray["source", Length[ribbonPairs]]];
ribbonPairs = Table[Switch[ribbonColorOrder[[i]],
"source",
Join @@ Transpose[
Partition[ribbonPairs[[i, 2]],
Length[sourceNodesTotals[[i]]]]]}],
"target",
Partition[ribbonPairs[[i, 1]],
Length[targetNodesTotals[[i]]]]], ribbonPairs[[i, 2]]}]]
, {i, Length[ribbonPairs]}];

nodeColorsPrePartiotioned =
If[KeyExistsQ[sankeyAssociation, "node-colors"],
Lookup[sankeyAssociation, "node-colors"],
TakeList[RandomColor[Total[Length /@ nodes]],
Values[Length /@ nodes]]];
nodeColors = Partition[nodeColorsPrePartiotioned, 2, 1];
ribbonPrimitives = Table[
ribbonColors = Switch[ribbonColorOrder[[i]],
"source",
Flatten[Transpose[
Partition[
nodeColors[[i, 1]]], Length[sourceNodesTotals[[i]]]]]],
"target",
Flatten[Transpose[
Partition[
nodeColors[[i, 2]]], Length[targetNodesTotals[[i]]]]]]];
sankeyRibbonGraphics[#1, Directive[Opacity[0.25], #2],
ribbonWidth] &, {ribbonPairs[[i]], ribbonColors}], {i,
Length[ribbonPairs]}];

nodePositions =
spaceAndNormalizeList@*Values /@
Append[sourceNodesTotals,
Max[Keys[nodes]] -> targetNodesTotals[Max[Keys[nodes]]]];
nodeAnchors =
Partition[
Append[Prepend[horizontalAnchors, 0],
Last[horizontalAnchors] + nodeWidth], 2];
nodePrimitives =
Table[{#1[[i]],
Rectangle[{#2[], #3[[i, 1]]}, {#2[], #3[[i, 2]]}]}, {i,
Length[#3]}] &, {nodeColorsPrePartiotioned, nodeAnchors,
Values[nodePositions]}];
Join[nodePrimitives, ribbonPrimitives]

]


Code and explanatory note: https://github.com/calischs/Sankey

• Note for visitors in a hurry : In the first link one discovers that a certain Sam Calisch has implemented sankeys-diagrams in Mathematica code (turns out to be Version 6). The second link gives the code. It looks like serious. Apr 6 '19 at 20:59
• Can you show how to use it to address OP's problem?
– Kuba
Apr 6 '19 at 21:06
• Wow, this can produce beautiful results, but it sure could use more documentation! Apr 7 '19 at 19:29