4
$\begingroup$

The following code is an enhanced version of the code from "Find a Four-Coloring of a Map of Europe".

provinces = 
  EntityList@
   Entity["AdministrativeDivision", {EntityProperty[
       "AdministrativeDivision", "ParentRegion"] -> 
      Entity["Country", "China"]}];
provinceneighbors = ({{"河北", {"辽宁", "内蒙古", "山西", "河南", "山东", "北京", 
       "天津"}}, {"山西", {"河北", "内蒙古", "陕西", "河南"}}, {"内蒙古", {"黑龙江", 
       "吉林", "辽宁", "河北", "山西", "陕西", "宁夏", "甘肃"}}, {"辽宁", {"吉林", 
       "内蒙古", "河北"}}, {"吉林", {"黑龙江", "内蒙古", "辽宁"}}, {"黑龙江", {"内蒙古", 
       "吉林"}}, {"陕西", {"山西", "内蒙古", "宁夏", "甘肃", "四川", "重庆", "湖北", 
       "河南"}}, {"宁夏", {"陕西", "内蒙古", "甘肃"}}, {"甘肃", {"内蒙古", "新疆", "青海",
        "四川", "山西", "宁夏"}}, {"青海", {"甘肃", "新疆", "西藏", 
       "四川"}}, {"新疆", {"甘肃", "青海", "西藏"}}, {"西藏", {"新疆", "青海", "四川", 
       "云南"}}, {"云南", {"西藏", "四川", "贵州", "广西"}}, {"重庆", {"陕西", "四川", 
       "贵州", "湖南", "湖北"}}, {"贵州", {"重庆", "四川", "云南", "广西", 
       "湖南"}}, {"广西", {"云南", "贵州", "湖南", "广东"}}, {"广东", {"福建", "江西", 
       "湖南", "广西"}}, {"湖南", {"湖北", "重庆", "贵州", "广西", "广东", 
       "江西"}}, {"江西", {"安徽", "湖北", "湖南", "广东", "福建", 
       "浙江"}}, {"福建", {"浙江", "江西", "广东"}}, {"湖北", {"河南", "陕西", "重庆", 
       "湖南", "江西", "安徽"}}, {"河南", {"河北", "山西", "陕西", "湖北", "安徽", "江苏",
        "山东"}}, {"安徽", {"河南", "湖北", "江西", "浙江", "江苏"}}, {"浙江", {"上海", 
       "江苏", "安徽", "江西", "福建"}}, {"上海", {"江苏", "浙江"}}, {"江苏", {"山东", 
       "安徽", "浙江", "上海"}}, {"山东", {"河北", "河南", "江苏"}}, {"天津", {"河北", 
       "北京"}}, {"北京", {"河北", "天津"}}} /. 
    Thread[{"安徽", "北京", "重庆", "福建", "甘肃", "广东", "广西", "贵州", "海南", 
       "河北", "河南", "湖北", "湖南", "吉林", "江苏", "江西", "辽宁", "宁夏", "青海", 
       "山东", "山西", "陕西", "上海", "四川", "天津", "西藏", "新疆", "云南", "浙江", 
       "黑龙江", "内蒙古"} -> provinces]);

colorcode = {{False, False} -> Red, {False, True} -> 
    Blue, {True, False} -> Green, {True, True} -> Yellow};
