fatigue
R. K. S. Hankin
To cite the hyper2 package in publications, please use Hankin (2017).
Analysis of the 1973 interzonal competition.
jj <- read.table("interzonal1973_petropolis.txt",header=TRUE,skip=2)
a <- data.frame(day=jj$day + 31*(jj$month=="August"),white=jj$white,black=jj$black,result=jj$result,round=jj$round,moves=jj$moves)
plot(sort(unique(a$day)),type='b',pch=c(1,1,16))
tail(a)## day white black result round moves
## 147 48 Hug Kagan 1/2-1/2 17 44
## 148 48 Keres Tan 1-0 17 40
## 149 48 Mecking Ljubojevic 1/2-1/2 17 13
## 150 48 Polugaeky Portisch 1-0 17 39
## 151 48 Savon Biyiasas 1-0 17 71
## 152 48 Smyslov Hort 1-0 17 32Above we see that the schedule was to have play on three consecutive days followed by a one- or two- day break.
players <- unique(sort(c(a$white,a$black)))
wm <- "wm" # white monster
dm <- "dm" # draw monster
rm <- "rm" # rest monster
tab <- matrix(0,length(players),3)
colnames(tab) <- c("won","lost","drawn")
rownames(tab) <- players
H <- hyper2()
for(i in seq_len(nrow(a))){
white_player <- a$white[i]
black_player <- a$black[i]
result <- a$result[i]
H[c(white_player,wm,black_player,dm)] %<>% dec()
if(result == "1-0"){ # white win, black loss
H[c(white_player,wm)] %<>% inc()
tab[white_player,] <- tab[white_player,] + c(1,0,0)
tab[black_player,] <- tab[black_player,] + c(0,1,0)
} else if(result == "0-1"){ # white loss, black win
H[black_player] %<>% inc()
tab[white_player,] <- tab[white_player,] + c(0,1,0)
tab[black_player,] <- tab[black_player,] + c(1,0,0)
} else if(result == "1/2-1/2"){ # draw
H[dm] %<>% inc()
tab[white_player,] <- tab[white_player,] + c(0,0,1)
tab[black_player,] <- tab[black_player,] + c(0,0,1)
} else {
stop("this cannot happen")
}
}mH <- maxp(H,n=100)specificp.gt.test(H,"wm",0)##
## Constrained support maximization
##
## data: H
## null hypothesis: sum p_i=1, wm <= 0 (notional)
## null estimate:
## Biyiasas Bronstein dm Geller Gheorghiu Hort Hug
## 5.2631e-02 5.2631e-02 5.2633e-02 5.2631e-02 5.2631e-02 5.2631e-02 5.2631e-02
## Ivkov Kagan Keres Ljubojevic Mecking Panno Polugaeky
## 5.2631e-02 5.2631e-02 5.2631e-02 5.2631e-02 5.2631e-02 5.2631e-02 5.2631e-02
## Portisch Resheky Savon Smyslov Tan wm
## 5.2631e-02 5.2631e-02 5.2631e-02 5.2631e-02 5.2631e-02 9.9973e-06
## (argmax, constrained optimization)
## Support for null: -166.99 + K
##
## alternative hypothesis: sum p_i=1
## alternative estimate:
## Biyiasas Bronstein dm Geller Gheorghiu Hort Hug
## 1.0013e-02 7.5699e-02 9.3134e-02 8.1886e-02 2.8058e-02 6.6922e-02 1.0061e-06
## Ivkov Kagan Keres Ljubojevic Mecking Panno Polugaeky
## 1.4546e-02 1.0055e-04 2.1756e-02 7.3534e-02 9.4381e-02 2.1940e-02 1.0337e-01
## Portisch Resheky Savon Smyslov Tan wm
## 8.7476e-02 5.0554e-02 5.5705e-02 1.0047e-01 1.0001e-06 2.0450e-02
## (argmax, free optimization)
## Support for alternative: -139.59 + K
##
## degrees of freedom: 1
## support difference = 27.403
## p-value: 1.3307e-13 (one-sided)head(H)## Warning in print.hyper2(x): powers have nonzero sum## log((Biyiasas + Bronstein + dm + wm)^-1 * (Biyiasas + Geller + dm +
## wm)^-1 * (Biyiasas + Gheorghiu + dm + wm)^-1 * (Biyiasas + Hort + dm +
## wm)^-1 * (Biyiasas + Hug + dm + wm)^-1 * (Biyiasas + Ivkov + dm +
## wm)^-1)pnames(H)## [1] "Biyiasas" "Bronstein" "dm" "Geller" "Gheorghiu"
## [6] "Hort" "Hug" "Ivkov" "Kagan" "Keres"
## [11] "Ljubojevic" "Mecking" "Panno" "Polugaeky" "Portisch"
## [16] "Resheky" "Savon" "Smyslov" "Tan" "wm"pie(mH)
dotchart(mH)
mH## Biyiasas Bronstein dm Geller Gheorghiu Hort Hug
## 9.0918e-03 7.5419e-02 9.5425e-02 8.1375e-02 2.8456e-02 6.6938e-02 1.0068e-06
## Ivkov Kagan Keres Ljubojevic Mecking Panno Polugaeky
## 1.4443e-02 1.1983e-06 2.1462e-02 7.2247e-02 9.6838e-02 2.1461e-02 1.0276e-01
## Portisch Resheky Savon Smyslov Tan wm
## 8.6911e-02 4.8583e-02 5.6392e-02 1.0147e-01 1.0016e-06 2.0726e-02summary(H)## A hyper2 object of size 20.
## pnames: Biyiasas Bronstein dm Geller Gheorghiu Hort Hug Ivkov Kagan Keres Ljubojevic Mecking Panno Polugaeky Portisch Resheky Savon Smyslov Tan wm
## Number of brackets: 182
## Sum of powers: 0
##
## Table of bracket lengths:
## 1 2 4
## 14 16 152
##
## Table of powers:
## -1 1 2 3 4 5 6 7 72
## 152 7 8 6 4 2 1 1 1tab <- cbind(tab,played=rowSums(tab))
tab <- cbind(tab,points=tab[,1] + tab[,3]/2)
tab## won lost drawn played points
## Biyiasas 3 7 7 17 6.5
## Bronstein 7 3 7 17 10.5
## Geller 7 1 9 17 11.5
## Gheorghiu 3 5 9 17 7.5
## Hort 6 3 8 17 10.0
## Hug 0 11 6 17 3.0
## Ivkov 2 1 14 17 9.0
## Kagan 2 13 2 17 3.0
## Keres 3 4 10 17 8.0
## Ljubojevic 6 5 6 17 9.0
## Mecking 7 0 10 17 12.0
## Panno 3 4 10 17 8.0
## Polugaeky 7 1 8 16 11.0
## Portisch 7 1 9 17 11.5
## Resheky 5 5 6 16 8.0
## Savon 5 3 9 17 9.5
## Smyslov 7 2 8 17 11.0
## Tan 0 11 6 17 3.0table(a$result)##
## 0-1 1-0 1/2-1/2
## 29 51 72hist(a$moves)
plot(moves~as.factor(result),data=a)
result## [1] "1-0"moves_drawn_games <- a$moves[a$result == "1/2-1/2"]
moves_won_games <- a$moves[a$result != "1/2-1/2"]
t.test(moves_drawn_games,moves_won_games)##
## Welch Two Sample t-test
##
## data: moves_drawn_games and moves_won_games
## t = -5.73, df = 141, p-value = 5.9e-08
## alternative hypothesis: true difference in means is not equal to 0
## 95 percent confidence interval:
## -18.6237 -9.0652
## sample estimates:
## mean of x mean of y
## 31.556 45.400head(a,10)## day white black result round moves
## 1 23 Biyiasas Kagan 1-0 1 40
## 2 23 Hort Geller 1/2-1/2 1 16
## 3 23 Ivkov Mecking 1/2-1/2 1 35
## 4 23 Ljubojevic Hug 1-0 1 53
## 5 23 Panno Gheorghiu 1/2-1/2 1 12
## 6 23 Portisch Keres 1-0 1 39
## 7 23 Savon Bronstein 1/2-1/2 1 60
## 8 23 Tan Smyslov 0-1 1 37
## 9 24 Bronstein Biyiasas 1/2-1/2 2 43
## 10 24 Geller Tan 1-0 2 52o <- matrix(0,max(a[,5]),length(players))
dimnames(o) <- list(round=paste("r",seq_len(nrow(o)),sep=""),player=players)
for(i in seq_len(nrow(a))){
o[a[i,5],which(players==a[i,2])] %<>% `+`(1)
o[a[i,5],which(players==a[i,3])] %<>% `+`(1)
}
o## player
## round Biyiasas Bronstein Geller Gheorghiu Hort Hug Ivkov Kagan Keres Ljubojevic
## r1 1 1 1 1 1 1 1 1 1 1
## r2 1 1 1 1 1 1 1 1 1 1
## r3 1 1 1 1 1 1 1 1 1 1
## r4 1 1 1 1 1 1 1 1 1 1
## r5 1 1 1 1 1 1 1 1 1 1
## r6 1 1 1 1 1 1 1 1 1 1
## r7 1 1 1 1 1 1 1 1 1 1
## r8 1 1 1 1 1 1 1 1 1 1
## r9 1 1 1 1 1 1 1 1 1 1
## r10 1 1 1 1 1 1 1 1 1 1
## r11 1 1 1 1 1 1 1 1 1 1
## r12 1 1 1 1 1 1 1 1 1 1
## r13 1 1 1 1 1 1 1 1 1 1
## r14 1 1 1 1 1 1 1 1 1 1
## r15 1 1 1 1 1 1 1 1 1 1
## r16 1 1 1 1 1 1 1 1 1 1
## r17 1 1 1 1 1 1 1 1 1 1
## player
## round Mecking Panno Polugaeky Portisch Resheky Savon Smyslov Tan
## r1 1 1 0 1 0 1 1 1
## r2 1 1 1 1 1 1 1 1
## r3 1 1 1 1 1 1 1 1
## r4 1 1 1 1 1 1 1 1
## r5 1 1 1 1 1 1 1 1
## r6 1 1 1 1 1 1 1 1
## r7 1 1 1 1 1 1 1 1
## r8 1 1 1 1 1 1 1 1
## r9 1 1 1 1 1 1 1 1
## r10 1 1 1 1 1 1 1 1
## r11 1 1 1 1 1 1 1 1
## r12 1 1 1 1 1 1 1 1
## r13 1 1 1 1 1 1 1 1
## r14 1 1 1 1 1 1 1 1
## r15 1 1 1 1 1 1 1 1
## r16 1 1 1 1 1 1 1 1
## r17 1 1 1 1 1 1 1 1Now focus on pairs of successive rounds: 1,2; 4,5; 7,8; 10,11; 13,14; 16,17
unlist(a[2,])## day white black result round moves
## "23" "Hort" "Geller" "1/2-1/2" "1" "16"`fatigued` <- function(i){
x <- unlist(a[i,])
day <- as.numeric(a[i,1])
white_player <- a[i,2]
black_player <- a[i,3]
result <- a[i,4]
round <- as.numeric(a[i,5])
out <- c(white_player_fatigued=FALSE,black_player_fatigued=FALSE)
if(round%%3 == 1){return(out)} # yesterday was a break day
out <- c(white_player_fatigued=FALSE,black_player_fatigued=FALSE)
b <- a[a$round==round-1,] # b = yesterday's schedule
yesterdays_white_players <- unique(sort(c(b[,2])))
yesterdays_black_players <- unique(sort(c(b[,3])))
if(white_player %in% yesterdays_white_players){ # he played white yesterday...
if(b[which(white_player==b[,2]),4] !="1/2-1/2"){ # ...and didn't draw...
out["white_player_fatigued"] <- TRUE # ... the white player is fatigued
}
}
if(white_player %in% yesterdays_black_players){ # he played black yesterday...
if(b[which(white_player==b[,3]),4] !="1/2-1/2"){ # ...and didn't draw...
out["white_player_fatigued"] <- TRUE # ... the white player is fatigued
}
}
if(black_player %in% yesterdays_white_players){ # he played white yesterday...
if(b[which(black_player==b[,2]),4] !="1/2-1/2"){ # ...and didn't draw...
out["black_player_fatigued"] <- TRUE # ... the black player is fatigued
}
}
if(black_player %in% yesterdays_black_players){ # he played black yesterday...
if(b[which(white_player==b[,3]),4] !="1/2-1/2"){ # ... and didn't draw...
out["black_player_fatigued"] <- TRUE # ... the black player is fatigued
}
}
return(out)
}
rm(H)
Hf <- hyper2() # H fatigue
for(i in seq_len(nrow(a))){
white_player <- a[i,2]
black_player <- a[i,3]
result <- a[i,4]
jj <- fatigued(i)
white_player_fatigued <- jj[1]
black_player_fatigued <- jj[2]
if(white_player_fatigued & black_player_fatigued){ # both fatigued: no fatigue monster
Hf[c(white_player,wm,black_player,dm)] %<>% dec()
if(result == "1-0"){ # white win, black loss
Hf[c(white_player,wm)] %<>% inc()
} else if(result == "0-1"){ # white loss, black win
Hf[c(black_player)] %<>% inc()
} else if(result == "1/2-1/2"){ # draw
Hf[dm] %<>% inc()
} else {
stop("result must be 0-1, 1-0, or 1/2-1/2")
}
} else if (white_player_fatigued & !black_player_fatigued){
Hf[c(white_player,wm,black_player,dm,rm)] %<>% dec()
if(result == "1-0"){ # white win, black loss
Hf[c(white_player,wm)] %<>% inc()
} else if(result == "0-1"){ # white loss, black win
Hf[c(black_player,rm)] %<>% inc()
} else if(result == "1/2-1/2"){ # draw
Hf[dm] %<>% inc()
} else {
stop("result must be 0-1, 1-0, or 1/2-1/2")
}
} else if (!white_player_fatigued & black_player_fatigued){
Hf[c(white_player,wm,black_player,dm,rm)] %<>% dec()
if(result == "1-0"){ # white win, black loss
Hf[c(white_player,wm,rm)] %<>% inc()
} else if(result == "0-1"){ # white loss, black win
Hf[c(black_player)] %<>% inc()
} else if(result == "1/2-1/2"){ # draw
Hf[dm] %<>% inc()
} else {
stop("result must be 0-1, 1-0, or 1/2-1/2")
}
} else if (!white_player_fatigued & !black_player_fatigued){ # neither fatigued
Hf[c(white_player,wm,black_player,dm)] %<>% dec()
if(result == "1-0"){ # white win, black loss
Hf[c(white_player,wm)] %<>% inc()
} else if(result == "0-1"){ # white loss, black win
Hf[c(black_player)] %<>% inc()
} else if(result == "1/2-1/2"){ # draw
Hf[dm] %<>% inc()
} else {
stop("result must be 0-1, 1-0, or 1/2-1/2")
}
} else {
stop("This is a logical impossibility")
}
}now play with it:
Hf_maxp <- maxp(Hf)summary(Hf)## A hyper2 object of size 21.
## pnames: Biyiasas Bronstein dm Geller Gheorghiu Hort Hug Ivkov Kagan Keres Ljubojevic Mecking Panno Polugaeky Portisch Resheky rm Savon Smyslov Tan wm
## Number of brackets: 191
## Sum of powers: 0
##
## Table of bracket lengths:
## 1 2 3 4 5
## 13 19 7 109 43
##
## Table of powers:
## -1 1 2 3 4 5 6 72
## 152 16 10 7 3 1 1 1pnames(Hf)## [1] "Biyiasas" "Bronstein" "dm" "Geller" "Gheorghiu"
## [6] "Hort" "Hug" "Ivkov" "Kagan" "Keres"
## [11] "Ljubojevic" "Mecking" "Panno" "Polugaeky" "Portisch"
## [16] "Resheky" "rm" "Savon" "Smyslov" "Tan"
## [21] "wm"Hf_maxp## Biyiasas Bronstein dm Geller Gheorghiu Hort Hug
## 9.0340e-03 7.5423e-02 9.5510e-02 8.1265e-02 2.8487e-02 6.6939e-02 1.0024e-06
## Ivkov Kagan Keres Ljubojevic Mecking Panno Polugaeky
## 1.4453e-02 1.9681e-06 2.1443e-02 7.2334e-02 9.6751e-02 2.1492e-02 1.0273e-01
## Portisch Resheky rm Savon Smyslov Tan wm
## 8.6856e-02 4.8655e-02 1.5425e-06 5.6396e-02 1.0144e-01 1.0013e-06 2.0787e-02pie(Hf_maxp)
Above we see the estimates of the strengths of the three monsters:
dm, the draw monster has strength about \(0.096\); rm, the rest
monster, has strength \(1.5\times 10^{-6}\), and wm, the white
monster, has strength about \(0.02\). Noting that the draw monster
cannot possibly have zero strength, and that the rest monster has a
very small estimated strength, the only null worth testing is
\(H_0\colon\mathtt{wm}=0\):
specificp.gt.test(Hf, "wm", 0)##
## Constrained support maximization
##
## data: Hf
## null hypothesis: sum p_i=1, wm <= 0 (notional)
## null estimate:
## Biyiasas Bronstein dm Geller Gheorghiu Hort Hug
## 3.4511e-02 5.2095e-02 4.9522e-02 5.3355e-02 1.0270e-01 5.3515e-02 2.4569e-02
## Ivkov Kagan Keres Ljubojevic Mecking Panno Polugaeky
## 4.5600e-02 2.3394e-02 6.1432e-02 5.4151e-02 6.7166e-02 4.3206e-02 5.1906e-02
## Portisch Resheky rm Savon Smyslov Tan wm
## 5.7555e-02 4.9301e-02 2.3479e-02 7.2566e-02 6.1377e-02 1.8595e-02 1.0003e-06
## (argmax, constrained optimization)
## Support for null: -161.68 + K
##
## alternative hypothesis: sum p_i=1
## alternative estimate:
## Biyiasas Bronstein dm Geller Gheorghiu Hort Hug
## 9.0340e-03 7.5423e-02 9.5510e-02 8.1265e-02 2.8487e-02 6.6939e-02 1.0024e-06
## Ivkov Kagan Keres Ljubojevic Mecking Panno Polugaeky
## 1.4453e-02 1.9681e-06 2.1443e-02 7.2334e-02 9.6751e-02 2.1492e-02 1.0273e-01
## Portisch Resheky rm Savon Smyslov Tan wm
## 8.6856e-02 4.8655e-02 1.5425e-06 5.6396e-02 1.0144e-01 1.0013e-06 2.0787e-02
## (argmax, free optimization)
## Support for alternative: -139.57 + K
##
## degrees of freedom: 1
## support difference = 22.113
## p-value: 2.9243e-11 (one-sided)Above we see that \(H_0\colon\mathtt{wm}=0\) may be rejected with a \(p\)-value of about \(3\times 10^{-11}\).
jj <- rep(0,nrow(a))
M <- data.frame(
white_player=rep(NA,nrow(a)),
black_player=rep(NA,nrow(a)),
white_player_fatigued=FALSE,
black_player_fatigued=FALSE
)
for(i in seq_len(nrow(a))){
M[i,1] <- a[i,2]
M[i,2] <- a[i,3]
jj <- fatigued(i)
M[i,3] <- jj[1]
M[i,4] <- jj[2]
}
colnames(M) <- c("white","black","white_fatigued","black_fatigued")
tail(M)## white black white_fatigued black_fatigued
## 147 Hug Kagan TRUE TRUE
## 148 Keres Tan FALSE TRUE
## 149 Mecking Ljubojevic TRUE TRUE
## 150 Polugaeky Portisch TRUE FALSE
## 151 Savon Biyiasas TRUE TRUE
## 152 Smyslov Hort FALSE FALSEtable(M[,3])##
## FALSE TRUE
## 104 48table(M[,4])##
## FALSE TRUE
## 101 51References
Hankin, R. K. S. 2017. “Partial Rank Data with the
hyper2 Package: Likelihood Functions for Generalized Bradley-Terry Models.” The R Journal 9 (2): 429–39.