Contiguous USA Graph

Author

Eric W. Weisstein
February 12, 2014

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/ContiguousUSAGraph.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/ContiguousUSAGraph.html.

©2014 Wolfram Research, Inc. except for portions noted otherwise

Image

kstates={"AL","FL","GA","MS","TN","AR","LA","MO","OK","TX","AZ","CA","NM","NV","UT","OR","CO","KS","NE","WY","CT","MA","NY","RI","DC","MD","VA","DE","NJ","PA","NC","SC","IA","IL","MN","SD","WI","ID","MT","WA","IN","KY","MI","OH","WV","NH","VT","ME","ND"};

Tally[Sort[kstates]][[All,2]]//Union

GraphPlot[GraphData["ContiguousUSAGraph"],VertexRenderingFunction->({White,EdgeForm[Black],Rectangle[#-.3,#+.3,RoundingRadius->.2],Black,Text[#2/.Thread[Range[Length[kstates]]->kstates],#1]}&)]

Neighbors

Tally[Sort[d=GraphData["ContiguousUSAGraph","Degrees"]]]

(#[[1,1]]->#[[All,2]])&/@SplitBy[Sort[MapIndexed[{#,states[[#2[[1]]]]}&,d]],First]//Column

Construction

Knuth

usa=System`Graph[UndirectedEdge@@@Import["http://www-cs-staff.stanford.edu/~uno/contiguous-usa.dat"]]

ToEntity[usa]

CanonicalName[%]

Attempt to import PDF image

Import["~/v4f0.pdf",{"PDF",{"Pages",15}}]

Import["~/v4f0-p15.pdf"]

Attempt to image-process image

gif=Import["/Users/eww/Documents/Troves/MathOzTeX/graphics/gifs/ContiguousUSAGraph.gif"]

ColorNegate[]

g=MorphologicalGraph[%]

VertexCount[g]

By hand

GraphData["ContiguousUSAGraph","Image"]

g=;

g2=Graphics[g[[1,1]]]

gc=g2[[1,1]]

Min/@Transpose[gc]

gc2=(#-{-1.5853364677583157`,-1.667059117754082`})&/@gc

Max/@Transpose[gc2]

f/@gc2

gc3=Round[({12#[[1]]/15.825066436279482`,6#[[2]]/7.31832112056444`})&/@gc2]

gc3={{7,1},{8,0},{8,1},{6,1},{7,2},{5,2},{5,1},{5,3},{4,2},{4,1},{2,2},{0,3},{3,2},{1,3},{2,3},{1,4},{3,3},{4,3},{4,4},{3,4},{11,4},{11,5},{10,5},{12,4},{9,2},{9,3},{8,2},{10,3},{10,4},{9,4},{9,1},{9,0},{5,4},{6,4},{5,5},{4,5},{6,5},{2,4},{3,5},{1,5},{7,4},{7,3},{7,5},{8,4},{8,3},{11,6},{10,6},{12,6},{4,6}};

Union[gc3]

lines=Graphics[GraphicsComplex[gc3,Line[{{1,2},{1,3},{1,4},{1,5},{2,3},{3,5},{3,31},{3,32},{4,5},{4,6},{4,7},{5,6},{5,8},{5,27},{5,31},{5,42},{6,7},{6,8},{6,9},{6,10},{7,10},{8,9},{8,18},{8,19},{8,33},{8,34},{8,42},{9,10},{9,13},{9,17},{9,18},{10,13},{11,12},{11,13},{11,14},{11,15},{12,14},{12,16},{13,17},{14,15},{14,16},{14,38},{15,17},{15,20},{15,38},{16,38},{16,40},{17,18},{17,19},{17,20},{18,19},{19,20},{19,33},{19,36},{20,36},{20,38},{20,39},{21,22},{21,23},{21,24},{22,23},{22,24},{22,46},{22,47},{23,29},{23,30},{23,47},{25,26},{25,27},{26,27},{26,28},{26,30},{26,45},{27,31},{27,42},{27,45},{28,29},{28,30},{29,30},{30,44},{30,45},{31,32},{33,34},{33,35},{33,36},{33,37},{34,37},{34,41},{34,42},{35,36},{35,37},{35,49},{36,39},{36,49},{37,43},{38,39},{38,40},{39,49},{41,42},{41,43},{41,44},{42,44},{42,45},{43,44},{44,45},{46,47},{46,48}}]]]

ShowGraph[gnew=LinesToGraph[Normal@lines,.5]]

RecognizeGraph[gnew]

FindGraphIsomorphism[CombinatoricaGraphToV8Graph[gnew],GraphData["ContiguousUSAGraph"]]

vs=Round[10^4ToCommonEdges[gnew,Graph["ContiguousUSAGraph"]]]

GetGraphData["ContiguousUSAGraph","File",#]&/@{"8.0","9.0"}

gg=System`Graph[GraphData["ContiguousUSAGraph","EdgeList"],System`VertexCoordinates->Thread[Range[49]->vs]]

RecognizeGraph[gg]

SetProperty[gg=GraphData["ContiguousUSAGraph"],VertexLabels->"Name"]

Wolfram|Alpha

Using W|A

states=DeleteCases[GeneralData[USStateData,"Entity"],"Guam"|"PuertoRico"|"UnitedStatesVirginIslands"]

states={"Arizona","California","Georgia","Indiana","Montana","Ohio","Virginia","Kansas","Massachusetts","Nebraska","Oklahoma","Alaska","SouthDakota","Hawaii","Alabama","Arkansas","Colorado","Connecticut","Delaware","DistrictOfColumbia","Florida","Idaho","Illinois","Iowa","Kentucky","Louisiana","Maine","Maryland","Michigan","Minnesota","Mississippi","Missouri","Nevada","NewHampshire","NewJersey","NewMexico","NewYork","NorthCarolina","NorthDakota","Oregon","Pennsylvania","RhodeIsland","SouthCarolina","Tennessee","Texas","Utah","Vermont","Washington","WestVirginia","Wisconsin","Wyoming"};

ah=Position[states,"Alaska"|"Hawaii"]//Flatten

Length[states]

coords=Reverse/@(AdministrativeDivisionData[{#,"UnitedStates"},"Position"]&/@states)[[All,1]]

Verify BorderingStates property is symmetric

pairs=Sort[Flatten[Function[state,{state,#}&/@GeneralData[USStateData,state,"BorderingStates"]]/@states,1]]

Select[SplitBy[SortBy[pairs,Sort[#]&],Sort],Length[#]=!=2&]

{#,GeneralData[USStateData,#,"BorderingStates"]}&/@states/.Thread[states->Range[Length[states]]]

adjlists={{1,{2,17,33,36,46}},{2,{40,33,1}},{3,{21,15,44,38,43}},{4,{23,25,29,6}},{5,{22,39,13,51}},{6,{41,49,25,4,29}},{7,{25,28,38,44,49,20}},{8,{17,32,10,11}},{9,{18,34,37,42,47}},{10,{17,24,8,32,13,51}},{11,{16,17,8,32,36,45}},{12,{}},{13,{24,30,5,10,39,51}},{14,{}},{15,{21,3,31,44}},{16,{26,31,32,11,44,45}},{17,{1,8,10,36,11,46,51}},{18,{9,37,42}},{19,{28,35,41}},{20,{7,28}},{21,{3,15}},{22,{5,33,40,46,48,51}},{23,{4,25,32,24,50}},{24,{23,30,32,10,13,50}},{25,{23,4,32,6,44,7,49}},{26,{16,31,45}},{27,{34}},{28,{19,41,7,20,49}},{29,{50,6,4,30}},{30,{24,29,39,13,50}},{31,{15,16,26,44}},{32,{16,23,24,8,25,10,11,44}},{33,{1,2,22,40,46}},{34,{27,9,47}},{35,{37,41,19}},{36,{1,17,11,45,46}},{37,{47,9,18,35,41,42}},{38,{3,43,44,7}},{39,{30,5,13}},{40,{2,22,33,48}},{41,{37,35,19,28,49,6}},{42,{18,9,37}},{43,{3,38}},{44,{15,16,3,25,31,32,38,7}},{45,{16,26,36,11}},{46,{1,17,22,33,36,51}},{47,{9,34,37}},{48,{22,40}},{49,{25,28,6,41,7}},{50,{30,29,24,23}},{51,{17,5,10,13,46,22}}};

Thread[Range[Length[states]]->states]

ShowLabeledGraph[g=FromAdjacencyLists[adjlists[[All,2]],coords]]

ShowLabeledGraph[g2=DeleteVertices[g,{12,14}]]

colors=BrelazColoring[g]

Max[colors]

coloring=Transpose[{{Red,Yellow,Green,Blue}[[colors]],Tooltip[Polygon[Entity["AdministrativeDivision",{#,"UnitedStates"}]],#]&/@states}];

GeoGraphics[coloring]

{V[g2],M[g2]}

Binomial[111,4]

usa1=GraphData["ContiguousUSAGraph"]

GraphData["ContiguousUSAGraph",{"V","M"}]

usa2=CombinatoricaGraphToV8Graph[g]

camelcase[s_String]:=Module[{l=StringSplit[s]},
StringJoin@@(ToUpperCase[StringTake[#,1]]<>StringDrop[#,1]&/@l)
]

abbrevs=Reverse/@Rule@@@Partition[camelcase/@Flatten@ImportString["AK\tAlaska\tKY\tKentucky\tNY\tNew York
AL\tAlabama\tLA\tLouisiana\tOH\tOhio
AR\tArkansas\tMA\tMassachusetts\tOK\tOklahoma
AZ\tArizona\tMD\tMaryland\tOR\tOregon
CA\tCalifornia\tME\tMaine\tPA\tPennsylvania
CO\tColorado\tMI\tMichigan\tRI\tRhode Island
CT\tConnecticut\tMN\tMinnesota\tSC\tSouth Carolina
DC\tDistrict of Columbia\tMO\tMissouri\tSD\tSouth Dakota
DE\tDelaware\tMS\tMississippi\tTN\tTennessee
FL\tFlorida\tMT\tMontana\tTX\tTexas
GA\tGeorgia\tNC\tNorth Carolina\tUT\tUtah
HI\tHawaii\tND\tNorth Dakota\tVA\tVirginia
IA\tIowa\tNE\tNebraska\tVT\tVermont
ID\tIdaho\tNH\tNew Hampshire\tWA\tWashington
IL\tIllinois\tNJ\tNew Jersey\tWI\tWisconsin
IN\tIndiana\tNM\tNew Mexico\tWV\tWest Virginia
KS\tKansas\tNV\tNevada\tWY\tWyoming"],2]

el1=Sort[Sort/@(EdgeList[usa1]/.i_Integer:>kstates[[i]])]

Length[el1]

el2=Sort[Sort/@(EdgeList[usa2]/.i_Integer:>states[[i]]/.abbrevs)]

Length[el2]

Complement[el2,el1]

Complement[el1,el2]

Function[pairs,GeoGraphics[Transpose[{{Red,Blue},Polygon[Entity["AdministrativeDivision",{#,"UnitedStates"}]]&/@pairs}]]]/@{
{"Arizona","Colorado"},
{"Michigan","Minnesota"},
{"NewMexico","Utah"},
{"NewYork","RhodeIsland"}
}

e=EdgeList[usa2]

usa2c=VertexDelete[usa2,ah]

Monitor[dels=Select[Subsets[Range[111],{4}],IsomorphicGraphQ[usa1,EdgeDelete[usa2c,d=e[[#]]]]&],d]//Timing

e[[#]]&/@dels/.i_Integer:>states[[i]]

Coloring

Code

ColoredDisk[cols_, fracs_]:=Module[{acc=Accumulate[Prepend[fracs,0]]},
acc=Partition[2π acc,2,1];Graphics[
Table[{cols[[i]], EdgeForm[{Black, Thickness[.04]}],Disk[{0,0},2,acc[[i]] ]}, {i, Length[cols]}]]
]

GraphPlotFractional[g_System`Graph,opts___?OptionQ] := GraphPlotFractional[g,FractionalChromaticNumberAndColoring[g],opts]
GraphPlotFractional[g_System`Graph, frac_List, opts___?OptionQ] := Module[{},
fracValuesOfColors= Last/@ Union[Flatten[frac[[2]],1]];
realcols=Join[{Red, Green,Yellow, Blue, Cyan, Magenta, Brown, Orange, Purple, Black, Pink, Gray},ColorData["Legacy"]/@ Range[100]];
cols=Union[First/@ Flatten[frac[[2]],1]];
SetProperty[g,{VertexSize->Large,opts,VertexShape->MapIndexed[#2[[1]]->ColoredDisk[realcols[[First/@ frac[[2,#2[[1]]]]]],fracValuesOfColors[[First/@ frac[[2,#2[[1]]]]]]]&, VertexList[g]]}]
]

GraphPlotColoring[g_System`Graph,opts___?OptionQ]:=GraphPlotColoring[g,MinimumVertexColoring[FromUnorderedPairs[List@@@EdgeList[g]]],opts]
GraphPlotColoring[g_System`Graph,colors_List,opts___?OptionQ]:=Module[
{
colorlist=Join[{Red, Green,Yellow, Blue, Cyan, Magenta, Brown, Orange, Purple, Black, Pink, Gray},ColorData["Legacy"]/@ Range[100]]
},
SetProperty[g,{VertexSize->.3,opts,System`VertexStyle->MapIndexed[#2[[1]]->#1&,colors/.Thread[Range[Max@colors]->Take[colorlist,Max@colors]]]}]
]

Colorings

Using Trick coumn generation

({chi,coloring}=ChromaticNumberAndColoringTrick[GraphData["ContiguousUSAGraph"]])//Timing

(* using V9-XKernel *)
ChromaticNumberAndColoringStatic[GraphData["ContiguousUSAGraph"]]//Timing

(* too slow to ever finish *)
ChromaticNumberAndColoringStatic[GraphData["ContiguousUSAGraph"]]//Timing

{chi,coloring}={4,{2,3,1,4,3,1,3,2,3,2,2,4,1,1,3,2,2,1,3,1,3,2,1,1,2,3,1,1,2,4,4,2,4,1,1,2,3,4,3,1,3,4,2,1,2,4,3,1,4}};

Stan Wagon, pers. comm.
Dec. 8, 2011

FractionalChromaticNumberAndColoring[GraphData["ContiguousUSAGraph"]]//Timing

fraccoloring={7/2,{{{2,1/2},{7,1/2}},{{3,1/2},{1,1/2}},{{4,1/2},{5,1/2}},{{4,1/2},{1,1/2}},{{3,1/2},{6,1/2}},{{7,1/2},{5,1/2}},{{2,1/2},{6,1/2}},{{4,1/2},{1,1/2}},{{6,1/2},{2,1/2}},{{1,1/2},{3,1/2}},{{3,1/2},{7,1/2}},{{4,1/2},{2,1/2}},{{4,1/2},{5,1/2}},{{5,1/2},{1,1/2}},{{6,1/2},{2,1/2}},{{7,1/2},{6,1/2}},{{3,1/2},{1,1/2}},{{7,1/2},{5,1/2}},{{6,1/2},{2,1/2}},{{5,1/2},{7,1/2}},{{3,1/2},{6,1/2}},{{4,1/2},{2,1/2}},{{7,1/2},{1,1/2}},{{5,1/2},{1,1/2}},{{3,1/2},{2,1/2}},{{7,1/2},{6,1/2}},{{5,1/2},{1,1/2}},{{3,1/2},{1,1/2}},{{4,1/2},{6,1/2}},{{5,1/2},{2,1/2}},{{7,1/2},{2,1/2}},{{3,1/2},{1,1/2}},{{7,1/2},{5,1/2}},{{6,1/2},{3,1/2}},{{3,1/2},{2,1/2}},{{4,1/2},{1,1/2}},{{4,1/2},{1,1/2}},{{4,1/2},{3,1/2}},{{6,1/2},{2,1/2}},{{5,1/2},{1,1/2}},{{4,1/2},{5,1/2}},{{7,1/2},{2,1/2}},{{7,1/2},{2,1/2}},{{6,1/2},{1,1/2}},{{3,1/2},{4,1/2}},{{5,1/2},{1,1/2}},{{6,1/2},{3,1/2}},{{3,1/2},{2,1/2}},{{5,1/2},{7,1/2}}}};

FractionalColoringIndependentSetForm@{{{2,1/2},{7,1/2}},{{3,1/2},{1,1/2}},{{4,1/2},{5,1/2}},{{4,1/2},{1,1/2}},{{3,1/2},{6,1/2}},{{7,1/2},{5,1/2}},{{2,1/2},{6,1/2}},{{4,1/2},{1,1/2}},{{6,1/2},{2,1/2}},{{1,1/2},{3,1/2}},{{3,1/2},{7,1/2}},{{4,1/2},{2,1/2}},{{4,1/2},{5,1/2}},{{5,1/2},{1,1/2}},{{6,1/2},{2,1/2}},{{7,1/2},{6,1/2}},{{3,1/2},{1,1/2}},{{7,1/2},{5,1/2}},{{6,1/2},{2,1/2}},{{5,1/2},{7,1/2}},{{3,1/2},{6,1/2}},{{4,1/2},{2,1/2}},{{7,1/2},{1,1/2}},{{5,1/2},{1,1/2}},{{3,1/2},{2,1/2}},{{7,1/2},{6,1/2}},{{5,1/2},{1,1/2}},{{3,1/2},{1,1/2}},{{4,1/2},{6,1/2}},{{5,1/2},{2,1/2}},{{7,1/2},{2,1/2}},{{3,1/2},{1,1/2}},{{7,1/2},{5,1/2}},{{6,1/2},{3,1/2}},{{3,1/2},{2,1/2}},{{4,1/2},{1,1/2}},{{4,1/2},{1,1/2}},{{4,1/2},{3,1/2}},{{6,1/2},{2,1/2}},{{5,1/2},{1,1/2}},{{4,1/2},{5,1/2}},{{7,1/2},{2,1/2}},{{7,1/2},{2,1/2}},{{6,1/2},{1,1/2}},{{3,1/2},{4,1/2}},{{5,1/2},{1,1/2}},{{6,1/2},{3,1/2}},{{3,1/2},{2,1/2}},{{5,1/2},{7,1/2}}}

FractionalChromaticNumber[GraphData["ContiguousUSAGraph"],"Coloring"->True]//Timing

Graphics

g1=GraphPlotColoring[GraphData["ContiguousUSAGraph"],coloring,VertexSize->.35]

g2=GraphPlotFractional[GraphData["ContiguousUSAGraph"],fraccoloring,VertexSize->.5]

GraphicsRow[{g1,g2},ImageSize->500]

GraphData

GraphClassString

GraphClassString[{"ContiguousUSAGraph"}]

GraphDataString

GraphDataString[g,
"StandardName"->"ContiguousUSAGraph",
"Name"->"contiguous USA graph",
"Vertices"->None,
"Information"->"ContinguousUSAGraph",
Debug->True,
TimeConstraint->60
]