# Graphing a network with state transition flows (of varying size)

In one of Stephen Wolfram's recent blog posts (http://blog.stephenwolfram.com/2013/04/data-science-of-the-facebook-world/#more-5350) he provides the network plot below. The size of the arrows that connects the different countries is supposed to illustrate the volume of people that moved from country X to country Y.

My questions:

1. Can somebody please illustrate how to replicate this graph in mathematica (or at least point out "relevant" documentation)?
2. [Bonus part] would it be possible to have the size of the flags (or just the end nodes) correspond to the size of the given country's population (i.e. Chinas flag will be relatively larger than USA's Flag, who's flag will be larger than that of the UK, etc.)?

-
As to "relevant" documentation: I would have a look at the tutorial GraphDrawing and at WeightedAdjacencyGraph to begin with. – eldo Jun 8 '14 at 14:57
Take a look also at GraphLayout (CircularEmbedding) reference.wolfram.com/mathematica/ref/GraphLayout.html and also at EdgeShapeFunction reference.wolfram.com/mathematica/ref/EdgeShapeFunction.html – DavidC Jun 8 '14 at 14:58
BTW, I for one am disappointed that Wolfram Blog doesn't make the source code available and easily accessible, contrary to its earlier practice. – DavidC Jun 8 '14 at 15:19
Thanks for the comments. I also found one example in the new Wolfram Language documentation that has some similar features to the problem above (see: reference.wolfram.com/language/example/…). – Seb Jun 8 '14 at 16:11

I start from a random graph and replace vertices with flags of countries in South America.

vflag[center : {x_, y_}, flag_, r_] :=
Rotate[Inset[flag, center, Automatic, r], ArcTan[y/x] + 90 Degree,
center]

flags = CountryData["SouthAmerica", "Flag"];

g = VertexReplace[
RandomGraph[{14, 30}, DirectedEdges -> True,
GraphLayout -> "CircularEmbedding", VertexShapeFunction -> vflag,
VertexSize -> 1], Thread[Range[14] -> flags]]


And now , define edge shape function.

h = Graphics[Polygon[{{-1, 1/2}, {0, 0}, {-1, -1/2}}]];

curved[weight_: .5][
pt : {x_, ___,
weight, {0, 1}, {.004, .045}], .35, {h, 0}}}],
Opacity[Rescale[weight, {0, 1}, {.2, .8}]],
Arrow[BSplineCurve[{x, {0, 0}, y},
SplineWeights -> {1, EuclideanDistance[x, y]/4, 1}]]}

SetProperty[g, {EdgeShapeFunction -> (curved[][##] &)}]


to assign weight to edges, I wrote another function.

SetAttributes[setWeightFunction, HoldRest];
setWeightFunction[g_, weight_, wFunction_] :=
Set[wFunction[#1], #2] & @@@
Transpose[{EdgeList[g],
Rescale[weight, {Min[weight], Max[weight]}, {0, 1}]}];

weights = RandomReal[{1, 2}, EdgeCount[g]];

setWeightFunction[g, weights, wfunc];

SetProperty[g, {EdgeShapeFunction -> (curved[wfunc[#2]][##] &)}]


Finally, you can set vertex size to change the size of flags.

pop = CountryData["SouthAmerica", "Population"];
pop = Rescale[pop, {Min[pop], Max[pop]}, {.7, 1.2}];

fg = SetProperty[
g, {EdgeShapeFunction -> (curved[wfunc[#2]][##] &),


-

Here is a Graphics based idea. Since you haven't provided any data everything is randomized.

n = 10;
coord = Table[{Cos[2 Pi i], Sin[2 Pi i]}, {i, 0, 1, 1/n}];
coordFlag = 1.05*coord;
rot = Pi/2 + #*Pi/n & /@ Range[0, n*2, 2 ];
rule = With[{sub = DeleteDuplicates@Subsets[Range@(n + 1), {2}]},
rect[{xc_, yc_}] :=
Graphics@{RGBColor[RandomReal[{}, 3]],
Rectangle[{xc - 1, yc - 0.5}, {xc + 1, yc + .5}]}
arrows = {
Opacity@Rescale[#2, {0, 150}],

Thread[{Rule @@@ First /@ rule, Last /@ rule}] // Short

{{1→2,7.30901},{1→3,21.2583},{1→4,89.7993},<<50>>,{9→11,10.6497},{10→11,85.3327}}