# Apply four color theorem to the map of Florida?

GROUPS:
 Gilmar Rodriguez-Pierluissi 1 Vote I'm attempting to apply the Four Color Theorem to a map of Florida and I'm following an example available among the standard collection of examples located at: ref/GeoGraphics; "Neat Examples" (provided by my Mathematica software). Unfortunately; the following: EntityProperty["AdministrativeDivision", "BorderingCounties"] doesn't work when I evaluate it using my Mathematica software. I found an alternative way to get around this difficulty and I can apply the four color theorem to subareas of the map of Florida but, the same code that I use for the subareas will not work for the whole state. I have built the attached Mathematica notebook explaining my problem in detail. Thank you for your help! Attachments:
1 year ago
8 Replies
 Szabolcs Horvát 4 Votes Here's a very compact solution using IGraph/M's IGVertexColoring function. counties = EntityList@EntityClass["AdministrativeDivision", "USCountiesFlorida"]; borderingQ[c1_, c2_] := MemberQ[c1["BorderingCounties"], c2] graph = RelationGraph[borderingQ, counties]; GeoGraphics@ MapThread[{GeoStyling[#2], Polygon[#1]} &, {counties, ColorData[97] /@ IGVertexColoring[graph]}]  ?IGVertexColoring  IGVertexColoring[graph] returns a vertex colouring of graph. Currently this function does not guarantee a minimum colouring, but it does well here. You can see the fifth colour (purple) around the quintipoint in the South East.
5 months ago
 Chip Hurst 3 Votes There's a 'quintipoint' in Florida, which breaks the ability to have a 4 color map.See here for more info: http://community.wolfram.com/groups/-/m/t/932548.About a year ago I did this for all US counties: Here's the code I used. Note how I manually tweaked the quintipoint. states = DeleteCases[ Entity["Country", "UnitedStates"][ EntityProperty["Country", "AdministrativeDivisions"]], s_ /; ! FreeQ[s, "Alaska" | "DistrictOfColumbia" | "Hawaii"]]; $triple = Entity["AdministrativeDivision", {"PalmBeachCounty" | "GladesCounty" | "OkeechobeeCounty", "Florida", "UnitedStates"}]; counties = Join @@ (EntityList[ EntityClass["AdministrativeDivision", "USCounties" <> CanonicalName[#][[1]]]] & /@ states); nassoc = EntityValue[counties, "BorderingCounties", "EntityAssociation"]; neighbors = {#, Intersection[nassoc[#] /. _Missing -> {}, counties]} & /@ counties; neighbors = neighbors /. {c :$triple, n_} :> {c, DeleteCases[n, \$triple]}; toColor[tf_] := <|{False, False} -> Red, {False, True} -> Blue, {True, False} -> Green, {True, True} -> Yellow|>[tf] eqs = And @@ (Flatten[ Function[{c, n}, BooleanConvert[Xor[x[c], x[#]] || Xor[y[c], y[#]], "CNF"] & /@ n] @@@ neighbors]); MaxMemoryUsed[ solution = Join[First[ FindInstance[eqs, Union[Cases[eqs, _x | _y, \[Infinity]]], Booleans]], Flatten[{x[#] -> True, y[#] -> True} & /@ Flatten[Cases[neighbors, {_, {}}]]]]] // AbsoluteTiming coloring = (#[[1, 1, 1]] -> Lighter@Lighter@toColor[Last /@ #]) & /@ Partition[SortBy[solution , #[[1, 1]] &], 2]; // Quiet (* {206.017, 20929584} *) GeoGraphics[{ {EdgeForm[{AbsoluteThickness[0.1], GrayLevel[0.3]}], {GeoStyling[#2], Polygon[#1]} & @@@ coloring}, {EdgeForm[{AbsoluteThickness[1.5], Black}], FaceForm[], Polygon[EntityList[ EntityClass["AdministrativeDivision", "ContinentalUSStates"]]]} }, GeoProjection -> "Mercator"] 
11 months ago
 I am going to assume that in your solution you want a nested list of string values that represent the Counties with which you are interested. In that case, you will need to apply the EntityValue function to a valid Entity Data Types. However, you will first need to obtain an Entity Class from your strings that represent the Entity Types you seek. xx = EntityValue[ EntityClass["AdministrativeDivision", "USCountiesFlorida"], "BorderingCounties"]; EntityValue[#, "Name"] & /@ xx 
1 year ago
 @Joel Gilly Thank you for responding to my query. I have no trouble getting the list of counties as you described. The trouble occurs when attempting to color the counties as described in another Mathematica notebook located at: http://community.wolfram.com/groups/-/m/t/1097057 Thank you for your help!
1 year ago