---
title: "Underdispersion in the context of community athletics"
output: bookdown::html_document2
author: "Robin K. S. Hankin"
bibliography: "hyper2.bib"
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```

```{r out.width='20%', out.extra='style="float:right; padding:10px"',echo=FALSE}
knitr::include_graphics(system.file("help/figures/hyper2.png", package = "hyper2"))
```

To cite the `hyper2` package in publications, please use @hankin2017_rmd.

@paul1995 [page 1401] state that "underdispersion will be seen very
rarely in real-life situations".

@prentice186 [page 322] states that "underdispersed data...may be rare
in applications"

Ranked data arises whenever multiple entities are sorted by some
criterion; the preferred interpretation is a race in which the
sufficient statistic is the order of competitors crossing the
finishing line.  The Plackett--Luce likelihood function
[@luce1959;@plackett1975] is a generalization of the Bradley--Terry
model [@bradley1952] in which non-negative strengths are assigned to
each competitor; without loss of generality, if the finishing order is
$1,2,\ldots,n$ and competitor $i$ has strength $p_i\geqslant 0$, then
the Plackett--Luce likelihood function will be proportional to

\begin{equation}\label{plackettluce}
\prod_{i=1}^n\frac{p_i}{\sum_{j=i}^np_j}
\end{equation}

\noindent where the strengths are normalised so $\sum p_i=1$.  Here we
consider Plackett--Luce likelihood functions in which
$p_i\propto\alpha^{-i}$ for some (generally unknown) $\alpha\geqslant
1$.  The reason for the minus sign is so that, if $\alpha\gg 1$, the
rank of competitor $i$ will be close to $i$.  Sometimes it will be
convenient to parametrize in terms of $\beta=\alpha^{-1}$.

Here, observations are restricted to knowledge of the rank of a single
competitor.  Such observations are common in practice: examples would
include an educational context in which a known number of people
attempt an examination and the only information one actually has is
one's own rank ["you came fifteenth out of a class of 85"]:
confidentiality considerations mean that knowledge of classmates'
performance is censored.  One might complete a foot race and learn
that you placed, say, 194${}^\mathrm{th}$ out of 340 entries.  In this
case the identities and abilities of the other runners are of no
interest.  Other examples might include Formula 1 motor racing, in
which a driver might race in multiple seasons in fields of 22-23:
@hankin2024 notes that Sergio Perez has raced against a total of 73
distinct competitors, rendering conventional Plackett-Luce techniques
intractable.

# Simple cases


### Two competitors {-}
The simplest non-trivial case would be two competitors with strengths
proportional to $1,\alpha^{-1}$, the unit-sum constraint meaning that
the strengths are
$\left(\frac{\alpha}{1+\alpha},\frac{1}{1+\alpha}\right)$; these are
the probabilities of competitor 1 coming first and second.

### Three competitors {-}

With three competitors we will do the general case first; let's say
the strengths are $a,b,c, a+b+c=1$.

Competitor $a$ comes first means the order was either $a\succ b\succ
c$ or $a\succ c\succ b$, that is with probability

$$
\frac{a}{a+b+c}\cdot\frac{b}{b+c} + 
\frac{a}{a+b+c}\cdot\frac{c}{b+c}
=\frac{a}{a+b+c}
$$

Competitor $a$ comes second means $b\succ a\succ c$ or $c\succ a\succ b$, that is

$$
\frac{b}{a+b+c}\cdot\frac{a}{a+c} + 
\frac{c}{a+b+c}\cdot\frac{a}{a+b}
$$

Competitor $a$ comes third means $b\succ c\succ a$ or $c\succ b\succ a$, that is

$$
\frac{b}{a+b+c}\cdot\frac{c}{a+c} + 
\frac{c}{a+b+c}\cdot\frac{b}{a+b}
$$


Now the strengths of $a,b,c$ are are proportional to
$1,\alpha^{-1},\alpha^{-2}$ respectively, so they are
$\left(\frac{\alpha^2}{1+\alpha+\alpha^2},\frac{\alpha}{1+\alpha+\alpha^2},\frac{1}{1+\alpha+\alpha^2}\right)$.



**Competitor ${\mathbf a}$** comes first with probability
$\frac{\alpha^2}{1+\alpha+\alpha^2}$.  Second with probability

$$
\frac{\alpha(1+2\alpha^2+\alpha^3)}{(1+\alpha)(1+\alpha^2)(1+\alpha+\alpha^2)}
$$

[interesting observation: this has a maximum at $a\simeq 1.35271>1$ of
about $0.3466 > \frac{1}{3}$].  He comes last with a probability of

$$
\frac{1+\alpha+2\alpha^2}{(1+\alpha)(1+\alpha^2)(1+\alpha+\alpha^2)}
$$


**Competitor ${\mathbf b}$** comes first with probability
$\frac{\alpha}{1+\alpha+\alpha^2}$.  Second with probability (after
simplification) of

$$
\frac{1+\alpha^3}{(1+\alpha)(1+\alpha+\alpha^2)}
$$

and third with probability $\frac{\alpha}{1+\alpha+\alpha^2}$.

**Competitor ${\mathbf c}$** comes first with probability
$\frac{1}{1+\alpha+\alpha^2}$.  Second with probability (after
simplification) of  

$$
\frac{\alpha(1+2\alpha+\alpha^3)}{(1+\alpha)(1+\alpha^2)(1+\alpha+\alpha^2)}
$$


and last with probability

$$
\frac{\alpha^3(2+\alpha+\alpha^2)}{(1+\alpha)(1+\alpha^2)(1+\alpha+\alpha^2)}
$$



```{r deff}
library("hyper2")

