Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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

enter image description here

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:

enter image description here

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

enter image description here

Here's the population cartogram based on county data:

enter image description here

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.

share|improve this question
2  
If you follow your links you find a paper on how they did it. –  wxffles Nov 9 '12 at 2:40
2  
+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. –  David Carraher Nov 9 '12 at 3:23
2  
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. –  cormullion Nov 9 '12 at 8:53
2  
also related: make a map of squares –  kguler Nov 9 '12 at 10:47
1  
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 –  David Carraher Nov 9 '12 at 11:41
show 10 more comments

1 Answer

up vote 32 down vote accepted
+50

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!

enter image description here

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"]

enter image description here

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):

enter image description here

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).
share|improve this answer
2  
This is excellent! –  Simon Woods Dec 12 '12 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. –  JohnD Dec 12 '12 at 16:49
1  
@Guillochon I updated the popdata URL as it was not working. –  shrx Mar 22 at 12:16
    
@shrx Great, thanks! –  Guillochon Mar 25 at 15:02
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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