---
title: "plackett_luce_monster"
output: html_document
date: '2022-05-16'
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library("hyper2")
library("partitions")
library("pdftools")
```

<p style="text-align: right;">
![](`r system.file("help/figures/hyper2.png", package = "hyper2")`){width=10%}
</p>

%
    
We will calculate a Plackett-Luce likelihood function for four runners
$\left\lbrace 1,2,3,4\right\rbrace$ but with a reified Bradley-Terry
monster that corresponds to having subsets of mutual friends who
support one another.  For example, we might have runners 1 and 2 being
friends, and runners 3 and 4 being friends: we would represent this as
$\left\lbrace\left\lbrace 1,2\right\rbrace,\left\lbrace
3,4\right\rbrace\right\rbrace$.

There seem to be a few distinct statistical models for nonindependence:

* Runner $i$ might wish to support $j$.  If runner $i$ finishes, once
  his rank is established he might be able to help $j$ in some way.
  He might cheer his still-running friend.  In general, we can
  consider $n$ ordered pairs $(i_r,j_r)$, $1\leq r\leq n$, with runner
  $i_1$ helping runner $j_1$, runner $i_2$ helping $j_2$, and so on.
  One simple case would be equivalence classes of
  $[n]=\{1,2,\ldots,n\}$ with each equivalence class comprising
  mutually supporting runners.  In this model, with a pair of mutually
  supporting runners only the higher-placed competitor can affect the
  other.  Each equivalence class might have a different supportive
  proclivity.
  
* Runner $i$ might hate runner $j$.  If $i$ finishes, he might expend
  his spare energy hindering $j$ (by throwing stones or booing, for
  example).  Note that equivalence classes of mutual hatred might
  exist.
  
* Also, the help or hindrance might have a finite lifetime.  Under one
  model, if $i$ finishes then he can stay helping (or hindering) $j$
  wherever $j$ places.  Alternatively, suppose $i$ places $n$th.  Then
  perhaps he can affect $j$ only place $n+1$, and after a competitor
  finishes in place $n+1$, then $i$ can exert no further influence.

* The help or hindrance discussed above might be contingent on
  placing: perhaps only the winnner (that is, first-placing
  competitor) would be able to influence other competitors.  Or maybe
  competitors with any placing could influence other competitors.

* Runners $i$ and $j$ might elect to cross the finishing line holding
  hands, with the apparent tie broken randomly.  This would be a
  symmetrical relationship.  In general, we could consider
  hand-holding equivalence classes.

* We might have a resource allocation problem, with runners having a
  certain [possibly unknown] amount of "strength" but also the ability
  to expend this strength on objectives other than ranking in the
  race.  A runner might be able to expend just enough energy to remain
  slightly ahead of a rival, reserving energy for other purposes.  If
  runner $i$ wishes to beat runner $j$, and has sufficient resources
  to do so, then runners $i$ and $j$ will finish consecutively with
  $i$ ahead of $j$.


The runner metaphor is not the only one.  We can apply the resulting
likelihood functions to other cases including the red bus-blue bus
problem (see `inst/red_bus_blue_bus.Rmd` for more discussion).

First do three runners, and suppose the equivalence classes are
$\left\lbrace\left\lbrace 1,2\right\rbrace,\left\lbrace
3\right\rbrace\right\rbrace$.


 123: $\frac{p_1}{p_1+p_2+p_3}\cdot\frac{p_2+M}{p_2+p_3+M}\qquad\frac{p_1}{p_1+p_2+p_3}\cdot\frac{\lambda p_2}{\lambda p_2+p_3}$
 
 132: $\frac{p_1}{p_1+p_3+p_2}\cdot\frac{p_3}{p_3+p_2+M}\qquad\frac{p_1}{p_1+p_3+p_2}\cdot\frac{p_3}{p_3+\lambda p_2}$
 
 213: $\frac{p_2}{p_2+p_1+p_3}\cdot\frac{p_1+M}{p_1+p_3+M}\qquad\frac{p_2}{p_2+p_1+p_3}\cdot\frac{\lambda p_1}{\lambda p_1+p_3}$
 
 231: $\frac{p_2}{p_2+p_3+p_1}\cdot\frac{p_3}{p_3+p_1+M}\qquad\frac{p_2}{p_2+p_1+p_3}\cdot\frac{\lambda p_1}{p_3+\lambda p_1}$
 
 312: $\frac{p_3}{p_3+p_1+p_2}\cdot\frac{p_1}{p_2+p_1}\qquad\frac{p_3}{p_3+p_1+p_2}\cdot\frac{\lambda p_1}{p_3+p_1}$
 
 321: $\frac{p_3}{p_3+p_2+p_1}\cdot\frac{p_2}{p_2+p_1}\qquad\frac{p_3}{p_3+p_2+p_1}\cdot\frac{p_2}{p_2+p_1}$


Now four runners with classes $\left\lbrace\left\lbrace
1,2\right\rbrace,\left\lbrace 3,4\right\rbrace\right\rbrace$.

 1234: $\frac{1}{1+2+3+4}\cdot\frac{2+M}{2+3+4+M}\cdot\frac{3}{3+4}$

 1243: $\frac{1}{1+2+4+3}\cdot\frac{2+M}{2+4+3+M}\cdot\frac{4}{4+3}$

 1324: $\frac{1}{1+3+2+4}\cdot\frac{3}{3+2+4+M}\cdot\frac{2}{2+4+M}$

 1342: $\frac{1}{1+3+4+2}\cdot\frac{3}{3+4+2+M}\cdot\frac{4+M}{2+4+M}$

 1423: $\frac{1}{1+4+2+3}\cdot\frac{4}{4+2+3+M}\cdot\frac{2}{2+3}$

 1432: $\frac{1}{1+4+3+2}\cdot\frac{4}{4+3+2+M}\cdot\frac{3}{2+3}$

 2134: $\frac{2}{2+1+3+4}\cdot\frac{1+M}{1+3+4+M}\cdot\frac{3}{3+4}$

 2143: $\frac{2}{2+1+4+3}\cdot\frac{1+M}{1+4+3+M}\cdot\frac{4}{4+3}$

 2314: $\frac{2}{2+3+1+4}\cdot\frac{3}{3+1+4+M}\cdot\frac{1}{1+4+M}$

 2341: $\frac{2}{2+3+4+1}\cdot\frac{3}{3+4+1+M}\cdot\frac{4+M}{1+4+M}$

 2413: $\frac{2}{2+4+1+3}\cdot\frac{4}{4+1+3+M}\cdot\frac{1}{1+3}$

 2431: $\frac{2}{2+4+3+1}\cdot\frac{4}{4+3+1+M}\cdot\frac{3}{1+3}$

etc.


Now 123 tethered, 45 tethered:


12345: $\frac{1}{1+2+3+4+5}\cdot\frac{2+M}{2+3+4+5+M}\cdot\frac{3+M}{3+4+5+M}\cdot\frac{4}{4+5}$

12354: $\frac{1}{1+2+3+5+4}\cdot\frac{2+M}{2+3+5+4+M}\cdot\frac{3+M}{3+5+4+M}\cdot\frac{5}{5+4}$

12435: $\frac{1}{1+2+3+5+4}\cdot\frac{2+M}{2+3+5+4+M}\cdot\frac{4}{3+5+4+M}\cdot\frac{3}{3+5+M}$

12453: $\frac{1}{1+2+3+5+4}\cdot\frac{2+M}{2+3+5+4+M}\cdot\frac{4}{3+5+4+M}\cdot\frac{5+M}{5+3+M}$

12534: $\frac{1}{1+2+3+5+4}\cdot\frac{2+M}{2+5+3+4+M}\cdot\frac{5}{3+5+4+M}\cdot\frac{3}{3+4+M}$

12543: $\frac{1}{1+2+3+5+4}\cdot\frac{2+M}{2+5+4+3+M}\cdot\frac{5}{3+5+4+M}\cdot\frac{4+M}{4+3+M}$



Might be better to consider ${5\choose 2\,3}$ arrangements of $aaabb\ldots bbaaa$.

aaabb: $\frac{a}{a+a+a+b+b}\cdot\frac{a+M}{a+a+b+b+M}\cdot\frac{a+M}{a+b+b+M}\cdot\frac{b}{b+b+M}$

aabab: $\frac{a}{a+a+a+b+b}\cdot\frac{a+M}{a+a+b+b+M}\cdot\frac{b}{a+b+b+M}\cdot\frac{a}{a+b+M}$

aabba: $\frac{a}{a+a+a+b+b}\cdot\frac{a+M}{a+a+b+b+M}\cdot\frac{b}{a+b+b+M}\cdot\frac{b+M}{b+a+M}$

abaab: $\frac{a}{a+a+a+b+b}\cdot\frac{b}{a+a+b+b+M}\cdot\frac{a}{a+a+b+M}\cdot\frac{a+M}{a+b+M}$
 
ababa: $\frac{a}{a+a+a+b+b}\cdot\frac{b}{a+a+b+b+M}\cdot\frac{a}{a+a+b+M}\cdot\frac{b}{b+a+M}$

abbaa: $\frac{a}{a+a+a+b+b}\cdot\frac{b}{a+a+b+b+M}\cdot\frac{b+M}{b+a+a+M}\cdot\frac{a}{a+a+M}$

baaab: $\frac{b}{a+a+a+b+b}\cdot\frac{a}{a+a+a+b+M}\cdot\frac{a+M}{a+a+b+M}\cdot\frac{a+M}{a+b+M}$
 
baaba: $\frac{b}{a+a+a+b+b}\cdot\frac{a}{a+a+a+b+M}\cdot\frac{a+M}{a+a+b+M}\cdot\frac{b}{a+b+M}$
 
babaa: $\frac{b}{a+a+a+b+b}\cdot\frac{a}{a+a+a+b+M}\cdot\frac{b}{b+a+a+M}\cdot\frac{a}{a+a}$
 
bbaaa: $\frac{b}{a+a+a+b+b}\cdot\frac{b+M}{a+a+a+b+M}\cdot\frac{a}{a+a+a}\cdot\frac{a}{a+a}$



```{r,label=definefunctionf}
f <- function (a,b,M){
return(factorial(3)*factorial(2)*(
(a)/(a+a+a+b+b)*(a+M)/(a+a+b+b+M)*(a+M)/(a+b+b+M)*(b)/(b+b+M)+
(a)/(a+a+a+b+b)*(a+M)/(a+a+b+b+M)*(b)/(a+b+b+M)*(a)/(a+b+M)+
(a)/(a+a+a+b+b)*(a+M)/(a+a+b+b+M)*(b)/(a+b+b+M)*(b+M)/(b+a+M)+
(a)/(a+a+a+b+b)*(b)  /(a+a+b+b+M)*(a)/(a+a+b+M)*(a+M)/(a+b+M)+
(a)/(a+a+a+b+b)*(b)  /(a+a+b+b+M)*(a)/(a+a+b+M)*(b)/(b+a+M)+
(a)/(a+a+a+b+b)*(b)  /(a+a+b+b+M)*(b+M)/(b+a+a+M)*(a)/(a+a+M)+
(b)/(a+a+a+b+b)*(a)  /(a+a+a+b+M)*(a+M)/(a+a+b+M)*(a+M)/(a+b+M)+
(b)/(a+a+a+b+b)*(a)  /(a+a+a+b+M)*(a+M)/(a+a+b+M)*(b)/(a+b+M)+
(b)/(a+a+a+b+b)*(a)  /(a+a+a+b+M)*(b)/(b+a+a)*(a)/(a+a)+
(b)/(a+a+a+b+b)*(b+M)/(a+a+a+b+M)*(a)/(a+a+a)*(a)/(a+a)))
}
```


```{r}
f(4.4,3.3, 0.2)*12
f(4.4,3.3, 0.0)*12
```


```{tikz, fig.cap = "Partial probability tree for five competitors $a-e$ with $a$ supporting $b$, hyper3 approach", fig.ext = 'png', echo=FALSE}
\usetikzlibrary{arrows}
\usetikzlibrary{patterns}
\begin{tikzpicture}[line cap=round,line join=round,>=triangle 45,x=1cm,y=1cm]
\fill (0,0) circle[radius=2pt]; % root; paths abcde
\draw (0,0) -- (2,3); 
\draw (0,0) -- (2,2);
\draw (0,0) -- (2,1);
\draw (0,0) -- (2,0);
\draw (0,0) -- (2,-1);
\node at (0,2.5) (eq1) {$a\longrightarrow b$};

