29
$\begingroup$

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

enter image description here

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

result = Flatten[MapThread[f, {start, end}]]

Graph[result]

enter image description here

$\endgroup$
47
$\begingroup$

Here's the start of a SankeyDiagram function:

Options[SankeyDiagram] = Join[
    {ColorFunction -> {"Start" -> ColorData[97], "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
}]

enter image description here

$\endgroup$
2
$\begingroup$

See: https://visualign.wordpress.com/2012/05/14/sankey-diagrams/

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

$\endgroup$
  • 1
    $\begingroup$ 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. $\endgroup$ – andre314 Apr 6 at 20:59
  • 2
    $\begingroup$ Can you show how to use it to address OP's problem? $\endgroup$ – Kuba Apr 6 at 21:06
  • $\begingroup$ Wow, this can produce beautiful results, but it sure could use more documentation! $\endgroup$ – Chris K Apr 7 at 19:29

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.