人口を約半分にする都道府県二分割をMathematicaでやってみた

Last updated at 2016-12-19Posted at 2016-12-19

ちょっと前に流行った、人口が約半分になるように都道府県を二分割する問題を Mathematica で書いてみました。

バージョンは Mathematica 11.0.1.0 を使いました。

参考: 人口が半分になるように都道府県を二分割してみたまとめ - Togetterまとめ

乞う! Mathematicaの文法色づけ!

話がそれますが、Mathematica Advent Calendar 2016 - Qiita の、

"ぜひこのカレンダーを盛り上げて今度こそQiitaにMathematicaのシンタックスハイライトを対応してもらいましょう！"

この1文に「乗った!」と思いました。

コード

Mathematica のプログラムはこれです。prefectureName のところをお好きな都道府県に書き換えて遊んでみてください。広島大学の学生など、Mathematica をキャンパスライセンスで好き放題で遊べる人は学生のうちにこのとっても高価なソフトウェアで遊んでみるのもいいかもしれませんね。:-P

prefectureName = "Hiroshima";
a = CityData[{All, prefectureName, "Japan"}]
allPopulation = 
 Total[QuantityMagnitude[CityData[#, "Population"]] & /@ 
   a]; diff = 1;
Do[
 rs = RandomSample[Range[Length[a]], RandomInteger[Length[a]]];
 t = Total[
   QuantityMagnitude[CityData[#, "Population"]] & /@ a[[rs]]];
 d = Abs[1/2 - t/allPopulation];
 If[d < diff, diff = d; goodPartition = rs;];
 , {300}]
part = ImportString[URLFetch[#], 
     "JSON"] & /@ \
("http://nominatim.openstreetmap.org/search/?country=Japan&state=" <> 
        prefectureName <> "&city=" <> # <> 
        "&format=json&polygon_geojson=1" //. 
       x : {__Rule} :> Association[x] & /@ 
     Table[CityData[c, "Name"], {c, a[[goodPartition]]}]);
wholeArea = 
  "coordinates" /. ("geojson" /. 
     Import["http://nominatim.openstreetmap.org/search/?country=Japan&\
state=" <> prefectureName <> "&format=json&polygon_geojson=1", 
       "JSON"][[1]]);
Lookup[#, "display_name", {}] & /@ part
Lookup[#, "coordinates", {}] & /@ (Lookup[#, "geojson", {}] & /@ part);
GeoGraphics[{{EdgeForm[Red], FaceForm[Red], 
   Polygon /@ Flatten[%, 2]}, {EdgeForm[{Thick, Black}], 
   FaceForm[White], Polygon /@ wholeArea}}]

t = Total[
   QuantityMagnitude[CityData[#, "Population"]] & /@ 
    a[[goodPartition]]];

Print["Partition A: ", a[[goodPartition]], " ", t, " people (", 
 N[100 t/allPopulation], "%)"]

Print["Partition B: ", 
 a[[Complement[Range[Length[a]], goodPartition]]], " ", 
 allPopulation - t, " people (", N[100 (1 - t/allPopulation)], "%)"]

今回のアルゴリズム

分割アルゴリズム

今回はこの二分割アルゴリズムには、 ~~思考停止アルゴリズム~~ 乱択アルゴリズムにしました。(時間があったらもっとかっこいい構築的なアルゴリズムにも挑戦したいデス!)

分割アルゴリズム自体はここだけです。(残りのコードは結果の描画のためです。)

Do[
 rs = RandomSample[Range[Length[a]], RandomInteger[Length[a]]];
 t = Total[
   QuantityMagnitude[CityData[#, "Population"]] & /@ a[[rs]]];
 d = Abs[1/2 - t/allPopulation];
 If[d < diff, diff = d; goodPartition = rs;];
 , {300}]