Constructing election cartograms?

I found this pretty neat page showing cartograms for the US elections and I don't really know how to get started doing these graphics in Mathematica. For those who don't know, a cartogram is a map in which the geometry is distorted in proportion to the variable being plotted.

For example, the standard red/blue US election map

is is transformed to a population cartogram by scaling each state so that its size on the map is proportional to the state's population:

Or again, according to a each state's number of electoral votes:

Here's the population cartogram based on county data:

Even more exotic plots are discussed on the linked page.

I'm asking for a kick start and ideas on how to approach it since I haven't done something like this before.

• If you follow your links you find a paper on how they did it. Commented Nov 9, 2012 at 2:40
• +1 A very substantial and worthy project to carry out in Mathematica. Especially if one could link up the curated data to curated maps. Not an easy matter to implement well. Commented Nov 9, 2012 at 3:23
• While these are cool, they do need to have labels, otherwise they're more like Geography quizzes than useful purveyors of information... And estimating areas this way is really hard - rectangular ones would be more effective. Commented Nov 9, 2012 at 8:53
• also related: make a map of squares
– kglr
Commented Nov 9, 2012 at 10:47
• I found this non-technical description of cartograms intriguing. sasi.group.shef.ac.uk/publications/2006/worldmapper_ieee.pdf The worldmapper website also has quite a few examples of their usage: worldmapper.org/data.html Commented Nov 9, 2012 at 11:41

Disclaimer: I didn't actually look at the links in the comments because I wanted to see how well I could do on my own, so here's my original Mathematica cartogram creation!

First, load the data from various web resources (as is done here):

ClearAll["Global*"]
usa = Import[
"Data"];
popdata =
Import["https://www.census.gov/geo/reference/docs/cenpop2010/CenPop2010_Mean_ST.txt", "CSV"][[2 ;;, 2 ;; 3]];
popdata = Thread[popdata[[All, 1]] -> popdata[[All, 2]]];
stateabbrev = Import["http://goo.gl/5wC23"][[All, {1, -1}]];
stateabbrev = Thread[stateabbrev[[All, 2]] -> stateabbrev[[All, 1]]];
presresults =
Import["http://www.fec.gov/pubrec/fe2008/tables2008.xls"];
Thread[presresults[[3, 5 ;; 55, 1]] ->
Total /@ (presresults[[3, 5 ;; 55, {2, 3}]] /. "" -> 0)] /.
stateabbrev;
presresults = presresults[[3, 5 ;; 55, {1, 4, 5}]] /. stateabbrev;
transform[s_] := StringTrim[s, Whitespace ~~ "(" ~~ ___ ~~ ")"]

polygons =
"PlacemarkNames" /. usa[[1]]] -> ("Geometry" /. usa[[1]])];
stateNames = polygons[[All, 1]];
stateNames =
Extract[stateNames,
Position[stateNames, x_ /; x != "Alaska" && x != "Hawaii"]];
stateColors =
Flatten[{#[[1]] -> If[#[[2]] > #[[3]], Blue, Red]} & /@
presresults];


I'm limiting myself here to the continental US, but the method is general to any collection of boundary data. Now, define some utility functions (borrowed from here):

area[pts_] :=
Plus @@ (ListCorrelate[{1, 1}, First /@ pts,
1] ListCorrelate[{-1, 1}, Last /@ pts, 1])/2;
com[pts_] := Module[{moments, thearea},
moments = (1/6) {
Plus @@ ((#1^2 + #1 #2 + #2^2 & @@ ({RotateLeft[#], #} &@(First \
/@ pts))) ListCorrelate[{-1, 1}, Last /@ pts, 1]),
-Plus @@ ((#1^2 + #1 #2 + #2^2 & @@ ({RotateLeft[#], #} &@(Last \
/@ pts))) ListCorrelate[{-1, 1}, First /@ pts, 1]) };
thearea = area[pts];
Return@If[thearea == 0.0, Mean[pts], moments/thearea]];
com2[pts_, weights_] := Module[{},
Return[Total[weights*pts]/Total[weights]]];


And now the meat of it:

origdata = (stateNames /. polygons)[[All, 2 ;;, 1]];
newdata = origdata;
nits = 10;
nstates = Length@stateNames;
weights = (stateNames /. popdata)/Total[stateNames /. popdata];
For[j = 1, j <= nits*nstates(*Length@origdata*),
i = Mod[j - 1, nstates] + 1;
tempdata = newdata;
(*compts=Map[com,newdata,{2}];*)

polyarrs = Map[area, newdata, {2}];
statearrs = Total /@ polyarrs;
allarr = Total@statearrs;
comall =
Table[com2[com /@ newdata[[i]], polyarrs[[i]]], {i,
Length@origdata}];
norms = Map[Norm[(# - comall[[i]])] &, tempdata, {3}];
exp = Tanh[Log[1/weights[[i]] statearrs[[i]]/allarr]]/2;
newdata =
Map[(# - comall[[i]]) &,
tempdata, {3}] (1 - exp Exp[-(norms/Max[norms[[i]]])^2]);
newdata *= Sqrt[
Total[Total /@ Map[area, tempdata, {2}]]/
Total[Total /@ Map[area, newdata, {2}]]];
j++];
plotcolors = stateNames /. stateColors;
Show[Graphics[
Table[{EdgeForm[Directive[Black, AbsoluteThickness[0.5]]],
plotcolors[[i]], Polygon[newdata[[i]]]}, {i, Length@newdata}]],
AspectRatio -> Automatic]


And voila!

The dataset is actually a bit tricky to handle as some of the states are not contiguous (such as the Channel islands), so the center of mass of each state is computed by calculating the centers of mass of each polygon that constitutes a particular state, and then finding the center of mass of the polygons.

My method of madness here is to simply "push" or "pull" all points in the map towards the center of mass of a particular state, with the amount of pushing or pulling falling off exponentially with distance. The code does this over multiple iterations, only pushing or pulling all the points by a small amount each time, with the amount being determined by the ratio of each state's area to the desired area. The CDF of the state areas as compared to the populations shows that this is a true cartogram (the more iterations, the better it is):

Histogram[{statearrs/Max[statearrs], (stateNames /. popdata)/
Max[stateNames /. popdata]}, Automatic, "CDF"]


This is for the 2008 presidential results, I couldn't find a machine-readable table of the 2012 results. Here's the map for electoral votes (looks pretty similar):

You can get the electoral vote cartogram by replacing the weights definition above with:

weights = (stateNames /. electoralVotes)/Total[stateNames /. electoralVotes];


Some caveats:

• I'm just going through the list of states alphabetically, but perhaps a more "pleasing" cartogram could be constructed by going through the states in a particular order.
• It's a bit slower than I would like (about 2 minutes to run this).
• This is excellent! Commented Dec 12, 2012 at 8:56
• Indeed it is. I was working on this problem this past week but wasn't able to get as nice of results. I hope to study your code more closely to see how you handled it. Commented Dec 12, 2012 at 16:49
• @Guillochon I updated the popdata` URL as it was not working.
– shrx
Commented Mar 22, 2014 at 12:16
• @shrx Great, thanks! Commented Mar 25, 2014 at 15:02
• @Guillochon I was actually planning to do that, but then realized it would be easier not to do that :) [I still might though] I believe the "meat" of your code is in the For loop and everything else is just problem specific data.
– user1722
Commented Jul 13, 2018 at 1:32