\node at (1.5,2.5) {$a$};
\node at (1.5,1.7) {$b$};
\node at (1.5,1.0) {$c$};
\node at (1.5,0.2) {$d$};
\node at (1.5,-0.5) {$e$};

\node at (3, 3)  {$\frac{a}{a+b+c+d+e}$};
\node at (3, 2)  {$\frac{b}{a+b+c+d+e}$};
\node at (3, 1)  {$\frac{c}{a+b+c+d+e}$};
\node at (3, 0)  {$\frac{d}{a+b+c+d+e}$};
\node at (3,-1)  {$\frac{e}{a+b+c+d+e}$};

\fill  (4, 3) circle[radius=2pt];  % a finishes; paths bcde
\fill  (4, 2) circle[radius=2pt];  % terminal node
\fill  (4, 1) circle[radius=2pt];  % terminal node
\fill  (4, 0) circle[radius=2pt];  % d finishes; paths abce
\fill  (4,-1) circle[radius=2pt];  % terminal node

\draw (4,3) -- (5,5); 
\draw (4,3) -- (5,4); 
\draw (4,3) -- (5,3); 
\draw (4,3) -- (5,2); 

\node at (4.5,4.6) {$b$};
\node at (4.5,3.7) {$c$};
\node at (4.5,3.2) {$d$};
\node at (4.5,2.7) {$e$};

