Wolfram Language™

Conectividad de condados de EE.UU.

Construya el grafo de conectividad entre condados vecinos de EE.UU.

Tome la lista de todos los condados en los estados contiguos de los EE.UU. continentales.

In[1]:=

Length[counties = Flatten[EntityClass["AdministrativeDivision", "ContinentalUSStates"]["Subdivisions"]]]

Out[1]=

Agregue el Distrito de Columbia, el cual no es una subdivisión de ninguno de los 48 estados contiguos.

In[2]:=

AppendTo[counties, Entity["AdministrativeDivision", {"DistrictOfColumbia", "DistrictOfColumbia", "UnitedStates"}]];

Calcule la lista de condados límite de cada estado.

In[3]:=

bordering = EntityValue[counties, "BorderingCounties"];

Elimine algunos casos para los cuales información de límite no está disponible.

In[4]:=

Length[missingpos = Position[bordering, _Missing]]

Out[4]=

In[5]:=

counties = Delete[counties, missingpos]; bordering = Delete[bordering, missingpos];

Construya los bordes del grafo de conectividad de los condados de EE.UU.

In[6]:=

Length[edges = DeleteDuplicates[ Sort /@ Flatten[ MapThread[Thread[UndirectedEdge[##]] &, {counties, bordering}]]]]

Out[6]=

In[7]:=

Graph[counties, edges]

Out[7]=

Para construir una incrustación más familiar, descarga la posición central de todos los condados.

In[8]:=

pos = GeoPosition[EntityValue[counties, "Position"]]

Out[8]=

Utilice la siguiente proyección cartográfica.

In[9]:=

proj = {"LambertAzimuthal", "Centering" -> Entity["City", {"Topeka", "Kansas", "UnitedStates"}]};

In[10]:=

projpos = First@GeoGridPosition[pos, proj];

Luego, usted tiene el siguiente incrustación de grafo.

In[11]:=

graph = Graph[counties, edges, VertexCoordinates -> projpos]

Out[11]=

Para ir del condado de San Francisco a Manhattan, usted necesita visitar al menos 67 condados, incluyendo los iniciales y finales.

In[12]:=

Length[path = FindShortestPath[graph, Entity[ "AdministrativeDivision", {"SanFranciscoCounty", "California", "UnitedStates"}], Entity[ "AdministrativeDivision", {"NewYorkCounty", "NewYork", "UnitedStates"}]]]

Out[12]=

In[13]:=

HighlightGraph[graph, PathGraph[path]]

Out[13]=