provincebooleans = # -> {x[#], y[#]} & /@ provinces;
eqs = And @@ (Flatten[
     Function[{province, neighbors}, 
       BooleanConvert[
          Xor[x[province], x[#]] || Xor[y[province], y[#]], "CNF"] & /@
         neighbors] @@@ provinceneighbors]);
solution = 
  First[FindInstance[eqs, Flatten[Last /@ provincebooleans], 
    Booleans]];
coloring = provincebooleans /. solution /. colorcode
GeoGraphics[{EdgeForm[
   Directive[Thin, 
    Black]], {GeoStyling[#2], Tooltip[Polygon[#1], #1[[2]]]} & @@@ 
   coloring}]

How can I join the administrative divisions of Taiwan to the list:

EntityList @ Entity["AdministrativeDivision", {EntityProperty[
    "AdministrativeDivision", "ParentRegion"] -> 
   Entity["Country", "China"]}]

enter image description here

$\endgroup$
  • 5
    $\begingroup$ "How can I add Taiwan to the list ...?" That's a question on which quite many people broke their head for more than 70 years... ;p $\endgroup$ – Henrik Schumacher Jan 18 at 12:59
  • 1
    $\begingroup$ The original title and formulation of the question could have been interpreted as an attempt to make a political statement. I edited both. $\endgroup$ – Anton Antonov Jan 18 at 16:45
6
$\begingroup$

Definitions

The code from WRI’s "Find a Four-Coloring of a Map of Europe" can be modified/refactored to use GeoNearest and use the provinces of two given countries.

Clear[GetProvinceNeighbors]
Options[GetProvinceNeighbors] = {"RemoveEntitiesWithoutNeighbors" -> False};
GetProvinceNeighbors[c1 : Entity["Country", _], c2 : Entity["Country", _], opts : OptionsPattern[]] :=
  Block[{ads1, ads2, provinces},
   ads1 = 
    EntityList@
     Entity["AdministrativeDivision", {EntityProperty[
         "AdministrativeDivision", "ParentRegion"] -> c1}];
   ads2 = 
    EntityList@
     Entity["AdministrativeDivision", {EntityProperty[
         "AdministrativeDivision", "ParentRegion"] -> c2}];
   provinces = Join[ads1, ads2];
   If[TrueQ[
     OptionValue[GetProvinceNeighbors, 
      "RemoveEntitiesWithoutNeighbors"]],
    Select[
     Association[# -> DeleteCases[GeoNearest[provinces, #], #] & /@ 
       provinces], Length[#] > 0 &],
    Association[# -> DeleteCases[GeoNearest[provinces, #], #] & /@ 
      provinces]
    ]
  ];
Clear[MakeProvinceFourColorMap]
MakeProvinceFourColorMap[provinceneighbors_Association,opts:OptionsPattern[]]:=
  Block[{provinces,colorcode,provincebooleans,eqs,solution,coloring},
    provinces=Keys[provinceneighbors];
    colorcode={{False,False}\[Rule]Red,{False,True}\[Rule]Blue,{True,False}\[Rule]Green,{True,True}\[Rule]Yellow};
    provincebooleans=#\[Rule]{x[#],y[#]}&/@provinces;
    eqs=And@@(Flatten[Function[{province,neighbors},BooleanConvert[Xor[x[province],x[#]]||Xor[y[province],y[#]],"CNF"]&/@neighbors]@@@(List@@@Normal[provinceneighbors])]);solution=First[FindInstance[eqs,Flatten[Last/@provincebooleans],Booleans]];coloring=provincebooleans/.solution/.colorcode;GeoGraphics[{EdgeForm[Directive[Thin,Black]],{GeoStyling[#2],Tooltip[Polygon[#1],#1[[2]]]}&@@@coloring},
    FilterRules[{opts},Options[GeoGraphics]],
    ImageSize\[Rule]Large]
  ];

Countries with common land borders

aProvinceNeighbors=GetProvinceNeighbors[Entity["Country","China"],Entity["Country","India"]];
MakeProvinceFourColorMap[aProvinceNeighbors,ImageSize\[Rule]900]

enter image description here

Countries with no common land borders

When the two countries do not share land borders the finding of province neighbors can be done programmatically, but in the case of China and Taiwan that is easily done manually.

aProvinceNeighbors=GetProvinceNeighbors[Entity["Country","China"],Entity["Country","Taiwan"]];
focusAdmins2 = {Entity["AdministrativeDivision", {"Taiwan", "Taiwan"}], Entity["AdministrativeDivision", {"Taichung", "Taiwan"}]};
focusAdmins1 = {Entity["AdministrativeDivision", {"Fujian", "China"}]};
aProvinceNeighbors=
  Join[
    aProvinceNeighbors,
    Association[#->Join[aProvinceNeighbors[#],focusAdmins1]&/@focusAdmins2],
    Association[#->Join[aProvinceNeighbors[#],focusAdmins2]&/@focusAdmins1]
  ];
MakeProvinceFourColorMap[aProvinceNeighbors,ImageSize\[Rule]900]

enter image description here

Additional explanations

Your map is missing Hainan Province. - Go with the wind

This is because the original version of GetProvinceNeighbors (and now by an option specification) removes the entities for which GeoNearest produces no neighbors.

Since I made GetProvinceNeighbors to return an association of geo-neighbors those geo-neighbors can be adjusted as demonstrated in the previous section.

(Meaning, you can use your geo-neighbor associations to produce the maps you want.)

Here we see the difference:

In[103]:= aProvinceNeighborsNotAll = 
  GetProvinceNeighbors[Entity["Country", "China"], 
   Entity["Country", "Taiwan"], "RemoveEntitiesWithoutNeighbors" -> True];
aProvinceNeighborsNotAll // Length

Out[104]= 36

In[105]:= aProvinceNeighborsAll = 
  GetProvinceNeighbors[Entity["Country", "China"], 
   Entity["Country", "Taiwan"], "RemoveEntitiesWithoutNeighbors" -> False];
aProvinceNeighborsAll // Length

Out[106]= 38

In[108]:= Complement[aProvinceNeighborsAll, aProvinceNeighborsNotAll]

Out[108]= <|Entity["AdministrativeDivision", {"Hainan", "China"}] -> {}, 
 Entity["AdministrativeDivision", {"Fukien", "Taiwan"}] -> {}|>
|improve this answer|||||
$\endgroup$
  • 1
    $\begingroup$ Your map is missing Hainan Province. $\endgroup$ – Please Correct GrammarMistakes Jan 19 at 2:45
  • 2
    $\begingroup$ @Gowiththewind "Your map is missing Hainan Province." -- With my update that province should be in. But if you followed and understood my original post, you should have figured out how to add it. Similar thing you did in your question -- you provided your own province neighbors associations. $\endgroup$ – Anton Antonov Jan 19 at 19:34

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.