\newcommand{\lb}{\lambda b }
\newcommand{\lc}{\lambda c }
\newcommand{\lee}{\lambda e }
\node at (6, 5)  {$\frac{\lb}{\lb+c+d+e}$};
\node at (6, 4)  {$\frac{c}{\lb+c+d+e}$};
\node at (6, 3)  {$\frac{d  }{\lb+c+d+e}$};
\node at (6, 2)  {$\frac{e  }{\lb+c+d+e}$};

\fill (7.4, 5) circle[radius=2pt];  % ab finishes; paths cde
\draw (7.4,5) -- (8.4,6);
\draw (7.4,5) -- (8.4,5);
\draw (7.4,5) -- (8.4,4);


\node at (7.9,5.7) {$c$};
\node at (7.9,5.2) {$d$};
\node at (7.9,4.7) {$e$};
\node at (9.3, 6) {$\frac{c}{c+d+e}$};
\node at (9.3, 5) {$\frac{d  }{c+d+e}$};
\node at (9.3, 4) {$\frac{e  }{c+d+e}$};

\fill (10.2, 6) circle[radius=2pt];  % abc finishes; paths de
\draw (10.2, 6) -- (11.2,7);
\node at (10.7,6.8) {$d$};

\node at (11.8, 7) {$\frac{d}{d+e}$};

\draw (10.2, 6) -- (11.2,6.2);
\node at (11.8, 6.2) {$\frac{e}{d+e}$};
\node at (10.7,6.3) {$e$};

\fill (10.2, 5) circle[radius=2pt];
\draw (10.2, 5) -- (11.2,5.3);
\node at (11.8, 5.3) {$\frac{c}{c+e}$};
\node at (10.7,5.3) {$c$};

\draw (10.2, 5) -- (11.2,4.7);
\node at (11.8, 4.7) {$\frac{e}{c+e}$};
\node at (10.7,4.7) {$e$};

\fill (10.2, 4) circle[radius=2pt];
\draw (10.2, 4) -- (11.2,3.9);
\node at (11.8, 3.9) {$\frac{c}{c+e}$};
\node at (10.7,4.1) {$c$};

\draw (10.2, 4) -- (11.2,3.1);
\node at (11.8, 3.1) {$\frac{e}{c+e}$};
\node at (10.7,3.7) {$e$};

\draw (4, 0) -- (5,1);
\node at (6, 1)  {$\frac{a}{a+b+c+e}$};

\draw (4, 0) -- (5,0);
\node at (6, 0)  {$\frac{b}{a+b+c+e}$};

