Wolfram Language

Geo Data

Connectivity of US Counties

Construct the connectivity graph between neighboring US counties.

Take the list of all counties in the contiguous continental US states.

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

Add the District of Columbia, which is not a subdivision of any of the 48 contiguous states.

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

Compute the list of counties bordering each county.

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

Discard some cases for which bordering information is not available.

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];

Construct the edges of the connectivity graph of the US counties.

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]=

To construct a more familiar embedding, download the center position of all counties.

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

Use the following cartographic projection.

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];

Then you have the following graph embedding.

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

To go from the county of San Francisco to Manhattan, you need to visit at least 67 counties, including the initial and final ones.

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]=

Related Examples

de es fr ja ko pt-br ru zh