Constructing election cartograms?

Question

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.

Answer 1

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[
   "http://code.google.com/apis/kml/documentation/us_states.kml", 
   "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"];
electoralVotes = 
  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 = 
  Thread[transform[
     "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).