f <- function(n,alpha){
  jj <- 1/alpha^(1:n)
  return(jj/sum(jj))
}

getlike <- function(v){
  alpha <- v[1]
  beta <- v[2]
 c(
tabulate(replicate(10000,which(rrace(setNames(f(26,alpha),letters))==letters[beta])),nbins=26)
,alpha,beta)
}
```

```{r calculateLikemat,cache=FALSE}
alpha_try <- seq(from=1,to=6,len=20)
beta_try <- 1:26
calculate_from_scratch <- FALSE
if(calculate_from_scratch){
    M <- as.matrix(expand.grid(alpha=alpha_try, beta=beta_try))
    system.time(L <- t(apply(M,1,getlike)))
    colnames(L) <- c(letters,'alpha','beta')
    saveRDS(L,file="likelihoodmatrix.Rdata")
} else {
    L <- readRDS("likelihoodmatrix.Rdata")
}
L_integer <- L  # counts
L[,1:26] <- L[,1:26]/mean(rowSums(L[,1:26]))
head(L_integer)
head(L)
```

```{r makecontL}
colSums(L)
mL <- function(i){matrix(L[,i],length(alpha_try),length(beta_try))}
filled.contour(alpha_try,beta_try,mL(1))
filled.contour(alpha_try,beta_try,mL(5))
filled.contour(alpha_try,beta_try,mL(10))
filled.contour(alpha_try,beta_try,mL(15))
filled.contour(alpha_try,beta_try,mL(20))
filled.contour(alpha_try,beta_try,mL(26))
```

```{r}
#plot(table(L_integer[,1:26]))
```

## Now some in-silico races

```{r doinsilico,cache=FALSE}
alphatrue <- 1.3
betatrue <- 11 
set.seed(1)
D <- replicate(7,which(rrace(setNames(f(26,alphatrue),letters))==letters[betatrue]))
sort(D)
plot(table(D))
```

```{r trylikeinsilico,cache=FALSE}
likelihood <- apply(0.00+L[,D],1,prod) + 0.00
likelihood <- matrix(likelihood,length(alpha_try),length(beta_try))
```

```{r showlike}
round(alpha_try,2)
matplot(alpha_try,likelihood*1e14,type='b')
matplot(beta_try,t(likelihood)*1e14,type='b')
matplot(alpha_try,log(likelihood)-log(max(likelihood)),type='b',ylim=c(-20,0))
matplot(beta_try,log(t(likelihood))-log(max(likelihood)),type='b',ylim=c(-20,0))
filled.contour(alpha_try,beta_try,(likelihood)*1e14)
table(likelihood==0)
plot(f(26,alphatrue))
abline(v=betatrue)
contour(alpha_try,beta_try,likelihood)
abline(v=alphatrue)
abline(h=betatrue)
contour(alpha_try,beta_try,log(likelihood) - log(max(likelihood)),levels=-(0:10))
abline(v=alphatrue)
abline(h=betatrue)
```



```{r try2}
likelihood <- apply(L[,c(11,18)],1,prod)
likelihood <- matrix(likelihood,length(alpha_try),length(beta_try))
contour(alpha_try,beta_try,likelihood)
contour(-1/alpha_try,beta_try,likelihood)
filled.contour(
    alpha_try,beta_try,log(likelihood)-max(log(likelihood )),
    color.palette = function(n) hcl.colors(n, "YlOrRd", rev = TRUE)
)

```

\subsection{Park run}

"Parkrun" is a distributed community initiative that organises
weekly timed 5 km runs/walks in parks worldwide~\cite{hindley2020}.  A
typical event will have 200 participants.  Table~\ref{parkruntable}
shows the author has completed a total of 15 parkruns to date, and
from the first pair of numbers we see that 238 runners attended that
particular parkrun, of whom the author placed 173.

\begin{table*}[t]
  \caption{Parkrun results}
\label{parkruntable}
\begin{tabular}{ccccccccccc}
\hline
rank   &173  & 165 & 172 & 199 & 181 & 229 & 177 & 222 & 206 & 142 \\
runners&238  & 238 & 196 & 242 & 242 & 318 & 259 & 305 & 297 & 241 \\ \\ \\
rank   & 118 & 224 & 128 & 115 & 183 &     &     &     &     &\\
runners& 179 & 338 & 203 & 245 & 254 &     &     &     &     &\\
\hline
\end{tabular}
\end{table*}


We may consider the author to have an unknown generalized Bradley
Terry strength $a$: Figure~\ref{parkrunsupport} shows a support curve
for $a$ with the evaluate, $\hat{a}\simeq 0.448$ shown.  We also see
two units of support~\cite{edwards1992} shown as a dotted line
illustrating a support interval of about 0.315 - 0.567; we may be
reasonably confident that the author's true BT strength lies in this
range.  In particular, note that a reasonable $H_0\colon
a=\frac{1}{2}$ may not be rejected, the support for $H_0$ being only
susceptible to very minor improvement [$\simeq 0.351$] by moving to
the evaluate.

```{asis}
\begin{figure}[t]
\includegraphics[width=4in]{plotparkrun}  % plotparkrun.pdf made in very_simplified_likelihood.Rmd
\caption{Author's strength\label{parkrunsupport}}
\end{figure}
```
