How to visualize the voting choices in the moderator elections?

Question

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[
 "https://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?

Answer 1

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

Answer 2

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[
   "https://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]]}]

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

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

Answer 3

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.

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]

Answer 4

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

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

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

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

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:

Answer 5

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.

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:

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

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.