\draw (4, 0) -- (5,-1);
\node at (6, -1)  {$\frac{c}{a+b+c+e}$}; 

\draw (4, 0) -- (5,-2);
\node at (6, -2)  {$\frac{e}{a+b+c+e}$};

\node at (4.5,0.7) {$a$};
\node at (4.5,0.2) {$b$};
\node at (4.5,-0.3) {$c$};
\node at (4.5,-0.8) {$e$};


\fill (7.4, -2) circle[radius=2pt];  % de finishes; paths abc
\draw (7.4, -2) -- (8.4,-1);
\draw (7.4, -2) -- (8.4,-2);
\draw (7.4, -2) -- (8.4,-3);

\node at (7.9,-1.2) {$a$};
\node at (7.9,-1.8) {$b$};
\node at (7.9,-2.3) {$c$};

\node at (9.3, -1) {$\frac{a}{a+b+c}$};
\node at (9.3, -2) {$\frac{b}{a+b+c}$};
\node at (9.3, -3) {$\frac{c}{a+b+c}$};

\fill (10.2, -1) circle[radius=2pt];  % dea finishes; paths bc
\fill (10.2, -2) circle[radius=2pt];  % deb finishes; paths ac
\fill (10.2, -3) circle[radius=2pt];  % dec finishes; paths ab

\draw (10.2, -1) -- (11.2,-0);
\node at (10.6,-0.4) {$b$};
\node at (10.6,-0.8) {$c$};


\node at (11.8, 0) {$\frac{\lb}{\lb+c}$};
\draw (10.2, -1) -- (11.2,-1);

\node at (11.8, -1) {$\frac{c}{\lb+c}$};


\draw (10.2, -2) -- (11.2,-1.6);
\node at (11.8, -1.6) {$\frac{a}{a+c}$};

\node at (10.6,-1.7) {$a$};
\node at (10.6,-2) {$c$};

\draw (10.2, -2) -- (11.2,-2.2);
\node at (11.8, -2.2) {$\frac{c}{a+c}$};

\draw (10.2, -3) -- (11.2,-2.9);
\node at (11.8, -2.9) {$\frac{a}{a+b}$};

\draw (10.2, -3) -- (11.2,-3.4);
\node at (11.8, -3.4) {$\frac{b}{a+b}$};

\node at (10.6,-2.8) {$a$};
\node at (10.6,-3.3) {$b$};

\fill (7.4, 1) circle[radius=2pt];  % da finishes; paths bce

\draw (7.4, 1) -- (8.4,2);
\draw (7.4, 1) -- (8.4,1);
\draw (7.4, 1) -- (8.4,0);

\node at (7.9,1.7) {$b$};
\node at (7.9,1.2) {$c$};
\node at (7.9,0.7) {$e$};

\node at (9.3, 2) {$\frac{\lb}{\lb+c+e}$};
\node at (9.3, 1) {$\frac{  c}{\lb+c+e}$};
\node at (9.3, 0) {$\frac{e  }{\lb+c+e}$};

\fill (10.2, 1) circle[radius=2pt];  % da finishes; paths bce
\draw (10.2, 1) -- (11.2,2);
\node at (11.8, 2) {$\frac{\lb}{\lb+e}$};
\draw (10.2, 1) -- (11.2,1);
\node at (11.8, 1) {$\frac{e}{\lb+e}$};

\end{tikzpicture}
```

```{tikz, fig.cap = "Partial probability tree for five competitors $a-e$ with mutually supporting  group $abc$, hyper3 approach.  If any competitor in the set {$a,b,c$} finishes, they lend their strength to the other competitors in the set who are still running", fig.ext = 'png', echo=FALSE}
\usetikzlibrary{arrows}
\usetikzlibrary{patterns}
\begin{tikzpicture}[line cap=round,line join=round,>=triangle 45,x=1cm,y=1cm]
\fill (0,0) circle[radius=2pt]; % root; paths abcde
\draw (0,0) -- (2,3); 
\draw (0,0) -- (2,2);
\draw (0,0) -- (2,1);
\draw (0,0) -- (2,0);
\draw (0,0) -- (2,-1);
\node at (0,2.5) (eq1) {$\underbrace{\left\lbrace a,b,c\right\rbrace}_{\lambda}$};

\node at (1.5,2.5) {$a$};
\node at (1.5,1.7) {$b$};
\node at (1.5,1.0) {$c$};
\node at (1.5,0.2) {$d$};
\node at (1.5,-0.5) {$e$};

\node at (3, 3)  {$\frac{a}{a+b+c+d+e}$};
\node at (3, 2)  {$\frac{b}{a+b+c+d+e}$};
\node at (3, 1)  {$\frac{c}{a+b+c+d+e}$};
\node at (3, 0)  {$\frac{d}{a+b+c+d+e}$};
\node at (3,-1)  {$\frac{e}{a+b+c+d+e}$};

\fill  (4, 3) circle[radius=2pt];  % a finishes; paths bcde
\fill  (4, 2) circle[radius=2pt];  % terminal node
\fill  (4, 1) circle[radius=2pt];  % terminal node
\fill  (4, 0) circle[radius=2pt];  % d finishes; paths abce
\fill  (4,-1) circle[radius=2pt];  % terminal node

\draw (4,3) -- (5,5); 
\draw (4,3) -- (5,4); 
\draw (4,3) -- (5,3); 
\draw (4,3) -- (5,2); 

\node at (4.5,4.6) {$b$};
\node at (4.5,3.7) {$c$};
\node at (4.5,3.2) {$d$};
\node at (4.5,2.7) {$e$};

