Wolfram Language

Données géographiques

Connectivité des comtés américains

Construisez le graphe de connectivité entre les comtés américains voisins.

Prenez la liste de tous les comtés dans les États continentaux contigus.

In[1]:=
Click for copyable input
Length[counties = Flatten[EntityClass["AdministrativeDivision", "ContinentalUSStates"]["Subdivisions"]]]
Out[1]=

Ajoutez le district de Columbia, qui n'est pas une subdivision de l'un des 48 états contigus.

In[2]:=
Click for copyable input
AppendTo[counties, Entity["AdministrativeDivision", {"DistrictOfColumbia", "DistrictOfColumbia", "UnitedStates"}]];

Calculez la liste des comtés limitrophes de chaque comté.

In[3]:=
Click for copyable input
bordering = EntityValue[counties, "BorderingCounties"];

Rejetez certains cas pour lesquels des informations limitrophes ne sont pas disponibles.

In[4]:=
Click for copyable input
Length[missingpos = Position[bordering, _Missing]]
Out[4]=
In[5]:=
Click for copyable input
counties = Delete[counties, missingpos]; bordering = Delete[bordering, missingpos];

Construisez les bords du graphique de connectivité des comtés américains.

In[6]:=
Click for copyable input
Length[edges = DeleteDuplicates[ Sort /@ Flatten[ MapThread[Thread[UndirectedEdge[##]] &, {counties, bordering}]]]]
Out[6]=
In[7]:=
Click for copyable input
Graph[counties, edges]
Out[7]=

Pour construire un plongement plus familier, téléchargez la position centrale de tous les comtés.

In[8]:=
Click for copyable input
pos = GeoPosition[EntityValue[counties, "Position"]]
Out[8]=

Utilisez la projection cartographique suivante.

In[9]:=
Click for copyable input
proj = {"LambertAzimuthal", "Centering" -> Entity["City", {"Topeka", "Kansas", "UnitedStates"}]};
In[10]:=
Click for copyable input
projpos = First@GeoGridPosition[pos, proj];

Et vous obtenez le plongement de graphe suivant.

In[11]:=
Click for copyable input
graph = Graph[counties, edges, VertexCoordinates -> projpos]
Out[11]=

Pour sortir du comté de San Francisco pour aller à Manhattan, vous devez visiter au moins 67 comtés incluant ces premiers et ces derniers.

In[12]:=
Click for copyable input
Length[path = FindShortestPath[graph, Entity[ "AdministrativeDivision", {"SanFranciscoCounty", "California", "UnitedStates"}], Entity[ "AdministrativeDivision", {"NewYorkCounty", "NewYork", "UnitedStates"}]]]
Out[12]=
In[13]:=
Click for copyable input
HighlightGraph[graph, PathGraph[path]]
Out[13]=

Exemples connexes

de en es ja ko pt-br ru zh