11
$\begingroup$

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.)?

Image from Wolfram's Blog Post

$\endgroup$
4
  • $\begingroup$ As to "relevant" documentation: I would have a look at the tutorial GraphDrawing and at WeightedAdjacencyGraph to begin with. $\endgroup$
    – eldo
    Commented Jun 8, 2014 at 14:57
  • $\begingroup$ 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 $\endgroup$
    – DavidC
    Commented Jun 8, 2014 at 14:58
  • 2
    $\begingroup$ BTW, I for one am disappointed that Wolfram Blog doesn't make the source code available and easily accessible, contrary to its earlier practice. $\endgroup$
    – DavidC
    Commented Jun 8, 2014 at 15:19
  • $\begingroup$ 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/…). $\endgroup$
    – Seb
    Commented Jun 8, 2014 at 16:11

2 Answers 2

12
$\begingroup$

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

enter image description here

And now , define edge shape function.

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

curved[weight_: .5][
  pt : {x_, ___, 
    y_}, __] := {Arrowheads[{{Rescale[
      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[][##] &)}]

enter image description here

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]][##] &)}]

enter image description here

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]][##] &), 
   VertexSize -> Thread[flags -> pop]}]

enter image description here

$\endgroup$
0
6
$\begingroup$

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}]},
   Thread[{sub, RandomReal[{0, 100}, Length@sub]}]];
rect[{xc_, yc_}] := 
  Graphics@{RGBColor[RandomReal[{}, 3]], 
            Rectangle[{xc - 1, yc - 0.5}, {xc + 1, yc + .5}]}
arrows = {
  Opacity@Rescale[#2, {0, 150}], 
  Arrowheads[{{Rescale[#2, {0, 1500}], .5}}], 
  Arrow[BezierCurve[{coord[[#[[1]]]], {0, 0},coord[[#[[2]]]]}]]} & @@@ rule; 
flags = Rotate[Inset[rect[{0, 0}], coordFlag[[#]], {0, 0}, .3], rot[[#]]] &;
Graphics[{arrows, Opacity@1, flags /@ Range@n}, ImageSize -> 350, 
  PlotRange -> 1.3]

Mathematica graphics

If one wants to visualize the rule:

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}}
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.