\newcommand{\la}{\lambda a }
\newcommand{\lb}{\lambda b }
\newcommand{\lc}{\lambda c }
\newcommand{\lee}{\lambda e }
 \node at (6, 5)  {$\frac{\lb}{\lb+\lc+d+e}$};
 \node at (6, 4)  {$\frac{\lc}{\lb+\lc+d+e}$};
 \node at (6, 3)  {$\frac{d  }{\lb+\lc+d+e}$};
 \node at (6, 2)  {$\frac{e  }{\lb+\lc+d+e}$};
 
 \fill (7.4, 5) circle[radius=2pt];  % ab finishes; paths cde
 \draw (7.4,5) -- (8.4,6);
 \draw (7.4,5) -- (8.4,5);
 \draw (7.4,5) -- (8.4,4);
 
 \node at (7.9,5.7) {$c$};
 \node at (7.9,5.2) {$d$};
 \node at (7.9,4.7) {$e$};
 \node at (9.3, 6) {$\frac{\lc}{\lc+d+e}$};
 \node at (9.3, 5) {$\frac{d  }{\lc+d+e}$};
 \node at (9.3, 4) {$\frac{e  }{\lc+d+e}$};
 
 \fill (10.2, 6) circle[radius=2pt];  % abc finishes; paths de
 \draw (10.2, 6) -- (11.2,7);
 \node at (10.7,6.8) {$d$};
 
 \node at (11.8, 7) {$\frac{d}{d+e}$};
 
 \draw (10.2, 6) -- (11.2,6.2);
 \node at (11.8, 6.2) {$\frac{e}{d+e}$};
 \node at (10.7,6.3) {$e$};
 
 \fill (10.2, 5) circle[radius=2pt];
 \draw (10.2, 5) -- (11.2,5.3);
 \node at (11.8, 5.3) {$\frac{\lc}{\lc+e}$};
 \node at (10.7,5.3) {$c$};
 
 \draw (10.2, 5) -- (11.2,4.7);
 \node at (11.8, 4.7) {$\frac{e}{\lc+e}$};
 \node at (10.7,4.7) {$e$};
 
 \fill (10.2, 4) circle[radius=2pt];
 \draw (10.2, 4) -- (11.2,3.9);
 \node at (11.8, 3.9) {$\frac{\lc}{\lc+e}$};
 \node at (10.7,4.1) {$c$};
 
 \draw (10.2, 4) -- (11.2,3.1);
 \node at (11.8, 3.1) {$\frac{e}{\lc+e}$};
 \node at (10.7,3.7) {$e$};
 
 \draw (4, 0) -- (5,1);
 \node at (6, 1)  {$\frac{a}{a+b+c+e}$};
 
 \draw (4, 0) -- (5,0);
 \node at (6, 0)  {$\frac{b}{a+b+c+e}$};
 
 \draw (4, 0) -- (5,-1);
 \node at (6, -1)  {$\frac{c}{a+b+c+e}$}; 
 
 \draw (4, 0) -- (5,-2);
 \node at (6, -2)  {$\frac{e}{a+b+c+e}$};
 
 \node at (4.5,0.7) {$a$};
 \node at (4.5,0.2) {$b$};
 \node at (4.5,-0.3) {$c$};
 \node at (4.5,-0.8) {$e$};
 
 
 \fill (7.4, -2) circle[radius=2pt];  % de finishes; paths abc
 \draw (7.4, -2) -- (8.4,-1);
 \draw (7.4, -2) -- (8.4,-2);
 \draw (7.4, -2) -- (8.4,-3);
 
 \node at (7.9,-1.2) {$a$};
 \node at (7.9,-1.8) {$b$};
 \node at (7.9,-2.3) {$c$};
 
 \node at (9.3, -1) {$\frac{a}{a+b+c}$};
 \node at (9.3, -2) {$\frac{b}{a+b+c}$};
 \node at (9.3, -3) {$\frac{c}{a+b+c}$};
 
 \fill (10.2, -1) circle[radius=2pt];  % dea finishes; paths bc
 \fill (10.2, -2) circle[radius=2pt];  % deb finishes; paths ac
 \fill (10.2, -3) circle[radius=2pt];  % dec finishes; paths ab
 
 \draw (10.2, -1) -- (11.2,-0);
 \node at (10.6,-0.4) {$b$};
 \node at (10.6,-0.8) {$c$};
 
 
 \node at (11.8, 0) {$\frac{\lb}{\lb+\lc}$};
 \draw (10.2, -1) -- (11.2,-1);
 
 \node at (11.8, -1) {$\frac{c}{\lb+\lc}$};
 
 
 \draw (10.2, -2) -- (11.2,-1.6);
 \node at (11.8, -1.6) {$\frac{\la}{\la+\lc}$};
 
 \node at (10.6,-1.7) {$a$};
 \node at (10.6,-2) {$c$};
 
 \draw (10.2, -2) -- (11.2,-2.2);
 \node at (11.8, -2.2) {$\frac{\lc}{\la+\lc}$};
 
 \draw (10.2, -3) -- (11.2,-2.9);
 \node at (11.8, -2.9) {$\frac{\la}{\la+\lb}$};
 
 \draw (10.2, -3) -- (11.2,-3.4);
 \node at (11.8, -3.4) {$\frac{\lb}{\la+\lb}$};
 
 \node at (10.6,-2.8) {$a$};
 \node at (10.6,-3.3) {$b$};
 
 \fill (7.4, 1) circle[radius=2pt];  % da finishes; paths bce
 
 \draw (7.4, 1) -- (8.4,2);
 \draw (7.4, 1) -- (8.4,1);
 \draw (7.4, 1) -- (8.4,0);
 
 \node at (7.9,1.7) {$b$};
 \node at (7.9,1.2) {$c$};
 \node at (7.9,0.7) {$e$};
 
 \node at (9.3, 2) {$\frac{\lb}{\lb+\lc+e}$};
 \node at (9.3, 1) {$\frac{\lc}{\lb+\lc+e}$};
 \node at (9.3, 0) {$\frac{e  }{\lb+\lc+e}$};
 
 \fill (10.2, 1) circle[radius=2pt];  % da finishes; paths bce
 \draw (10.2, 1) -- (11.2,2);
 \node at (11.8, 2) {$\frac{\lb}{\lb+e}$};
 \draw (10.2, 1) -- (11.2,1);
 \node at (11.8, 1) {$\frac{e}{\lb+e}$};

