4
$\begingroup$

I'd like to create a graph where the vertices are replaced by scaled versions of images, with the images fitting in the circles (like the avatar here).

My attempt at this graph simply overlays the flags, creating a very ugly outcome:enter image description here

Here's the code sample that generated the graph above.

v1 = {"Australia", "Austria", "Belgium"};
vSize1 = {1, 3, 0.3};
vSizeRule1 = Transpose@{v1, vSize1} /. List[a_, b_] -> Rule[a, b];
m1 = {{∞, 1, 1}, {1, ∞, 
    1}, {1, ∞, ∞}};
vShapeRule1 = 
 Flatten[# -> Placed[CountryData[#, "Flag"], Center] & /@ v1]
g1 = Graph[
  WeightedAdjacencyGraph[v1, m1],
  VertexLabels -> vShapeRule1,
  VertexSize -> vSizeRule
  ]

How can I do better without downloading circular avatars and scaling them by hand?

$\endgroup$
2
  • $\begingroup$ Related: mathematica.stackexchange.com/questions/95799/… $\endgroup$ May 11 '17 at 1:52
  • $\begingroup$ I do not have time to update my answer, but here's what can be improved if you want to set different vertex sizes for each vertex and maintain a good appearance: instead of VertexShape, use a VertexShapeFunction that returns the appropriate shape for each vertex. The sizes should still be set through VertexSize. Finally, add PerformanceGoal -> "Quality". I am not sure it will work, but it is what I would try. $\endgroup$
    – Szabolcs
    May 11 '17 at 8:28
6
$\begingroup$

tl;dr Use VertexShape, and create a Textured polygon for each country.


v1 = {"Australia", "Austria", "Belgium"};

disk = {EdgeForm[Black], 
   Polygon[#, VertexTextureCoordinates -> #] &@
    CirclePoints[{1/2, 1/2}, 1/2, 25]};

vertexShapes = 
 Graphics@{Texture@Image@CountryData[#, "Flag"], disk} & /@ v1

Mathematica graphics

Of course, this needs some improvement. In particular, the aspect ratio of the flags should be less distorted. That is a bit difficult because this differs from flag to flag.

VertexReplace[
 CompleteGraph[3, DirectedEdges -> True, 
  VertexShape -> Thread[Range[3] -> vertexShapes], VertexSize -> 0.3, 
  EdgeStyle -> Gray],
 Thread[Range[3] -> v1]
 ]

Mathematica graphics


Update

v1 = {"Australia", "Austria", "Belgium"};

disk = {EdgeForm[Black], 
   Polygon[CirclePoints[30], 
    VertexTextureCoordinates -> CirclePoints[{1/2, 1/2}, 1/2, 30]]};

vertexShapes = 
 Graphics@{Texture@
      Rasterize[CountryData[#, "Flag"], "Image", ImageSize -> 200], 
     disk} & /@ v1

shapes = AssociationThread[v1, vertexShapes]

shapeFun[pt_, v_, sz_] := Translate[Scale[First@shapes[v], sz], pt]

g = VertexReplace[
  CompleteGraph[3, DirectedEdges -> True],
  Thread[Range[3] -> v1]
  ]

Graph[g, VertexShapeFunction -> shapeFun, 
 VertexSize -> Thread[v1 -> {.2, .4, .3}], 
 PerformanceGoal -> "Quality", EdgeStyle -> Gray]

Key points:

For correct arrowhead positioning with scaled vertices, we need to add PerformanceGoal -> "Quality", and we need to specify the vertex shapes as graphics primitives. VertexShape uses an Inset under the hood, which prevents the system from detecting the shape of the vertex and placing the arrowheads at the right place. It will treat the vertices as rectangles. To work around this, we needed to use VertexShapeFunction.

$\endgroup$
2
$\begingroup$

Here are two possibilities. Both are improvements over what you show, The 1st one makes square flags just fill the vertex circles; the 2nd makes the flags just fill the vertex circles, but maintains their aspect ratios.

Countries

countries = {"Australia", "Austria", "Belgium"};

Square flags

ShapeRule1 = 
  # -> 
    Placed[
      Show[CountryData[#, "Flag"], AspectRatio -> 1, ImageSize -> 70.7], 
      Center] & /@ countries;

Graph[
  WeightedAdjacencyGraph[countries, {{∞, 1, 1}, {1, ∞, 1}, {1, ∞, ∞}}],
  VertexLabels -> ShapeRule1,
  VertexSize -> Large]

graph1

Flags with preserved aspect ratios

flagSize[aspectRatio_] :=
  Module[{n = Numerator[aspectRatio], d = Denominator[aspectRatio]},
    100. d/Norm[{n, d}]]

ShapeRule2 =
  # ->
     Placed[
       Show[CountryData[#, "Flag"], 
         ImageSize -> flagSize[ImageAspectRatio[CountryData[#, "Flag"]]]], 
       Center] & /@ countries;

Graph[
  WeightedAdjacencyGraph[countries, {{∞, 1, 1}, {1, ∞, 1}, {1, ∞, ∞}}],
  VertexLabels -> ShapeRule2,
  VertexSize -> Large]

graph2

$\endgroup$
2
$\begingroup$

In:

cs = {"Australia", "Austria", "Belgium"};
imageResize[image_] := ImageResize[image, {128, 96}];
shapeRule = Rule[#, imageResize@CountryData[#, "Flag"]] & /@ cs;
m1 = {{\[Infinity], 1, 1}, {1, \[Infinity], 
   1}, {1, \[Infinity], \[Infinity]}}
g1 = Graph[WeightedAdjacencyGraph[v1, m1], VertexSize -> Large, 
  VertexShape -> shapeRule]

Out:

Mathematica graphics

$\endgroup$

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.