Graph-like info-graphics












2












$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.










share|improve this question











$endgroup$












  • $begingroup$
    Fundamentally this is made challenging by what Szabolcs' mentions here: community.wolfram.com/groups/-/m/t/1060237 If multigraph styling were supported properly this'd be easy.
    $endgroup$
    – b3m2a1
    2 hours ago
















2












$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.










share|improve this question











$endgroup$












  • $begingroup$
    Fundamentally this is made challenging by what Szabolcs' mentions here: community.wolfram.com/groups/-/m/t/1060237 If multigraph styling were supported properly this'd be easy.
    $endgroup$
    – b3m2a1
    2 hours ago














2












2








2


2



$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.










share|improve this question











$endgroup$




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.







graphs-and-networks directed






share|improve this question















share|improve this question













share|improve this question




share|improve this question








edited 2 hours ago







David G. Stork

















asked 3 hours ago









David G. StorkDavid G. Stork

24.2k22153




24.2k22153












  • $begingroup$
    Fundamentally this is made challenging by what Szabolcs' mentions here: community.wolfram.com/groups/-/m/t/1060237 If multigraph styling were supported properly this'd be easy.
    $endgroup$
    – b3m2a1
    2 hours ago


















  • $begingroup$
    Fundamentally this is made challenging by what Szabolcs' mentions here: community.wolfram.com/groups/-/m/t/1060237 If multigraph styling were supported properly this'd be easy.
    $endgroup$
    – b3m2a1
    2 hours ago
















$begingroup$
Fundamentally this is made challenging by what Szabolcs' mentions here: community.wolfram.com/groups/-/m/t/1060237 If multigraph styling were supported properly this'd be easy.
$endgroup$
– b3m2a1
2 hours ago




$begingroup$
Fundamentally this is made challenging by what Szabolcs' mentions here: community.wolfram.com/groups/-/m/t/1060237 If multigraph styling were supported properly this'd be easy.
$endgroup$
– b3m2a1
2 hours ago










1 Answer
1






active

oldest

votes


















3












$begingroup$

Final result:



enter image description here



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


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.






share|improve this answer











$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
    54 mins ago










  • $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
    45 mins ago










  • $begingroup$
    @DavidG.Stork how does it look now? All it took was a bit of sorting :)
    $endgroup$
    – b3m2a1
    42 mins ago











Your Answer





StackExchange.ifUsing("editor", function () {
return StackExchange.using("mathjaxEditing", function () {
StackExchange.MarkdownEditor.creationCallbacks.add(function (editor, postfix) {
StackExchange.mathjaxEditing.prepareWmdForMathJax(editor, postfix, [["$", "$"], ["\\(","\\)"]]);
});
});
}, "mathjax-editing");

StackExchange.ready(function() {
var channelOptions = {
tags: "".split(" "),
id: "387"
};
initTagRenderer("".split(" "), "".split(" "), channelOptions);

StackExchange.using("externalEditor", function() {
// Have to fire editor after snippets, if snippets enabled
if (StackExchange.settings.snippets.snippetsEnabled) {
StackExchange.using("snippets", function() {
createEditor();
});
}
else {
createEditor();
}
});

function createEditor() {
StackExchange.prepareEditor({
heartbeatType: 'answer',
autoActivateHeartbeat: false,
convertImagesToLinks: false,
noModals: true,
showLowRepImageUploadWarning: true,
reputationToPostImages: null,
bindNavPrevention: true,
postfix: "",
imageUploader: {
brandingHtml: "Powered by u003ca class="icon-imgur-white" href="https://imgur.com/"u003eu003c/au003e",
contentPolicyHtml: "User contributions licensed under u003ca href="https://creativecommons.org/licenses/by-sa/3.0/"u003ecc by-sa 3.0 with attribution requiredu003c/au003e u003ca href="https://stackoverflow.com/legal/content-policy"u003e(content policy)u003c/au003e",
allowUrls: true
},
onDemand: true,
discardSelector: ".discard-answer"
,immediatelyShowMarkdownHelp:true
});


}
});














draft saved

draft discarded


















StackExchange.ready(
function () {
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fmathematica.stackexchange.com%2fquestions%2f190361%2fgraph-like-info-graphics%23new-answer', 'question_page');
}
);

Post as a guest















Required, but never shown

























1 Answer
1






active

oldest

votes








1 Answer
1






active

oldest

votes









active

oldest

votes






active

oldest

votes









3












$begingroup$

Final result:



enter image description here



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


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.






share|improve this answer











$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
    54 mins ago










  • $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
    45 mins ago










  • $begingroup$
    @DavidG.Stork how does it look now? All it took was a bit of sorting :)
    $endgroup$
    – b3m2a1
    42 mins ago
















3












$begingroup$

Final result:



enter image description here



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


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.






share|improve this answer











$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
    54 mins ago










  • $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
    45 mins ago










  • $begingroup$
    @DavidG.Stork how does it look now? All it took was a bit of sorting :)
    $endgroup$
    – b3m2a1
    42 mins ago














3












3








3





$begingroup$

Final result:



enter image description here



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


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.






share|improve this answer











$endgroup$



Final result:



enter image description here



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


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.







share|improve this answer














share|improve this answer



share|improve this answer








edited 28 mins ago

























answered 1 hour ago









b3m2a1b3m2a1

27.4k257160




27.4k257160












  • $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
    54 mins ago










  • $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
    45 mins ago










  • $begingroup$
    @DavidG.Stork how does it look now? All it took was a bit of sorting :)
    $endgroup$
    – b3m2a1
    42 mins ago


















  • $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
    54 mins ago










  • $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
    45 mins ago










  • $begingroup$
    @DavidG.Stork how does it look now? All it took was a bit of sorting :)
    $endgroup$
    – b3m2a1
    42 mins ago
















$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
54 mins ago




$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
54 mins ago












$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
45 mins ago




$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
45 mins ago












$begingroup$
@DavidG.Stork how does it look now? All it took was a bit of sorting :)
$endgroup$
– b3m2a1
42 mins ago




$begingroup$
@DavidG.Stork how does it look now? All it took was a bit of sorting :)
$endgroup$
– b3m2a1
42 mins ago


















draft saved

draft discarded




















































Thanks for contributing an answer to Mathematica Stack Exchange!


  • Please be sure to answer the question. Provide details and share your research!

But avoid



  • Asking for help, clarification, or responding to other answers.

  • Making statements based on opinion; back them up with references or personal experience.


Use MathJax to format equations. MathJax reference.


To learn more, see our tips on writing great answers.




draft saved


draft discarded














StackExchange.ready(
function () {
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fmathematica.stackexchange.com%2fquestions%2f190361%2fgraph-like-info-graphics%23new-answer', 'question_page');
}
);

Post as a guest















Required, but never shown





















































Required, but never shown














Required, but never shown












Required, but never shown







Required, but never shown

































Required, but never shown














Required, but never shown












Required, but never shown







Required, but never shown







Popular posts from this blog

Ponta tanko

Tantalo (mitologio)

Erzsébet Schaár