\end{tikzpicture}
```



```{tikz, fig.cap = "Partial probability tree for five competitors $a$-$e$ with mutually supporting subsets $\\left\\lbrace a,b,c\\right\\rbrace$ [with support term $\\lambda$] and $(de)$ [with support term $\\mu$], hyper3 approach", fig.ext = 'png', echo=FALSE}
\usetikzlibrary{arrows}
\usetikzlibrary{patterns}
\begin{tikzpicture}[line cap=round,line join=round,>=triangle 45,x=1cm,y=1cm]
\fill (0,0) circle[radius=2pt]; % root; paths abcde
\draw (0,0) -- (2,3); 
\draw (0,0) -- (2,2);
\draw (0,0) -- (2,1);
\draw (0,0) -- (2,0);
\draw (0,0) -- (2,-1);
\node at (0,2.5) (eq1) {$\underbrace{\left\lbrace a,b,c\right\rbrace}_{\lambda}\underbrace{\left\lbrace d,e\right\rbrace}_{\mu}$};

\node at (1.5,2.5) {$a$};
\node at (1.5,1.7) {$b$};
\node at (1.5,1.0) {$c$};
\node at (1.5,0.2) {$d$};
\node at (1.5,-0.5) {$e$};

\node at (3, 3)  {$\frac{a}{a+b+c+d+e}$};
\node at (3, 2)  {$\frac{b}{a+b+c+d+e}$};
\node at (3, 1)  {$\frac{c}{a+b+c+d+e}$};
\node at (3, 0)  {$\frac{d}{a+b+c+d+e}$};
\node at (3,-1)  {$\frac{e}{a+b+c+d+e}$};

\fill  (4, 3) circle[radius=2pt];  % a finishes; paths bcde
\fill  (4, 2) circle[radius=2pt];  % terminal node
\fill  (4, 1) circle[radius=2pt];  % terminal node
\fill  (4, 0) circle[radius=2pt];  % d finishes; paths abce
\fill  (4,-1) circle[radius=2pt];  % terminal node

\draw (4,3) -- (5,5); 
\draw (4,3) -- (5,4); 
\draw (4,3) -- (5,3); 
\draw (4,3) -- (5,2); 

\node at (4.5,4.6) {$b$};
\node at (4.5,3.7) {$c$};
\node at (4.5,3.2) {$d$};
\node at (4.5,2.7) {$e$};

