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'm trying to use Mathematica to create some visual representations of the votes cast in the recent Mathematica-StackExchange moderator elections. (Not the vote-counting system itself, OpenSTV, but rather the choices people made.) This is what I've got so far, but I'm stuck on how to represent the data visually, not knowing much about charting.

According to this Meta post, the results can be downloaded in text form from this page. It looks to be a plain text file (with oddball Unicode characters):

data = Import[
 "http://mathematica.stackexchange.com/election/download-result/1", "Table", CharacterEncoding -> "UTF8"]

(*
{{6, 3}, {1, 1, 2, 3, 0}, {1, 2, 4, 3, 0}, {1, 1, 4, 2, 0}, {1, 3, 1, 5, 0}, 
.... {"Verbeia"}, {"Mr.Wizard"}, {"F'x"}, {"Eiyrioü von Kauyf"}, {"Mathematica Moderator Election 2012"}}
*)

Although I couldn't find a guide to the format, it looks reasonable to assume that the initial {6,3} is the number of candidates and the number of vacancies, that the strings at the end before the election name are the candidates names, and that the lists starting with 1 and ending with 0 are the individual votes. So:

votes = Cases[data, {1, a_, b_, c_, 0} -> {a, b, c}]

gives the votes:

(*
{{1, 2, 3}, {2, 4, 3}, ... {1, 3, 5}}
*)

which I suppose can be turned into something more readable by picking up the names from the end of the list:

votes1 = votes /. 
 Table[
   n -> First@data[[Rescale[n, {1, 6}, {-7, -2}]]], 
 {n, 1, 6}]

to give something like this:

(*
{{"R.M.", "J.M", "Verbeia"}, {"J.M", "Mr.Wizard", "Verbeia"}, 
 {"R.M.", "Mr.Wizard", "J.M"}, {"Verbeia", "R.M.", "F'x"}, 
 {"Mr.Wizard", "J.M", "Verbeia"}, {"J.M", "R.M.", "Mr.Wizard"} ...
*)

So now I'd like to make this data accessible visually, using charts or graphs. (Or, as the online help says, "produce compelling dynamic visualizations".) How could I do this?

share|improve this question
5  
"(with oddball Unicode characters)" - blame the toad. ;) –  J. M. Sep 26 '12 at 11:00

5 Answers 5

What about perceived co-operative strength (well, at least something derived from counting the times two candidates were mentioned together):

