set.seed(0) knitr::opts_chunk$set(echo = TRUE) library("hyper2") library("magrittr") options("digits" = 5)
knitr::include_graphics(system.file("help/figures/hyper2.png", package = "hyper2"))
(takes about forty five minutes to run without cache)
To cite the hyper2
package in publications, please use
@hankin2017_rmd. Here we define dataset kka
which is the observed
scorelines between players Karpov, Kasparov, and Anand. It is used to
calculate likelihood functions: karpov_kasparov_anand
, kka_3whites
and kka_3draws
. This Rmd file supercedes files
inst/karpov_kasparov_anand.R
and inst/kka_3draws.R
and
inst/kka_array.R
. Some more detail is given in man/kka.Rd
.
kka <- c( ## Kasparov vs Karpov karpov_plays_white_beats_kasparov = 18, # 12 on p1, 6 on p2 kasparov_plays_white_beats_karpov = 30, # 13 on p1, 17 on p2 kasparov_plays_white_losesto_karpov = 07, karpov_plays_white_losesto_kasparov = 09, karpov_plays_white_draws_kasparov = 11+13+14+17+14+03, kasparov_plays_white_draws_karpov = 14+12+11+08+11+01, ## Kasparov vs Anand kasparov_plays_white_beats_anand = 15, anand_plays_white_beats_kasparov = 06, anand_plays_white_losesto_kasparov = 11, kasparov_plays_white_losesto_anand = 02, kasparov_plays_white_draws_anand = 26, anand_plays_white_draws_kasparov = 20, ## Karpov vs Anand karpov_plays_white_beats_anand = 07, anand_plays_white_beats_karpov = 18, anand_plays_white_losesto_karpov = 05, karpov_plays_white_losesto_anand = 13, karpov_plays_white_draws_anand = 29, anand_plays_white_draws_karpov = 20 ) kka
Quite a lot of information here, but for example we might ask what the scoreline is for Karpov playing white against Kasparov:
(a1 <- c( kka["karpov_plays_white_beats_kasparov"], kka["karpov_plays_white_draws_kasparov"], kka["karpov_plays_white_losesto_kasparov"] ))
If we were to ask instead what happens if Karpov plays black against Kasparov this would be:
(a2 <- c( kka["kasparov_plays_white_beats_karpov"], kka["kasparov_plays_white_draws_karpov"], kka["kasparov_plays_white_losesto_karpov"] ))
To investigate the effect of playing white we might do this:
M <- rbind(a1,rev(a2)) dimnames(M) <- list(karpov_plays=c("White","Black"),result=c("karpov wins","karpov draws","karpov loses")) M fisher.test(M)
but we need a likelihood function. Here I define likelihood function
karpov_kasparov_anand
but to save typing we work with temporary
object H
and rename it at the end:
results <- as.list(kka) attach(results) H <- hyper2() ## Kasparov vs Karpov karpov_vs_kasparov <- c("Karpov","Kasparov","white","draw") # all "players", real and imaginary H <- H + trial(c("Karpov" ,"white"), karpov_vs_kasparov, karpov_plays_white_beats_kasparov) H <- H + trial(c("Kasparov","white"), karpov_vs_kasparov, kasparov_plays_white_beats_karpov) H <- H + trial( "Karpov" , karpov_vs_kasparov, kasparov_plays_white_losesto_karpov) H <- H + trial( "Kasparov" , karpov_vs_kasparov, karpov_plays_white_losesto_kasparov) H <- H + trial( "draw" , karpov_vs_kasparov, karpov_plays_white_draws_kasparov) H <- H + trial( "draw" , karpov_vs_kasparov, kasparov_plays_white_draws_karpov) ## Kasparov vs Anand kasparov_vs_anand <- c("Kasparov","Anand","white","draw") H <- H + trial(c("Kasparov","white"), kasparov_vs_anand, kasparov_plays_white_beats_anand) H <- H + trial(c("Anand" ,"white"), kasparov_vs_anand, anand_plays_white_beats_kasparov) H <- H + trial(c("Kasparov" ), kasparov_vs_anand, anand_plays_white_losesto_kasparov) H <- H + trial(c("Anand" ), kasparov_vs_anand, kasparov_plays_white_losesto_anand) H <- H + trial( "draw" , kasparov_vs_anand, kasparov_plays_white_draws_anand) H <- H + trial( "draw" , kasparov_vs_anand, anand_plays_white_draws_kasparov) ## Karpov vs Anand karpov_vs_anand <- c("Karpov","Anand","white","draw") H <- H + trial(c("Karpov","white"), karpov_vs_anand, karpov_plays_white_beats_anand) H <- H + trial(c("Anand" ,"white"), karpov_vs_anand, anand_plays_white_beats_karpov) H <- H + trial( "Karpov" , karpov_vs_anand, anand_plays_white_losesto_karpov) H <- H + trial( "Anand" , karpov_vs_anand, karpov_plays_white_losesto_anand) H <- H + trial( "draw" , karpov_vs_anand, karpov_plays_white_draws_anand) H <- H + trial( "draw" , karpov_vs_anand, anand_plays_white_draws_karpov) detach(results) karpov_kasparov_anand <- H karpov_kasparov_anand (karpov_kasparov_anand_maxp <- maxp(karpov_kasparov_anand))
Test the hypothesis that all three players have the same strength; first do the free optimization:
samep.test(karpov_kasparov_anand,c("Karpov","Kasparov","Anand"))
and we reject that null. Now test the hypothesis that playing white confers no advantage:
specificp.test(karpov_kasparov_anand,"white",0)
We now allow each player to have a personalised draw monster. The
resulting likelihood function is called kka_3draws
but the idiom
below uses H
to save typing.
library("hyper2") H <- hyper2() results <- as.list(kka) attach(results) karpov_vs_kasparov <- c("Karpov","Kasparov","Karpov_draw","Kasparov_draw","white") draw1 <- c("Karpov_draw","Kasparov_draw") H <- H + trial(c("Karpov" ,"white"), karpov_vs_kasparov, karpov_plays_white_beats_kasparov) H <- H + trial(c("Kasparov","white"), karpov_vs_kasparov, kasparov_plays_white_beats_karpov) H <- H + trial(c("Karpov" ) , karpov_vs_kasparov, kasparov_plays_white_losesto_karpov) H <- H + trial(c("Kasparov") , karpov_vs_kasparov, karpov_plays_white_losesto_kasparov) H <- H + trial(draw1 , karpov_vs_kasparov, karpov_plays_white_draws_kasparov) H <- H + trial(draw1 , karpov_vs_kasparov, kasparov_plays_white_draws_karpov) ## Kasparov vs Anand kasparov_vs_anand <- c("Kasparov","Anand","Kasparov_draw","Anand_draw","white") draw2 <- c("Kasparov_draw","Anand_draw") H <- H + trial(c("Kasparov","white"), kasparov_vs_anand, kasparov_plays_white_beats_anand) H <- H + trial(c("Anand" ,"white"), kasparov_vs_anand, anand_plays_white_beats_kasparov) H <- H + trial(c("Kasparov" ) , kasparov_vs_anand, anand_plays_white_losesto_kasparov) H <- H + trial(c("Anand") , kasparov_vs_anand, kasparov_plays_white_losesto_anand) H <- H + trial(draw2 , kasparov_vs_anand, kasparov_plays_white_draws_anand) H <- H + trial(draw2 , kasparov_vs_anand, anand_plays_white_draws_kasparov) ## Karpov vs Anand karpov_vs_anand <- c("Karpov","Anand","Karpov_draw","Anand_draw","white") draw3 <- c("Karpov_draw","Anand_draw") H <- H + trial(c("Karpov","white"), karpov_vs_anand, karpov_plays_white_beats_anand) H <- H + trial(c("Anand" ,"white"), karpov_vs_anand, anand_plays_white_beats_karpov) H <- H + trial(c("Karpov" ), karpov_vs_anand, anand_plays_white_losesto_karpov) H <- H + trial(c("Anand" ), karpov_vs_anand, karpov_plays_white_losesto_anand) H <- H + trial(draw3 , karpov_vs_anand, karpov_plays_white_draws_anand) H <- H + trial(draw3 , karpov_vs_anand, anand_plays_white_draws_karpov) detach(results) kka_3draws <- H kka_3draws
and one natural test is that the three draw monsters are of equal strength:
(kka_3draws_maxp <- maxp(kka_3draws)) pie(kka_3draws_maxp) samep.test(kka_3draws,c("Karpov_draw","Kasparov_draw","Anand_draw"))
Now allow each player to have distinct white strength. We create
kka_3whites
, again using temporary variable H
to save typing:
H <- hyper2() results <- as.list(kka) attach(results) D <- "draw" ## First: Karpov vs Kasparov karpov_plays_white_vs_kasparov <- c("Karpov","Kasparov","Karpov_white","draw" ) # "players" kasparov_plays_white_vs_karpov <- c("Karpov","Kasparov","Kasparov_white","draw") H <- H + trial(c("Karpov" ,"Karpov_white" ), karpov_plays_white_vs_kasparov, karpov_plays_white_beats_kasparov ) # Karpov wins playing white H <- H + trial(c("Kasparov","Kasparov_white"), kasparov_plays_white_vs_karpov, kasparov_plays_white_beats_karpov ) # Kasparov wins playing white H <- H + trial(c("Kasparov") , karpov_plays_white_vs_kasparov, karpov_plays_white_losesto_kasparov) # Kasparov wins playing black H <- H + trial(c("Karpov" ) , kasparov_plays_white_vs_karpov, kasparov_plays_white_losesto_karpov) # Karpov wins playing black H <- H + trial(D , karpov_plays_white_vs_kasparov, karpov_plays_white_draws_kasparov ) # Karpov white, draws H <- H + trial(D , kasparov_plays_white_vs_karpov, kasparov_plays_white_draws_karpov ) # Kasparov white, draws ## Second: Karpov vs Anand karpov_plays_white_vs_anand <- c("Karpov","Anand","Karpov_white","draw" ) anand_plays_white_vs_karpov <- c("Karpov","Anand","Anand_white","draw") H <- H + trial(c("Karpov","Karpov_white"), karpov_plays_white_vs_anand, karpov_plays_white_beats_anand ) # Karpov wins playing white H <- H + trial(c("Anand" ,"Anand_white" ), anand_plays_white_vs_karpov, anand_plays_white_beats_karpov ) # Anand wins playing white H <- H + trial(c("Anand" ), karpov_plays_white_vs_anand, karpov_plays_white_losesto_anand) # Anand wins playing black H <- H + trial(c("Karpov" ), anand_plays_white_vs_karpov, anand_plays_white_losesto_karpov) # Karpov wins playing black H <- H + trial(D , karpov_plays_white_vs_anand, karpov_plays_white_draws_anand ) # Karpov white, draws H <- H + trial(D , anand_plays_white_vs_karpov, anand_plays_white_draws_karpov ) # Anand white, draws ## Third: Kasparov vs Anand anand_plays_white_vs_kasparov <- c("Anand","Kasparov","Anand_white","draw" ) kasparov_plays_white_vs_anand <- c("Anand","Kasparov","Kasparov_white","draw") H <- H + trial(c("Kasparov","Kasparov_white"), kasparov_plays_white_vs_anand, kasparov_plays_white_beats_anand ) # Kasparov wins playing white H <- H + trial(c("Anand" ,"Anand_white" ), anand_plays_white_vs_kasparov, anand_plays_white_beats_kasparov ) # Anand wins playing white H <- H + trial(c("Anand" ), kasparov_plays_white_vs_anand, kasparov_plays_white_losesto_anand) # Anand wins playing black H <- H + trial(c("Kasparov" ), anand_plays_white_vs_kasparov, anand_plays_white_losesto_kasparov) # Kasparov wins playing black H <- H + trial(D , kasparov_plays_white_vs_anand, kasparov_plays_white_draws_anand ) # Kasparov white, draws H <- H + trial(D , anand_plays_white_vs_kasparov, anand_plays_white_draws_kasparov ) # Anand white, draws detach(results) kka_3whites <- H kka_3whites
Natural test for equality of the three white monsters's strengths:
(kka_3whites_maxp <- maxp(kka_3whites)) pie(kka_3whites_maxp) samep.test(kka_3whites,c("Karpov_white","Kasparov_white","Anand_white"))
(fail to reject the null).
We now create a 3x3x3 array of results for the dataset.
library("hyper2") library("abind") attach(as.list(kka)) players <- c("Anand","Karpov","Kasparov") plays_white_wins <- matrix(NA,3,3) dimnames(plays_white_wins) <- list(plays_white_wins=players,plays_black_loses=players) plays_white_wins["Anand" ,"Karpov" ] <- anand_plays_white_beats_karpov plays_white_wins["Anand" ,"Kasparov"] <- anand_plays_white_beats_kasparov plays_white_wins["Karpov" ,"Anand" ] <- karpov_plays_white_beats_anand plays_white_wins["Karpov" ,"Kasparov"] <- karpov_plays_white_beats_kasparov plays_white_wins["Kasparov","Anand" ] <- kasparov_plays_white_beats_anand plays_white_wins["Kasparov","Karpov" ] <- kasparov_plays_white_beats_karpov plays_white_draws <- matrix(NA,3,3) dimnames(plays_white_draws) <- list(plays_white_draws=players,plays_black_draws=players) plays_white_draws["Anand" ,"Karpov" ] <- anand_plays_white_draws_karpov plays_white_draws["Anand" ,"Kasparov"] <- anand_plays_white_draws_kasparov plays_white_draws["Karpov" ,"Anand" ] <- karpov_plays_white_draws_anand plays_white_draws["Karpov" ,"Kasparov"] <- karpov_plays_white_draws_kasparov plays_white_draws["Kasparov","Anand" ] <- kasparov_plays_white_draws_anand plays_white_draws["Kasparov","Karpov" ] <- kasparov_plays_white_draws_karpov plays_white_loses <- matrix(NA,3,3) dimnames(plays_white_loses) <- list(plays_white_loses=players,plays_black_wins=players) plays_white_loses["Karpov" ,"Anand" ] <- karpov_plays_white_losesto_anand plays_white_loses["Kasparov" ,"Anand" ] <- kasparov_plays_white_losesto_anand plays_white_loses["Anand" ,"Karpov" ] <- anand_plays_white_losesto_karpov plays_white_loses["Kasparov" ,"Karpov" ] <- kasparov_plays_white_losesto_karpov plays_white_loses["Anand" ,"Kasparov"] <- anand_plays_white_losesto_kasparov plays_white_loses["Karpov" ,"Kasparov"] <- karpov_plays_white_losesto_kasparov detach(as.list(kka)) plays_white_wins plays_white_draws plays_white_loses kka_array <- abind( plays_white_wins, plays_white_draws, plays_white_loses, along=3) dimnames(kka_array)[[3]] <- c("plays_white_wins", "plays_white_draws", "plays_white_loses") kka_array
hyper3
analysis.First we ignore the draws and create a matrix with real parts representing white wins (home wins in the context of football) and imaginary parts representing black (away) wins. A pairwise likelihood function would be
$$ \left(\frac{\lambda p_1}{\lambda p_1+p_2}\right)^a \left(\frac{ p_2}{\lambda p_1+p_2}\right)^b \left(\frac{ p_1}{p_1+\lambda p_2}\right)^c \left(\frac{\lambda p_1}{p_1+\lambda p_2}\right)^d $$
for the observation of $+a$ $\text{=}0$ $-b$ for $p_1$ playing white
and $+c$ $\text{=}0$ $-d$ for $p_2$ playing white. We then translate
this into a hyper3
likelihood function as follows
(M <- kka_array[,,1] + 1i*kka_array[,,3]) home_away3(M,lambda=1.1)
Above we use $\lambda=1.1$, as a specific numeric value is required by the idiom.
l <- function(lambda){ H <- home_away3(M,lambda=lambda) loglik(maxp(H),H) } lam <- seq(from=1.2,to=3.5,len=10) like <- sapply(lam,l)
and plot it:
plot(lam,like-max(like),type="b",pch=16) abline(h=c(0,-2),lty=2)
Above we see a credible interval for $\lambda$ being about $(1.4,2.9)$. Of course, this is crude and it would be better to have more transparent package idiom. But I'm working on this.
We can now introduce draws but first a change of notation. Considering repeated trials between entities $1,2,\ldots, r$ with Bradley-Terry strengths $p_1,\ldots, p_r$ and counts $n_1,\ldots, n_r$ a suitable likelihood function would be
$$ \left(\frac{p_1}{\sum p_i}\right)^{n_1}\cdot \left(\frac{p_2}{\sum p_i}\right)^{n_2}\ldots \left(\frac{p_r}{\sum p_i}\right)^{n_r} $$
but we may represent this in the following compact form:
$$ \left(\frac{p_1,p_2,\ldots, p_r}{\sum p_i}\right)^{\left(n_1,\ldots n_r\right)} $$
Or, noting that the sum of the numerators is equal to the common denominator, even more compactly as $\left(p_1,p_2,\ldots, p_r\right)^{\left(n_1,\ldots n_r\right)}$.
The previous likelihood function can be represented thus:
$$ \left(\frac{\lambda p_1, p_2}{\lambda p_1+p_2}\right)^{(a,b)} \left(\frac{p_1, \lambda p_2}{p_1+\lambda p_2}\right)^{(c,d)} $$
Draws would change this by introducing a weighted Draw monster $D$:
$$ \left(\frac{\lambda p_1, D(p_1+p_2),p_2}{\lambda p_1+D(p_1+p_2)+p_2}\right)^{(a,b,c)} \left(\frac{p_1, D(p_1+p_2),\lambda p_2}{p_1+D(p_1+p_2)+\lambda p_2}\right)^{(d,e,f)} $$
or possibly an individual Draw monster:
$$ \left(\frac{\lambda p_1, D_1p_1+D_2p_2,p_2}{\lambda p_1+D_1p_1+D_2p_2+p_2}\right)^{(a,b,c)} \left(\frac{p_1, D_1p_1+D_2p_2),\lambda p_2}{p_1+D_1p_1+D_2p_2+\lambda p_2}\right)^{(d,e,f)} $$
Package idiom for this would require the following form:
$$ \left(\frac{\lambda p_1, D_1p_1+D_2p_2,p_2}{(\lambda+D_1)p_1+(1+D_2)p_2}\right)^{(a,b,c)} \left(\frac{p_1, D_1p_1+D_2p_2,\lambda p_2}{(1+D_1)p_1+(\lambda+D_2)p_2}\right)^{(d,e,f)} $$
Note that in neither of these models do we have the probability of a draw for $p_1$ playing white being the same as for $p_2$ playing white. In the first case the two probabilities are
$$ \frac{D(p_1+p_2)}{(\lambda +D)p_1 + (1+D)p_2},\qquad \frac{D(p_1+p_2)}{(1+D)p_1 + (\lambda+D)p_2} $$
and in the second they are
$$ \frac{D_1p_1+D_2p_2}{(\lambda +D_1)p_1 + (1+D_2)p_2},\qquad \frac{D_1p_1+D_2p_2}{(1 +D_1)p_1 + (\lambda+D_2)p_2} $$
With strictly positive $D,D_1,D_2$ these are equal if and only if $(\lambda-1)(p_1-p_2)=0$, that is, if the white advantage is nonexistent, or if the players have the same strength.
We can use the bespoke function hyper2::white_draw3()
to make a
likelihood function:
white_draw3(kka_array, 1.1, 2.3)
Then make a wrapper:
f <- function(v){ lambda <- v[1] D <- v[2] H <- white_draw3(kka_array, lambda,D) max(maxp(H,n=1,justlikes=TRUE)) } f(c(1.5,2.3))
n <- 10 lambda <- seq(from=1.4,to=2.9,len=n) D <- seq(from=1.6,to=3.4,len=n) M <- as.matrix(expand.grid(lambda=lambda,D=D)) l <- matrix(apply(M,1,f),n,n)
l <- l-max(l) contour(lambda,D,l,nlevels=30,xlab="lambda",ylab="D") abline(v=lambda,col='gray',lwd=0.2) abline(h=D,col='gray',lwd=0.2) lambda D
Optimize:
(o <- optim(par=c(2.1,2.4),fn=f,control=list(fnscale = -1)))
jj <- round(o$par,2) (chess3 <- white_draw3(kka_array, lambda=jj[1],D=jj[2])) (chess3_maxp <- maxp(chess3))
Following lines create kka.rda
, residing in the data/
directory of
the package.
save(kka,karpov_kasparov_anand,kka_3draws,kka_3whites,kka_array,chess3,chess3_maxp,file="kka.rda")
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.