\newcommand{\la}[1]{\lambda{#1}}
\newcommand{\ld}[1]{\mu    {#1}}
\node at (6, 5)  {$\frac{\la{b}}{\la{b}+\la{c}+d+e}$};
\node at (6, 4)  {$\frac{\la{c}}{\la{b}+\la{c}+d+e}$};
\node at (6, 3)  {$\frac{d     }{\la{b}+\la{c}+d+e}$};
\node at (6, 2)  {$\frac{e     }{\la{b}+\la{c}+d+e}$};

\fill (7.4, 5) circle[radius=2pt];  % ab finishes; pahts cde
\draw (7.4,5) -- (8.4,6);
\draw (7.4,5) -- (8.4,5);
\draw (7.4,5) -- (8.4,4);


\node at (7.9,5.7) {$c$};
\node at (7.9,5.2) {$d$};
\node at (7.9,4.7) {$e$};
\node at (9.3, 6) {$\frac{\la{c}}{\la{c}+d+e}$};
\node at (9.3, 5) {$\frac{d  }{\la{c}+d+e}$};
\node at (9.3, 4) {$\frac{e  }{\la{c}+d+e}$};

\fill (10.2, 6) circle[radius=2pt];  % abc finishes; paths de
\draw (10.2, 6) -- (11.2,7);
\node at (10.7,6.8) {$d$};

\node at (11.8, 7) {$\frac{d}{d+e}$};

\draw (10.2, 6) -- (11.2,6.2);
\node at (11.8, 6.2) {$\frac{e}{d+e}$};
\node at (10.7,6.3) {$e$};

\fill (10.2, 5) circle[radius=2pt];
\draw (10.2, 5) -- (11.2,5.3);
\node at (11.8, 5.3) {$\frac{\la{c}}{\la{c}+\ld{e}}$};
\node at (10.7,5.3) {$c$};

\draw (10.2, 5) -- (11.2,4.7);
\node at (11.8, 4.7) {$\frac{\ld{e}}{\la{c}+\ld{e}}$};
\node at (10.7,4.7) {$e$};

\fill (10.2, 4) circle[radius=2pt];
\draw (10.2, 4) -- (11.2,3.9);
\node at (11.8, 3.9) {$\frac{\la{c}}{\la{c}+\ld{e}}$};
\node at (10.7,4.1) {$c$};

\draw (10.2, 4) -- (11.2,3.1);
\node at (11.8, 3.1) {$\frac{\ld{e}}{\la{c}+\ld{e}}$};
\node at (10.7,3.7) {$e$};

\draw (4, 0) -- (5,1);
\node at (6, 1)  {$\frac{a}{a+b+c+\ld{e}}$};

\draw (4, 0) -- (5,0);
\node at (6, 0)  {$\frac{b}{a+b+c+\ld{e}}$};

\draw (4, 0) -- (5,-1);
\node at (6, -1)  {$\frac{c}{a+b+c+\ld{e}}$}; 

\draw (4, 0) -- (5,-2);
\node at (6, -2)  {$\frac{\ld{e}}{a+b+c+\ld{e}}$};

\node at (4.5,0.7) {$a$};
\node at (4.5,0.2) {$b$};
\node at (4.5,-0.3) {$c$};
\node at (4.5,-0.8) {$e$};


\fill (7.4, -2) circle[radius=2pt];  % de finishes; paths abc
\draw (7.4, -2) -- (8.4,-1);
\draw (7.4, -2) -- (8.4,-2);
\draw (7.4, -2) -- (8.4,-3);

\node at (7.9,-1.2) {$a$};
\node at (7.9,-1.8) {$b$};
\node at (7.9,-2.3) {$c$};

\node at (9.3, -1) {$\frac{a}{a+b+c}$};
\node at (9.3, -2) {$\frac{b}{a+b+c}$};
\node at (9.3, -3) {$\frac{c}{a+b+c}$};

\fill (10.2, -1) circle[radius=2pt];  % dea finishes; paths bc
\fill (10.2, -2) circle[radius=2pt];  % deb finishes; paths ac
\fill (10.2, -3) circle[radius=2pt];  % dec finishes; paths ab

\draw (10.2, -1) -- (11.2,-0);
\node at (10.6,-0.4) {$b$};
\node at (10.6,-0.8) {$c$};


\node at (11.8, 0) {$\frac{\la{b}}{\la{b}+\la{c}}$};
\draw (10.2, -1) -- (11.2,-1);

\node at (11.8, -1) {$\frac{\la{c}}{\la{b}+\la{c}}$};


\draw (10.2, -2) -- (11.2,-1.6);
\node at (11.8, -1.6) {$\frac{\la{a}}{\la{a}+\la{c}}$};

\node at (10.6,-1.7) {$a$};
\node at (10.6,-2) {$c$};

\draw (10.2, -2) -- (11.2,-2.2);
\node at (11.8, -2.2) {$\frac{\la{c}}{\la{a}+\la{c}}$};

\draw (10.2, -3) -- (11.2,-2.9);
\node at (11.8, -2.9) {$\frac{\la{a}}{\la{a}+\la{b}}$};

\draw (10.2, -3) -- (11.2,-3.4);
\node at (11.8, -3.4) {$\frac{\la{b}}{\la{a}+\la{b}}$};

\node at (10.6,-2.8) {$a$};
\node at (10.6,-3.3) {$b$};

\fill (7.4, 1) circle[radius=2pt];  % da finishes; paths bce

\draw (7.4, 1) -- (8.4,2);
\draw (7.4, 1) -- (8.4,1);
\draw (7.4, 1) -- (8.4,0);

\node at (7.9,1.7) {$b$};
\node at (7.9,1.2) {$c$};
\node at (7.9,0.7) {$e$};

\node at (9.3, 2) {$\frac{\la{b}}{\la{b}+\la{c}+e}$};
\node at (9.3, 1) {$\frac{\la{c}}{\la{b}+\la{c}+e}$};
\node at (9.3, 0) {$\frac{e     }{\la{b}+\la{c}+e}$};


\fill (10.2, 1) circle[radius=2pt];  % da finishes; paths bce
\draw (10.2, 1) -- (11.2,2);
\node at (11.8, 2) {$\frac{\la{b}}{\la{b}+\ld{e}}$};
\draw (10.2, 1) -- (11.2,1);
\node at (11.8, 1) {$\frac{\ld{e}}{\la{b}+e}$};

\end{tikzpicture}
```



# Package idiom

We can investigate red bus-blue bus phenomenon (as discussed, in a
slightly different context, in `inst/red_bus_blue_bus.Rmd`).  Here, we
consider a person who is given the choice of five transport methods:

* `C`, car
* `T`, train
* `RB` a red bus
* `BB` a blue bus
* `W` walking


Now, he does not really care what colour the bus is.  If we ask him to
rank his options, it is highly probable that he will put `RB` and `BB`
consecutively (because they are essentially indistinguishable).  Can
we quantify the strength of this effect?  To do this, we define a
bespoke function `RB_BB_LF()` which returns a `hyper3` log-likelihood
function corresponding to repeated observations of our commuter's
reported ranks for the five options:


```{r,defineredbuslf}
`RB_BB_LF` <- function(s){
    ec <- c(C=1,T=2,RB=3,BB=3,W=4) # equivalence classes
    h <- c(1,1,s,1)                # strength of support
    (
        cheering3(v=c("RB","BB","C" ,"T","W"),e=ec,h=h)*3 + 
        cheering3(v=c("BB","RB","T" ,"C","W"),e=ec,h=h)*2 + 
        cheering3(v=c("T" ,"BB","RB","C","W"),e=ec,h=h)*2 + 
        cheering3(v=c("W" ,"BB","RB","T","C"),e=ec,h=h)*4 + 
        cheering3(v=c("C" ,"RB","BB","W","T"),e=ec,h=h)*4 + 
        cheering3(v=c("BB","C" ,"RB","T","W"),e=ec,h=h)*3
    )
}
```

Above, we see from the function body that he reported `RB,BB,C,T,W`
three times [first row], `BB,RB,T,C,W` twice [second row], and so on;
perhaps his ranking depends on the weather or how tired he is on any
given day.  Observe that in almost every case he ranks `RB` and `BB`
consecutively.  Function `RB_BB_LF()` takes argument `s` that
quantifies the perceived similarity between `RB` and `BB`.  For
example:

```{r,examplerbbblf,cache=TRUE}
(H <- RB_BB_LF(s=1.8888))
(mH <- maxp(H,n=1))
```

Now to find a profile likelihood function for `s`:

```{r,label=proflikeredbus,cache=TRUE}
o <- function(s){maxp(RB_BB_LF(s),give=TRUE,n=1)$likes} # optimand
s <- exp(seq(from=log(1.3),to=log(47),len=17)) # putative similarity measures
L <- sapply(s,o)
L <- L-max(L)
```

We can plot these:



```{r,plotproflike}
plot(s,L,type="b")
abline(h=c(0,-2))
abline(v=1)
plot(log(s),L,type="b")
abline(h=c(0,-2))
abline(v=0)
```

And formally maximize the likelihood:

```{r,label=maxlikesim,cache=TRUE}
(osup <- optimize(o,c(6,10),maximum=TRUE))
```

So a likelihood ratio test of the null that $S=1$ would be:

```{r,label=LRT_RB,cache=TRUE}
(suppdiff <- o(osup$maximum) - o(1))
```


Easily satisfying Edwards's two-units-of-support criterion; Wilks gives us an asymptotic $p$-value:

```{r,label=RBBBpval}
pchisq(suppdiff*2,df=1,lower.tail=FALSE)
```

# University ranking analysis

Here we use a dataset of university rankings, `timesData.csv`, taken
from
`https://github.com/arnaudbenard/university-ranking/blob/master/timesData.csv`.

```{r}
a <- read.table("timesData.csv",sep=",", header=TRUE)
wanted <- c("California Institute of Technology", "Harvard University", 
"Massachusetts Institute of Technology", "Princeton University", 
"Stanford University", "University of Cambridge", "University of Oxford")
names(wanted) <- c("cal","harv","mass","prin","stan","cam","ox")

a <- a[a$university_name %in% wanted,]
a <- cbind(a,"top7rank"=0)
for(y in unique(a$year)){
    a[a$year==y,"top7rank"] <- order(
     			  as.numeric(a[a$year==y,"world_rank"]) + 
                                     a[a$year==y,"research"]/1e6,
decreasing=TRUE)}
a <- a[,c("top7rank","university_name","year")]
a <- reshape(a,idvar="university_name",timevar="year",direction="wide")
for(i in seq_len(nrow(a))){
   a$university_name[i] <- names(which(wanted == a$university_name[i]))
}
rownames(a) <- a$university_name
a <- a[,-1]
colnames(a) <- paste("Y",2011:2016,sep="")
a
H <- ordertable2supp(a)
```

```{r,label=testuniv,cache=TRUE}
equalp.test(H)
samep.test(H,c("ox","cam"))
```

Start to use `hyper3` idiom:

```{r,label=defineoxcam}
H3 <- function(oxcam){
  out <- hyper3()
  for(i in seq_len(ncol(a))){
    jj <- rep("",nrow(a))
    jj[a[,i]] <- rownames(a)
    out <- out + cheering3(v=jj,e=c(ox=1,cam=1,prin=2, stan=3, mass=4, harv=5, cal=6), help=c(oxcam,1,1,1,1,1))
  }
  return(out)
}
```

```{r,label=calculateoxcam,cache=TRUE}
o <- function(oxcam){maxp(H3(oxcam),give=TRUE,n=1)$likes}
oc <- exp(seq(from=log(0.5),to=log(5),len=15))
L <- sapply(oc,o)
L <- L - max(L)
```


```{r,label=plotoxcam}
plot(log(oc),L,type="b")
abline(v=0)
```


# Five nations championship

The five nations rugby championship was held from 1910 to 1999 and
file `five_nations.txt` shows the order statistic for England (E),
Scotland (S), Ireland (I), Wales (W), and France (F).

`https://en.wikipedia.org/wiki/Six_Nations_Championship`

Here is `hyper2` analysis:


```{r,load5nationsdata,cache=TRUE}
a <- as.matrix(read.table("five_nations.txt",header=FALSE))
head(a)
H <- hyper2()
for(i in seq_len(nrow(a))){
  H <- H + race(a[i,-1])
} 
mH <- maxp(H)
pie(mH)
equalp.test(H)
```


Now use `hyper3` to see whether teams do better following a win:

```{r,rugby3,cache=TRUE}
rugby <- function(lambda){
  H3a <- hyper3()
  for(i in seq(from=2,to=nrow(a))){
        last_year_winner <- a[i-1,2] # e.g. "W" or "E"
        H3a <- H3a + ordervec2supp3a(a[i,-1],nonfinishers=NULL,helped=last_year_winner,lambda=lambda)
  }
  return(H3a)
}
rugby(1.888)
rugby(1.111111)
```


```{r,rugby3max, cache=TRUE}
maxp(rugby(1.8),n=1,give=TRUE)
maxp(rugby(1.9),n=1,give=TRUE)
```

      