t = 1/Table[
         Count[votes, _?(MemberQ[#, i] && MemberQ[#, j] &)], {i, 6}, {j, 6}]/.
                       ComplexInfinity -> DirectedInfinity[1] // Quiet
Do[t[[i, i]] = DirectedInfinity[1], {i, 6}];

WeightedAdjacencyGraph[t,
     EdgeShapeFunction -> ({CapForm["Round"], 
     Thickness[1/t[[#2[[1]], #2[[2]]]]/1000], Line[#1]} &),
     VertexLabels -> Thread[Rule[Range[6], Placed[#, Above] & /@ Flatten@data[[-7 ;; -2]]]],
     VertexLabelStyle -> Directive[FontFamily -> "Arial", Bold, 16],
     ImagePadding -> {{30, 60}, {0, 10}}
]

Mathematica graphics

share|improve this answer
1  
That is an interesting way of visualizing the result, +1. –  rcollyer Sep 26 '12 at 15:28

How about a BubbleChart3D showing the three choices as 3 axes:

names = {"??", "RM", "JM", "Vb", "Wz", "Fx", "EK"};

data = Tooltip[Flatten[{##}], 
     ToString[names[[1 + #1]]] <> " : " <> ToString[#2]] & @@@ Tally[votes];

With[{tt = Transpose[{Range[0, 6], names}]},
 BubbleChart3D[data, 
  AxesLabel -> Framed /@ {"First", "Second", "Third"},
  Ticks -> {tt, tt, tt}, BaseStyle -> {FontFamily -> "Calibri", 16},
  ChartStyle -> "DarkRainbow"]]

enter image description here

Hover over a bubble for a tooltip showing the 3 choices and the number of people who voted that way.

Another one

Here each voter is a vertex in a graph, with 7 larger vertices for the candidates. Each vote is a directed edge from voter to candidate (there is no distinction between first, second and third choices). By using "SpringEmbedding" the graph layout algorithm positions the candidates closer together if a lot of voters selected them both. This therefore reveals similar information to Sjoerd's graph.

votes = 1 + Cases[data, {1, a_, b_, c_, 0} :> {a, b, c}];
names = {"??", "RM", "JM", "Vb", "Wz", "Fx", "EK"};
v = DeleteDuplicates@Flatten[Table[Thread[(7 + i) -> votes[[i]]], {i, Length@votes}]];

g = Graph[Range[7 + Length@votes], v, 
   VertexSize -> Table[i -> 2, {i, 7}], 
   VertexStyle -> Table[i -> White, {i, 7}], 
   GraphLayout -> "SpringEmbedding"];

vc = (VertexCoordinates /. AbsoluteOptions[g, VertexCoordinates])[[;;7]];

Show[g, Graphics[{White, Table[{Disk[vc[[i]], 0.13], 
     Text[Style[names[[i]], Red, 14], vc[[i]]]}, {i, 7}]}]]

enter image description here

You can see for example a clear separation between Verbeia and the {Wizard, RM, JM} cluster. This comes from her popularity with the less conventional voters (those who also voted for the less popular candidates).

And Another One

I wanted to look at the preference aspect of the votes. For example if someone votes {Fx, JM, Wz} it implies that they consider Fx better than all the other candidates, JM better than all the candidates except Fx, and so on. We can draw up a table showing the number of voters expressing a preference for candidate A over candidate B:

votes = 1 + Cases[data, {1, a_, b_, c_, 0} :> {a, b, c}];
votes = votes /. Thread[{5, 2, 3, 4, 6, 7, 1} -> Range[7]];
names = {"Wz", "RM", "JM", "Vb", "Fx", "EK", "??"};

z = ConstantArray[0, {7, 7}];
With[{r = Range[7]}, Do[Module[{a, b, c}, {a, b, c} = vote;
   z[[Complement[r, {a}], a]]++;
   z[[Complement[r, {a, b}], b]]++;
   z[[Complement[r, {a, b, c}], c]]++],
  {vote, votes}]];

Panel[Style[TableForm[z, TableHeadings -> {names, names}], 
  FontFamily -> "Calibri", 16], {"Preferred", "Over"}, {Top, Left}]

enter image description here

For example there were 30 voters who preferred RM to Mr Wizard, but 45 voters who preferred Mr Wizard to RM.

The information is clearer if we look at the net preference between two candidates, so we could say Mr Wizard "beats" RM by 15 votes.

scoring = (z - Transpose[z]) /. x_ /; x < 1 -> ".";
Panel[Style[TableForm[scoring, TableHeadings -> {names, names}], 
  FontFamily -> "Calibri", 16], {"Preferred", "Over"}, {Top, Left}]

enter image description here

The direction of the net preferences can be shown in a graph, giving a picture of overall voter preference. An arrow from A to B indicates an overall preference for candidate B over candidate A:

enter image description here

share|improve this answer
2  
Lovely figure, though I notice my brain has difficulties drawing meaningful conclusions from this. –  Sjoerd C. de Vries Sep 26 '12 at 15:58
3  
@SjoerdC.deVries “bubbles bubbles bubbles bubbles” is the only conclusion my brain can draw from this graph :) –  F'x Sep 26 '12 at 16:02
    
Where is the toad? :D –  belisarius Sep 26 '12 at 16:36
2  
@SjoerdC.deVries, fair criticism. I suppose you could say I have visualised the data but concealed the information... –  Simon Woods Sep 26 '12 at 16:47
    
I like it, although the axes are all equivalent, rather than one being much more important than the other. Cool idea, though! –  cormullion Sep 27 '12 at 11:13

With small tables of values, complex graphics can obscure the data. Ed Tufte has recommended just showing the counts. He also points out the worth of presenting the values in a meaningful order: here, the rows go from first to third place while the columns are (roughly) in order of the standings.

raw = Import[
   "http://mathematica.stackexchange.com/election/download-result/1", 
   "Table", CharacterEncoding -> "UTF8"];
votes = Cases[raw, {1, a_, b_, c_, 0} -> {a, b, c}];
names = {"--", "RM", "JM", "Vb", "Wz", "Fx", "EK"};

order = {5, 2, 4, 3, 6, 7, 1};
table[i_, j_] := Length[Select[votes, #[[i]] == j - 1 &]]
TableForm[t = Table[table[i, j], {i, 1, 3}, {j, order}], 
 TableHeadings -> {{"First", "Second", "Third"}, names[[order]]}]

Table

It might help to supplement such a table with a gentle graphic symbolization of its values. The following varies the intensity of a background disk and the size and shading of the text itself:

With[{w = 1/4}, 
 Rasterize @ 
  TableForm[
   Map[Graphics[{RGBColor @@ ( (6 + {#, 0.2 #, 0.2 #})/(32 + 6)), 
       Disk[{w/2, w/2}, w/2], GrayLevel[0.9*UnitStep[16 - #]],  
       Text[Style[#, 120 w (# + 32)/64, 
         TextAlignment -> Center], {w/2, w/2}]}, ImageSize -> 50] &,  
    t, {2}], TableAlignments -> Center, TableSpacing -> {1/4, 1/4}, 
   TableHeadings -> {{"First", "Second", "Third"}, names[[order]]}]]

Graphics table

This illuminates why each person placed as they did: there were clear choices for first, second, and third places along with a strong fourth candidate.

Those interested in exploring connections within the voting will also appreciate the graphical display of Sjoerd C. de Vries (which shows bivariate associations) and might also want to look into ways of visualizing the hypergraph of votes (where the candidates form vertices which are connected in triples by weighted 2-simplices indicating how many times all three candidates were chosen simultaneously by a voter).

share|improve this answer
    
I like the second one very much. It's telling a story using numbers and colours. Did you just guess at order? –  cormullion Sep 27 '12 at 11:35
    
@cor The order could be justified as a sort on total votes (with non-votes placed last), but the fact is that while fiddling with the graphical details, I adjusted an initial ordering to emphasize the diagonal 32-26-23 pattern. –  whuber Sep 27 '12 at 13:04

Another interesting way of looking at the voting data would be to visualize the 2nd and 3rd choices for a given 1st choice. In a way, this is a breakdown of Sjoerd's plot when a given candidate is the 1st choice.

For example, among those who voted for me as the 1st choice, they were evenly split between J. M., Mr.Wizard and Verbeia for 2nd choice and a similar even split between the three for third, with Verbeia having a slight edge.

enter image description here

On the other hand, those who voted for Mr.Wizard as the 1st choice strongly preferred me as the second choice and Verbeia as the third:

enter image description here

Similar charts for J. M. (left) and Verbeia (right) are below:

enter image description here enter image description here

It appears to me as if the voting patterns roughly fell into two camps — one which felt there should be 2 of the old and one of the new, and the other, which felt there should be two of the new and one of the old. Both of these are very reasonable voting behaviours and it doesn't spring any surprises.


BLT file format

The format for the .blt file is fairly simple.

  1. The first number on the first line is the number of candidates and the second number is the number of seats.
  2. If any candidates have withdrawn, their IDs (see point 4) will be listed in the second line with a - sign prepended (like -6, for example). If no candidates have withdrawn, this line is not included.
  3. The votes follow next. These have the general pattern of

    count, 1st choice, 2nd choice, 3rd choice, 0
    

    In this case, the individual votes were given, but it is not uncommon to see a tallied count of unique triplets. 0 terminates each line.

  4. The next 7 lines (in general, the number of candidates + 1) are the identifiers for the candidate IDs. 0 indicates no vote cast for that choice.

  5. The final line in the file is the title of the election.

Code for the above charts

I have made the structure apparent in the formatting below to aid the eye. I've also "fixed" my name so that it doesn't throw any oddball unicode characters :)

1: Import and filter data

blt = Import["http://mathematica.stackexchange.com/election/download-result/1", "Table", 
    CharacterEncoding -> "UTF8"];
{{$candidates,$seats},$withdrawn,$votes,$names,$title} = blt /. 
    {
    {candidates_,seats_},
    withdrawn___,
    votes:Longest[{1,___,0}..],
    names__,
    title_
}:>

    {
    {candidates,seats},
    {withdrawn},
    {votes}[[All,2;;-2]],
    MapIndexed[#2[[1]]-1->#[[1]]&,{names}],
    title[[1]]
} /. {HoldPattern[0->0] :> 0->None}

2: Tally 2nd and 3rd choices for a given 1st choice

Clear@tallied2nd3rdVotes
tallied2nd3rdVotes[id_] := Module[
    {user,others,nilPad},
    user = id/.$names;
        others = DeleteCases[$names[[All,2]],user];
    nilPad[list_] := (others/.x:_String|None:>If[MemberQ[list,{x,_}],##&[],{x,0}]) ~Join~ list;
    {
        {"2nd choice","3rd choice"},
        Composition[Transpose,Sort,nilPad,Tally] /@ 
            (Transpose@Cases[$votes,{id,x__}:>{x}]/.$names)//Transpose
    }
]

3: Visualize the votes

Clear@visualizeVotes
visualizeVotes[id_] := tallied2nd3rdVotes[id] /. {choice_,{{names_,_},{tally__}}} :> 
    PairedBarChart[tally,
        ChartLabels->{Placed[choice,Above],None,Placed[names/.None->"None","RightAxis"]},
        ChartStyle->"Rainbow",
        BaseStyle->{FontSize->13},
        ImageSize->500
    ]

You then call it as visualizeVotes[4], for Mr.Wizard. The IDs can be found in $names. There is some small glitch in the function for ID 6 (Eiyrioü von Kauyf), probably because of the lack of votes, but I'm not going to fix it.

share|improve this answer
    
That's nice. I'll see if I can make a "small multiple" (© Edward Tufte) of the whole set. –  cormullion Sep 27 '12 at 11:12
1  
+1 I am impressed by how clean and clear the code is. The visualization is informative, too (although perhaps it's more than I wanted to know :-). –  whuber Sep 27 '12 at 13:01

If we assume that the votes are listed in the order they were cast, we can look at how the race evolved over time during the election period and monitor step by step who were in the leading positions. In this case I'm just calculating the number of votes without taking into account the rank.

enter image description here

Here the very dirty code to create this animation:

data = Import[
   "http://mathematica.stackexchange.com/election/download-result/1", 
   "Table", CharacterEncoding -> "UTF8"];
votes = Cases[data, {1, a_, b_, c_, 0} -> {a, b, c}];
votes1 = votes /. 
   Table[n -> First@data[[Rescale[n, {1, 6}, {-7, -2}]]], {n, 1, 6}];
votes2 = Partition[Flatten[votes1] /. {0 -> "Absent"}, 3];
cand = Union[Flatten[votes2]];
counter = Transpose[{cand, Table[0, {Length[cand]}]}];
counterList = {counter};
Flatten[Table[(Table[
     counter[[Position[counter, votes2[[j, i]]][[1, 1]], 2]] = 
      counter[[Position[counter, votes2[[j, i]]][[1, 1]], 2]] + 1,
     {i, 3}]; AppendTo[counterList, counter]), {j, Length[votes2]}], 
  1];
seq = Table[Show[
    ListLinePlot[
     Table[counterList[[1 ;; v, i, 2]], {i, Length[cand]}], 
     PlotStyle -> Orange, PlotRange -> {{0, 80}, {0, 80}}, 
     AspectRatio -> 1, 
     PlotLabel -> Style["Total Votes vs. Votes Cast", Bold]],
    Graphics[
     Table[{Orange, Disk[{v, counterList[[v, i, 2]]}, .75]}, {i, 
       Length[cand]}]],
    (o = Sort[counterList[[v]], #1[[2]] > #2[[2]] &][[1 ;; 4, 1]];
     Graphics[
      {Text[Style["Position:", Bold, Medium], {10, 75}, {-1, 0}],
       Text["1. " <> o[[1]], {10, 70}, {-1, 0}],
       Text["2. " <> o[[2]], {10, 65}, {-1, 0}],
       Text["3. " <> o[[3]], {10, 60}, {-1, 0}],
       Text["4. " <> o[[4]], {10, 55}, {-1, 0}]}
      ])], {v, 1, Length[votes2], 1}];
Export["image.gif", seq, "DisplayDurations" -> .25]
share|improve this answer
1  
Love it. One day all elections will be like this, only live! –  cormullion Sep 27 '12 at 16:18
    
@cormullion In this case, I propose "spermatozoon race plot" as the name for this plot and hope that Microsoft doesn't try to patent it like Tufte's sparklines. –  VLC Sep 27 '12 at 16:43
    
Haha, very nice! But I don't think it is in order, because then there would be a 1:1 correspondence with when the Constituent badges were awarded, leading to a loss in anonymity of votes. Also, votes can be changed anytime during the 7 days, further complicating it. Nevertheless, you get a +1 for a very interesting idea! :) –  rm -rf Sep 27 '12 at 17:16

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.