Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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

share|improve this question
    
As to "relevant" documentation: I would have a look at the tutorial GraphDrawing and at WeightedAdjacencyGraph to begin with. –  eldo Jun 8 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 –  David Carraher Jun 8 at 14:58
2  
BTW, I for one am disappointed that Wolfram Blog doesn't make the source code available and easily accessible, contrary to its earlier practice. –  David Carraher Jun 8 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 at 16:11

2 Answers 2

up vote 9 down vote accepted

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

share|improve this answer

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}}
share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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