14
$\begingroup$

I'm looking for a way to create a nodal graph of clusters of countries that border each other.

I have the code for finding the bordering countries of, say, Germany:

Entity["Country", "Germany"][EntityProperty["Country", "BorderingCountries"]]

(Austria | Belgium | Czech Republic | Denmark | France | Luxembourg | Netherlands | Poland | Switzerland)

and France:

Entity["Country", "France"][EntityProperty["Country", "BorderingCountries"]]

(Andorra | Belgium | Germany | Italy | Luxembourg | Monaco | Spain | Switzerland)

So from this information I want to create something that looks like this: here

Is this possible? How would I do this?

$\endgroup$
1

2 Answers 2

21
$\begingroup$

France and Germany

countries = {Entity["Country", "France"], Entity["Country", "Germany"]};
data = EntityValue[countries, "BorderingCountries", "EntityAssociation"];

vertices = Keys[data];
edges = UndirectedEdge @@@ Join @@ Thread /@ Normal[data];

SimpleGraph[Graph[vertices, edges], VertexLabels -> "Name"]

enter image description here

(It's too bad the default layout places Belgium right on the edge connecting France and Germany.)

All Countries

data = EntityValue["Country", "BorderingCountries", "EntityAssociation"];

vertices = Keys[data];
edges = UndirectedEdge @@@ Join @@ Thread /@ DeleteMissing[Normal[data], 1];

SimpleGraph[Graph[vertices, edges]]

enter image description here

If you want to add coordinates:

pos = Reverse[EntityValue["Country", "Position"][[All, 1]], {2}];

SimpleGraph[Graph[vertices, edges], VertexCoordinates -> pos, ImageSize -> Large]

enter image description here

If you want a background in your Graph object:

background = {EdgeForm[Thin], LightGray, EntityValue["Country", "Polygon"]};

SimpleGraph[
  Graph[vertices, edges], 
  VertexCoordinates -> pos, 
  ImageSize -> Large, 
  VertexSize -> 20,
  VertexStyle -> Green, 
  EdgeStyle -> {Thick, Red}, 
  Prolog -> background
]

enter image description here

$\endgroup$
4
  • $\begingroup$ Nice and simple! $\endgroup$ Feb 20, 2018 at 21:56
  • $\begingroup$ For some reason I get an error when this runs. $\endgroup$ Dec 4, 2021 at 22:02
  • $\begingroup$ This returns an error of Join::heads: Heads List and Rule at positions 1 and 99 are expected to be the same. for me. $\endgroup$ Dec 4, 2021 at 22:13
  • $\begingroup$ See my edit. Had to take Normal[data] to DeleteMissing[Normal[data], 1]. For whatever reason Hong Kong and Macau now point to Missing["NotApplicable"] instead of {}. $\endgroup$
    – Greg Hurst
    Dec 5, 2021 at 20:42
1
$\begingroup$

I dont know how to combine them though.

list = CanonicalName[
       Entity["Country", "Germany"][
        EntityProperty["Country", "BorderingCountries"]]];

    StarGraph[Length@list + 1, 
     VertexLabels -> 
      Table[i -> Placed[Join[{"Germany"}, list][[i]], Center], {i, 
        Length@list + 1}], ImageSize -> 450, VertexSize -> 0.6, 
     VertexShapeFunction -> "Capsule", VertexStyle -> LightGreen]

enter image description here

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