├── DESCRIPTION ├── MD5 ├── NAMESPACE ├── R └── ratings.R ├── build └── vignette.rds ├── data ├── aflodds.rda └── riichi.rda ├── inst └── doc │ ├── AFLRatings.R │ ├── AFLRatings.Rnw │ ├── AFLRatings.pdf │ ├── ChessRatings.pdf │ ├── MathSport.pdf │ ├── MathSport.txt │ ├── glicko.pdf │ ├── glicko2.pdf │ └── sweave │ └── ChessRatings.Rnw ├── man ├── aflodds.Rd ├── elo.Rd ├── elom.Rd ├── fide.Rd ├── glicko.Rd ├── glicko2.Rd ├── hist.rating.Rd ├── kfide.Rd ├── kgames.Rd ├── krating.Rd ├── kriichi.Rd ├── metrics.Rd ├── plot.rating.Rd ├── predict.rating.Rd ├── riichi.Rd └── steph.Rd ├── src ├── PlayerRatings_init.c └── ratings.c └── vignettes └── AFLRatings.Rnw /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: PlayerRatings 2 | Version: 1.1-0 3 | Date: 2020-02-28 4 | Title: Dynamic Updating Methods for Player Ratings Estimation 5 | Author: Alec Stephenson and Jeff Sonas. 6 | Maintainer: Alec Stephenson 7 | Depends: R (>= 3.5.0) 8 | Description: Implements schemes for estimating player or 9 | team skill based on dynamic updating. Implemented methods include 10 | Elo, Glicko, Glicko-2 and Stephenson. Contains pdf documentation 11 | of a reproducible analysis using approximately two million chess 12 | matches. Also contains an Elo based method for multi-player games 13 | where the result is a placing or a score. This includes zero-sum 14 | games such as poker and mahjong. 15 | LazyData: yes 16 | License: GPL-3 17 | NeedsCompilation: yes 18 | Packaged: 2020-03-01 10:40:59 UTC; ste6an 19 | Repository: CRAN 20 | Date/Publication: 2020-03-01 15:50:06 UTC 21 | -------------------------------------------------------------------------------- /MD5: -------------------------------------------------------------------------------- 1 | a9567290df03229884e9b46a0297bda5 *DESCRIPTION 2 | 0f4cee67afe57c1cb5c2f10142ea7aea *NAMESPACE 3 | d7de2e46c29ce53dd3288382373807e0 *R/ratings.R 4 | 501d518233776c30f8d48bf5ef7d393f *build/vignette.rds 5 | fe523826fbc3bdcdd924b2abd234912a *data/aflodds.rda 6 | ea8f012310ece7c8cee42b9c559c08dc *data/riichi.rda 7 | 1398916e785994d084be6b9f182b9b11 *inst/doc/AFLRatings.R 8 | bba086a7b5f8373a9e7a9bb6801a4e0c *inst/doc/AFLRatings.Rnw 9 | 68505996d7958cb9fdf2928f8a158c79 *inst/doc/AFLRatings.pdf 10 | 63899a076795ea63ba1de1158a93bf65 *inst/doc/ChessRatings.pdf 11 | 55300069dec6e2a77aff46adb591614c *inst/doc/MathSport.pdf 12 | e8656f8915847dadc824b93dbe40f332 *inst/doc/MathSport.txt 13 | 6a7fc6457518e4c303859f5fbd2461a3 *inst/doc/glicko.pdf 14 | 23562f7b8bc0a4b273ad28e5b6bced6b *inst/doc/glicko2.pdf 15 | 308fd9191f1d6839181f0377afdc2e08 *inst/doc/sweave/ChessRatings.Rnw 16 | 84230295c461b195f68dd7503b7a2251 *man/aflodds.Rd 17 | c4701325b63b957dc977a4594bf03397 *man/elo.Rd 18 | 29fcedb5255ff0d9ddb59f633b89fbee *man/elom.Rd 19 | 2084f5a72c48325f1219ae29e6663a54 *man/fide.Rd 20 | 6c1e0bd4cfe694aecfc70e858693cde2 *man/glicko.Rd 21 | fcea4cdcf04ead7bd83d0f1d30c13aae *man/glicko2.Rd 22 | cb0a3d4755282af4248c5d17593abc0d *man/hist.rating.Rd 23 | 164189a68c79b04fd568e1c14f2763c3 *man/kfide.Rd 24 | 8194ddc87f32dbcfb4f34133f285e55a *man/kgames.Rd 25 | 3c88f50b3fc1a27ea598d9bf1be045ff *man/krating.Rd 26 | d82cb0a0621ccbf9b03e1a789f8fbe7a *man/kriichi.Rd 27 | da44081e341b735d209bf922ac7956c9 *man/metrics.Rd 28 | e18a0cef6991c58ee23b00456c70b00a *man/plot.rating.Rd 29 | ba68405eb9651773c0b046592e153f00 *man/predict.rating.Rd 30 | 40752d5373ba114dd09999d1ad93acbf *man/riichi.Rd 31 | e544cecdc857352236cbe190320e06e2 *man/steph.Rd 32 | c58638fe4cf5fe089df2fdb12074378e *src/PlayerRatings_init.c 33 | 0ddbe78a09bd4a979ca1397f36cb8f0d *src/ratings.c 34 | bba086a7b5f8373a9e7a9bb6801a4e0c *vignettes/AFLRatings.Rnw 35 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | useDynLib(PlayerRatings, .registration = TRUE) 2 | 3 | export(elo, 4 | fide, 5 | glicko, 6 | glicko2, 7 | steph, 8 | elom, 9 | metrics, 10 | kfide, 11 | krating, 12 | kgames) 13 | 14 | S3method(print, rating) 15 | S3method(summary, rating) 16 | S3method(predict, rating) 17 | S3method(plot, rating) 18 | S3method(hist, rating) 19 | 20 | importFrom("graphics", "hist", "lines", "matplot", "par", "plot") 21 | importFrom("stats", "optimize") 22 | -------------------------------------------------------------------------------- /R/ratings.R: -------------------------------------------------------------------------------- 1 | "elo" <- function(x, status=NULL, init=2200, gamma=0, kfac=27, history=FALSE, sort=TRUE, ...) 2 | { 3 | if(!is.data.frame(x)) x <- as.data.frame(x) 4 | if(!is.data.frame(status) && !is.null(status)) status <- as.data.frame(status) 5 | if(length(init) != 1) stop("the length of 'init' must be one") 6 | if(ncol(x) != 4) stop("'x' must have four variables") 7 | if(nrow(x) == 0) { 8 | if(is.null(status)) stop("'x' is empty and 'status' is NULL") 9 | lout <- list(ratings = status, history = NULL, gamma = gamma, kfac=kfac, type = "Elo") 10 | class(lout) <- "rating" 11 | return(lout) 12 | } 13 | gammas <- rep(gamma, length.out = nrow(x)) 14 | names(x) <- c("Month","White","Black","Score") 15 | if(!is.numeric(x$Month)) 16 | stop("Time period must be numeric") 17 | if(!is.numeric(x$White) && !is.character(x$White)) 18 | stop("Player identifiers must be numeric or character") 19 | if(!is.numeric(x$Black) && !is.character(x$Black)) 20 | stop("Player identifiers must be numeric or character") 21 | if(!is.numeric(x$Score) || any(x$Score > 1) || any(x$Score < 0)) 22 | stop("Game scores must be in the interval [0,1]") 23 | 24 | play <- sort(unique(c(x$White,x$Black))) 25 | np <- length(play) 26 | x$White <- match(x$White, play) 27 | x$Black <- match(x$Black, play) 28 | if(!is.null(status)) { 29 | npadd <- play[!(play %in% status$Player)] 30 | zv <- rep(0, length(npadd)) 31 | npstatus <- data.frame(Player = npadd, Rating = rep(init,length(npadd)), Games = zv, 32 | Win = zv, Draw = zv, Loss = zv, Lag = zv) 33 | if(!("Games" %in% names(status))) status <- cbind(status, Games = 0) 34 | if(!("Win" %in% names(status))) status <- cbind(status, Win = 0) 35 | if(!("Draw" %in% names(status))) status <- cbind(status, Draw = 0) 36 | if(!("Loss" %in% names(status))) status <- cbind(status, Loss = 0) 37 | if(!("Lag" %in% names(status))) status <- cbind(status, Lag = 0) 38 | status <- rbind(status[,c("Player","Rating","Games","Win","Draw","Loss","Lag")], npstatus) 39 | rinit <- status[[2]] 40 | ngames <- status[[3]] 41 | nwin <- status[[4]] 42 | ndraw <- status[[5]] 43 | nloss <- status[[6]] 44 | nlag <- status[[7]] 45 | names(rinit) <- names(ngames) <- status$Player 46 | } 47 | else { 48 | rinit <- rep(init, length.out=np) 49 | ngames <- nwin <- ndraw <- nloss <- nlag <- rep(0, length.out=np) 50 | names(rinit) <- names(ngames) <- names(nlag) <- play 51 | } 52 | 53 | if(!all(names(rinit) == names(ngames))) 54 | stop("names of ratings and ngames are different") 55 | if(!all(play %in% names(rinit))) 56 | stop("Payers in data are not within current status") 57 | 58 | nm <- length(unique(x$Month)) 59 | curplay <- match(play, names(rinit)) 60 | orats <- rinit[-curplay] 61 | ongames <- ngames[-curplay] 62 | onwin <- nwin[-curplay] 63 | ondraw <- ndraw[-curplay] 64 | onloss <- nloss[-curplay] 65 | olag <- nlag[-curplay] 66 | olag[ongames != 0] <- olag[ongames != 0] + nm 67 | crats <- rinit[curplay] 68 | ngames <- ngames[curplay] 69 | nwin <- nwin[curplay] 70 | ndraw <- ndraw[curplay] 71 | nloss <- nloss[curplay] 72 | nlag <- nlag[curplay] 73 | 74 | gammas <- split(gammas, x$Month) 75 | x <- split(x, x$Month) 76 | if(history) { 77 | histry <- array(NA, dim=c(np,nm,3), dimnames=list(play,1:nm,c("Rating","Games","Lag"))) 78 | } 79 | 80 | for(i in 1:nm) { 81 | traini <- x[[i]] 82 | gammai <- gammas[[i]] 83 | nr <- nrow(traini) 84 | dscore <- .C("elo_c", 85 | as.integer(np), as.integer(nr), as.integer(traini$White-1), as.integer(traini$Black-1), 86 | as.double(traini$Score), as.double(crats), as.double(gammai), dscore = double(np))$dscore 87 | if(!is.function(kfac)) { 88 | crats <- crats + kfac * dscore 89 | } 90 | else { 91 | crats <- crats + kfac(crats, ngames, ...) * dscore 92 | } 93 | trainipl <- c(traini$White,traini$Black) 94 | trainiplw <- c(traini$White[traini$Score==1],traini$Black[traini$Score==0]) 95 | trainipld <- c(traini$White[traini$Score==0.5],traini$Black[traini$Score==0.5]) 96 | trainipll <- c(traini$White[traini$Score==0],traini$Black[traini$Score==1]) 97 | ngames <- ngames + tabulate(trainipl, np) 98 | nwin <- nwin + tabulate(trainiplw, np) 99 | ndraw <- ndraw + tabulate(trainipld, np) 100 | nloss <- nloss + tabulate(trainipll, np) 101 | playi <- unique(trainipl) 102 | nlag[ngames!=0] <- nlag[ngames!=0] + 1 103 | nlag[playi] <- 0 104 | 105 | if(history) { 106 | histry[,i,1] <- crats 107 | histry[,i,2] <- ngames 108 | histry[,i,3] <- nlag 109 | } 110 | } 111 | if(!history) histry <- NULL 112 | player <- suppressWarnings(as.numeric(names(c(crats,orats)))) 113 | if (any(is.na(player))) player <- names(c(crats,orats)) 114 | dfout <- data.frame(Player=player, Rating=c(crats,orats), Games=c(ngames,ongames), 115 | Win=c(nwin,onwin), Draw=c(ndraw,ondraw), Loss=c(nloss,onloss), Lag=c(nlag,olag), 116 | stringsAsFactors = FALSE) 117 | if(sort) dfout <- dfout[order(dfout$Rating,decreasing=TRUE),] else dfout <- dfout[order(dfout$Player),] 118 | row.names(dfout) <- 1:nrow(dfout) 119 | 120 | lout <- list(ratings = dfout, history = histry, gamma = gamma, kfac=kfac, type = "Elo") 121 | class(lout) <- "rating" 122 | lout 123 | } 124 | 125 | "fide" <- function(x, status=NULL, init=2200, gamma=0, kfac=kfide, 126 | history=FALSE, sort=TRUE, ...) 127 | { 128 | if(!is.data.frame(x)) x <- as.data.frame(x) 129 | if(!is.data.frame(status) && !is.null(status)) status <- as.data.frame(status) 130 | if(length(init) != 1) stop("the length of 'init' must be one") 131 | if(ncol(x) != 4) stop("'x' must have four variables") 132 | if(nrow(x) == 0) { 133 | if(is.null(status)) stop("'x' is empty and 'status' is NULL") 134 | lout <- list(ratings = status, history = NULL, gamma = gamma, kfac=kfac, type = "Elo") 135 | class(lout) <- "rating" 136 | return(lout) 137 | } 138 | gammas <- rep(gamma, length.out = nrow(x)) 139 | names(x) <- c("Month","White","Black","Score") 140 | if(!is.numeric(x$Month)) 141 | stop("Time period must be numeric") 142 | if(!is.numeric(x$White) && !is.character(x$White)) 143 | stop("Player identifiers must be numeric or character") 144 | if(!is.numeric(x$Black) && !is.character(x$Black)) 145 | stop("Player identifiers must be numeric or character") 146 | if(!is.numeric(x$Score) || any(x$Score > 1) || any(x$Score < 0)) 147 | stop("Game scores must be in the interval [0,1]") 148 | 149 | play <- sort(unique(c(x$White,x$Black))) 150 | np <- length(play) 151 | x$White <- match(x$White, play) 152 | x$Black <- match(x$Black, play) 153 | 154 | if(!is.null(status)) { 155 | npadd <- play[!(play %in% status$Player)] 156 | zv <- rep(0, length(npadd)) 157 | ev <- rep(as.numeric(init > 2400), length.out=length(npadd)) 158 | npstatus <- data.frame(Player = npadd, Rating = rep(init,length(npadd)), Games = zv, 159 | Win = zv, Draw = zv, Loss = zv, Lag = zv, Elite = ev, Opponent = zv) 160 | if(!("Games" %in% names(status))) status <- cbind(status, Games = 0) 161 | if(!("Win" %in% names(status))) status <- cbind(status, Win = 0) 162 | if(!("Draw" %in% names(status))) status <- cbind(status, Draw = 0) 163 | if(!("Loss" %in% names(status))) status <- cbind(status, Loss = 0) 164 | if(!("Lag" %in% names(status))) status <- cbind(status, Lag = 0) 165 | if(!("Elite" %in% names(status))) status <- cbind(status, Elite = as.numeric(status$Player >= 2400)) 166 | if(!("Opponent" %in% names(status))) status <- cbind(status, Opponent = status$Rating) 167 | status <- rbind(status[,c("Player","Rating","Games","Win","Draw","Loss","Lag","Elite","Opponent")], npstatus) 168 | rinit <- status[[2]] 169 | ngames <- status[[3]] 170 | nwin <- status[[4]] 171 | ndraw <- status[[5]] 172 | nloss <- status[[6]] 173 | nlag <- status[[7]] 174 | elite <- status[[8]] 175 | opponent <- status[[9]] 176 | names(rinit) <- names(ngames) <- status$Player 177 | } 178 | else { 179 | rinit <- rep(init, length.out=np) 180 | ngames <- nwin <- ndraw <- nloss <- nlag <- elite <- opponent <- rep(0, length.out=np) 181 | names(rinit) <- names(ngames) <- names(nlag) <- play 182 | } 183 | 184 | if(!all(names(rinit) == names(ngames))) 185 | stop("names of ratings and ngames are different") 186 | if(!all(play %in% names(rinit))) 187 | stop("Payers in data are not within current status") 188 | 189 | nm <- length(unique(x$Month)) 190 | curplay <- match(play, names(rinit)) 191 | orats <- rinit[-curplay] 192 | ongames <- ngames[-curplay] 193 | onwin <- nwin[-curplay] 194 | ondraw <- ndraw[-curplay] 195 | onloss <- nloss[-curplay] 196 | olag <- nlag[-curplay] 197 | olag[ongames != 0] <- olag[ongames != 0] + nm 198 | oelite <- elite[-curplay] 199 | oopponent <- opponent[-curplay] 200 | crats <- rinit[curplay] 201 | ngames <- ngames[curplay] 202 | nwin <- nwin[curplay] 203 | ndraw <- ndraw[curplay] 204 | nloss <- nloss[curplay] 205 | nlag <- nlag[curplay] 206 | elite <- elite[curplay] 207 | opponent <- opponent[curplay] 208 | 209 | gammas <- split(gammas, x$Month) 210 | x <- split(x, x$Month) 211 | if(history) { 212 | histry <- array(NA, dim=c(np,nm,3), dimnames=list(play,1:nm,c("Rating","Games","Lag"))) 213 | } 214 | 215 | for(i in 1:nm) { 216 | traini <- x[[i]] 217 | gammai <- gammas[[i]] 218 | nr <- nrow(traini) 219 | trainiW <- traini$White; trainiB <- traini$Black; trainiS <- traini$Score 220 | 221 | dscore <- .C("elo_c", 222 | as.integer(np), as.integer(nr), as.integer(trainiW-1), as.integer(trainiB-1), 223 | as.double(trainiS), as.double(crats), as.double(gammai), dscore = double(np))$dscore 224 | if(!is.function(kfac)) { 225 | crats <- crats + kfac * dscore 226 | } 227 | else { 228 | crats <- crats + kfac(crats, ngames, elite, ...) * dscore 229 | } 230 | 231 | trainipl <- c(trainiW,trainiB) 232 | trainiplw <- c(trainiW[traini$Score==1],trainiB[traini$Score==0]) 233 | trainipld <- c(trainiW[traini$Score==0.5],trainiB[traini$Score==0.5]) 234 | trainipll <- c(trainiW[traini$Score==0],trainiB[traini$Score==1]) 235 | ngamesi <- tabulate(trainipl, np) 236 | ngames <- ngames + ngamesi 237 | nwin <- nwin + tabulate(trainiplw, np) 238 | ndraw <- ndraw + tabulate(trainipld, np) 239 | nloss <- nloss + tabulate(trainipll, np) 240 | playi <- unique(trainipl) 241 | nlag[ngames!=0] <- nlag[ngames!=0] + 1 242 | nlag[playi] <- 0 243 | elite[crats >= 2400] <- 1 244 | 245 | opponentiw <- sapply(split(crats[trainiB], trainiW), sum) 246 | opponentib <- sapply(split(crats[trainiW], trainiB), sum) 247 | opponenti <- numeric(np) 248 | opponenti[as.numeric(names(opponentiw))] <- opponentiw 249 | opponenti[as.numeric(names(opponentib))] <- opponenti[as.numeric(names(opponentib))] + opponentib 250 | opponent[ngames!=0] <- (((ngames-ngamesi)/ngames)*opponent + opponenti/ngames)[ngames!=0] 251 | 252 | if(history) { 253 | histry[,i,1] <- crats 254 | histry[,i,2] <- ngames 255 | histry[,i,3] <- nlag 256 | } 257 | } 258 | if(!history) histry <- NULL 259 | player <- suppressWarnings(as.numeric(names(c(crats,orats)))) 260 | if (any(is.na(player))) player <- names(c(crats,orats)) 261 | dfout <- data.frame(Player=player, Rating=c(crats,orats), Games=c(ngames,ongames), 262 | Win=c(nwin,onwin), Draw=c(ndraw,ondraw), Loss=c(nloss,onloss), Lag=c(nlag,olag), 263 | Elite=c(elite,oelite), Opponent=c(opponent,oopponent), 264 | stringsAsFactors = FALSE) 265 | if(sort) dfout <- dfout[order(dfout$Rating,decreasing=TRUE),] else dfout <- dfout[order(dfout$Player),] 266 | row.names(dfout) <- 1:nrow(dfout) 267 | 268 | lout <- list(ratings = dfout, history = histry, gamma = gamma, kfac=kfac, type = "Elo") 269 | class(lout) <- "rating" 270 | lout 271 | } 272 | 273 | "glicko" <- function(x, status=NULL, init=c(2200,300), gamma=0, cval=15, history=FALSE, sort=TRUE, rdmax = 350, ...) 274 | { 275 | if(!is.data.frame(x)) x <- as.data.frame(x) 276 | if(!is.data.frame(status) && !is.null(status)) status <- as.data.frame(status) 277 | if(length(init) != 2) stop("the length of 'init' must be two") 278 | if(init[2] <= 0) stop("initial deviation must be positive") 279 | if(init[2] > rdmax) stop("initial deviation cannot be greater than rdmax") 280 | if(ncol(x) != 4) stop("'x' must have four variables") 281 | if(nrow(x) == 0) { 282 | if(is.null(status)) stop("'x' is empty and 'status' is NULL") 283 | lout <- list(ratings=status, history=NULL, gamma=gamma, cval=cval, type = "Glicko") 284 | class(lout) <- "rating" 285 | return(lout) 286 | } 287 | gammas <- rep(gamma, length.out = nrow(x)) 288 | names(x) <- c("Month","White","Black","Score") 289 | if(!is.numeric(x$Month)) 290 | stop("Time period must be numeric") 291 | if(!is.numeric(x$White) && !is.character(x$White)) 292 | stop("Player identifiers must be numeric or character") 293 | if(!is.numeric(x$Black) && !is.character(x$Black)) 294 | stop("Player identifiers must be numeric or character") 295 | if(!is.numeric(x$Score) || any(x$Score > 1) || any(x$Score < 0)) 296 | stop("Game scores must be in the interval [0,1]") 297 | 298 | play <- sort(unique(c(x$White,x$Black))) 299 | np <- length(play) 300 | x$White <- match(x$White, play) 301 | x$Black <- match(x$Black, play) 302 | 303 | if(!is.null(status)) { 304 | npadd <- play[!(play %in% status$Player)] 305 | zv <- rep(0, length(npadd)) 306 | npstatus <- data.frame(Player = npadd, Rating = rep(init[1],length(npadd)), 307 | Deviation = rep(init[2],length(npadd)), Games = zv, Win = zv, Draw = zv, 308 | Loss = zv, Lag = zv) 309 | if(!("Games" %in% names(status))) status <- cbind(status, Games = 0) 310 | if(!("Win" %in% names(status))) status <- cbind(status, Win = 0) 311 | if(!("Draw" %in% names(status))) status <- cbind(status, Draw = 0) 312 | if(!("Loss" %in% names(status))) status <- cbind(status, Loss = 0) 313 | if(!("Lag" %in% names(status))) status <- cbind(status, Lag = 0) 314 | status <- rbind(status[,c("Player","Rating","Deviation","Games","Win","Draw","Loss","Lag")], npstatus) 315 | rinit <- status[[2]] 316 | dinit <- status[[3]] 317 | ngames <- status[[4]] 318 | nwin <- status[[5]] 319 | ndraw <- status[[6]] 320 | nloss <- status[[7]] 321 | nlag <- status[[8]] 322 | names(rinit) <- names(dinit) <- names(ngames) <- status$Player 323 | } 324 | else { 325 | rinit <- rep(init[1], length.out=np) 326 | dinit <- rep(init[2], length.out=np) 327 | ngames <- nwin <- ndraw <- nloss <- rep(0, length.out=np) 328 | nlag <- rep(0,np) 329 | names(rinit) <- names(dinit) <- names(ngames) <- names(nlag) <- play 330 | } 331 | 332 | if(!all(names(rinit) == names(ngames))) 333 | stop("names of ratings and ngames are different") 334 | if(!all(play %in% names(rinit))) 335 | stop("Payers in data are not within current status") 336 | 337 | nm <- length(unique(x$Month)) 338 | curplay <- match(play, names(rinit)) 339 | orats <- rinit[-curplay] 340 | odevs <- dinit[-curplay]^2 341 | ongames <- ngames[-curplay] 342 | onwin <- nwin[-curplay] 343 | ondraw <- ndraw[-curplay] 344 | onloss <- nloss[-curplay] 345 | olag <- nlag[-curplay] 346 | olag[ongames != 0] <- olag[ongames != 0] + nm 347 | crats <- rinit[curplay] 348 | cdevs <- dinit[curplay]^2 349 | ngames <- ngames[curplay] 350 | nwin <- nwin[curplay] 351 | ndraw <- ndraw[curplay] 352 | nloss <- nloss[curplay] 353 | nlag <- nlag[curplay] 354 | 355 | qv <- log(10)/400; qip3 <- 3*(qv/pi)^2 356 | gammas <- split(gammas, x$Month) 357 | x <- split(x, x$Month) 358 | players <- lapply(x, function(y) unique(c(y$White, y$Black))) 359 | if(history) { 360 | histry <- array(NA, dim=c(np,nm,4), dimnames=list(play,1:nm,c("Rating","Deviation","Games","Lag"))) 361 | } 362 | 363 | for(i in 1:nm) { 364 | traini <- x[[i]] 365 | gammai <- gammas[[i]] 366 | nr <- nrow(traini) 367 | playi <- players[[i]] 368 | 369 | cdevs[playi] <- pmin(cdevs[playi] + (nlag[playi]+1)*(cval^2), rdmax * rdmax) 370 | gdevs <- 1/sqrt(1 + qip3*cdevs) 371 | ngamesi <- tabulate(c(traini$White,traini$Black), np) 372 | dscore <- .C("glicko_c", 373 | as.integer(np), as.integer(nr), as.integer(traini$White-1), as.integer(traini$Black-1), 374 | as.double(traini$Score), as.double(crats), as.double(gdevs), as.double(gammai), 375 | dscore = double(2*np))$dscore 376 | dval <- dscore[(np+1):(2*np)]; dscore <- dscore[1:np] 377 | cdevs <- 1/(1/cdevs + dval) 378 | crats <- crats + cdevs * qv * dscore 379 | 380 | trainiplw <- c(traini$White[traini$Score==1],traini$Black[traini$Score==0]) 381 | trainipld <- c(traini$White[traini$Score==0.5],traini$Black[traini$Score==0.5]) 382 | trainipll <- c(traini$White[traini$Score==0],traini$Black[traini$Score==1]) 383 | ngames <- ngames + ngamesi 384 | nwin <- nwin + tabulate(trainiplw, np) 385 | ndraw <- ndraw + tabulate(trainipld, np) 386 | nloss <- nloss + tabulate(trainipll, np) 387 | nlag[ngames!=0] <- nlag[ngames!=0] + 1 388 | nlag[playi] <- 0 389 | 390 | if(history) { 391 | histry[,i,1] <- crats 392 | histry[,i,2] <- sqrt(cdevs) 393 | histry[,i,3] <- ngames 394 | histry[,i,4] <- nlag 395 | } 396 | } 397 | if(!history) histry <- NULL 398 | player <- suppressWarnings(as.numeric(names(c(crats,orats)))) 399 | if (any(is.na(player))) player <- names(c(crats,orats)) 400 | dfout <- data.frame(Player=player, Rating=c(crats,orats), Deviation=sqrt(c(cdevs,odevs)), 401 | Games=c(ngames,ongames), Win=c(nwin,onwin), Draw=c(ndraw,ondraw), Loss=c(nloss,onloss), 402 | Lag=c(nlag,olag), 403 | stringsAsFactors = FALSE) 404 | if(sort) dfout <- dfout[order(dfout$Rating,decreasing=TRUE),] else dfout <- dfout[order(dfout$Player),] 405 | row.names(dfout) <- 1:nrow(dfout) 406 | 407 | lout <- list(ratings=dfout, history=histry, gamma=gamma, cval=cval, type = "Glicko") 408 | class(lout) <- "rating" 409 | lout 410 | } 411 | 412 | "glicko2" <- function(x, status=NULL, init=c(2200,300,0.15), gamma=0, tau=1.2, history=FALSE, sort=TRUE, rdmax = 350, ...) 413 | { 414 | if(!is.data.frame(x)) x <- as.data.frame(x) 415 | if(!is.data.frame(status) && !is.null(status)) status <- as.data.frame(status) 416 | qv <- log(10)/400 417 | if(length(init) != 3) stop("the length of 'init' must be three") 418 | if(init[2] <= 0) stop("initial deviation must be positive") 419 | if(init[2] > rdmax) stop("initial deviation cannot be greater than rdmax") 420 | if(init[3] <= 0) stop("initial volatility must be positive") 421 | if(init[3] > qv*rdmax) stop("initial volatility cannot be greater than log(10)*rdmax/400") 422 | if(ncol(x) != 4) stop("'x' must have four variables") 423 | if(nrow(x) == 0) { 424 | if(is.null(status)) stop("'x' is empty and 'status' is NULL") 425 | lout <- list(ratings=status, history=NULL, gamma=gamma, tau=tau, type = "Glicko-2") 426 | class(lout) <- "rating" 427 | return(lout) 428 | } 429 | gammas <- rep(gamma, length.out = nrow(x)) 430 | names(x) <- c("Month","White","Black","Score") 431 | if(!is.numeric(x$Month)) 432 | stop("Time period must be numeric") 433 | if(!is.numeric(x$White) && !is.character(x$White)) 434 | stop("Player identifiers must be numeric or character") 435 | if(!is.numeric(x$Black) && !is.character(x$Black)) 436 | stop("Player identifiers must be numeric or character") 437 | if(!is.numeric(x$Score) || any(x$Score > 1) || any(x$Score < 0)) 438 | stop("Game scores must be in the interval [0,1]") 439 | 440 | play <- sort(unique(c(x$White,x$Black))) 441 | np <- length(play) 442 | x$White <- match(x$White, play) 443 | x$Black <- match(x$Black, play) 444 | 445 | if(!is.null(status)) { 446 | npadd <- play[!(play %in% status$Player)] 447 | zv <- rep(0, length(npadd)) 448 | npstatus <- data.frame(Player = npadd, Rating = rep(init[1],length(npadd)), 449 | Deviation = rep(init[2],length(npadd)), Volatility = rep(init[3],length(npadd)), 450 | Games = zv, Win = zv, Draw = zv, Loss = zv, Lag = zv) 451 | if(!("Games" %in% names(status))) status <- cbind(status, Games = 0) 452 | if(!("Win" %in% names(status))) status <- cbind(status, Win = 0) 453 | if(!("Draw" %in% names(status))) status <- cbind(status, Draw = 0) 454 | if(!("Loss" %in% names(status))) status <- cbind(status, Loss = 0) 455 | if(!("Lag" %in% names(status))) status <- cbind(status, Lag = 0) 456 | status <- rbind(status[,c("Player","Rating","Deviation","Volatility","Games","Win","Draw","Loss","Lag")], npstatus) 457 | rinit <- status[[2]] 458 | dinit <- status[[3]] 459 | vinit <- status[[4]] 460 | ngames <- status[[5]] 461 | nwin <- status[[6]] 462 | ndraw <- status[[7]] 463 | nloss <- status[[8]] 464 | nlag <- status[[9]] 465 | names(rinit) <- names(dinit) <- names(vinit) <- names(ngames) <- status$Player 466 | } 467 | else { 468 | rinit <- rep(init[1], length.out=np) 469 | dinit <- rep(init[2], length.out=np) 470 | vinit <- rep(init[3], length.out=np) 471 | ngames <- nwin <- ndraw <- nloss <- rep(0, length.out=np) 472 | nlag <- rep(0,np) 473 | names(rinit) <- names(dinit) <- names(vinit) <- names(ngames) <- names(nlag) <- play 474 | } 475 | 476 | if(!all(names(rinit) == names(ngames))) 477 | stop("names of ratings and ngames are different") 478 | if(!all(play %in% names(rinit))) 479 | stop("Payers in data are not within current status") 480 | 481 | # conversion to Glicko-2 scale 482 | rinit <- qv*(rinit - 1500) 483 | gammas <- qv*gammas 484 | dinit <- qv*dinit 485 | 486 | nm <- length(unique(x$Month)) 487 | curplay <- match(play, names(rinit)) 488 | orats <- rinit[-curplay] 489 | odevs <- dinit[-curplay]^2 490 | ovols <- vinit[-curplay] 491 | ongames <- ngames[-curplay] 492 | onwin <- nwin[-curplay] 493 | ondraw <- ndraw[-curplay] 494 | onloss <- nloss[-curplay] 495 | olag <- nlag[-curplay] 496 | olag[ongames != 0] <- olag[ongames != 0] + nm 497 | crats <- rinit[curplay] 498 | cdevs <- dinit[curplay]^2 499 | cvols <- vinit[curplay] 500 | ngames <- ngames[curplay] 501 | nwin <- nwin[curplay] 502 | ndraw <- ndraw[curplay] 503 | nloss <- nloss[curplay] 504 | nlag <- nlag[curplay] 505 | 506 | gammas <- split(gammas, x$Month) 507 | x <- split(x, x$Month) 508 | players <- lapply(x, function(y) unique(c(y$White, y$Black))) 509 | if(history) { 510 | histry <- array(NA, dim=c(np,nm,5), dimnames=list(play,1:nm,c("Rating","Deviation","Volatility","Games","Lag"))) 511 | } 512 | 513 | tau2 <- tau * tau 514 | for(i in 1:nm) { 515 | traini <- x[[i]] 516 | gammai <- gammas[[i]] 517 | nr <- nrow(traini) 518 | playi <- players[[i]] 519 | 520 | # nlag[payi]*(cvols[playi]^2) in Glicko-2, (nlag[payi]+1)*(cval^2) in Glicko 521 | rdmax2 <- qv * qv * rdmax * rdmax 522 | cdevs[playi] <- pmin(cdevs[playi] + (nlag[playi])*(cvols[playi]^2), rdmax2) 523 | qip3 <- 3*(1/pi)^2 524 | gdevs <- 1/sqrt(1 + qip3*cdevs) 525 | ngamesi <- tabulate(c(traini$White,traini$Black), np) 526 | dscore <- .C("glicko2_c", 527 | as.integer(np), as.integer(nr), as.integer(traini$White-1), as.integer(traini$Black-1), 528 | as.double(traini$Score), as.double(crats), as.double(gdevs), as.double(gammai), 529 | dscore = double(2*np))$dscore 530 | vval <- dscore[(np+1):(2*np)]; dscore <- dscore[1:np] 531 | 532 | if(tau > 0) { 533 | nllh <- function(z, pz, cdev, vvi, dsco) { 534 | denom <- cdev + exp(z) + vvi 535 | delta <- vvi * dsco 536 | (z - pz) * (z - pz) / tau2 + log(denom) + delta*delta/denom 537 | } 538 | for(k in seq_along(playi)) { 539 | prv <- 2*log(cvols[playi[k]]) 540 | oval <- optimize(nllh, lower = prv-4*tau, upper = prv+4*tau, pz = prv, 541 | cdev = cdevs[playi[k]], vvi = 1/vval[playi[k]], dsco = dscore[playi[k]])$minimum 542 | cvols[playi[k]] <- min(exp(oval/2), qv * rdmax) 543 | } 544 | } 545 | 546 | cdevs[playi] <- cdevs[playi] + cvols[playi]^2 547 | cdevs <- pmin(1/(1/cdevs + vval), rdmax2) 548 | crats <- crats + cdevs * dscore 549 | 550 | trainiplw <- c(traini$White[traini$Score==1],traini$Black[traini$Score==0]) 551 | trainipld <- c(traini$White[traini$Score==0.5],traini$Black[traini$Score==0.5]) 552 | trainipll <- c(traini$White[traini$Score==0],traini$Black[traini$Score==1]) 553 | ngames <- ngames + ngamesi 554 | nwin <- nwin + tabulate(trainiplw, np) 555 | ndraw <- ndraw + tabulate(trainipld, np) 556 | nloss <- nloss + tabulate(trainipll, np) 557 | nlag[ngames!=0] <- nlag[ngames!=0] + 1 558 | nlag[playi] <- 0 559 | 560 | if(history) { 561 | histry[,i,1] <- crats 562 | histry[,i,2] <- sqrt(cdevs) 563 | histry[,i,3] <- cvols 564 | histry[,i,4] <- ngames 565 | histry[,i,5] <- nlag 566 | } 567 | } 568 | if(!history) histry <- NULL 569 | player <- suppressWarnings(as.numeric(names(c(crats,orats)))) 570 | if (any(is.na(player))) player <- names(c(crats,orats)) 571 | dfout <- data.frame(Player=player, Rating=c(crats,orats), Deviation=sqrt(c(cdevs,odevs)), Volatility=c(cvols,ovols), 572 | Games=c(ngames,ongames), Win=c(nwin,onwin), Draw=c(ndraw,ondraw), Loss=c(nloss,onloss), 573 | Lag=c(nlag,olag), 574 | stringsAsFactors = FALSE) 575 | if(sort) dfout <- dfout[order(dfout$Rating,decreasing=TRUE),] else dfout <- dfout[order(dfout$Player),] 576 | row.names(dfout) <- 1:nrow(dfout) 577 | 578 | # conversion from Glicko-2 scale 579 | dfout$Rating <- dfout$Rating/qv + 1500 580 | dfout$Deviation <- dfout$Deviation/qv 581 | if(history) { 582 | histry[,,1] <- histry[,,1]/qv + 1500 583 | histry[,,2] <- histry[,,2]/qv 584 | } 585 | 586 | lout <- list(ratings=dfout, history=histry, gamma=gamma, tau=tau, type = "Glicko-2") 587 | class(lout) <- "rating" 588 | lout 589 | } 590 | 591 | "steph" <- function(x, status=NULL, init=c(2200,300), gamma=0, cval=10, hval=10, 592 | bval=0, lambda = 2, history=FALSE, sort=TRUE, rdmax = 350, ...) 593 | { 594 | if(!is.data.frame(x)) x <- as.data.frame(x) 595 | if(!is.data.frame(status) && !is.null(status)) status <- as.data.frame(status) 596 | if(length(init) != 2) stop("the length of 'init' must be two") 597 | if(init[2] <= 0) stop("initial deviation must be positive") 598 | if(init[2] > rdmax) stop("initial deviation cannot be greater than rdmax") 599 | if(ncol(x) != 4) stop("'x' must have four variables") 600 | if(nrow(x) == 0) { 601 | if(is.null(status)) stop("'x' is empty and 'status' is NULL") 602 | lout <- list(ratings=status, history=NULL, gamma=gamma, cval=cval, hval=hval, 603 | bval=bval, lambda=lambda, type = "Stephenson") 604 | class(lout) <- "rating" 605 | return(lout) 606 | } 607 | gammas <- rep(gamma, length.out = nrow(x)) 608 | names(x) <- c("Month","White","Black","Score") 609 | if(!is.numeric(x$Month)) 610 | stop("Time period must be numeric") 611 | if(!is.numeric(x$White) && !is.character(x$White)) 612 | stop("Player identifiers must be numeric or character") 613 | if(!is.numeric(x$Black) && !is.character(x$Black)) 614 | stop("Player identifiers must be numeric or character") 615 | if(!is.numeric(x$Score) || any(x$Score > 1) || any(x$Score < 0)) 616 | stop("Game scores must be in the interval [0,1]") 617 | 618 | play <- sort(unique(c(x$White,x$Black))) 619 | np <- length(play) 620 | x$White <- match(x$White, play) 621 | x$Black <- match(x$Black, play) 622 | 623 | if(!is.null(status)) { 624 | npadd <- play[!(play %in% status$Player)] 625 | zv <- rep(0, length(npadd)) 626 | npstatus <- data.frame(Player = npadd, Rating = rep(init[1],length(npadd)), 627 | Deviation = rep(init[2],length(npadd)), Games = zv, Win = zv, Draw = zv, 628 | Loss = zv, Lag = zv) 629 | if(!("Games" %in% names(status))) status <- cbind(status, Games = 0) 630 | if(!("Win" %in% names(status))) status <- cbind(status, Win = 0) 631 | if(!("Draw" %in% names(status))) status <- cbind(status, Draw = 0) 632 | if(!("Loss" %in% names(status))) status <- cbind(status, Loss = 0) 633 | if(!("Lag" %in% names(status))) status <- cbind(status, Lag = 0) 634 | status <- rbind(status[,c("Player","Rating","Deviation","Games","Win","Draw","Loss","Lag")], npstatus) 635 | rinit <- status[[2]] 636 | dinit <- status[[3]] 637 | ngames <- status[[4]] 638 | nwin <- status[[5]] 639 | ndraw <- status[[6]] 640 | nloss <- status[[7]] 641 | nlag <- status[[8]] 642 | names(rinit) <- names(dinit) <- names(ngames) <- status$Player 643 | } 644 | else { 645 | rinit <- rep(init[1], length.out=np) 646 | dinit <- rep(init[2], length.out=np) 647 | ngames <- nwin <- ndraw <- nloss <- rep(0, length.out=np) 648 | nlag <- rep(0,np) 649 | names(rinit) <- names(dinit) <- names(ngames) <- names(nlag) <- play 650 | } 651 | 652 | if(!all(names(rinit) == names(ngames))) 653 | stop("names of ratings and ngames are different") 654 | if(!all(play %in% names(rinit))) 655 | stop("Payers in data are not within current status") 656 | 657 | nm <- length(unique(x$Month)) 658 | curplay <- match(play, names(rinit)) 659 | orats <- rinit[-curplay] 660 | odevs <- dinit[-curplay]^2 661 | ongames <- ngames[-curplay] 662 | onwin <- nwin[-curplay] 663 | ondraw <- ndraw[-curplay] 664 | onloss <- nloss[-curplay] 665 | olag <- nlag[-curplay] 666 | olag[ongames != 0] <- olag[ongames != 0] + nm 667 | crats <- rinit[curplay] 668 | cdevs <- dinit[curplay]^2 669 | ngames <- ngames[curplay] 670 | nwin <- nwin[curplay] 671 | ndraw <- ndraw[curplay] 672 | nloss <- nloss[curplay] 673 | nlag <- nlag[curplay] 674 | 675 | qv <- log(10)/400; qip3 <- 3*(qv/pi)^2 676 | gammas <- split(gammas, x$Month) 677 | x <- split(x, x$Month) 678 | players <- lapply(x, function(y) unique(c(y$White, y$Black))) 679 | if(history) { 680 | histry <- array(NA, dim=c(np,nm,4), dimnames=list(play,1:nm,c("Rating","Deviation","Games","Lag"))) 681 | } 682 | 683 | for(i in 1:nm) { 684 | traini <- x[[i]] 685 | gammai <- gammas[[i]] 686 | nr <- nrow(traini) 687 | playi <- players[[i]] 688 | 689 | cdevs[playi] <- pmin(cdevs[playi] + (nlag[playi]+1)*(cval^2), rdmax * rdmax) 690 | gdevs <- 1/sqrt(1 + qip3*cdevs) 691 | ngamesi <- tabulate(c(traini$White,traini$Black), np) 692 | 693 | dscore <- .C("stephenson_c", 694 | as.integer(np), as.integer(nr), as.integer(traini$White-1), as.integer(traini$Black-1), 695 | as.double(traini$Score), as.double(crats), as.double(gdevs), as.double(gammai), 696 | as.double(bval/100), dscore = double(3*np))$dscore 697 | 698 | l1t <- dscore[(2*np+1):(3*np)] 699 | dval <- dscore[(np+1):(2*np)] 700 | dscore <- dscore[1:np] 701 | 702 | cdevs <- 1/(1/(cdevs + ngamesi*(hval^2)) + dval) 703 | crats <- crats + cdevs * qv * dscore 704 | crats[playi] <- crats[playi] + (lambda/100)*l1t[playi]/(ngamesi[playi]) 705 | 706 | trainiplw <- c(traini$White[traini$Score==1],traini$Black[traini$Score==0]) 707 | trainipld <- c(traini$White[traini$Score==0.5],traini$Black[traini$Score==0.5]) 708 | trainipll <- c(traini$White[traini$Score==0],traini$Black[traini$Score==1]) 709 | ngames <- ngames + ngamesi 710 | nwin <- nwin + tabulate(trainiplw, np) 711 | ndraw <- ndraw + tabulate(trainipld, np) 712 | nloss <- nloss + tabulate(trainipll, np) 713 | nlag[ngames!=0] <- nlag[ngames!=0] + 1 714 | nlag[playi] <- 0 715 | 716 | if(history) { 717 | histry[,i,1] <- crats 718 | histry[,i,2] <- sqrt(cdevs) 719 | histry[,i,3] <- ngames 720 | histry[,i,4] <- nlag 721 | } 722 | } 723 | if(!history) histry <- NULL 724 | player <- suppressWarnings(as.numeric(names(c(crats,orats)))) 725 | if (any(is.na(player))) player <- names(c(crats,orats)) 726 | dfout <- data.frame(Player=player, Rating=c(crats,orats), Deviation=sqrt(c(cdevs,odevs)), 727 | Games=c(ngames,ongames), Win=c(nwin,onwin), Draw=c(ndraw,ondraw), Loss=c(nloss,onloss), 728 | Lag=c(nlag,olag), 729 | stringsAsFactors = FALSE) 730 | if(sort) dfout <- dfout[order(dfout$Rating,decreasing=TRUE),] else dfout <- dfout[order(dfout$Player),] 731 | row.names(dfout) <- 1:nrow(dfout) 732 | 733 | lout <- list(ratings=dfout, history=histry, gamma=gamma, cval=cval, hval=hval, 734 | bval=bval, lambda=lambda, type = "Stephenson") 735 | class(lout) <- "rating" 736 | lout 737 | } 738 | 739 | "elom" <- function(x, nn=4, exact=TRUE, base=c(30,10,-10,-30), status=NULL, init=1500, kfac=kriichi, history=FALSE, sort=TRUE, ..., placing=FALSE) 740 | { 741 | if(!is.data.frame(x)) x <- as.data.frame(x) 742 | if(!is.data.frame(status) && !is.null(status)) status <- as.data.frame(status) 743 | if(is.function(base) && placing) stop("'base' cannot be a function if using placings") 744 | if(!is.function(base) && !is.vector(base) && !is.matrix(base)) 745 | stop("'base' must be a function, vector or matrix") 746 | if(length(init) != 1) stop("the length of 'init' must be one") 747 | if(ncol(x) != 2*nn+1) stop("'x' must have 2*nn+1 variables") 748 | if(exact && any(is.na(x))) 749 | stop("'x' cannot have missing values when 'exact' is TRUE") 750 | if(is.vector(base) && length(base) != nn) 751 | stop("'base' must be a function or vector of length nn or a nrow(x) by nn matrix") 752 | if(is.matrix(base) && (ncol(base) != nn || nrow(base) != nrow(x))) 753 | stop("'base' must be a function or vector of length nn or a nrow(x) by nn matrix") 754 | if(nrow(x) == 0) { 755 | if(is.null(status)) stop("'x' is empty and 'status' is NULL") 756 | lout <- list(ratings = status, history = NULL, nn=nn, exact=exact, kfac=kfac, type = "EloM") 757 | class(lout) <- "rating" 758 | return(lout) 759 | } 760 | plays <- paste0("Player", 1:nn) 761 | scores <- paste0("Score", 1:nn) 762 | names(x) <- c("Month", plays, scores) 763 | if(!is.numeric(x$Month)) 764 | stop("Time period must be numeric") 765 | for(i in 1:nn) { 766 | if(!is.numeric(x[[plays[i]]]) && !is.character(x[[plays[i]]])) 767 | stop("Player identifiers must be numeric or character") 768 | if(!is.numeric(x[[scores[i]]])) 769 | stop("Game scores must be numeric") 770 | } 771 | npord <- paste0(1:nn, "th") 772 | npord[npord == "1th"] <- "1st" 773 | npord[npord == "2th"] <- "2nd" 774 | npord[npord == "3th"] <- "3rd" 775 | 776 | play <- unique(c(x[["Player1"]],x[["Player2"]])) 777 | for(i in seq_len(nn-2)) play <- unique(c(play, x[[plays[i+2]]])) 778 | play <- sort(play) 779 | for(i in seq_len(nn)) x[[plays[i]]] <- match(x[[plays[i]]], play) 780 | np <- length(play) 781 | 782 | if(!is.null(status)) { 783 | npadd <- play[!(play %in% status$Player)] 784 | df <- data.frame(matrix(0, ncol = nn+2, nrow = length(npadd))) 785 | colnames(df) <- c("Games", npord, "Lag") 786 | npstatus <- cbind(data.frame(Player = npadd, Rating = rep(init,length(npadd))), df) 787 | if(!("Games" %in% names(status))) status <- cbind(status, Games = 0) 788 | for(i in 1:length(npord)) { 789 | if(!(npord[i] %in% names(status))) { 790 | status <- cbind(status, 0) 791 | colnames(status)[ncol(status)] <- npord[i] 792 | } 793 | } 794 | if(!("Lag" %in% names(status))) status <- cbind(status, Lag = 0) 795 | status <- rbind(status[,c("Player","Rating","Games",npord,"Lag")], npstatus) 796 | rinit <- status[[2]] 797 | ngames <- status[[3]] 798 | for(i in 1:length(npord)) { 799 | assign(paste0("n",npord[i]), status[[i + 3]]) 800 | } 801 | nlag <- status[[length(npord) + 4]] 802 | names(rinit) <- names(ngames) <- status$Player 803 | } 804 | else { 805 | rinit <- rep(init, length.out=np) 806 | ngames <- nlag <- rep(0, length.out=np) 807 | for(i in 1:length(npord)) { 808 | assign(paste0("n",npord[i]), rep(0, length.out=np)) 809 | } 810 | names(rinit) <- names(ngames) <- names(nlag) <- play 811 | } 812 | 813 | if(!all(names(rinit) == names(ngames))) 814 | stop("names of ratings and ngames are different") 815 | if(!all(play %in% names(rinit))) 816 | stop("Payers in data are not within current status") 817 | 818 | nm <- length(unique(x$Month)) 819 | curplay <- match(play, names(rinit)) 820 | orats <- rinit[-curplay] 821 | ongames <- ngames[-curplay] 822 | for(i in 1:length(npord)) { 823 | tmp <- get(paste0("n",npord[i]))[-curplay] 824 | assign(paste0("on",npord[i]), tmp) 825 | } 826 | olag <- nlag[-curplay] 827 | olag[ongames != 0] <- olag[ongames != 0] + nm 828 | crats <- rinit[curplay] 829 | ngames <- ngames[curplay] 830 | for(i in 1:length(npord)) { 831 | tmp <- get(paste0("n",npord[i]))[curplay] 832 | assign(paste0("n",npord[i]), tmp) 833 | } 834 | nlag <- nlag[curplay] 835 | 836 | ranks <- paste0("Rank", 1:nn) 837 | bases <- paste0("Base", 1:nn) 838 | tmp <- as.matrix(x[,(nn+2):(nn+nn+1)]) 839 | rnk <- t(apply(tmp, 1, 840 | function(zz) { 841 | if(placing == TRUE) zz <- -zz 842 | rank(-zz, ties.method = "min", na.last = "keep") 843 | })) 844 | colnames(rnk) <- ranks 845 | x <- cbind(x, rnk) 846 | 847 | if(is.function(base)) { 848 | for(i in 1:nn) x[[bases[i]]] <- base(x[[scores[i]]]) 849 | } else { 850 | tmpfun <- function(zz, basev) 851 | { 852 | if(placing == TRUE) zz <- -zz 853 | nan <- sum(is.na(zz)) 854 | if(nan == 0) return(basev[rank(-zz, ties.method = "min")]) 855 | for(k in 1:(nn-2)) { 856 | sbase <- basev 857 | nb <- length(sbase) 858 | if((nb %% 2) == 0) { 859 | sbase <- c(sbase[1:(nb/2-1)], mean(sbase[(nb/2):(nb/2+1)]), sbase[(nb/2+2):nb]) 860 | } else { 861 | sbase <- c(sbase[1:((nb-1)/2)], sbase[((nb+3)/2):nb]) 862 | } 863 | if(nan == k) return(sbase[rank(-zz, ties.method = "min", na.last = "keep")]) 864 | } 865 | } 866 | if(is.vector(base)) { 867 | tmp <- t(apply(tmp, 1, tmpfun, basev = base)) 868 | } else { 869 | tmp <- t(sapply(1:nrow(tmp), function(i) tmpfun(tmp[i,], base[i,]))) 870 | } 871 | colnames(tmp) <- bases 872 | x <- cbind(x, tmp) 873 | } 874 | 875 | x[is.na(x)] <- 0 876 | x <- split(x, x$Month) 877 | if(history) { 878 | histry <- array(NA, dim=c(np,nm,3), dimnames=list(play,1:nm,c("Rating","Games","Lag"))) 879 | } 880 | 881 | for(i in 1:nm) { 882 | traini <- x[[i]] 883 | trainip <- as.matrix(traini[,2:(nn+1)]) 884 | trainir <- as.matrix(traini[,(2*nn+2):(3*nn+1)]) 885 | trainib <- as.matrix(traini[,(3*nn+2):(4*nn+1)]) 886 | 887 | nr <- nrow(traini) 888 | dscore <- .C("elom_c", 889 | as.integer(np), as.integer(nr), as.integer(nn), as.integer(t(trainip) - 1), 890 | as.double(t(trainib)), as.double(crats), dscore = double(np))$dscore 891 | 892 | if(!is.function(kfac)) { 893 | crats <- crats + kfac * dscore 894 | } 895 | else { 896 | crats <- crats + kfac(crats, ngames, ...) * dscore 897 | } 898 | trainipl <- as.integer(trainip) 899 | ngames <- ngames + tabulate(trainipl, np) 900 | for(k in 1:length(npord)) { 901 | tmp <- get(paste0("n",npord[k])) + tabulate(trainip[trainir == k] , np) 902 | assign(paste0("n",npord[k]), tmp) 903 | } 904 | 905 | playi <- unique(trainipl) 906 | nlag[ngames!=0] <- nlag[ngames!=0] + 1 907 | nlag[playi] <- 0 908 | 909 | if(history) { 910 | histry[,i,1] <- crats 911 | histry[,i,2] <- ngames 912 | histry[,i,3] <- nlag 913 | } 914 | } 915 | 916 | if(!history) histry <- NULL 917 | player <- suppressWarnings(as.numeric(names(c(crats,orats)))) 918 | if (any(is.na(player))) player <- names(c(crats,orats)) 919 | dfout <- data.frame(Player=player, Rating=c(crats,orats), Games=c(ngames,ongames), stringsAsFactors = FALSE) 920 | for(k in 1:length(npord)) { 921 | dfout <- cbind(dfout, c(get(paste0("n",npord[k])), get(paste0("on",npord[k])))) 922 | } 923 | dfout <- cbind(dfout, Lag=c(nlag,olag)) 924 | colnames(dfout) <- c("Player","Rating","Games",npord,"Lag") 925 | 926 | if(sort) dfout <- dfout[order(dfout$Rating,decreasing=TRUE),] else dfout <- dfout[order(dfout$Player),] 927 | row.names(dfout) <- 1:nrow(dfout) 928 | 929 | lout <- list(ratings = dfout, history = histry, nn=nn, exact=exact, kfac=kfac, type = "EloM") 930 | class(lout) <- "rating" 931 | lout 932 | } 933 | 934 | # could add metrics for multiplayer 935 | 936 | "metrics" <- function(act, pred, cap = c(0.01,0.99), which = 1:3, na.rm = TRUE, 937 | sort = TRUE, digits = 3, scale = TRUE) 938 | { 939 | if(!is.numeric(pred)) stop("'pred' must be numeric") 940 | if(!is.numeric(act)) stop("'act' must be numeric") 941 | pred <- as.matrix(pred) 942 | np <- ncol(pred); nr <- nrow(pred) 943 | mets <- matrix(NA, ncol=3, nrow=np, 944 | dimnames=list(colnames(pred),c("bdev","mse","mae"))) 945 | for(i in 1:np) { 946 | predc <- pmax.int(pmin.int(pred[,i], cap[2]), cap[1]) 947 | mets[i,1] <- -mean(act*log(predc) + (1-act)*log(1-predc), na.rm = na.rm) 948 | if(scale) mets[i,1] <- mets[i,1]/(-mean(act*log(0.5) + (1-act)*log(0.5), na.rm = na.rm)) 949 | mets[i,2] <- sqrt(mean((pred[,i]-act)^2, na.rm = na.rm)) 950 | if(scale) mets[i,2] <- mets[i,2]/sqrt(mean((0.5-act)^2, na.rm = na.rm)) 951 | mets[i,3] <- mean(abs(pred[,i]-act), na.rm = na.rm) 952 | if(scale) mets[i,3] <- mets[i,3]/mean(abs(0.5-act), na.rm = na.rm) 953 | } 954 | mets <- 100*mets[,which] 955 | if(sort && is.matrix(mets)) mets <- mets[order(mets[,1]),] 956 | round(drop(mets), digits) 957 | } 958 | 959 | "kfide" <- function(rating, games, elite = NULL, kv = c(10,15,30)) 960 | { 961 | if(any(is.na(rating))) stop("missing values in 'ratings' vector") 962 | if(any(is.na(games))) stop("missing values in 'games' vector") 963 | if(length(rating) != length(games)) 964 | stop("lengths of 'ratings' and 'games' must be the same") 965 | kfac <- rep(NA, length(rating)) 966 | if(is.null(elite)) elite <- (rating >= 2400) else elite <- as.logical(elite) 967 | kfac[!elite & games < 30] <- kv[3] 968 | kfac[!elite & games >= 30] <- kv[2] 969 | kfac[elite] <- kv[1] 970 | if(any(is.na(kfac))) stop("missing values in K factor") 971 | kfac 972 | } 973 | 974 | "krating" <- function(rating, games, elite = NULL, rv = 2300, kv = c(32,26)) 975 | { 976 | if(any(is.na(rating))) stop("missing values in 'ratings' vector") 977 | if(any(is.na(games))) stop("missing values in 'games' vector") 978 | if(length(rating) != length(games)) 979 | stop("lengths of 'ratings' and 'games' must be the same") 980 | if(length(rv) != (length(kv)-1)) 981 | stop("length of 'kv' must be one more than 'gv'") 982 | 983 | rv <- c(-Inf, rv, Inf) 984 | rind <- as.numeric(cut(rating, rv)) 985 | kfac <- kv[rind] 986 | if(any(is.na(kfac))) stop("missing values in K factor") 987 | kfac 988 | } 989 | 990 | "kgames" <- function(rating, games, elite = NULL, gv = 30, kv = c(32,26)) 991 | { 992 | if(any(is.na(rating))) stop("missing values in 'ratings' vector") 993 | if(any(is.na(games))) stop("missing values in 'games' vector") 994 | if(length(rating) != length(games)) 995 | stop("lengths of 'ratings' and 'games' must be the same") 996 | if(length(gv) != (length(kv)-1)) 997 | stop("length of 'kv' must be one more than 'gv'") 998 | 999 | gv <- c(-Inf, gv, Inf) 1000 | gind <- as.numeric(cut(games, gv)) 1001 | kfac <- kv[gind] 1002 | if(any(is.na(kfac))) stop("missing values in K factor") 1003 | kfac 1004 | } 1005 | 1006 | "kriichi" <- function(rating, games, gv = 400, kv = 0.2) 1007 | { 1008 | if(any(is.na(rating))) stop("missing values in 'ratings' vector") 1009 | if(any(is.na(games))) stop("missing values in 'games' vector") 1010 | if(length(rating) != length(games)) 1011 | stop("lengths of 'ratings' and 'games' must be the same") 1012 | if(length(gv) != 1) 1013 | stop("'gv' must be a single number") 1014 | if(length(kv) != 1) 1015 | stop("'kv' must be a single number") 1016 | 1017 | kfac <- 1 - (1-kv)*games/gv 1018 | kfac[games >= gv] <- kv 1019 | if(any(is.na(kfac))) stop("missing values in K factor") 1020 | kfac 1021 | } 1022 | 1023 | "print.rating" <- function(x, cols = 1:ncol(x$ratings), digits = 0, ...) 1024 | { 1025 | rdf <- x$ratings 1026 | rdf$Rating <- round(rdf$Rating, digits) 1027 | if(x$type == "Glicko" || x$type == "Glicko-2" || x$type == "Stephenson") 1028 | rdf$Deviation <- round(rdf$Deviation, digits+2) 1029 | if(x$type == "Glicko-2") 1030 | rdf$Volatility <- round(rdf$Volatility, digits+4) 1031 | np <- nrow(rdf) 1032 | if(x$type != "EloM") { 1033 | ng <- round(sum(rdf$Games)/2) 1034 | cat(paste("\n",x$type," Ratings For ",np," Players Playing ",ng," Games\n\n", sep="")) 1035 | } else if(x$exact) { 1036 | ng <- round(sum(rdf$Games)/x$nn) 1037 | cat(paste("\n",x$type," Ratings For ",np," Players Playing ",ng," Games\n\n", sep="")) 1038 | } else { 1039 | cat(paste("\n",x$type," Ratings For ",np," Players\n\n", sep="")) 1040 | } 1041 | 1042 | print(rdf[1:(min(1000,np)),cols,drop=FALSE]) 1043 | if(np > 1000) cat("\nOutput Tructated To First 1000 Players \n") 1044 | cat("\n") 1045 | invisible(0) 1046 | } 1047 | 1048 | "summary.rating" <- function(object, ...) 1049 | { 1050 | obj <- object$ratings 1051 | obj$Games <- factor(obj$Games) 1052 | obj$Lag <- factor(obj$Lag) 1053 | summary(obj) 1054 | } 1055 | 1056 | "predict.rating" <- function(object, newdata, tng=15, trat=NULL, gamma=30, 1057 | thresh, placing = FALSE, ...) 1058 | { 1059 | if(missing(newdata) || nrow(newdata) == 0) 1060 | stop("'newdata' must be non-missing and have non-zero rows") 1061 | obj <- object$ratings 1062 | 1063 | fun_trat <- function(vec) { 1064 | vec[is.na(vec)] <- trat[1] 1065 | return(vec) 1066 | } 1067 | 1068 | if(object$type != "EloM") { 1069 | wmat <- match(newdata[[2]], obj$Player) 1070 | bmat <- match(newdata[[3]], obj$Player) 1071 | qv <- log(10)/400; qip3 <- 3*(qv/pi)^2 1072 | } else { 1073 | np <- (ncol(newdata)-1L) %/% 2L 1074 | for(i in 1:np) { 1075 | assign(paste0("mat",i), match(newdata[[i+1]], obj$Player)) 1076 | } 1077 | } 1078 | 1079 | if(!is.null(trat)) { 1080 | if(object$type == "Elo" && length(trat) != 1) 1081 | stop("'trat' must be vector of length one") 1082 | if(object$type == "EloM" && length(trat) != 1) 1083 | stop("'trat' must be vector of length one") 1084 | if(object$type != "Elo" && object$type != "EloM" && length(trat) != 2) 1085 | stop("'trat' must be vector of length two") 1086 | } 1087 | 1088 | if(!is.null(trat)) obj$Rating[obj$Games < tng] <- trat[1] 1089 | else is.na(obj$Rating[obj$Games < tng]) <- TRUE 1090 | if(object$type != "Elo" && object$type != "EloM") { 1091 | if(!is.null(trat)) obj$Deviation[obj$Games < tng] <- trat[2] 1092 | else is.na(obj$Deviation[obj$Games < tng]) <- TRUE 1093 | } 1094 | 1095 | if(object$type != "EloM") { 1096 | wrat <- obj$Rating[wmat]; brat <- obj$Rating[bmat] 1097 | if(!is.null(trat)) wrat[is.na(wrat)] <- trat[1] 1098 | if(!is.null(trat)) brat[is.na(brat)] <- trat[1] 1099 | } else { 1100 | rats <- matrix(NA, nrow = nrow(newdata), ncol = np) 1101 | for(i in 1:np) { 1102 | assign(paste0("rat",i), obj$Rating[get(paste0("mat",i))]) 1103 | if(!is.null(trat)) { 1104 | assign(paste0("rat",i), fun_trat(get(paste0("rat",i)))) 1105 | } 1106 | rats[,i] <- get(paste0("rat",i)) 1107 | } 1108 | } 1109 | 1110 | if(object$type != "Elo" && object$type != "EloM") 1111 | { 1112 | wdev <- obj$Deviation[wmat]; bdev <- obj$Deviation[bmat] 1113 | if(!is.null(trat)) wdev[is.na(wdev)] <- trat[2] 1114 | if(!is.null(trat)) bdev[is.na(bdev)] <- trat[2] 1115 | } 1116 | 1117 | if(object$type == "Elo") 1118 | preds <- 1/(1+10^((brat-wrat-gamma)/400)) 1119 | if(object$type != "Elo" && object$type != "EloM") { 1120 | vec <- 1/sqrt(1 + qip3*(wdev^2 + bdev^2)) 1121 | preds <- 1/(1+10^(vec * (brat-wrat-gamma)/400)) 1122 | } 1123 | if(object$type == "EloM") { 1124 | preds <- (rats - rowMeans(rats, na.rm = TRUE))/40 1125 | } 1126 | 1127 | if(!missing(thresh) && object$type != "EloM") 1128 | preds <- as.numeric(preds >= thresh) 1129 | if(placing && object$type == "EloM") 1130 | preds <- t(apply(-preds, 1, rank, na.last = "keep", ties.method = "min")) 1131 | 1132 | return(preds) 1133 | } 1134 | 1135 | "hist.rating" <- function(x, which = "Rating", tng=15, history = FALSE, log = FALSE, 1136 | xlab = which, main = paste(x$type," Ratings System"), density=FALSE, add=FALSE, ...) 1137 | { 1138 | if(!history) { 1139 | obj <- x$ratings 1140 | obj <- obj[obj$Games >= tng,] 1141 | obj <- obj[[which]] 1142 | if(log) obj <- log(obj+1) 1143 | if(density) { 1144 | if(add) lines(density(obj), xlab=xlab, main=main, ...) 1145 | else plot(density(obj), xlab=xlab, main=main, ...) 1146 | } else hist(obj, xlab=xlab, main=main, ...) 1147 | } else { 1148 | if(is.null(x$history)) stop("Need Full History For Plotting") 1149 | obj <- x$history[,,which] 1150 | ngm <- x$history[,,"Games"] 1151 | nt <- ncol(obj) 1152 | old <- par(ask = TRUE) 1153 | for(i in 1:nt) { 1154 | ngi <- (ngm[,i] >= tng) 1155 | if(all(!ngi)) next 1156 | if(density) { 1157 | if(add) lines(density(obj[ngi,i]), xlab=xlab, main=main, ...) 1158 | else plot(density(obj[ngi,i]), xlab=xlab, main=main, ...) 1159 | } else hist(obj[ngi,i], xlab=xlab, main=main, ...) 1160 | } 1161 | par(old) 1162 | } 1163 | invisible(obj) 1164 | } 1165 | 1166 | "plot.rating" <- function(x, which = "Rating", players = NULL, t0 = 1, tv = NULL, 1167 | npl = 10, random = FALSE, xlab = "Time Period", ylab = paste(x$type," Ratings"), 1168 | main = paste(x$type," Ratings System"), inflation = FALSE, add=FALSE, ...) 1169 | { 1170 | if(is.null(x$history)) stop("Need Full History For Plotting") 1171 | dmh <- dim(x$history) 1172 | np <- dmh[1] 1173 | if(length(t0) == 2) { 1174 | nt <- t0[2] 1175 | t0 <- t0[1] 1176 | } else nt <- dmh[2] 1177 | if(nt > dmh[2] || nt==1) stop("Not enough history available") 1178 | obj <- x$history[,t0:nt,which] 1179 | ngm <- x$history[,t0:nt,"Games"] 1180 | if(is.null(tv)) tv <- t0:nt 1181 | if(inflation == TRUE) { 1182 | obj <- x$history[,t0:nt,"Rating"] 1183 | objG <- x$history[,t0:nt,"Games"] 1184 | objL <- x$history[,t0:nt,"Lag"] 1185 | is.na(obj) <- (objL > 11 | objG < 25) 1186 | obj <- apply(obj, 2, function(x) mean(sort(x, decreasing = TRUE)[1:npl])) 1187 | if(!add) plot(tv, obj, type="l", xlab=xlab, ylab=ylab, main=main, ...) 1188 | else lines(tv, obj, ...) 1189 | return(invisible(0)) 1190 | } 1191 | if(!is.null(players)) { 1192 | obj <- t(as.matrix(obj[as.character(players),])) 1193 | matplot(tv, obj, type="l", xlab=xlab, ylab=ylab, main=main, add=add, ...) 1194 | } else { 1195 | if(!random) players <- order(ngm[,1],decreasing=TRUE)[1:npl] 1196 | else players <- sample(1:npl, 10) 1197 | obj <- t(as.matrix(obj[players,])) 1198 | matplot(tv, obj, type="l", xlab=xlab, ylab=ylab, main=main, add=add, ...) 1199 | } 1200 | invisible(0) 1201 | } 1202 | 1203 | 1204 | -------------------------------------------------------------------------------- /build/vignette.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/PlayerRatings/3229f664b5a5d0f882406d3acb42d7bc94a931c7/build/vignette.rds -------------------------------------------------------------------------------- /data/aflodds.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/PlayerRatings/3229f664b5a5d0f882406d3acb42d7bc94a931c7/data/aflodds.rda -------------------------------------------------------------------------------- /data/riichi.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/PlayerRatings/3229f664b5a5d0f882406d3acb42d7bc94a931c7/data/riichi.rda -------------------------------------------------------------------------------- /inst/doc/AFLRatings.R: -------------------------------------------------------------------------------- 1 | ### R code from vignette source 'AFLRatings.Rnw' 2 | 3 | ################################################### 4 | ### code chunk number 1: AFLRatings.Rnw:43-49 5 | ################################################### 6 | library(PlayerRatings) 7 | afl <- aflodds[,c(2,3,4,7)] 8 | train <- afl[afl$Week < 100,] 9 | test <- afl[afl$Week >= 100 & afl$Week < 150,] 10 | valid <- afl[afl$Week >= 150,] 11 | head(train,12) 12 | 13 | 14 | ################################################### 15 | ### code chunk number 2: AFLRatings.Rnw:54-56 16 | ################################################### 17 | sobj <- steph(train[train$Week==1,]) 18 | for(i in 2:80) sobj <- steph(train[train$Week==i,], sobj$ratings) 19 | 20 | 21 | ################################################### 22 | ### code chunk number 3: AFLRatings.Rnw:61-63 23 | ################################################### 24 | sobj <- steph(train, history = TRUE) 25 | sobj 26 | 27 | 28 | ################################################### 29 | ### code chunk number 4: stabilize 30 | ################################################### 31 | plot(sobj, npl=16) 32 | abline(v=c(27,55),lty=2,lwd=2,col="grey") 33 | text(c(14,42),c(2500,2500),c("2009","2010"),cex=1.5) 34 | 35 | 36 | ################################################### 37 | ### code chunk number 5: AFLRatings.Rnw:78-79 38 | ################################################### 39 | plot(sobj, npl=16) 40 | abline(v=c(27,55),lty=2,lwd=2,col="grey") 41 | text(c(14,42),c(2500,2500),c("2009","2010"),cex=1.5) 42 | 43 | 44 | ################################################### 45 | ### code chunk number 6: AFLRatings.Rnw:89-92 46 | ################################################### 47 | test1 <- test[test$Week==min(test$Week),] 48 | pred <- predict(sobj, test1, trat = c(1900,300), thresh = 0.5) 49 | cbind(test1, Predict = pred) 50 | 51 | 52 | ################################################### 53 | ### code chunk number 7: AFLRatings.Rnw:97-109 54 | ################################################### 55 | sobj <- steph(train, init = c(2200,300), cval = 8, 56 | hval = 8, lambda = 5) 57 | pred <- NULL 58 | for(i in unique(test$Week)) { 59 | testi <- test[test$Week == i,] 60 | predi <- predict(sobj, testi, trat = c(1900,300), gamma = 30, 61 | thresh = 0.5) 62 | pred <- c(pred, predi) 63 | sobj <- steph(testi, sobj$ratings, init = c(2200,300), cval = 8, 64 | hval = 8, lambda = 5) 65 | } 66 | table(Result=test$Score, Predictions=pred) 67 | 68 | 69 | ################################################### 70 | ### code chunk number 8: AFLRatings.Rnw:116-123 71 | ################################################### 72 | trav <- function(dat) { 73 | teams <- sort(unique(afl$HomeTeam)) 74 | locs <- c("Ade","Bri","Mel","Mel","Mel","Per","Gel","Bri","Syd", 75 | "Mel","Mel","Mel","Ade","Mel","Mel","Syd","Per","Mel") 76 | (locs[factor(dat$HomeTeam,levels=teams)] 77 | != locs[factor(dat$AwayTeam,levels=teams)]) 78 | } 79 | 80 | 81 | ################################################### 82 | ### code chunk number 9: AFLRatings.Rnw:128-144 83 | ################################################### 84 | st0 <- data.frame(Player=sort(unique(train$HomeTeam)), Rating=2200, 85 | Deviation=300, stringsAsFactors=FALSE) 86 | sobj <- steph(train, st0, init = c(1900,300), cval = 8, 87 | hval = 8, lambda = 5) 88 | pred <- NULL 89 | for(i in unique(test$Week)) { 90 | testi <- test[test$Week == i,] 91 | predi <- predict(sobj, testi, trat = c(1900,300), 92 | gamma = 30*trav(testi), thresh = 0.5) 93 | pred <- c(pred, predi) 94 | sobj <- steph(testi, sobj$ratings, init = c(1900,300), cval = 8, 95 | hval = 8, lambda = 5) 96 | } 97 | rp <- table(Result=test$Score, Predictions=pred) 98 | rp 99 | round(100*(rp[1,2]+rp[nrow(rp),1])/sum(rp), 2) 100 | 101 | 102 | ################################################### 103 | ### code chunk number 10: AFLRatings.Rnw:149-166 104 | ################################################### 105 | st0 <- data.frame(Player=sort(unique(train$HomeTeam)), Rating=2200, 106 | Deviation=300, stringsAsFactors=FALSE) 107 | sobj <- steph(rbind(train,test), st0, init = c(1900,300), cval = 8, 108 | hval = 8, lambda = 5) 109 | pred <- NULL 110 | for(i in unique(valid$Week)) { 111 | testi <- valid[valid$Week == i,] 112 | predi <- predict(sobj, testi, trat = c(1900,300), 113 | gamma = 30*trav(testi), thresh = 0.5) 114 | pred <- c(pred, predi) 115 | sobj <- steph(testi, sobj$ratings, init = c(1900,300), cval = 8, 116 | hval = 8, lambda = 5) 117 | } 118 | rp <- table(Result=valid$Score, Predictions=pred) 119 | rp 120 | round(100*(rp[1,2]+rp[nrow(rp),1])/sum(rp), 2) 121 | sobj 122 | 123 | 124 | ################################################### 125 | ### code chunk number 11: AFLRatings.Rnw:173-176 126 | ################################################### 127 | sobj <- steph(rbind(train,test,valid), st0, init = c(1900,300), cval = 8, 128 | hval = 8, lambda = 5, history = TRUE) 129 | p1 <- sobj$ratings[1:8,1]; p2 <- sobj$ratings[9:16,1] 130 | 131 | 132 | ################################################### 133 | ### code chunk number 12: ratings1 134 | ################################################### 135 | plot(sobj, t0 = 40, players = p1, ylim = c(2050,2350),lwd = 2) 136 | abline(v=c(55,83),lty=2,lwd=2,col="grey") 137 | legend(70,2160,p1,lty=1:5,col=1:6,lwd=3,cex=0.8) 138 | text(c(47,70,90),rep(2320,3),c("2010","2011","2012"),cex=1.5) 139 | 140 | 141 | ################################################### 142 | ### code chunk number 13: ratings2 143 | ################################################### 144 | plot(sobj, t0 = 40, players = p2, ylim = c(2050,2350),lwd = 2) 145 | abline(v=c(55,83),lty=2,lwd=2,col="grey") 146 | legend(68,2350,p2,lty=1:5,col=1:6,lwd=3,cex=0.8) 147 | text(c(47,70,90),rep(2070,3),c("2010","2011","2012"),cex=1.5) 148 | 149 | 150 | ################################################### 151 | ### code chunk number 14: AFLRatings.Rnw:193-194 152 | ################################################### 153 | plot(sobj, t0 = 40, players = p1, ylim = c(2050,2350),lwd = 2) 154 | abline(v=c(55,83),lty=2,lwd=2,col="grey") 155 | legend(70,2160,p1,lty=1:5,col=1:6,lwd=3,cex=0.8) 156 | text(c(47,70,90),rep(2320,3),c("2010","2011","2012"),cex=1.5) 157 | 158 | 159 | ################################################### 160 | ### code chunk number 15: AFLRatings.Rnw:203-204 161 | ################################################### 162 | plot(sobj, t0 = 40, players = p2, ylim = c(2050,2350),lwd = 2) 163 | abline(v=c(55,83),lty=2,lwd=2,col="grey") 164 | legend(68,2350,p2,lty=1:5,col=1:6,lwd=3,cex=0.8) 165 | text(c(47,70,90),rep(2070,3),c("2010","2011","2012"),cex=1.5) 166 | 167 | 168 | ################################################### 169 | ### code chunk number 16: AFLRatings.Rnw:215-222 170 | ################################################### 171 | library(PlayerRatings) 172 | afl <- aflodds[,c(2,3,4,7)] 173 | train <- afl[afl$Week < 100,] 174 | test <- afl[afl$Week >= 100 & afl$Week < 150,] 175 | valid <- afl[afl$Week >= 150,] 176 | sobj <- glicko2(train, history = TRUE) 177 | print(sobj, cols=1:4) 178 | 179 | 180 | ################################################### 181 | ### code chunk number 17: stabilize2 182 | ################################################### 183 | plot(sobj, npl=16) 184 | abline(v=c(27,55),lty=2,lwd=2,col="grey") 185 | text(c(14,42),c(2500,2500),c("2009","2010"),cex=1.5) 186 | 187 | 188 | ################################################### 189 | ### code chunk number 18: AFLRatings.Rnw:235-236 190 | ################################################### 191 | plot(sobj, npl=16) 192 | abline(v=c(27,55),lty=2,lwd=2,col="grey") 193 | text(c(14,42),c(2500,2500),c("2009","2010"),cex=1.5) 194 | 195 | 196 | ################################################### 197 | ### code chunk number 19: AFLRatings.Rnw:246-261 198 | ################################################### 199 | st0 <- data.frame(Player=sort(unique(train$HomeTeam)), Rating=2200, 200 | Deviation=300, Volatility=0.15, stringsAsFactors=FALSE) 201 | sobj <- glicko2(train, st0, init = c(1900,300,0.15), tau = 1.2) 202 | pred <- NULL 203 | for(i in unique(test$Week)) { 204 | testi <- test[test$Week == i,] 205 | predi <- predict(sobj, testi, trat = c(1900,300), 206 | gamma = 30*trav(testi), thresh = 0.5) 207 | pred <- c(pred, predi) 208 | sobj <- glicko2(testi, sobj$ratings, init = c(1900,300,0.15), 209 | tau = 1.2) 210 | } 211 | rp <- table(Result=test$Score, Predictions=pred) 212 | rp 213 | round(100*(rp[1,2]+rp[nrow(rp),1])/sum(rp), 2) 214 | 215 | 216 | -------------------------------------------------------------------------------- /inst/doc/AFLRatings.Rnw: -------------------------------------------------------------------------------- 1 | \documentclass[12pt,a4paper]{article} 2 | \usepackage{amsmath,amssymb} 3 | 4 | \pagestyle{plain} 5 | \setlength{\parindent}{0in} 6 | \setlength{\parskip}{1.5ex plus 0.5ex minus 0.5ex} 7 | \setlength{\oddsidemargin}{0in} 8 | \setlength{\topmargin}{-0.5in} 9 | \setlength{\textwidth}{6.3in} 10 | \setlength{\textheight}{9.8in} 11 | 12 | %\VignetteIndexEntry{Rating Football Teams} 13 | 14 | \begin{document} 15 | \SweaveOpts{concordance=TRUE} 16 | 17 | \title{Rating Australian Rules Football Teams \\ With The \textbf{PlayerRatings} Package \\ \vspace*{0.5cm} \large Now updated for glicko-2} 18 | \author{Alec Stephenson} 19 | \maketitle 20 | 21 | \begin{center} 22 | \LARGE 23 | \textbf{Summary} \\ 24 | \end{center} 25 | \normalsize 26 | \vspace{0.5cm} 27 | This vignette presents a short example of the use of \textbf{PlayerRatings}, using a small dataset to demonstrate rating Australian football teams and predicting the winner of future games based on those ratings. A second more detailed analysis using a large dataset of chess matches is given in the file \texttt{doc/ChessRatings.pdf}. 28 | \normalsize 29 | 30 | \section{Functions and Datasets} 31 | 32 | The \textbf{PlayerRatings} package implements iterative updating systems for rating players (i.e.\ individuals or teams) in two-player games. These methods are fast and surprisingly accurate. The idea is that given games played in time period $t$, the ratings can be updated using only the information about the status of the system at the end of time period $t-1$, so that all games before $t$ can be ignored. The ratings can then be used to predict the result of games at time $t+1$. Comparing the game predictions with the actual results gives a method of evaluating the accuracy of the ratings as an estimate of a player's true skill. 33 | 34 | The result of a game is considered to be a value in the interval $[0,1]$. For the football data, we only use information on wins, draws and losses, so a value of one represents a win for the home team, a value of zero represents a win for the away team, and a value of one half represents a draw. The status of the system is typically a small number of features, such as player ratings, player rating (standard) deviations, and the number of games played. The more computationally intensive (and often slightly more accurate) approaches of using the full gaming history via a time decay weighting function is not considered here. 35 | 36 | The functions \texttt{elo} and \texttt{fide} implement the Elo system (Elo, 1978), the functions \texttt{glicko} and \texttt{glicko2} implement the Glicko (Glickman, 1999) and Glicko-2 (Glickman, 2001) systems, and the function \texttt{steph} implements the Stephenson system as detailed in the appendix of \texttt{doc/ChessRatings.pdf}. We only use the \texttt{steph} and \texttt{glicko2} functions in this vignette. 37 | 38 | 39 | \section{Modelling and Prediction} 40 | 41 | The \texttt{aflodds} dataset includes the results of Australian football games played from 26th March 2009 until 24th June 2012. We use the 2009 and 2010 games for our training data, the 2011 games for our test data and the 2012 data (which represents only the first half of the 2012 season) as our validation data. For the game results we will only use win, loss or draw information, ignoring the size of any victory. 42 | 43 | <<>>= 44 | library(PlayerRatings) 45 | afl <- aflodds[,c(2,3,4,7)] 46 | train <- afl[afl$Week < 100,] 47 | test <- afl[afl$Week >= 100 & afl$Week < 150,] 48 | valid <- afl[afl$Week >= 150,] 49 | head(train,12) 50 | @ 51 | 52 | All modelling functions in the package can be used to update player ratings over several time periods, or over individual time periods. For example, the following code uses \texttt{steph} to iteratively update the team ratings once every round in the \texttt{train} data. The state of the system is contained in the \texttt{ratings} component of the returned object, which can then be passed back into the function for subsequent updates. 53 | 54 | <<>>= 55 | sobj <- steph(train[train$Week==1,]) 56 | for(i in 2:80) sobj <- steph(train[train$Week==i,], sobj$ratings) 57 | @ 58 | 59 | More simply, we can call the function once to perform the same task. 60 | 61 | <<>>= 62 | sobj <- steph(train, history = TRUE) 63 | sobj 64 | @ 65 | 66 | In either case, the resulting \texttt{sobj} object is identical. It gives the current (i.e.\ the end of 2010) rating for all 16 teams, and also gives a deviation parameter, which is an assessment of the accuracy of the rating. The deviation parameters are similar since all teams play roughly the same number of games. The lag parameter shows the number of weeks since each team has played; the two zero lags are associated with the two teams that played in the grand final of 2010. Unusually, the grand final of 2010 was drawn and was replayed the following week, and therefore no team has a lag value of one. 67 | 68 | The following code uses the \texttt{plot} function to plot traces of the ratings across the 2009-2010 period for all 16 teams. We begin the period with no information, and therefore initially the rating changes are large. As the system learns about the teams the rating traces begin to stabilize. Flat lines denote the periods of inactivity that occur for teams not involved in the finals series, which takes place following the regular season. 69 | 70 | <>= 71 | plot(sobj, npl=16) 72 | abline(v=c(27,55),lty=2,lwd=2,col="grey") 73 | text(c(14,42),c(2500,2500),c("2009","2010"),cex=1.5) 74 | @ 75 | 76 | \begin{figure}[ht] 77 | \begin{center} 78 | <>= 79 | <> 80 | @ 81 | \end{center} 82 | \vspace{-1cm} 83 | \caption{Plots of ratings traces for the 16 teams during 2009-2010, beginning with no information.} 84 | \label{inffig} 85 | \end{figure} 86 | 87 | The \texttt{predict} function gives predictions of future matches, expressed as a value in the interval $[0,1]$. In this vignette we use the argument \texttt{thresh} to instead produce binary values representing the predicted winner. This example predicts the results of round one in 2011 and compares the predictions to the actual outcomes. A new team was introduced in 2011; by default the prediction of matches involving new teams (less than 15 games) will be missing. We override this behaviour using the argument \texttt{trat}, which sets the parameters of new teams\footnote{The new team did not play in round one and therefore in this particular case the argument makes no difference to the output.} for prediction purposes. 88 | 89 | <<>>= 90 | test1 <- test[test$Week==min(test$Week),] 91 | pred <- predict(sobj, test1, trat = c(1900,300), thresh = 0.5) 92 | cbind(test1, Predict = pred) 93 | @ 94 | 95 | We now combine the above code snippets in order to predict all games in the test set. We first run the system on the training data, and then loop through each round of the test set. 96 | 97 | <<>>= 98 | sobj <- steph(train, init = c(2200,300), cval = 8, 99 | hval = 8, lambda = 5) 100 | pred <- NULL 101 | for(i in unique(test$Week)) { 102 | testi <- test[test$Week == i,] 103 | predi <- predict(sobj, testi, trat = c(1900,300), gamma = 30, 104 | thresh = 0.5) 105 | pred <- c(pred, predi) 106 | sobj <- steph(testi, sobj$ratings, init = c(2200,300), cval = 8, 107 | hval = 8, lambda = 5) 108 | } 109 | table(Result=test$Score, Predictions=pred) 110 | @ 111 | 112 | We now make a couple of adjustments to the above. Firstly, we better account for new teams entering the system. In Australian football, the two new teams introduced in 2011 and 2012 were largely made up of younger players and were expected to me much weaker. To account for this, we create our own starting object \texttt{st0} to initialize the system, allowing the \texttt{init} argument to apply to the new teams only, and hence allowing us to account for this expected weakness. 113 | 114 | Secondly, we focus on the \texttt{gamma} argument to \texttt{predict}, which accounts for the home team advantage. In Australian football teams are often from the same location or share the same ground, in which case the home advantage is likely to be zero. We can account for this, with a little work, by passing a vector to gamma. We first define a helper function which returns a logical vector to indicate whether the away team is travelling. 115 | 116 | <<>>= 117 | trav <- function(dat) { 118 | teams <- sort(unique(afl$HomeTeam)) 119 | locs <- c("Ade","Bri","Mel","Mel","Mel","Per","Gel","Bri","Syd", 120 | "Mel","Mel","Mel","Ade","Mel","Mel","Syd","Per","Mel") 121 | (locs[factor(dat$HomeTeam,levels=teams)] 122 | != locs[factor(dat$AwayTeam,levels=teams)]) 123 | } 124 | @ 125 | 126 | In the code below, we multiply our original \texttt{gamma} value by \texttt{trav(testi)} in order to specify a zero home advantage when the away team does not travel. 127 | 128 | <<>>= 129 | st0 <- data.frame(Player=sort(unique(train$HomeTeam)), Rating=2200, 130 | Deviation=300, stringsAsFactors=FALSE) 131 | sobj <- steph(train, st0, init = c(1900,300), cval = 8, 132 | hval = 8, lambda = 5) 133 | pred <- NULL 134 | for(i in unique(test$Week)) { 135 | testi <- test[test$Week == i,] 136 | predi <- predict(sobj, testi, trat = c(1900,300), 137 | gamma = 30*trav(testi), thresh = 0.5) 138 | pred <- c(pred, predi) 139 | sobj <- steph(testi, sobj$ratings, init = c(1900,300), cval = 8, 140 | hval = 8, lambda = 5) 141 | } 142 | rp <- table(Result=test$Score, Predictions=pred) 143 | rp 144 | round(100*(rp[1,2]+rp[nrow(rp),1])/sum(rp), 2) 145 | @ 146 | 147 | The mis-classification percentage as given above (which counts draws as correctly classified) may be overly optimistic since we roughly chose our parameters to be optimal over the test data\footnote{The football dataset is much smaller and contains far less information than the chess dataset, and therefore different parameter combinations often yield similar predictions.}. We therefore combine our training and test datasets to predict results on the validation data using the same parameters. In other words, we use the 2009-2011 results to predict the results in the first half of the 2012 season. 148 | 149 | <<>>= 150 | st0 <- data.frame(Player=sort(unique(train$HomeTeam)), Rating=2200, 151 | Deviation=300, stringsAsFactors=FALSE) 152 | sobj <- steph(rbind(train,test), st0, init = c(1900,300), cval = 8, 153 | hval = 8, lambda = 5) 154 | pred <- NULL 155 | for(i in unique(valid$Week)) { 156 | testi <- valid[valid$Week == i,] 157 | predi <- predict(sobj, testi, trat = c(1900,300), 158 | gamma = 30*trav(testi), thresh = 0.5) 159 | pred <- c(pred, predi) 160 | sobj <- steph(testi, sobj$ratings, init = c(1900,300), cval = 8, 161 | hval = 8, lambda = 5) 162 | } 163 | rp <- table(Result=valid$Score, Predictions=pred) 164 | rp 165 | round(100*(rp[1,2]+rp[nrow(rp),1])/sum(rp), 2) 166 | sobj 167 | @ 168 | 169 | The code takes less than one-tenth of one second on my machine. We correctly predict $72.2\%$ of the game results in the first half of 2012. We show above the current ratings as of 24th June 2012. We see that the two new teams (the lowest rated) have larger deviation values because they have played less games. 170 | 171 | We finish by showing plots of the rating traces for the 16 established teams from mid-2010 to mid-2012. The rating trace plots require the full history of the process to be retained, which requires re-running the updates with the argument \texttt{history} set to \texttt{TRUE}. The current top eight teams are plotted first, with the remainder plotted second. 172 | 173 | <<>>= 174 | sobj <- steph(rbind(train,test,valid), st0, init = c(1900,300), cval = 8, 175 | hval = 8, lambda = 5, history = TRUE) 176 | p1 <- sobj$ratings[1:8,1]; p2 <- sobj$ratings[9:16,1] 177 | @ 178 | <>= 179 | plot(sobj, t0 = 40, players = p1, ylim = c(2050,2350),lwd = 2) 180 | abline(v=c(55,83),lty=2,lwd=2,col="grey") 181 | legend(70,2160,p1,lty=1:5,col=1:6,lwd=3,cex=0.8) 182 | text(c(47,70,90),rep(2320,3),c("2010","2011","2012"),cex=1.5) 183 | @ 184 | <>= 185 | plot(sobj, t0 = 40, players = p2, ylim = c(2050,2350),lwd = 2) 186 | abline(v=c(55,83),lty=2,lwd=2,col="grey") 187 | legend(68,2350,p2,lty=1:5,col=1:6,lwd=3,cex=0.8) 188 | text(c(47,70,90),rep(2070,3),c("2010","2011","2012"),cex=1.5) 189 | @ 190 | 191 | \begin{figure}[ht] 192 | \begin{center} 193 | <>= 194 | <> 195 | @ 196 | \end{center} 197 | \vspace{-1cm} 198 | \caption{Plots of ratings traces for eight football teams from mid-2010 to mid-2012.} 199 | \end{figure} 200 | 201 | \begin{figure}[ht] 202 | \begin{center} 203 | <>= 204 | <> 205 | @ 206 | \end{center} 207 | \vspace{-1cm} 208 | \caption{Plots of ratings traces for eight football teams during mid-2010 to mid-2012.} 209 | \end{figure} 210 | 211 | \section{Glicko-2 Ratings} 212 | 213 | In the Glicko-2 rating system each team has a volatility parameter in addition to a deviation parameter. The calculation of the volatility requires a single parameter function optimization for each team within each time period, and will therefore be slower than Glicko or Stephenson. 214 | 215 | <<>>= 216 | library(PlayerRatings) 217 | afl <- aflodds[,c(2,3,4,7)] 218 | train <- afl[afl$Week < 100,] 219 | test <- afl[afl$Week >= 100 & afl$Week < 150,] 220 | valid <- afl[afl$Week >= 150,] 221 | sobj <- glicko2(train, history = TRUE) 222 | print(sobj, cols=1:4) 223 | @ 224 | 225 | The traces of the ratings for the Glicko-2 system are given below. Glicko-2 is primarily designed for situations where a player (or team) plays several games in any single time period. This is not the case here, and therefore the volatilities show little movement. This can be seen from plotting the volatility traces using \texttt{plot(sobj, npl=16, which = "Volatility")}. 226 | 227 | <>= 228 | plot(sobj, npl=16) 229 | abline(v=c(27,55),lty=2,lwd=2,col="grey") 230 | text(c(14,42),c(2500,2500),c("2009","2010"),cex=1.5) 231 | @ 232 | 233 | \begin{figure}[ht] 234 | \begin{center} 235 | <>= 236 | <> 237 | @ 238 | \end{center} 239 | \vspace{-1cm} 240 | \caption{Plots of Glicko-2 ratings traces for the 16 teams during 2009-2010, beginning with no information.} 241 | \label{inffig2} 242 | \end{figure} 243 | 244 | The code in the previous section can be replicated for Glicko-2, with only minor alterations. The volatility parameter must be included in the status object and in the \texttt{init} vector. The Glicko-2 system parameter is called \texttt{tau}; smaller values of \texttt{tau} restrict the movement of the volatilities. If \texttt{tau} is zero or negative, then the volatilities are never updated. The code below provides an example. 245 | 246 | <<>>= 247 | st0 <- data.frame(Player=sort(unique(train$HomeTeam)), Rating=2200, 248 | Deviation=300, Volatility=0.15, stringsAsFactors=FALSE) 249 | sobj <- glicko2(train, st0, init = c(1900,300,0.15), tau = 1.2) 250 | pred <- NULL 251 | for(i in unique(test$Week)) { 252 | testi <- test[test$Week == i,] 253 | predi <- predict(sobj, testi, trat = c(1900,300), 254 | gamma = 30*trav(testi), thresh = 0.5) 255 | pred <- c(pred, predi) 256 | sobj <- glicko2(testi, sobj$ratings, init = c(1900,300,0.15), 257 | tau = 1.2) 258 | } 259 | rp <- table(Result=test$Score, Predictions=pred) 260 | rp 261 | round(100*(rp[1,2]+rp[nrow(rp),1])/sum(rp), 2) 262 | @ 263 | 264 | \section*{Bibliography} 265 | 266 | Elo, A. (1978) \textit{The Rating of Chessplayers, Past and Present}. Arco. ISBN 0-668-04721-6 267 | 268 | Glickman, M. E. (1999) Parameter estimation in large dynamic paired comparison experiments. \textit{Applied Statistics}, \textbf{48}, 377--394. 269 | 270 | Glickman, M.E. (2001) Dynamic paired comparison models with stochastic variances. \textit{Journal of Applied Statistics}, \textbf{28}, 673-689. 271 | 272 | \end{document} 273 | 274 | 275 | 276 | 277 | 278 | 279 | -------------------------------------------------------------------------------- /inst/doc/AFLRatings.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/PlayerRatings/3229f664b5a5d0f882406d3acb42d7bc94a931c7/inst/doc/AFLRatings.pdf -------------------------------------------------------------------------------- /inst/doc/ChessRatings.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/PlayerRatings/3229f664b5a5d0f882406d3acb42d7bc94a931c7/inst/doc/ChessRatings.pdf -------------------------------------------------------------------------------- /inst/doc/MathSport.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/PlayerRatings/3229f664b5a5d0f882406d3acb42d7bc94a931c7/inst/doc/MathSport.pdf -------------------------------------------------------------------------------- /inst/doc/MathSport.txt: -------------------------------------------------------------------------------- 1 | \documentclass[12pt,a4paper]{article} 2 | \usepackage{amsmath,amssymb,graphicx} 3 | %\usepackage{mathtools} 4 | 5 | \pagestyle{plain} 6 | \setlength{\parindent}{0in} 7 | \setlength{\parskip}{1.5ex plus 0.5ex minus 0.5ex} 8 | \setlength{\oddsidemargin}{0in} 9 | \setlength{\topmargin}{-0.5in} 10 | \setlength{\textwidth}{6.3in} 11 | \setlength{\textheight}{9.8in} 12 | 13 | \begin{document} 14 | 15 | \title{A Comparison of the Predictive Performance of Dynamic Updating Methods for 16 | Chess Player Ratings} 17 | \author{Alec G.\ Stephenson \\ \small CSIRO Mathematics, Informatics and Statistics, \\ 18 | \small Clayton South, Victoria, Australia.} 19 | 20 | \maketitle 21 | \begin{center} 22 | \small 23 | \textit{The 11th Australasian Conference on Mathematics and Computers in Sport} \\ 24 | \textit{17--19 September 2012, Melbourne, Australia} 25 | \end{center} 26 | 27 | \begin{center} 28 | \LARGE 29 | \textbf{Summary} \\ 30 | \end{center} 31 | \normalsize 32 | \vspace{0.5cm} 33 | This article uses a large dataset to analyze and compare the predictive performance of different dynamic updating methods for rating chess players. The analysis shows that the simpler Elo system is outperformed by both the Glicko and Stephenson systems. The analysis also suggests that the K factors used in the current FIDE (World Chess Federation) implementation of the Elo system are smaller than what would be needed for optimum predictive performance. 34 | \normalsize 35 | 36 | \section{Introduction} 37 | 38 | Updating systems for rating players (i.e.\ individuals or teams) in two-player games are fast and surprisingly accurate. The idea is that given games played in time period $t$, the ratings can be updated using only the information about the status of the system at the end of time period $t-1$, so that all games before $t$ can be ignored. The ratings can then be used to predict the result of games at time $t+1$. Comparing the game predictions with the actual results gives a method of evaluating the accuracy of the ratings as an estimate of a player's true skill. There exists more computationally intensive approaches that use the full gaming history via a time decay weighting function (e.g.\ Sismanis, 2010). These can be more accurate but will not be considered here. 39 | 40 | The result of a game is considered to be a value in the interval $[0,1]$. For chess data, a value of $1$ represents a win for white, a value of $0$ represents a win for black, and a value of $0.5$ represents a draw. The status of the system is typically a small number of features, such as player ratings, player rating standard deviations, and the number of games played. We focus on comparing variations of three basic systems. In increasing order of mathematical complexity, these systems are: the Elo system (Elo, 1978), the Glicko system (Glickman, 1999), and the Stephenson system (Stephenson \& Sonas, 2012), which is currently under consideration by FIDE for implementation as the official system for chess player ratings. 41 | 42 | The ratings systems considered here derive from statistical models for paired comparisons (e.g.\ Bradley \& Terry, 1952). Preference of one item over another can be related to player preference in two-player games. Draws can be treated as one win and one loss, with each game given a one-half weighting. It is possible to explicitly account for draws using an additional parameter (Davidson, 1970), but this approach does not work well for the dataset considered here. Similar findings for chess data were reported by Joe (1990). 43 | 44 | \section{Methods} 45 | 46 | The dataset we analyze here contains approximately one million games played over the eight year period $1999-2007$ by $41\,077$ chess players. Each record contains the white and black player identifiers, the game result and the month in which the game was played. The dataset was constructed by Jeff Sonas of Chessmetrics and is used with his kind permission. During this period the reporting of individual game results was not required and therefore it contains only a proportion of all games played by FIDE rated players. We also have a dataset of FIDE ratings for $14\,118$ chess players active at January 1999 which we use to initialize the ratings systems. It may not be an ideal initialization for all systems, but gives a fair method of comparison between them. 47 | 48 | We use games from the period $1999-2005$ as training data, games from $2006$ as validation data, and games from $2007$ as test data. Parameter estimation is performed by minimizing the binomial deviance criterion on predictions for the $2006$ data, and we evaluate the performance of different systems using the same criterion applied to the unseen $2007$ data. For a single game, the binomial deviance criterion is defined by 49 | \begin{equation} 50 | -[S\log(P) + (1-S)\log(1-P)] 51 | \end{equation} 52 | where $S \in \{0,0.5,1\}$ is the actual game result and $P \in [0,1]$ is the predicted score. The minimum value is obtained at $P=S$ but predictions of $P=0$ or $P=1$ should only be made in cases of 100\% certainty, otherwise an infinite value could be obtained. For drawn games the minimum value occurs at $P=0.5$ and is therefore equal to $-\log(0.5) \approx 0.69$. For the overall criterion, we present the mean of this value across all predicted games, multiplied by a scaling factor of $100$. 53 | 54 | The basic form of the Elo system tracks only the rating $R$ for each player at each time period. After each period, the rating of a player is updated using $R := R + K\sum_i(S_i - E_i)$ where the sum is over the games that the player plays within the period, $S_i$ is the actual game result and $E_i$ is the expected game result which is based on the current rating of the player and his or her opponent. The Elo system has one global parameter $K$ which is known as the $K$ factor. The Elo system therefore tracks one system parameter (i.e.\ the rating) and has one global parameter (i.e.\ the $K$ factor). In practice the system is often applied by making the $K$ factor dependent on additional information on the player such as the player ratings or number of games played, requiring the use of additional system parameters. 55 | 56 | The Glicko and Stephenson systems track both the player rating and the player deviation, which is a measure of the accuracy of the player rating as an estimate of true skill. The mathematical details are more complex and are not given here. The Glicko system has a global parameter $c$ which controls the changes in the deviations through time. In the Stephenson system this role is shared by the global parameters $c$ and $h$. In addition there is a global neighbourhood parameter $\lambda$ which shrinks the rating of each player to that of his or her opponents, and a global activity parameter $b$ which gives a small per game bonus irrespective of the result. The $b$ parameter improves predictive performance but also creates rating inflation over time. For chess data this is undesirable and so we do not consider it further. 57 | 58 | \section{Results} 59 | 60 | The initialization of ratings is an important issue for all systems. It is useful to distinguish between two forms of initialization: the initialization for players who are already known to exist in the player pool before any updates are performed, and the initialization for players who subsequently enter the system during the updates. For the first case, we use FIDE ratings for $14\,118$ chess players active at January 1999 as our initial ratings. For the second case, we set the rating of any new player to the value $2200$. For the Glicko and Stephenson methods, the initial deviation parameters are set to the value $300$ for all players. Another issue in chess is that white typically has a small advantage over black, and this can be modelled using a white advantage parameter $\gamma$. It is not important to account for this when constructing the player ratings, but it is important to account for it when predicting subsequent games. We use $\gamma = 30$ for this purpose, which seems roughly optimal across all systems. 61 | 62 | \begin{table}[t] 63 | \begin{center} 64 | \begin{tabular}{l|l|ll} 65 | Method & Parameters & Valid ($2006$) & Test ($2007$) \\ \hline 66 | Stephenson & $c=h=9$, $\lambda=2$ & 61.46 & 62.31 \\ 67 | Glicko & $c=15$ & 61.54 & 62.40 \\ 68 | EloG ($G < 30$) & $K = 32 \mbox{ or } 26$ & 61.64 & 62.40 \\ 69 | EloR ($R < 2300$) & $K = 32 \mbox{ or } 26$ & 61.63 & 62.41 \\ 70 | EloP ($G < 30$, $R^* < 2400$) & $K = 30 \mbox{ or } 20 \mbox{ or } 15 $ & 61.69 & 62.42 \\ 71 | Elo & $K = 27$ & 61.71 & 62.47 \\ 72 | EloF ($G < 30$, $R^* < 2400$) & $K = 30 \mbox{ or } 15 \mbox{ or } 10 $ & 61.96 & 62.64 \\ 73 | \end{tabular} 74 | \caption{A comparison of predictive performance of dynamic updating methods for chess player ratings. 75 | The Valid and Test columns give the binomial deviance values for predictions on the validation and test data. 76 | Details of the different methods are given in the text.} 77 | \label{results} 78 | \end{center} 79 | \end{table} 80 | 81 | Table \ref{results} presents the key findings of this article, showing the predictive performance of seven different methods. The seven methods include five different variations of the Elo system, using different methodologies for determining the K Factor. The Elo system is fairly simple, and so several implementations introduce additional complexity by allowing the K factor to depend on additional features. The basic Elo method uses a constant K factor. The methods EloG and EloR use two different K factors. For EloG the K factors are specified according to whether the number of games $G$ played by the player is less than $30$, while for EloR they are specified according to whether the player rating $R$ is less than $2300$. Lower K factors are typically associated with more experienced or stronger players, so that their ratings have less tendency to change. 82 | 83 | The EloF method applies the FIDE implementation of the K factor. This currently specifies $K=30$ for players with $G < 30$ games, $K=15$ for players with $G \geq 30$ and whose highest rating ever obtained $R^*$ is less than $2400$, and finally $K=10$ for $G \geq 30$ and $R^* \geq 2400$. Although EloF uses exactly the same K factors as FIDE, it does not implement the initialization system of FIDE, which would require knowledge of the type of tournaments that correspond to the games. Despite this, it can still be used to gain some insight into the FIDE ratings implementation. For all methods other than EloF, the parameters have been chosen to be optimal on validation data predictions (i.e.\ predictions on games in $2006$). The EloP method is the same as the EloF method but where K factor values are optimized on the validation data. 84 | 85 | The final column of Table \ref{results} shows the predictive accuracy of each method on the unseen test data (i.e.\ predictions on games in $2007$, using data from the period $1999-2006$). We see that Stephenson is best, followed by Glicko, then EloG, EloR, EloP, Elo and EloF. The EloF method has the worst predictive performance. The EloP method outperforms EloF because increasing the K factor by 5 for players who have played 30 or more games gives an increase in predictive accuracy. 86 | 87 | The top ten players on 1st January 2007 identified by the Stephenson method are shown in Table \ref{steprat}, selecting from the set of players who have played at least 25 games and have played at least once in 2006. The latter condition removes Garry Kasparov. Figure \ref{tfigt} shows the ratings traced over the period $2001-2006$ for these same ten players. Note that all rating systems discussed here are relative rating systems, and therefore the mean of the overall ratings is dependent on the method of initialization used in any particular application. The ranking of both the Glicko (not shown) and Stephenson methods are similar, but for Stephenson the absolute ratings are lower. This is a direct consequence of the neighbourhood parameter $\lambda$, which draws player's ratings towards their opponents and therefore prevents spread at both the high and low ends. The histogram of the Stephenson ratings (not shown) is slightly more peaked than for Glicko ratings, and acts more like Elo in the upper tail. When $\lambda = 0$, the overall distributions of Glicko and Stephenson ratings are virtually identical, and therefore $\lambda$ narrows the spread. 88 | 89 | \begin{table}[t] 90 | \begin{center} 91 | \begin{tabular}{l|llll} 92 | & Name & Rating & Deviation & Lag \\ \hline 93 | 1 & Anand, Viswanathan & 2759 & 65 & 2 \\ 94 | 2 & Kramnik, Vladimir & 2757 & 61 & 2 \\ 95 | 3 & Topalov, Veselin & 2756 & 59 & 2 \\ 96 | 4 & Morozevich, Alexander & 2755 & 60 & 0 \\ 97 | 5 & Ponomariov, Ruslan & 2751 & 60 & 1 \\ 98 | 6 & Mamedyarov, Shakhriyar & 2750 & 59 & 1 \\ 99 | 7 & Leko, Peter & 2741 & 61 & 1 \\ 100 | 8 & Aronian, Levon & 2737 & 60 & 1 \\ 101 | 9 & Radjabov, Teimour & 2731 & 61 & 2 \\ 102 | 10 & Polgar, Judit & 2728 & 65 & 2 \\ 103 | \end{tabular} 104 | \caption{Stephenson ratings and rating deviations for the top ten chess players, 1st January 2007. The lag value represents 105 | the number of months since the player last played a game.} 106 | \label{steprat} 107 | \end{center} 108 | \end{table} 109 | 110 | The role of the $c$ parameter in Glicko is to increase the rating deviations over time. In Stephenson this role is shared by $c$ and $h$, and so $c$ is typically lower in Stephenson than the corresponding parameter in Glicko. This feature appears to make little or no difference to the overall distribution of the ratings, but typically improves predictive performance. 111 | 112 | 113 | \begin{figure}[ht] 114 | \begin{center} 115 | \includegraphics{ratings-020} 116 | \end{center} 117 | \vspace{-1cm} 118 | \caption{Ratings over time for the `current' (1st Jan 2007) top ten players.} 119 | \label{tfigt} 120 | \end{figure} 121 | 122 | \section{Discussion} 123 | 124 | The Elo system has been in existence for more than $50$ years. These results suggest that for chess data, rather than attempting to add complexity to the K factor, a better approach for predictive performance is to use systems such as Glicko or Stephenson, which use a rating deviation value to explicitly model the accuracy of the ratings as an estimate of skill. Under these systems, players who have not played many games may have very high or very low ratings with large rating deviation values. It therefore makes sense to consider a rating official only when the player has played some fixed number of games or when the rating deviation decreases below some fixed threshold. 125 | 126 | \section*{Bibliography} 127 | 128 | Bradley, R. A. and Terry, M. E. (1952) The rank analysis of incomplete block designs: I, The method of paired 129 | comparisons. \textit{Biometrika}, \textbf{39}, 324--345. 130 | 131 | Davidson, R. R. (1970) On extending the Bradley-Terry model to accommodate ties in paired comparison experiments. 132 | \textit{J. Am. Statist. Ass.}, \textbf{65}, 317--328. 133 | 134 | Elo, A. (1978) \textit{The Rating of Chessplayers, Past and Present}. Arco. ISBN 0-668-04721-6 135 | 136 | Glickman, M. E. (1999) Parameter estimation in large dynamic paired comparison experiments. \textit{Appl. Statist.}, \textbf{48}, 377--394. 137 | 138 | Joe, H. (1990) Extended use of paired comparison models, with application to chess rankings. \textit{Appl. Statist.}, \textbf{39}, 85--93. 139 | 140 | Sismanis, Y. (2010) How I won the ``Chess Ratings - Elo vs the Rest of the World'' competition. arXiv:1012.4571v1 141 | 142 | Stephenson, A. G. and Sonas, J. (2012) PlayerRatings: Dynamic Updating Methods For Player Ratings Estimation. R package version 1.0-0. 143 | 144 | \end{document} 145 | 146 | 147 | 148 | 149 | 150 | 151 | -------------------------------------------------------------------------------- /inst/doc/glicko.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/PlayerRatings/3229f664b5a5d0f882406d3acb42d7bc94a931c7/inst/doc/glicko.pdf -------------------------------------------------------------------------------- /inst/doc/glicko2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cran/PlayerRatings/3229f664b5a5d0f882406d3acb42d7bc94a931c7/inst/doc/glicko2.pdf -------------------------------------------------------------------------------- /inst/doc/sweave/ChessRatings.Rnw: -------------------------------------------------------------------------------- 1 | \documentclass[12pt,a4paper]{article} 2 | \usepackage{amsmath,amssymb} 3 | 4 | \pagestyle{plain} 5 | \setlength{\parindent}{0in} 6 | \setlength{\parskip}{1.5ex plus 0.5ex minus 0.5ex} 7 | \setlength{\oddsidemargin}{0in} 8 | \setlength{\topmargin}{-0.5in} 9 | \setlength{\textwidth}{6.3in} 10 | \setlength{\textheight}{9.8in} 11 | 12 | \begin{document} 13 | \SweaveOpts{concordance=TRUE} 14 | 15 | \title{Comparing Predictive Performance Of Chess Ratings \\ With The \textbf{PlayerRatings} Package} 16 | \author{Alec Stephenson} 17 | \date{July 24, 2012} 18 | \maketitle 19 | 20 | \begin{center} 21 | \LARGE 22 | \textbf{Summary} \\ 23 | \end{center} 24 | \normalsize 25 | \vspace{0.5cm} 26 | This document presents an example of the use of \textbf{PlayerRatings}, using a large dataset to analyse different methods for rating chess players. The analysis shows that, in terms of predictive performance, the Elo system is outperformed by both the Glicko and Stephenson systems. The analysis also suggests that the K factors used in the current FIDE (World Chess Federation) implementation of the Elo system are smaller than what would be needed for optimum predictive performance. 27 | 28 | This pdf document is located in the file \texttt{doc/ChessRatings.pdf} and the corresponding sweave file is located at \texttt{doc/sweave/ChessRatings.Rnw}. The sweave file can be converted to a latex file by calling \texttt{Sweave(file)}, where \texttt{file} is the filename \texttt{system.file("doc/sweave/ChessRatings.Rnw", package = "PlayerRatings")}. This will run all the code in this document and will therefore download about 20 MB of data. The latex file and corresponding pdf figures will then be located in the working directory. 29 | \normalsize 30 | 31 | \section{Functions and Datasets} 32 | 33 | The \textbf{PlayerRatings} package implements iterative updating systems for rating players (i.e.\ individuals or teams) in two-player games. These methods are fast and surprisingly accurate. The idea is that given games played in time period $t$, the ratings can be updated using only the information about the status of the system at the end of time period $t-1$, so that all games before $t$ can be ignored. The ratings can then be used to predict the result of games at time $t+1$. Comparing the game predictions with the actual results gives a method of evaluating the accuracy of the ratings as an estimate of a player's true skill. 34 | 35 | The result of a game is considered to be a value in the interval $[0,1]$. For the chess data, a value of $1$ represents a win for white, a value of $0$ represents a win for black, and a value of $0.5$ represents a draw. The status of the system is typically a small number of features, such as player ratings, player rating (standard) deviations, and the number of games played. The more computationally intensive (and often slightly more accurate) approaches of using the full gaming history via a time decay weighting function is not considered here. 36 | 37 | The functions \texttt{elo} and \texttt{fide} implement the Elo system (Elo, 1978), the function \texttt{glicko} implements the Glicko system (Glickman, 1999), and the function \texttt{steph} implements the Stephenson system as detailed in the appendix. There are other functions to aid incorporating additional complexity into the K factor of the Elo system, to predict the result of future games, to produce appropriate plots, and to evaluate predictive performance. 38 | 39 | \section{Chess Data Creation} 40 | 41 | The \texttt{chess} dataset contains approximately 1.8 million games played over the eleven year period $1999-2009$ by 54205 chess players. We create the dataset by downloading comma separated value files from the website Chessmetrics. The data was constructed and made publicly available by Jeff Sonas. We will use the first nine years of data. We take training data from the period $1999-2005$, test data from the year $2006$ and validation data from the year $2007$. The three zip files are about 6MB each and may take some time to download on slow internet connections. 42 | 43 | <<>>= 44 | cm <- "http://www.chessmetrics.com/KaggleComp/" 45 | temp <- tempfile() 46 | download.file(paste(cm,"primary_training_part1.zip",sep=""),temp) 47 | chess <- read.csv(unz(temp, "primary_training_part1.csv"))[,2:5] 48 | download.file(paste(cm,"primary_training_part2.zip",sep=""),temp) 49 | chess <- rbind(chess, 50 | read.csv(unz(temp, "primary_training_part2.csv"))[,2:5]) 51 | download.file(paste(cm,"primary_training_part3.zip",sep=""),temp) 52 | chess <- rbind(chess, 53 | read.csv(unz(temp, "primary_training_part3.csv"))[,2:5]) 54 | names(chess) <- c("Month","White","Black","Score") 55 | unlink(temp) 56 | @ 57 | 58 | <<>>= 59 | train <- chess[chess$Month < 84.5,] 60 | trainM <- train$Month 61 | test <- chess[chess$Month > 84.5 & chess$Month < 96.5,] 62 | testS <- test$Score 63 | valid <- chess[chess$Month > 96.5 & chess$Month < 108.5,] 64 | validS <- valid$Score 65 | @ 66 | 67 | The dataset \texttt{cSt} is created below. It contains FIDE ratings for 14118 chess players at January 1999, before the data in the \texttt{chess} dataset were recorded. We will use \texttt{cSt} in the remainder of this document to initialize the system. This is not required, however if the information exists it makes sense to use it. It is not an ideal initialization for all methods, but appears to always work better than initializing every player at fixed values. Other players that subsequently enter the system are initialized according to the argument \texttt{init} of the modelling functions. 68 | 69 | <<>>= 70 | temp <- tempfile() 71 | download.file(paste(cm,"initial_ratings.csv",sep=""),temp) 72 | cSt <- read.csv(temp) 73 | cSt <- data.frame(Player = cSt$Player, Rating = cSt$Rating, 74 | Deviation = 200, Games = cSt$NumGames) 75 | unlink(temp) 76 | @ 77 | 78 | Finally, we download data that identifies players from their identification numbers in the \texttt{chess} dataset. Some names contain non-ASCII characters that may not be read correctly. 79 | 80 | <<>>= 81 | temp <- tempfile() 82 | download.file(paste(cm,"players.csv",sep=""),temp) 83 | chessPlayers <- read.csv(temp, as.is=TRUE) 84 | names(chessPlayers) <- c("Player","Name") 85 | unlink(temp) 86 | @ 87 | 88 | \section{Modelling and Prediction} 89 | 90 | In this section we will demonstrate the features of the \textbf{PlayerRatings} package by comparing the predictive performance of alternative methods applied to the \texttt{chess} dataset. 91 | 92 | All modelling functions in the package can be used to update player ratings over several time periods, or over individual time periods. For example, the following code uses the Elo system to iteratively update the chess ratings once every month for each of the 84 months in the \texttt{train} data. The state of the system is contained in the \texttt{ratings} component of the returned object, which can then be passed back into the function for subsequent updates. 93 | 94 | <<>>= 95 | library(PlayerRatings) 96 | robje1 <- elo(train[trainM==1,], cSt) 97 | for(i in 2:84) robje1 <- elo(train[trainM==i,], robje1$ratings) 98 | @ 99 | 100 | More simply, we can call the function once to perform the same task. 101 | 102 | <<>>= 103 | robje1 <- elo(train, cSt, init=2200, gamma=0, kfac=27) 104 | @ 105 | 106 | The specified parameters are the defaults. The argument \texttt{init} specifies the initial rating for players who are added to the system. The argument \texttt{gamma} can account for the advantage of white, however it appears to have little effect for the chess data. The argument \texttt{kfac} is the K factor, which by default is equal to 27 for all players. The Elo system is fairly simple, and so several implementations introduce additional complexity by allowing the K factor to depend on aspects of the model such as the player rating or the number of games played by the player. The following give examples of this, where \texttt{kfac} is specified using a function that is provided by the package. 107 | 108 | <<>>= 109 | robje2 <- elo(train, cSt, kfac=krating, rv=2300, kv=c(32,26)) 110 | robje3 <- elo(train, cSt, kfac=kgames, gv=30, kv=c(32,26)) 111 | @ 112 | 113 | The \texttt{robje2} object employs a K factor of 26 for players rated above 2300 and a K factor of 32 otherwise. The \texttt{robje3} object employs a K factor of 26 for players who have played more than 30 games and a K factor of 32 otherwise. 114 | 115 | The function \texttt{fide} also implements the Elo system, but uses exactly the same default parameters and K factors as FIDE, and consequently allows a little more flexibility. It does not implement the initialization system of FIDE, which would require knowledge of the tournaments that correspond to the games. Despite this, it can still be used to gain some insight into the FIDE ratings implementation. In the following, we call \texttt{fide} twice: the first with default arguments and the second with the K factor increased by $5$ for players who have played 30 or more games. We also call the functions \texttt{glicko} and \texttt{steph} to implement the Glicko and Stephenson systems respectively. 116 | 117 | <<>>= 118 | robjf1 <- fide(train, cSt) 119 | robjf2 <- fide(train, cSt, kv = c(15,20,30)) 120 | robjg <- glicko(train, cSt, init=c(2200,300), gamma=0, cval=15) 121 | robjs <- steph(train, cSt, init=c(2200,300), gamma=0, cval=9, 122 | hval=9, bval=0, lambda=2) 123 | @ 124 | 125 | The \texttt{steph} implementation was developed by Alec Stephenson in 2012 as a variant of his winning entry in a competition to find the most useful practical chess rating system, organized by Jeff Sonas on Kaggle, a platform for data prediction competitions. The details are given in the appendix as they are not available elsewhere. The \texttt{bval} parameter can be used to give a per game bonus to each player; it typically improves prediction accuracy but it also creates ratings inflation, which may not be desirable. 126 | 127 | The seven objects we have created are S3 objects of class \texttt{"rating"}, with corresponding \texttt{print}, \texttt{summary}, \texttt{predict}, \texttt{plot} and \texttt{hist} methods. The following code uses the \texttt{predict} method in conjunction with the \texttt{metrics} function to compare our seven rating methods by evaluating their predictive performance on the $2006$ test data. The advantage of white must be accounted for when making predictions. The \texttt{predict} function has a white advantage parameter \texttt{gamma} which by default is set to the value $30$, as this seems to be roughly optimal across all systems. 128 | 129 | <<>>= 130 | pre1 <- predict(robje1, test); pre2 <- predict(robje2, test) 131 | pre3 <- predict(robje3, test); prf1 <- predict(robjf1, test) 132 | prf2 <- predict(robjf2, test) 133 | prg <- predict(robjg, test); prs <- predict(robjs, test) 134 | metrics(testS, cbind(pre1,pre2,pre3,prf1,prf2,prg,prs)) 135 | @ 136 | 137 | The \texttt{metrics} function implements three metrics, scaled so that random guessing corresponds to the number $100$. The first is the binomial deviance, which is the most appropriate metric for chess data. Smaller values on all metrics correspond to more accurate predictions. We see that Stephenson is best, followed by Glicko, then Elo (2), Elo (3), FIDE (2) and Elo (1). The FIDE (1) method is a worst because the parameters were not optimized. 138 | 139 | To quantify the comparison, we can say that Stephenson gives a 140 | \begin{equation} 141 | \frac{(89.034-88.668)}{(100-89.034)} = 3.34\% 142 | \end{equation} 143 | improvement over Elo (with a constant K factor of 27) for this dataset under this metric, whereas Glicko gives a $2.31\%$ improvement over Elo, and Elo gives a $3.36\%$ improvement over the FIDE (1) implementation. We also see that FIDE (2) outperforms FIDE (1) because increasing the K factor by $5$ for players who have played 30 or more games gives an increase in predictive performance, with an improvement of $3.71\%$. 144 | 145 | The Elo system has been in existence for more than $50$ years. These results suggest that for the chess data, rather than attempting to add complexity to the K factor, a better approach for predictive performance is to use systems such as Glicko or Stephenson, which use a rating deviation value to explicitly model the accuracy of the ratings as an estimate of skill. Players who have not played many games may have very high or very low ratings with large rating deviation values. It therefore makes sense under these systems to only consider a rating official when the player has played some fixed number of games or when the rating deviation decreases below some fixed threshold. We see from the above that Stephenson improves over the Elo implementation of FIDE by $6.80\%$, and Glicko improves over the Elo implementation of FIDE by $5.74\%$. 146 | 147 | With the exception of Elo (fide), the default parameters of modelling functions have been approximately optimized for predictions on the $2006$ test data. We therefore repeat the process again, combining the training and test data to form a larger training dataset for the period $1999-2006$, and using the completely untouched $2007$ validation data to evaluate performance. 148 | 149 | <<>>= 150 | train <- rbind(train, test) 151 | robje1 <- elo(train, cSt) 152 | robje2 <- elo(train, cSt, kfac=krating) 153 | robje3 <- elo(train, cSt, kfac=kgames) 154 | robjf1 <- fide(train, cSt, history = TRUE) 155 | robjf2 <- fide(train, cSt, kv = c(15,20,30)) 156 | robjg <- glicko(train, cSt, history = TRUE) 157 | robjs <- steph(train, cSt, history = TRUE) 158 | pre1 <- predict(robje1, valid); pre2 <- predict(robje2, valid) 159 | pre3 <- predict(robje3, valid); prf1 <- predict(robjf1, valid) 160 | prf2 <- predict(robjf2, valid) 161 | prg <- predict(robjg, valid); prs <- predict(robjs, valid) 162 | metrics(validS, cbind(pre1,pre2,pre3,prf1,prf2,prg,prs)) 163 | @ 164 | 165 | With this additional data, Stephenson tends to get further ahead of Glicko. Stephenson gives a $2.48\%$ improvement over Elo, while Glicko gives a $1.11\%$ improvement over Elo. 166 | 167 | Each object has a \texttt{ratings} component containing the current status of the updating algorithm, and by default players are listed in order of rating, from highest to lowest. The top ten players from the FIDE (1), Stephenson and Glicko objects can be shown as follows, selecting from the set of players who have played at least 25 games and have played at least once in 2006. The latter condition removes Garry Kasparov. Note that these are all relative rating systems, and therefore the mean of the overall ratings is dependent on the method of initialization used in any particular application. The number of games played is inaccurate here as they were essentially unknown in the initial \texttt{cSt} object. We use the \texttt{chessPlayers} dataset to identify the player names. 168 | 169 | \textbf{Elo Ratings (Jan 2007):} 170 | <<>>= 171 | re <- robjf1$ratings 172 | re <- re[re$Lag <= 11 & re$Games >= 25,-c(4:6,8:10)] 173 | PlayerN <- chessPlayers$Name[re$Player] 174 | row.names(re) <- 1:nrow(re) 175 | head(cbind(PlayerN, round(re,0)), 10) 176 | @ 177 | 178 | \textbf{Glicko Ratings (Jan 2007):} 179 | <<>>= 180 | rg <- robjg$ratings 181 | rg <- rg[rg$Lag <= 11 & rg$Games >= 25,-(5:7)] 182 | PlayerN <- chessPlayers$Name[rg$Player] 183 | row.names(rg) <- 1:nrow(rg) 184 | head(cbind(PlayerN, round(rg,0)), 10) 185 | @ 186 | 187 | \textbf{Stephenson Ratings (Jan 2007):} 188 | <<>>= 189 | rs <- robjs$ratings 190 | rs <- rs[rs$Lag <= 11 & rs$Games >= 25,-(5:7)] 191 | PlayerN <- chessPlayers$Name[rs$Player] 192 | row.names(rs) <- 1:nrow(rs) 193 | top <- head(cbind(PlayerN, round(rs,0)), 10); top 194 | @ 195 | 196 | The ranking of both Glicko and Stephenson methods are similar, but in Stephenson the absolute ratings are lower. This is a direct consequence of the parameter \texttt{lambda}, which draws player's ratings towards their opponents and therefore prevents spread at both the high and low ends. Figure \ref{hfigx} shows this feature of the system, comparing Elo (the FIDE implementation), Glicko and Stephenson. Notice that the Stephenson denisity is more peaked than Glicko, so it acts more like Elo in the upper tail. When \texttt{lambda} is zero, the Glicko and Stephenson densities (not shown) are virtually identical. So \texttt{lambda} narrows the spread. 197 | 198 | For comparison purposes, Table \ref{FIDErat} shows FIDE ratings for the top fifteen players from January 2007 as archived on their website. The top ten players under both Glicko and Stephenson all appear in the top fifteen FIDE ratings table. Note that our implementation of FIDE Elo will not be the same as the actual FIDE ratings because of the different initialization procedures. 199 | 200 | \begin{table} 201 | \begin{center} 202 | \begin{tabular}{l|ll} 203 | & Name & Rating \\ \hline 204 | 1 & Topalov, Veselin & 2783 \\ 205 | 2 & Anand, Viswanathan & 2779 \\ 206 | 3 & Kramnik, Vladimir & 2766 \\ 207 | 4 & Mamedyarov, Shakhriyar & 2754 \\ 208 | 5 & Ivanchuk, Vassily & 2750 \\ 209 | 6 & Leko, Peter & 2749 \\ 210 | 7 & Aronian, Levon & 2744 \\ 211 | 8 & Morozevich, Alexander & 2741 \\ 212 | 9 & Adams, Michael & 2735 \\ 213 | 10 & Gelfand, Boris & 2733 \\ 214 | 11 & Radjabov, Teimour & 2729 \\ 215 | 12 & Svidler, Peter & 2728 \\ 216 | 13 & Polgar, Judit & 2727 \\ 217 | 14 & Ponomariov, Ruslan & 2723 \\ 218 | 15 & Navara, David & 2719 \\ 219 | \end{tabular} 220 | \caption{FIDE ratings for the top fifteen chess players, January 2007.} 221 | \label{FIDErat} 222 | \end{center} 223 | \end{table} 224 | 225 | <>= 226 | hist(robjs, density=TRUE, lwd=3, ylim=c(0,0.004), xlim=c(1800,2800), 227 | main = "Rating System Comparison") 228 | hist(robjg, density=TRUE, lwd=3, lty=2, col=2, add=TRUE) 229 | hist(robjf1, density=TRUE, lwd=3, lty=3, col=3, add=TRUE) 230 | legend(2400,0.003, c("Stephenson","Glicko","Elo"), lty=1:3, 231 | col=1:3, lwd=3, cex=1.1) 232 | @ 233 | 234 | \begin{figure}[ht] 235 | \begin{center} 236 | <>= 237 | <> 238 | @ 239 | \end{center} 240 | \vspace{-1cm} 241 | \caption{A comparison of ratings distributions.} 242 | \label{hfigx} 243 | \end{figure} 244 | 245 | The role of \texttt{cval} in Glicko is to increase the rating deviations over time. In Stephenson this role is shared by \texttt{cval} and \texttt{hval}, and so \texttt{cval} should typically be lower in Stephenson than the corresponding parameter in Glicko. The \texttt{hval} parameter appears to make little or no difference to the overall density of the ratings, but typically improves predictive performance. 246 | 247 | \section{Producing Plots} 248 | 249 | The are two plotting methods for visualizing \texttt{"rating"} objects. The S3 method function \texttt{hist} will plot a histogram or density estimate of the player ratings. It can also plot other features of the current status, selectable by the argument \texttt{which}. If the full history of ratings for each time period is retained in the object, then \texttt{hist} can produce a series of histograms. The following produces (not shown) 96 histograms, one for each month, prompting the user between each display. By default, players are only depicted on histograms if they have played 15 games or more. 250 | 251 | <>= 252 | hist(robjs, history=TRUE, xlim = c(1900,2900)) 253 | @ 254 | 255 | The S3 method function \texttt{plot} can only be used if the full history of ratings has been retained. It plots line traces across time of estimated ratings or other features for a selected set of players. By default, active players are selected, and therefore these players may be more likely to improve than the general population. Figures \ref{tfigx} and \ref{tfigt} are plotted as follows. The first uses a default selection of the most active players in January 2001, whereas the second selects the `current' (i.e.\ at the end of the year 2006) top ten players as identified previously. 256 | 257 | <>= 258 | tv <- seq(2001, 2007, 1/12)[-73] 259 | plot(robjs, t0=25, lwd=2, tv=tv, xlab="Year") 260 | @ 261 | 262 | \begin{figure}[ht] 263 | \begin{center} 264 | <>= 265 | <> 266 | @ 267 | \end{center} 268 | \vspace{-1cm} 269 | \caption{Ratings over time for 10 active players.} 270 | \label{tfigx} 271 | \end{figure} 272 | 273 | <>= 274 | plot(robjs, players = top$Player, t0=25, lwd=2, tv=tv, xlab="Year") 275 | legend(2004, 2630, chessPlayers$Name[top$Player], lty=1:5, 276 | col=1:6, lwd=3, cex=0.9) 277 | @ 278 | 279 | \begin{figure}[ht] 280 | \begin{center} 281 | <>= 282 | <> 283 | @ 284 | \end{center} 285 | \vspace{-1cm} 286 | \caption{Ratings over time for the `current' (Jan 2007) top 10 players.} 287 | \label{tfigt} 288 | \end{figure} 289 | 290 | <>= 291 | <> 292 | <> 293 | @ 294 | 295 | The function \texttt{plot} can also analyse ratings inflation by setting the \texttt{inflation} argument to \texttt{TRUE}. The mean rating of the top \texttt{np} players at any given time point is then plotted. The example below shows the progression in the mean rating for the top 100 players, comparing the FIDE implementation of Elo with Glicko and Stephenson. System initialization was performed in 1999 using FIDE ratings for all systems, and we therefore plot from 2001 to ensure that the systems have had time to stabilize. There does not appear to be any evidence of ratings inflation for the top 100 players in this time period under Elo and Stephenson, but there is some suggestion of ratings inflation for Glicko. 296 | 297 | <>= 298 | tv <- seq(2001,2007,1/12)[-73] 299 | plot(robjs, t0=25, lwd=2, tv=tv, xlab="Year", ylim = c(2630,2690), 300 | inflation=TRUE, np = 100) 301 | plot(robjg, t0=25, lwd=2, tv=tv, lty=2, col=2, inflation=TRUE, 302 | add=TRUE, np = 100) 303 | plot(robjf1, t0=25, lwd=2, tv=tv, lty=3, col=3, inflation=TRUE, 304 | add=TRUE, np = 100) 305 | legend(2001,2690, c("Stephenson","Glicko","Elo"), lty=1:3, 306 | col=1:3, lwd=3, cex=1) 307 | @ 308 | 309 | \begin{figure}[ht] 310 | \begin{center} 311 | <>= 312 | <> 313 | @ 314 | \end{center} 315 | \vspace{-1cm} 316 | \caption{Average ratings over time for top 100 players in any given time period.} 317 | \label{inffig} 318 | \end{figure} 319 | 320 | \section*{Appendix: Stephenson System} 321 | 322 | Suppose that at the beginning of the $i$th month a player has a rating $r$ and a variance $v$. After the $i$th month, these values need to be updated. 323 | 324 | Step 1: Increase the variance of each player using $v = v + ct$ where $c$ is a value to be decided and $t > 0$ is the number of periods since the player last competed. 325 | 326 | Step 2: Let $(r^*,v^*)$ be the player's rating and variance at the beginning of the $(i+1)$th month. Then, with $q=\ln(10)/400$, the updating formulas are given as follows, where $(r_j,v_j)$ for $j=1,\dots,m$ are the ratings and variances at the beginning of month $i$ of the player's opponents in the $m > 0$ games that the player plays in that month, and where $s_j$ are the scores in those games. Let $\bar{r}=(\sum_j r_j)/m$ and let $w_j$ be a colour indicator with $w_j=1$ if the the player is white, $w_j=-1$ if the player is black, and $w_j=0$ if this is unknown. 327 | 328 | \begin{eqnarray*} 329 | v^* &=& \left(\frac{1}{v + hm} + d\right)^{-1} \\ 330 | r^* &=& r + qv^*\sum_{j=1}^m k_j(s_j - e_j + b) + \lambda(\bar{r}-r) 331 | \end{eqnarray*} 332 | where 333 | \begin{eqnarray*} 334 | k_j &=& \frac{1}{\sqrt{1+3q^2v_j/\pi^2}} \\ 335 | e_j &=& \frac{1}{1+10^{-k_j(r-r_j+\gamma w_j)/400}} \\ 336 | d &=& q^2 \sum_{j=1}^m k_j^2e_j(1-e_j) 337 | \end{eqnarray*} 338 | 339 | \subsection*{Prediction} 340 | 341 | If player $a$ playing white with current rating vector $(r_a,v_a)$ has a game against player $b$ playing black with current rating vector $(r_b,v_b)$, and $\gamma$ is a white advantage parameter, then the predicted score is given by 342 | \begin{equation*} 343 | e_{ab} = \frac{1}{1+10^{-k_{ab}(r_a-r_b+\gamma)/400}}, 344 | \end{equation*} 345 | where 346 | \begin{equation*} 347 | k_{ab} = \frac{1}{\sqrt{1+3q^2(v_a+v_b)/\pi^2}}. 348 | \end{equation*} 349 | 350 | Note that the $\gamma$ used in prediction is not necessarily the same as the $\gamma$ used for constructing the ratings. For chess data, accounting for the advantage of white is important in prediction but appears to be of little importance for ratings construction. 351 | 352 | \subsection*{R Function} 353 | 354 | In the R function \texttt{steph}, the argument \texttt{gamma} is $\gamma$, \texttt{cval} is $\sqrt{c}$, \texttt{hval} is $\sqrt{h}$, \texttt{bval} is $100b$ and \texttt{lambda} is $100\lambda$. We use the same terminology as Glicko, so the player rating deviations are the standard deviations of the ratings given by $\sqrt{v}$. In Step 1 above we impose a ceiling of $350$ on the deviations. This is not necessary but is done to ensure that Stephenson contains Glicko as a special case, so that \texttt{steph} reproduces \texttt{glicko} upon setting $h=b=\lambda=0$. The R function \texttt{predict} has an argument \texttt{gamma} so that different $\gamma$ values can be used for constructing the ratings and for obtaining predictions. 355 | 356 | \section*{Bibliography} 357 | 358 | Elo, A. (1978) \textit{The Rating of Chessplayers, Past and Present}. Arco. ISBN 0-668-04721-6 359 | 360 | Glickman, M. E. (1999) Parameter estimation in large dynamic paired comparison experiments. \textit{Applied Statistics}, \textbf{48}, 377--394. 361 | 362 | \end{document} 363 | 364 | 365 | 366 | 367 | 368 | 369 | -------------------------------------------------------------------------------- /man/aflodds.Rd: -------------------------------------------------------------------------------- 1 | \name{aflodds} 2 | \docType{data} 3 | \alias{aflodds} 4 | \title{Australian Football Game Results and Odds} 5 | \usage{aflodds} 6 | \description{ 7 | The \code{aflodds} data frame has 675 rows and 9 variables. It 8 | shows the results and betting odds for 675 Australian football 9 | games played by 18 teams from 26th March 2009 until 24th June 10 | 2012. 11 | } 12 | \format{ 13 | This data frame contains the following columns: 14 | \describe{ 15 | \item{Date}{A date object showing the date of the game.} 16 | \item{Week}{The number of weeks since 25th March 2009.} 17 | \item{HomeTeam}{The home team name.} 18 | \item{AwayTeam}{The away team name.} 19 | \item{HomeScore}{The home team score.} 20 | \item{AwayScore}{The home team score.} 21 | \item{Score}{A numeric vector giving the value one, zero or one 22 | half for a home win, an away win or a draw respectively.} 23 | \item{HomeOdds}{The best decimal odds offered for the home team. 24 | This is missing for some earlier games.} 25 | \item{AwayOdds}{The best decimal odds offered for the away team. 26 | This is missing for some earlier games.} 27 | } 28 | } 29 | \source{ 30 | Wikipedia and www.oddsportal.com. 31 | } 32 | \keyword{datasets} 33 | 34 | -------------------------------------------------------------------------------- /man/elo.Rd: -------------------------------------------------------------------------------- 1 | \name{elo} 2 | \alias{elo} 3 | \alias{print.rating} 4 | \alias{summary.rating} 5 | \title{The Elo Rating System} 6 | \description{ 7 | Implements the Elo rating system for estimating the relative 8 | skill level of players in two-player games such as chess. 9 | } 10 | \usage{ 11 | elo(x, status = NULL, init = 2200, gamma = 0, kfac = 27, 12 | history = FALSE, sort = TRUE, \dots) 13 | } 14 | \arguments{ 15 | \item{x}{A data frame containing four variables: (1) a numeric 16 | vector denoting the time period in which the game took place 17 | (2) a numeric or character identifier for player one (3) 18 | a numeric or character identifier for player two and (4) 19 | the result of the game expressed as a number, typically 20 | equal to one for a player one win, zero for a player two 21 | win and one half for a draw.} 22 | \item{status}{A data frame with the current status of the 23 | system. If not \code{NULL}, this needs to be a data frame 24 | in the form of the \code{ratings} component of the returned 25 | list, containing variables named \code{Player}, \code{Rating}, 26 | and optionally \code{Games}, \code{Win}, \code{Draw}, 27 | \code{Loss} and \code{Lag}, which are set to zero if not given.} 28 | \item{init}{The rating at which to initialize a new player not 29 | appearing in \code{status}. Must be a single number. If 30 | different initializations for different players are required, 31 | this can be done using \code{status}.} 32 | \item{gamma}{A player one advantage parameter; either a single 33 | value or a numeric vector equal to the number of rows in 34 | \code{x}. Positive values favour player one, while negative 35 | values favour player two. This could represent the advantage 36 | of playing at home, or the advantage of playing white for chess. 37 | Note that this is not passed to \code{\link{predict.rating}}, 38 | which has its own \code{gamma} parameter.} 39 | \item{kfac}{The K factor parameter. Can be a single number or 40 | a vectorized function of two arguments, the first being the 41 | ratings and the second being the number of games played. See 42 | \code{\link{kfide}}, \code{\link{kgames}} and 43 | \code{\link{krating}} for examples.} 44 | \item{history}{If \code{TRUE} returns the entire history for each 45 | period in the component \code{history} of the returned list.} 46 | \item{sort}{If \code{TRUE} sort the results by rating (highest 47 | to lowest). If \code{FALSE} sort the results by player.} 48 | \item{\dots}{Passed to the function \code{kfac}.} 49 | } 50 | \details{ 51 | The Elo rating system is a simple method for evaluating the skill 52 | of players. It has been used since around 1960 and is still 53 | employed in various settings. Although the basic form uses only 54 | the ratings, additional complexity is commonly introduced 55 | by adding a player one advantage parameter and by using different 56 | K factors. A player one advantage parameter has been added to the 57 | original definition in the reference. A player one advantage 58 | parameter is also used for prediction purposes in 59 | \code{\link{predict.rating}}. 60 | 61 | This implementation has a simple initialization, and allows the 62 | K factor to depend on both the ratings and the number of games 63 | played. Default values are roughly optimized the chess data 64 | analyzed in the file doc/ChessRatings.pdf, using the binomial 65 | deviance criterion and considering only constant K factors. 66 | See the function \code{\link{fide}} for a different 67 | implementation. 68 | } 69 | \value{ 70 | A list object of class \code{"rating"} with the following 71 | components 72 | 73 | \item{ratings}{A data frame of the results at the end of the 74 | final time period. The variables are self explanatory except 75 | for \code{Lag}, which represents the number of time periods 76 | since the player last played a game. This is equal to zero 77 | for players who played in the latest time period, and is 78 | also zero for players who have not yet played any games.} 79 | \item{history}{A three dimensional array, or \code{NULL} if 80 | \code{history} is \code{FALSE}. The row dimension is the 81 | players, the column dimension is the time periods. 82 | The third dimension gives different parameters.} 83 | \item{gamma}{The player one advantage parameter.} 84 | \item{kfac}{The K factor or K factor function.} 85 | \item{type}{The character string \code{"Elo"}.} 86 | } 87 | \references{ 88 | Elo, Arpad (1978) 89 | The Rating of Chessplayers, Past and Present. 90 | Arco. ISBN 0-668-04721-6. 91 | } 92 | \seealso{ 93 | \code{\link{fide}}, \code{\link{glicko}}, \code{\link{kfide}} 94 | } 95 | \examples{ 96 | afl <- aflodds[,c(2,3,4,7)] 97 | robj <- elo(afl) 98 | robj 99 | 100 | robj <- elo(afl[afl$Week==1,]) 101 | for(i in 2:max(afl$Week)) robj <- elo(afl[afl$Week==i,], robj$ratings) 102 | robj 103 | } 104 | \keyword{models} 105 | 106 | 107 | 108 | 109 | -------------------------------------------------------------------------------- /man/elom.Rd: -------------------------------------------------------------------------------- 1 | \name{elom} 2 | \alias{elom} 3 | \title{Multi-player Elo Based Rating System} 4 | \description{ 5 | Implements the Elo based rating system for for multi-player games 6 | where the result is a placing or a score. This includes zero-sum 7 | games such as poker and mahjong. The default arguments used here 8 | are those used by Tenhou for riichi mahjong. 9 | } 10 | \usage{ 11 | elom(x, nn = 4, exact = TRUE, base = c(30,10,-10,-30), status = NULL, 12 | init = 1500, kfac = kriichi, history = FALSE, sort = TRUE, \dots, 13 | placing = FALSE) 14 | } 15 | \arguments{ 16 | \item{x}{A data frame containing \code{2nn+1} variables, where 17 | \code{nn} is the number of players in a single game: (col \code{1}) 18 | a numeric vector denoting the time period in which the game 19 | took place, (cols \code{2} to \code{nn+1}) numeric or character 20 | identifiers for each of the \code{nn} players, (cols \code{nn+2} 21 | to \code{2nn+1}) the result of the game expressed as a number, 22 | typically a score for each player (e.g. the number of remaining 23 | chips in poker). Negative numbers are allowed. 24 | Alternatively, the result can be a placing (e.g. 1 for 25 | first place, 2 for second place), in which case the \code{placing} 26 | argument MUST be set to \code{TRUE}. Placings must be integers: in the 27 | event of a tie, multiple players can be given the same placing.} 28 | \item{nn}{Number of players in a single game. If the number of players 29 | varies, then this argument should be set to the maximum number of 30 | players in any game, and the \code{exact} argument should be set to 31 | \code{FALSE}. Unused player identifiers in \code{x} must then 32 | be set to the missing value \code{NA}. The game score for \code{NA} 33 | player identifiers is ignored and therefore can also be set to 34 | \code{NA}.} 35 | \item{exact}{If \code{TRUE} (the default), then every game always has 36 | exactly \code{nn} players. If \code{TRUE}, then \code{x} cannot have 37 | missing values.} 38 | \item{base}{The base values used for the rating. Can be a numeric 39 | vector of length equal to \code{nn}, a numeric matrix with \code{nrow(x)} 40 | rows and \code{nn} columns, or a vectorized function of 41 | the game score. If a numeric vector, then the person with the highest 42 | score gets \code{base[1]}, the person with the second highest score 43 | gets \code{base[2]}, and so on. In the event of a tie on the game score, 44 | tied players are given the largest available \code{base} value. For 45 | games with less than \code{nn} players, see Details. If \code{base} is 46 | a matrix, then the ith row is used for the ith game in \code{x}. If 47 | \code{base} is a vectorized function, then each player gets 48 | the result of the function applied to the game score. In Riichi 49 | mahjong, where players start with 25000 points, a typical example 50 | might be \code{function(x) (x-25000)/250}.} 51 | \item{status}{A data frame with the current status of the 52 | system. If not \code{NULL}, this needs to be a data frame 53 | in the form of the \code{ratings} component of the returned 54 | list, containing variables named \code{Player}, \code{Rating}, 55 | and optionally \code{Games}, \code{1st}, \code{2nd}, 56 | \code{3rd} and so on, and finally \code{Lag}, which 57 | are all set to zero if not given.} 58 | \item{init}{The rating at which to initialize a new player not 59 | appearing in \code{status}. Must be a single number. If 60 | different initializations for different players are required, 61 | this can be done using \code{status}.} 62 | \item{kfac}{The K factor parameter. Can be a single number or 63 | a vectorized function of two arguments, the first being the 64 | ratings and the second being the number of games played. See 65 | \code{\link{kriichi}} for an example.} 66 | \item{history}{If \code{TRUE} returns the entire history for each 67 | period in the component \code{history} of the returned list.} 68 | \item{sort}{If \code{TRUE} sort the results by rating (highest 69 | to lowest). If \code{FALSE} sort the results by player.} 70 | \item{\dots}{Passed to the function \code{kfac}.} 71 | \item{placing}{If the results are given as placings (e.g. 1 for 72 | first place, 2 for second place) then this argument MUST be set 73 | to \code{TRUE}, otherwise the placings will be interpreted 74 | as game scores.} 75 | } 76 | \details{ 77 | For multi-player games there is no player one advantage parameter 78 | (e.g. a home advantage in football or a white advantage in chess). 79 | 80 | If the sum of the vector \code{base} is not zero, or 81 | if \code{base} is a function which is not zero when evaluated 82 | at the starting chip/points value, then you may observe 83 | unusual behaviour and/or substantial ratings inflation/deflation. 84 | 85 | The two-player Elo system is based on game outcomes in the interval 86 | [0,1] and therefore uses a different scaling. As a result, the K 87 | factors here should be smaller. The default (as used by Tenhou) 88 | is a K factor of 0.2 for players that have played a large number of 89 | games (see \code{\link{kriichi}}). 90 | 91 | If the number of players varies and \code{base} is a vector (of length 92 | \code{nn}), then if the game has less than \code{nn} players, the vector 93 | is reduced by successively removing the centre value (for odd lengths) 94 | or by averaging both centre values (for even lengths). For example, if 95 | the \code{x} data frame contains both four-player and three-player 96 | mahjong games, then under the default values the three-player base 97 | vector becomes \code{c(30,0,-30)}, which is consistent with the vector 98 | that Tenhou uses for three-player mahjong. 99 | 100 | A numeric matrix can be used to allocate different \code{base} vectors to 101 | different games. For example, in Riichi mahjong, games can be Tonpuusen 102 | (East round only) or Hanchan (East and South rounds), and you may wish 103 | to allocate different base vectors to each type. 104 | } 105 | \value{ 106 | A list object of class \code{"rating"} with the following 107 | components 108 | 109 | \item{ratings}{A data frame of the results at the end of the 110 | final time period. The variables are self explanatory except 111 | for \code{Lag}, which represents the number of time periods 112 | since the player last played a game. This is equal to zero 113 | for players who played in the latest time period, and is 114 | also zero for players who have not yet played any games.} 115 | \item{history}{A three dimensional array, or \code{NULL} if 116 | \code{history} is \code{FALSE}. The row dimension is the 117 | players, the column dimension is the time periods. 118 | The third dimension gives different parameters.} 119 | \item{nn}{The number of players for a single game.} 120 | \item{kfac}{The K factor or K factor function.} 121 | \item{type}{The character string \code{"EloM"}.} 122 | } 123 | \references{ 124 | Elo, Arpad (1978) 125 | The Rating of Chessplayers, Past and Present. 126 | Arco. ISBN 0-668-04721-6. 127 | } 128 | \seealso{ 129 | \code{\link{elo}}, \code{\link{fide}}, \code{\link{glicko}}, \code{\link{kriichi}} 130 | } 131 | \examples{ 132 | robj <- elom(riichi) 133 | robj 134 | 135 | ut <- unique(riichi$Time) 136 | robj <- elom(riichi[riichi$Time == ut[1],]) 137 | for(i in 2:length(ut)) { 138 | robj <- elom(riichi[riichi$Time == ut[i],], status = robj$ratings) 139 | } 140 | robj 141 | } 142 | \keyword{models} 143 | 144 | 145 | 146 | 147 | -------------------------------------------------------------------------------- /man/fide.Rd: -------------------------------------------------------------------------------- 1 | \name{fide} 2 | \alias{fide} 3 | \title{The Elo Rating System Employed By The FIDE} 4 | \description{ 5 | Implements the Elo rating system for estimating the relative 6 | skill level of players in two-player games such as chess, 7 | implementing a version similar to that employed by the FIDE. 8 | } 9 | \usage{ 10 | fide(x, status = NULL, init = 2200, gamma = 0, kfac = kfide, 11 | history = FALSE, sort = TRUE, \dots) 12 | } 13 | \arguments{ 14 | \item{x}{A data frame containing four variables: (1) a numeric 15 | vector denoting the time period in which the game took place 16 | (2) a numeric or character identifier for player one (3) 17 | a numeric or character identifier for player two and (4) 18 | the result of the game expressed as a number, typically 19 | equal to one for a player one win, zero for a player two 20 | win and one half for a draw.} 21 | \item{status}{A data frame with the current status of the 22 | system. If not \code{NULL}, this needs to be a data frame 23 | in the form of the \code{ratings} component of the returned 24 | list, containing variables named \code{Player}, \code{Rating}, 25 | and optionally \code{Games}, \code{Win}, \code{Draw}, 26 | \code{Loss} \code{Lag} and \code{Elite}, which are set 27 | to zero if not given, and \code{Opponent}, which is set 28 | to the player rating if not given.} 29 | \item{init}{The rating at which to initialize a new player not 30 | appearing in \code{status}. Must be a single number. If 31 | different initializations for different players are required, 32 | this can be done using \code{status}.} 33 | \item{gamma}{A player one advantage parameter; either a single 34 | value or a numeric vector equal to the number of rows in 35 | \code{x}. Positive values favour player one, while negative 36 | values favour player two. This could represent the advantage 37 | of playing at home, or the advantage of playing white for chess. 38 | Note that this is not passed to \code{\link{predict.rating}}, 39 | which has its own \code{gamma} parameter.} 40 | \item{kfac}{The K factor parameter. Can be a single number or 41 | a vectorized function of three arguments, the first being the 42 | ratings, the second being the number of games played, and the 43 | third being a binary indicator for whether or not a player 44 | has ever achieved a rating above 2400. See \code{\link{kfide}}, 45 | \code{\link{kgames}} and \code{\link{krating}} for examples. 46 | The function \code{\link{kfide}} is used by default.} 47 | \item{history}{If \code{TRUE} returns the entire history for each 48 | period in the component \code{history} of the returned list.} 49 | \item{sort}{If \code{TRUE} sort the results by rating (highest 50 | to lowest). If \code{FALSE} sort the results by player.} 51 | \item{\dots}{Passed to the function \code{kfac}.} 52 | } 53 | \details{ 54 | The Elo rating system is a simple method for evaluating the skill 55 | of players. It has been used since around 1960 and is still 56 | employed in various settings. Although the basic form uses only 57 | the ratings, additional complexity is commonly introduced 58 | by adding a player one advantage parameter and by using different 59 | K factors. A player one advantage parameter has been added to the 60 | original definition in the reference. A player one advantage 61 | parameter is also used for prediction purposes in 62 | \code{\link{predict.rating}}. 63 | 64 | This implementation uses default arguments that are consistent 65 | with the implementation of FIDE for rating chess players. 66 | It does not employ the initialization used by FIDE. For the 67 | chess data analyzed in the file doc/ChessRatings.pdf, prediction 68 | performance is poor because the default values of the K factors 69 | are too low. This can be altered using the \code{kv} argument 70 | which is passed to the function \code{\link{kfide}}. 71 | } 72 | \value{ 73 | A list object of class \code{"rating"} with the following 74 | components 75 | 76 | \item{ratings}{A data frame of the results at the end of the 77 | final time period. The variables are self explanatory except 78 | for \code{Lag}, which represents the number of time periods 79 | since the player last played a game, \code{Elite}, which 80 | is a binary indicator for whether or not a player has ever 81 | reached 2400, and \code{Opponent}, which gives the average 82 | rating of all opponents. The \code{Lag} variable is equal 83 | to zero for players who played in the latest time period, 84 | and is also zero for players who have not yet played any 85 | games. The \code{Elite} variable is required due to the 86 | K factor dependency in the FIDE implementation. The 87 | \code{Opponent} variable is not currently used in the 88 | updating algorithm.} 89 | \item{history}{A three dimensional array, or \code{NULL} if 90 | \code{history} is \code{FALSE}. The row dimension is the 91 | players, the column dimension is the time periods. 92 | The third dimension gives different parameters.} 93 | \item{gamma}{The player one advantage parameter.} 94 | \item{kfac}{The K factor or K factor function.} 95 | \item{type}{The character string \code{"Elo"}.} 96 | } 97 | \references{ 98 | Elo, Arpad (1978) 99 | The Rating of Chessplayers, Past and Present. 100 | Arco. ISBN 0-668-04721-6. 101 | } 102 | 103 | \seealso{\code{\link{elo}}, \code{\link{kfide}}} 104 | 105 | \examples{ 106 | afl <- aflodds[,c(2,3,4,7)] 107 | robj <- fide(afl) 108 | robj 109 | 110 | robj <- fide(afl[afl$Week==1,]) 111 | for(i in 2:max(afl$Week)) robj <- fide(afl[afl$Week==i,], robj$ratings) 112 | robj 113 | } 114 | \keyword{models} 115 | 116 | 117 | 118 | 119 | -------------------------------------------------------------------------------- /man/glicko.Rd: -------------------------------------------------------------------------------- 1 | \name{glicko} 2 | \alias{glicko} 3 | \title{The Glicko Rating System} 4 | \description{ 5 | Implements the Glicko rating system for estimating the relative 6 | skill level of players in two-player games such as chess. It 7 | extends the Elo method by including a deviation parameter for 8 | each player, representing uncertainty on the rating. 9 | } 10 | \usage{ 11 | glicko(x, status = NULL, init = c(2200,300), gamma = 0, cval = 15, 12 | history = FALSE, sort = TRUE, rdmax = 350, \dots) 13 | } 14 | \arguments{ 15 | \item{x}{A data frame containing four variables: (1) a numeric 16 | vector denoting the time period in which the game took place 17 | (2) a numeric or character identifier for player one (3) 18 | a numeric or character identifier for player two and (4) 19 | the result of the game expressed as a number, typically 20 | equal to one for a player one win, zero for a player two 21 | win and one half for a draw.} 22 | \item{status}{A data frame with the current status of the 23 | system. If not \code{NULL}, this needs to be a data frame 24 | in the form of the \code{ratings} component of the returned 25 | list, containing variables named \code{Player}, \code{Rating}, 26 | \code{Deviation}, and optionally \code{Games}, \code{Win}, 27 | \code{Draw}, \code{Loss} and \code{Lag}, which are set to zero 28 | if not given.} 29 | \item{init}{The rating vector at which to initialize a new player 30 | not appearing in \code{status}. Must be a vector of length two 31 | giving the initial rating and initial deviation respectively. 32 | If different initializations for different players are 33 | required, this can be done using \code{status}. The initial 34 | deviation cannot be greater than \code{rdmax}.} 35 | \item{gamma}{A player one advantage parameter; either a single 36 | value or a numeric vector equal to the number of rows in 37 | \code{x}. Positive values favour player one, while negative 38 | values favour player two. This could represent the advantage 39 | of playing at home, or the advantage of playing white for chess. 40 | Note that this is not passed to \code{\link{predict.rating}}, 41 | which has its own \code{gamma} parameter.} 42 | \item{cval}{The c parameter, which controls the increase in the 43 | player deviations across time. Must be a single non-negative 44 | number.} 45 | \item{history}{If \code{TRUE} returns the entire history for each 46 | period in the component \code{history} of the returned list.} 47 | \item{sort}{If \code{TRUE} sort the results by rating (highest 48 | to lowest). If \code{FALSE} sort the results by player.} 49 | \item{rdmax}{The maximum value allowed for the rating deviation.} 50 | \item{\dots}{Not used.} 51 | } 52 | \details{ 53 | The Glicko rating system is a method for evaluating the skill 54 | of players. It is more complex than Elo but typically yields 55 | better predictions. 56 | Default values are roughly optimized for the chess data analyzed 57 | in the file doc/ChessRatings.pdf, using the binomial deviance 58 | criterion. A player one advantage parameter has been added to 59 | the original definition in the reference. A player one advantage 60 | parameter is also used for prediction purposes in 61 | \code{\link{predict.rating}}. 62 | In this implementation, rating deviances increase at the 63 | beginning of the updating period, and decrease at the end. 64 | This is slightly different from the Glicko-2 implementation, 65 | where deviance increases for active players may occur at the end 66 | of the previous period. In both implementations there will be 67 | an initial increase for existing but previously inactive players. 68 | } 69 | \value{ 70 | A list object of class \code{"rating"} with the following 71 | components 72 | 73 | \item{ratings}{A data frame of the results at the end of the 74 | final time period. The variables are self explanatory except 75 | for \code{Lag}, which represents the number of time periods 76 | since the player last played a game. This is equal to zero 77 | for players who played in the latest time period, and is 78 | also zero for players who have not yet played any games.} 79 | \item{history}{A three dimensional array, or \code{NULL} if 80 | \code{history} is \code{FALSE}. The row dimension is the 81 | players, the column dimension is the time periods. 82 | The third dimension gives different parameters.} 83 | \item{gamma}{The player one advantage parameter.} 84 | \item{cval}{The c parameter.} 85 | \item{type}{The character string \code{"Glicko"}.} 86 | } 87 | \references{ 88 | Glickman, M.E. (1999) 89 | Parameter estimation in large dynamic paired comparison experiments. 90 | J. R. Stat. Soc. Ser. C: Applied Statistics, 48(3), 377-394. 91 | } 92 | 93 | \seealso{\code{\link{elo}}, \code{\link{glicko2}}, \code{\link{steph}}} 94 | 95 | \examples{ 96 | afl <- aflodds[,c(2,3,4,7)] 97 | robj <- glicko(afl) 98 | robj 99 | 100 | robj <- glicko(afl[afl$Week==1,]) 101 | for(i in 2:max(afl$Week)) robj <- glicko(afl[afl$Week==i,], robj$ratings) 102 | robj 103 | } 104 | \keyword{models} 105 | 106 | 107 | 108 | 109 | -------------------------------------------------------------------------------- /man/glicko2.Rd: -------------------------------------------------------------------------------- 1 | \name{glicko2} 2 | \alias{glicko2} 3 | \title{The Glicko-2 Rating System} 4 | \description{ 5 | Implements the Glicko-2 rating system for estimating the relative 6 | skill level of players in two-player games such as chess. It 7 | extends the Glicko method by including a volatility parameter for 8 | each player, representing the degree of expected fluctuation in 9 | the rating. Volatility is therefore a measure of consistency of 10 | performance. 11 | } 12 | \usage{ 13 | glicko2(x, status = NULL, init = c(2200,300,0.15), gamma = 0, 14 | tau = 1.2, history = FALSE, sort = TRUE, rdmax = 350, \dots) 15 | } 16 | \arguments{ 17 | \item{x}{A data frame containing four variables: (1) a numeric 18 | vector denoting the time period in which the game took place 19 | (2) a numeric or character identifier for player one (3) 20 | a numeric or character identifier for player two and (4) 21 | the result of the game expressed as a number, typically 22 | equal to one for a player one win, zero for a player two 23 | win and one half for a draw.} 24 | \item{status}{A data frame with the current status of the 25 | system. If not \code{NULL}, this needs to be a data frame 26 | in the form of the \code{ratings} component of the returned 27 | list, containing variables named \code{Player}, \code{Rating}, 28 | \code{Deviation}, \code{Volatility}, and optionally \code{Games}, 29 | \code{Win}, \code{Draw}, \code{Loss} and \code{Lag}, which are 30 | set to zero if not given.} 31 | \item{init}{The rating vector at which to initialize a new player 32 | not appearing in \code{status}. Must be a vector of length three 33 | giving the initial rating, initial deviation and initial volatility 34 | respectively. If different initializations for different players are 35 | required, this can be done using \code{status}. The initial 36 | deviation cannot be greater than \code{rdmax}. The initial 37 | volatility cannot be greater than \code{rdmax} divided by 38 | \code{400/log(10)}.} 39 | \item{gamma}{A player one advantage parameter; either a single 40 | value or a numeric vector equal to the number of rows in 41 | \code{x}. Positive values favour player one, while negative 42 | values favour player two. This could represent the advantage 43 | of playing at home, or the advantage of playing white for chess. 44 | Note that this is not passed to \code{\link{predict.rating}}, 45 | which has its own \code{gamma} parameter.} 46 | \item{tau}{The tau parameter, which controls the change in the 47 | player volatility across time. Smaller values prevent the 48 | volatility measures from changing by large amounts. Must be a 49 | single number. Mark Glickman suggests a value between 0.3 and 1.2. 50 | A non-positive value can be specified, in which case the 51 | volatilities are never updated.} 52 | \item{history}{If \code{TRUE} returns the entire history for each 53 | period in the component \code{history} of the returned list.} 54 | \item{sort}{If \code{TRUE} sort the results by rating (highest 55 | to lowest). If \code{FALSE} sort the results by player.} 56 | \item{rdmax}{The maximum value allowed for the rating deviation. 57 | The maximum value allowed for the volatility is \code{rdmax} 58 | divided by \code{400/log(10)}.} 59 | \item{\dots}{Not used.} 60 | } 61 | \details{ 62 | The Glicko-2 rating system is a method for evaluating the skill 63 | of players. It is more complex than Glicko because it includes a 64 | volatility for each player. It requires a single parameter 65 | optimization for each player within each time period. We use the 66 | R function \code{optimize} in preference to the root-finding 67 | approaches suggested in Glickman (2001) and Glickman (2013). 68 | Default values are roughly optimized for the chess data analyzed 69 | in the file doc/ChessRatings.pdf, using the binomial deviance 70 | criterion. A player one advantage parameter has been added to 71 | the original definition in the reference. A player one advantage 72 | parameter is also used for prediction purposes in 73 | \code{\link{predict.rating}}. 74 | } 75 | \value{ 76 | A list object of class \code{"rating"} with the following 77 | components 78 | 79 | \item{ratings}{A data frame of the results at the end of the 80 | final time period. The variables are self explanatory except 81 | for \code{Lag}, which represents the number of time periods 82 | since the player last played a game. This is equal to zero 83 | for players who played in the latest time period, and is 84 | also zero for players who have not yet played any games.} 85 | \item{history}{A three dimensional array, or \code{NULL} if 86 | \code{history} is \code{FALSE}. The row dimension is the 87 | players, the column dimension is the time periods. 88 | The third dimension gives different parameters.} 89 | \item{gamma}{The player one advantage parameter.} 90 | \item{tau}{The tau parameter.} 91 | \item{type}{The character string \code{"Glicko-2"}.} 92 | } 93 | \references{ 94 | Glickman, M.E. (2001) 95 | Dynamic paired comparison models with stochastic variances. 96 | Journal of Applied Statistics, 28, 673-689. 97 | 98 | Glickman, M.E. (2013) 99 | Example of the Glicko-2 system. 100 | } 101 | 102 | \seealso{\code{\link{elo}}, \code{\link{glicko}}, \code{\link{steph}}} 103 | 104 | \examples{ 105 | initstate <- data.frame(Player=1:4, Rating = c(1500,1400,1550,1700), 106 | Deviation = c(200,30,100,300), Volatility = 0.06) 107 | games <- data.frame(Week = 1, Payer1 = 1, Player2 = 2:4, Score = c(1,0,0)) 108 | robj <- glicko2(games, status = initstate, tau = 0.5, sort = FALSE) 109 | print(robj, cols = 1:4, digits = 6) 110 | 111 | afl <- aflodds[,c(2,3,4,7)] 112 | robj <- glicko2(afl) 113 | robj 114 | 115 | robj <- glicko2(afl[afl$Week==1,]) 116 | for(i in 2:max(afl$Week)) robj <- glicko2(afl[afl$Week==i,], robj$ratings) 117 | robj 118 | } 119 | \keyword{models} 120 | 121 | 122 | 123 | 124 | -------------------------------------------------------------------------------- /man/hist.rating.Rd: -------------------------------------------------------------------------------- 1 | \name{hist.rating} 2 | \alias{hist.rating} 3 | 4 | \title{Histogram Plotting for a Rating Object} 5 | \description{ 6 | Plot histograms of estimated ratings or other features, 7 | including full history progressions. 8 | } 9 | \usage{ 10 | \method{hist}{rating}(x, which = "Rating", tng=15, history = FALSE, log = FALSE, 11 | xlab = which, main = paste(x$type," Ratings System"), density = FALSE, 12 | add = FALSE, \dots) 13 | } 14 | \arguments{ 15 | \item{x}{An object of class \code{"rating"}.} 16 | \item{which}{The variable to be plotted.} 17 | \item{tng}{A single value. If the number of games played by the 18 | player is below this value, the player is not depicted on the 19 | plot.} 20 | \item{history}{If \code{TRUE}, a histogram is plotted for every 21 | single time point. Only available if the history was retained 22 | in \code{x}.} 23 | \item{log}{The log(x+1) transform. May be useful if plotting e.g. 24 | the number of games.} 25 | \item{xlab,main}{Graphical parameters.} 26 | \item{density}{If \code{TRUE}, plot a density estimate rather 27 | than a histogram.} 28 | \item{add}{Add to an existing plot? Only relevant for density 29 | estimates.} 30 | \item{\dots}{Other parameters to be passed through to plotting 31 | functions.} 32 | } 33 | 34 | \seealso{\code{\link{plot.rating}}} 35 | 36 | \examples{ 37 | afl <- aflodds[,c(2,3,4,7)] 38 | robj <- steph(afl) 39 | hist(robj, xlim = c(1900,2500), density=TRUE) 40 | 41 | afl <- aflodds[,c(2,3,4,7)] 42 | robj <- steph(afl, history=TRUE) 43 | hist(robj, history=TRUE, xlim = c(1900,2500), density=TRUE) 44 | 45 | robj <- elom(riichi) 46 | hist(robj, xlim = c(1100,1900)) 47 | 48 | robj <- elom(riichi, history=TRUE) 49 | hist(robj, history=TRUE, xlim = c(1100,1900)) 50 | } 51 | \keyword{hplot} 52 | -------------------------------------------------------------------------------- /man/kfide.Rd: -------------------------------------------------------------------------------- 1 | \name{kfide} 2 | \alias{kfide} 3 | \title{The K Factor Function Used By FIDE} 4 | \description{ 5 | Calculates the K factor for the Elo rating system based 6 | on player rating, number of games played, and optionally 7 | a binary elite player identifier. 8 | } 9 | \usage{ 10 | kfide(rating, games, elite = NULL, kv = c(10,15,30)) 11 | } 12 | \arguments{ 13 | \item{rating}{A numeric vector of player ratings.} 14 | \item{games}{A numeric vector with the number of games played 15 | by each player.} 16 | \item{elite}{If not \code{NULL}, then a binary identifier for 17 | elite players.} 18 | \item{kv}{The three different K factors that the function can 19 | produce.} 20 | } 21 | \details{ 22 | This function is designed to be used for the \code{kfac} argument 23 | of either \code{\link{fide}} or \code{\link{elo}}. It returns 24 | \code{kv[1]} for elite players, \code{kv[2]} for non-elite 25 | players with 30 games or more, and \code{kv[3]} for non-elite 26 | players with less than 30 games. The default is the current FIDE 27 | implementation which uses the K factors 10, 15 and 30. The K factor 28 | of 30 was changed from 25 in the year 2011. In this context, elite 29 | players are defined by FIDE as being those who have reached 30 | the rating 2400 or more at any time in the past. 31 | } 32 | \value{ 33 | A numeric vector of K factors. 34 | } 35 | 36 | \seealso{\code{\link{fide}}} 37 | 38 | \keyword{manip} 39 | 40 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /man/kgames.Rd: -------------------------------------------------------------------------------- 1 | \name{kgames} 2 | \alias{kgames} 3 | \title{A K Factor Function With Dependence On Number Of Games} 4 | \description{ 5 | Calculates the K factor for the Elo rating system based 6 | on number of games played. 7 | } 8 | \usage{ 9 | kgames(rating, games, elite = NULL, gv = 30, kv = c(32,26)) 10 | } 11 | \arguments{ 12 | \item{rating}{A numeric vector of player ratings. The K factor 13 | does not depend on this quantity.} 14 | \item{games}{A numeric vector with the number of games played 15 | by each player.} 16 | \item{elite}{Not used.} 17 | \item{gv}{A numeric vector of length one less than \code{kv} 18 | giving the thresholds for the number of games played.} 19 | \item{kv}{A numeric vector of length one more than \code{gv} 20 | giving the different K factors that the function can 21 | produce.} 22 | } 23 | \details{ 24 | This function is designed to be used for the \code{kfac} argument 25 | of either \code{\link{fide}} or \code{\link{elo}}. It returns 26 | \code{kv[i]} for players who have played a total number of games 27 | within the intervals defined by \code{gv} (closed on the right). 28 | } 29 | \value{ 30 | A numeric vector of K factors. 31 | } 32 | 33 | \seealso{\code{\link{elo}}, \code{\link{fide}}} 34 | 35 | \keyword{manip} 36 | 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /man/krating.Rd: -------------------------------------------------------------------------------- 1 | \name{krating} 2 | \alias{krating} 3 | \title{A K Factor Function With Dependence On Rating} 4 | \description{ 5 | Calculates the K factor for the Elo rating system based 6 | on the player rating. 7 | } 8 | \usage{ 9 | krating(rating, games, elite = NULL, rv = 2300, kv = c(32,26)) 10 | } 11 | \arguments{ 12 | \item{rating}{A numeric vector of player ratings.} 13 | \item{games}{A numeric vector with the number of games played 14 | by each player. The K factor does not depend on this 15 | quantity.} 16 | \item{elite}{Not used.} 17 | \item{rv}{A numeric vector of length one less than \code{kv} 18 | giving the thresholds for the ratings.} 19 | \item{kv}{A numeric vector of length one more than \code{gv} 20 | giving the different K factors that the function can 21 | produce.} 22 | } 23 | \details{ 24 | This function is designed to be used for the \code{kfac} argument 25 | of either \code{\link{fide}} or \code{\link{elo}}. It returns 26 | \code{kv[i]} for players who have a rating within the intervals 27 | defined by \code{rv} (closed on the right). 28 | } 29 | \value{ 30 | A numeric vector of K factors. 31 | } 32 | 33 | \seealso{\code{\link{elo}}, \code{\link{fide}}} 34 | 35 | \keyword{manip} 36 | 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /man/kriichi.Rd: -------------------------------------------------------------------------------- 1 | \name{kriichi} 2 | \alias{kriichi} 3 | \title{A multi-player K Factor Function for Riichi Mahjong} 4 | \description{ 5 | Calculates the K factor for the rating system employed by 6 | Tenhou for Riichi mahjong. 7 | } 8 | \usage{ 9 | kriichi(rating, games, gv = 400, kv = 0.2) 10 | } 11 | \arguments{ 12 | \item{rating}{A numeric vector of player ratings. The K factor 13 | does not depend on this quantity.} 14 | \item{games}{A numeric vector with the number of games played 15 | by each player.} 16 | \item{gv}{A value giving the threshold for the number of games 17 | played.} 18 | \item{kv}{The K factor if the number of games played is greater 19 | than or equal to \code{gv}.} 20 | } 21 | \details{ 22 | This function is designed to be used for the \code{kfac} argument 23 | of \code{\link{elom}}. It returns \code{kv} for players who have 24 | played at least \code{gv} games, and returns \code{1-(1-kv)N/gv} 25 | otherwise, where \code{N} is the number of games played. 26 | } 27 | \value{ 28 | A numeric vector of K factors. 29 | } 30 | 31 | \seealso{\code{\link{elom}}, \code{\link{fide}}} 32 | 33 | \keyword{manip} 34 | 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /man/metrics.Rd: -------------------------------------------------------------------------------- 1 | \name{metrics} 2 | \alias{metrics} 3 | \title{Prediction Evaluation} 4 | \description{ 5 | Returns measures that assess prediction performance. 6 | } 7 | \usage{ 8 | metrics(act, pred, cap = c(0.01,0.99), which = 1:3, na.rm = TRUE, 9 | sort = TRUE, digits = 3, scale = TRUE) 10 | } 11 | \arguments{ 12 | \item{act}{A numeric vector of actual values. Typically equal to 13 | one for a player one win, zero for a player two win, and one 14 | half for a draw.} 15 | \item{pred}{A numeric vector of predictions, typically values 16 | between zero and one. A matrix can also be given, in which 17 | case the jth column contains the predictions for model j.} 18 | \item{cap}{A numeric vector of length two giving values at which 19 | to cap the binomial deviance.} 20 | \item{which}{Select metrics using any subset of \code{1:3}. All 21 | are produced by default.} 22 | \item{na.rm}{Remove missing values in predictions. The default is 23 | to remove missing values because the default predict method will 24 | predict missing values for games with new players.} 25 | \item{sort}{By default output is ordered from best to worst using 26 | the first metric specified.} 27 | \item{digits}{Round to this number of digits.} 28 | \item{scale}{If \code{TRUE} (the default), all metrics are scaled 29 | so that a value of 100 corresponds to predicting 0.5 for every 30 | game.} 31 | } 32 | \details{ 33 | The preferred metric for assessing predictions in chess is 34 | the capped binomial deviance. Mean squared error and mean 35 | absolute error metrics are also produced. By default all metrics 36 | are scaled so that the value 100 represents the zero information 37 | case. If not scaled, then all metrics are multiplied by 100. 38 | } 39 | \value{ 40 | A numeric vector. 41 | } 42 | 43 | \seealso{\code{\link{predict.rating}}} 44 | 45 | \examples{ 46 | afl <- aflodds[,c(2,3,4,7)] 47 | train <- afl[afl$Week <= 80,] 48 | test <- afl[afl$Week > 80,] 49 | robj <- elo(train) 50 | metrics(test$Score, predict(robj, test)) 51 | metrics(test$Score, predict(robj, test), scale = FALSE) 52 | } 53 | \keyword{manip} 54 | 55 | 56 | 57 | 58 | -------------------------------------------------------------------------------- /man/plot.rating.Rd: -------------------------------------------------------------------------------- 1 | \name{plot.rating} 2 | \alias{plot.rating} 3 | 4 | \title{Plot Player Features Across Time for a Rating Object} 5 | \description{ 6 | Plot line traces of estimated ratings or other features for 7 | selected players. This function can only be used if the full 8 | history is retained in the object \code{x}. 9 | } 10 | \usage{ 11 | \method{plot}{rating}(x, which = "Rating", players = NULL, t0 = 1, tv = NULL, 12 | npl = 10, random = FALSE, xlab = "Time Period", ylab = paste(x$type," Ratings"), 13 | main = paste(x$type," Ratings System"), inflation = FALSE, add=FALSE, \dots) 14 | } 15 | \arguments{ 16 | \item{x}{An object of class \code{"rating"}.} 17 | \item{which}{The variable to be plotted.} 18 | \item{players}{If not \code{NULL}, should be a vector of player 19 | identifiers to explicitly select players to be plotted.} 20 | \item{t0}{The time index at which to begin. Note that unless players 21 | are specified explicitly, players who do not play at time index 22 | \code{t0} will not be selected for the plot. Can also be a 23 | vector of length two, in which case the second value is the 24 | time index at which to end.} 25 | \item{tv}{If not \code{NULL}, then a vector of values to be used on the 26 | x-axis instead of the time index.} 27 | \item{npl}{The number of players to select.} 28 | \item{random}{If \code{TRUE}, \code{npl} players are selected at random from 29 | those who played at time \code{t0}. If \code{FALSE} (the default), 30 | the \code{npl} players who played most games at \code{t0} are selected. 31 | Ignored if \code{players} is not \code{NULL}.} 32 | \item{xlab,ylab,main}{Graphical parameters.} 33 | \item{inflation}{If \code{TRUE}, plot the average rating of the best \code{npl} 34 | players at each time point. This is designed to investigate ratings inflation.} 35 | \item{add}{Add to an existing plot.} 36 | \item{\dots}{Other parameters to be passed through to plotting 37 | functions.} 38 | } 39 | \details{ 40 | Note that the argument \code{random} is not used by default, since it can 41 | produce flat profiles from randomly selected players who play few games. 42 | The default selection is non-random and selects more active players, 43 | however they may be more likely to improve over time than the 44 | general population. 45 | } 46 | 47 | \seealso{\code{\link{hist.rating}}} 48 | 49 | \examples{ 50 | afl <- aflodds[,c(2,3,4,7)] 51 | robj <- steph(afl, history=TRUE) 52 | plot(robj) 53 | 54 | robj <- elom(riichi, history = TRUE) 55 | pl <- robj$ratings$Player[robj$ratings$Games >= 80] 56 | plot(robj, players = pl) 57 | } 58 | \keyword{hplot} 59 | -------------------------------------------------------------------------------- /man/predict.rating.Rd: -------------------------------------------------------------------------------- 1 | \name{predict.rating} 2 | \alias{predict.rating} 3 | 4 | \title{Predict Result Of Games Based On Player Ratings} 5 | \description{ 6 | Predict the result of two-player or multi-player games, 7 | given the estimated ratings for each player. 8 | } 9 | \usage{ 10 | \method{predict}{rating}(object, newdata, tng=15, trat=NULL, gamma=30, 11 | thresh, placing = FALSE, \dots) 12 | } 13 | \arguments{ 14 | \item{object}{An object of class \code{"rating"}.} 15 | \item{newdata}{For two player games, a dataframe containing 16 | three variables: (1) a numeric vector denoting the time period 17 | in which the game is taking place (2) a numeric or character 18 | identifier for player one (3) a numeric or character identifier 19 | for player two. The time period can contain missing values as 20 | it is not used for the prediction. For N-player games (i.e. 21 | for objects created by the \code{elom} function), the player 22 | identifiers should be in columns 2 to N-1. This argument cannot 23 | be missing; if predictions on the original dataset are required, 24 | then this dataset must be passed to the prediction function.} 25 | \item{tng}{A single value. If the number of games played by 26 | any player is below this value, then either the prediction 27 | will be a missing value, or the prediction will be based on 28 | \code{trat}.} 29 | \item{trat}{A single number (for Elo and EloM), or a vector of 30 | length two (for Glicko or Glicko-2 or Stephenson) giving the 31 | rating and deviation parameters to be used for players who have 32 | played less than \code{tng} games. If \code{NULL} then these 33 | predictions will be missing. The volatility parameter in 34 | Glicko-2 is not needed for predictions.} 35 | \item{gamma}{A player one advantage parameter; either a single 36 | value or a numeric vector equal to the number of rows in 37 | \code{newdata}. Positive values favour player one, while 38 | negative values favour player two. This could represent the 39 | advantage of playing at home, or the advantage of playing 40 | white for chess. The default value is roughly optimal for 41 | chess ratings. Ignored for multi-player.} 42 | \item{thresh}{A single value. If given, a binary vector is 43 | returned indicating whether the prediction is greater than 44 | this value. Ignored for multi-player.} 45 | \item{placing}{For multi-player only. If \code{TRUE}, predicted 46 | placings are given rather than expected base scores.} 47 | \item{\dots}{Not used.} 48 | } 49 | \details{ 50 | The function predicts the expectation of the game result. In 51 | two-player games, if the value of one is a win for player one, and 52 | the value of zero is a win for player two, and there are no other 53 | possibilities, then the prediction is the probability of a win 54 | for player one. This is not the case when draws are a possibility. 55 | 56 | For multi-player predictions using objects produced by \code{elom}, 57 | expected base scores are given for each player. These are simply the 58 | difference between the rating of a player and the average of all 59 | players in the game, divided by 40. 60 | } 61 | \value{ 62 | A numeric vector of predictions of two-player games, or a matrix of 63 | expected base scores for multi-player games, either of which may contain 64 | missing values. 65 | } 66 | 67 | \seealso{\code{\link{elo}}, \code{\link{elom}}, \code{\link{metrics}}} 68 | 69 | \examples{ 70 | afl <- aflodds[,c(2,3,4,7)] 71 | train <- afl[afl$Week <= 80,] 72 | test <- afl[afl$Week > 80,] 73 | robj <- elo(train) 74 | pvals <- predict(robj, test) 75 | 76 | train <- riichi[riichi$Time <= 250,] 77 | test <- riichi[riichi$Time > 250,] 78 | robj <- elom(train) 79 | predict(robj, test, trat = 1400, placing = TRUE) 80 | } 81 | \keyword{models} 82 | -------------------------------------------------------------------------------- /man/riichi.Rd: -------------------------------------------------------------------------------- 1 | \name{riichi} 2 | \docType{data} 3 | \alias{riichi} 4 | \title{Riichi Mahjong Game Results} 5 | \usage{aflodds} 6 | \description{ 7 | The \code{aflodds} data frame has 540 rows and 9 variables. It 8 | shows the results for 540 Riichi Mahjong games played by 69 9 | players at the Melbourne Mahjong Club in 2019. Player identifiers 10 | are randomly assigned. 11 | } 12 | \format{ 13 | This data frame contains the following columns: 14 | \describe{ 15 | \item{Time}{The day number within the year 2019.} 16 | \item{Play1}{Player 1 identifier.} 17 | \item{Play2}{Player 2 identifier.} 18 | \item{Play3}{Player 3 identifier.} 19 | \item{Play4}{Player 4 identifier.} 20 | \item{Score1}{Player 1 score.} 21 | \item{Score2}{Player 2 score.} 22 | \item{Score3}{Player 3 score.} 23 | \item{Score4}{Player 4 score.} 24 | } 25 | } 26 | \details{ 27 | Players start the game with 25000 points. Mahjong is a zero-sum 28 | game, therfore the sum of all four scores is always 100000. Negative 29 | scores are possible. The largest recorded score is 93900. The 30 | smallest recorded score is -24600. 31 | } 32 | \source{ 33 | Hand collected by The Melbourne Mahjong Club. 34 | } 35 | \keyword{datasets} 36 | 37 | -------------------------------------------------------------------------------- /man/steph.Rd: -------------------------------------------------------------------------------- 1 | \name{steph} 2 | \alias{steph} 3 | \title{The Stephenson Rating System} 4 | \description{ 5 | Implements the Stephenson rating system for estimating the relative 6 | skill level of players in two-player games such as chess. It 7 | extends the Glicko method by including a second parameter 8 | controlling player deviation across time, a bonus parameter, 9 | and a neighbourhood parameter. 10 | } 11 | \usage{ 12 | steph(x, status = NULL, init = c(2200,300), gamma = 0, cval = 10, 13 | hval = 10, bval = 0, lambda = 2, history = FALSE, sort = TRUE, 14 | rdmax = 350, \dots) 15 | } 16 | \arguments{ 17 | \item{x}{A data frame containing four variables: (1) a numeric 18 | vector denoting the time period in which the game took place 19 | (2) a numeric or character identifier for player one (3) 20 | a numeric or character identifier for player two and (4) 21 | the result of the game expressed as a number, typically 22 | equal to one for a player one win, zero for a player two 23 | win and one half for a draw.} 24 | \item{status}{A data frame with the current status of the 25 | system. If not \code{NULL}, this needs to be a data frame 26 | in the form of the \code{ratings} component of the returned 27 | list, containing variables named \code{Player}, \code{Rating}, 28 | \code{Deviation}, and optionally \code{Games}, \code{Win}, 29 | \code{Draw}, \code{Loss} and \code{Lag}, which are set to zero 30 | if not given.} 31 | \item{init}{The rating vector at which to initialize a new player 32 | not appearing in \code{status}. Must be a vector of length two 33 | giving the initial rating and initial deviation respectively. 34 | If different initializations for different players are 35 | required, this can be done using \code{status}. The initial 36 | deviation cannot be greater than \code{rdmax}.} 37 | \item{gamma}{A player one advantage parameter; either a single 38 | value or a numeric vector equal to the number of rows in 39 | \code{x}. Positive values favour player one, while negative 40 | values favour player two. This could represent the advantage 41 | of playing at home, or the advantage of playing white for chess. 42 | Note that this is not passed to \code{\link{predict.rating}}, 43 | which has its own \code{gamma} parameter.} 44 | \item{cval}{The c parameter, which controls the increase in the 45 | player deviations across time. Must be a single non-negative number. 46 | Note that both \code{cval} and \code{hval} increase player 47 | deviations, so if \code{hval} is not zero then \code{cval} should 48 | typically be lower than the corresponding parameter in 49 | \code{\link{glicko}}.} 50 | \item{hval}{The h parameter, which also controls the increase in the 51 | player deviations across time. Must be a single non-negative number.} 52 | \item{bval}{The bonus parameter, which gives a per game bonus to each 53 | player on the basis that players who play more often may improve 54 | irrespective of whether they win or lose. A single non-negative 55 | number. Note that this will create ratings inflation (i.e. ratings 56 | will increase over time).} 57 | \item{lambda}{The neighbourhood parameter, which shrinks player 58 | ratings towards their opponents. A single non-negative number.} 59 | \item{history}{If \code{TRUE} returns the entire history for each 60 | period in the component \code{history} of the returned list.} 61 | \item{sort}{If \code{TRUE} sort the results by rating (highest 62 | to lowest). If \code{FALSE} sort the results by player.} 63 | \item{rdmax}{The maximum value allowed for the rating deviation.} 64 | \item{\dots}{Not used.} 65 | } 66 | \details{ 67 | The Stephenson rating system is a method for evaluating the skill 68 | of players. It was developed by Alec Stephenson in 2012 as a variant 69 | of his winning entry in a competition to find the most useful 70 | practical chess rating system, organized by Jeff Sonas on Kaggle, 71 | a platform for data prediction competitions. The precise details 72 | are given in the file doc/ChessRatings.pdf. 73 | 74 | This implementation is written so that Glicko is obtained as a 75 | special case upon setting all of the parameters \code{hval}, 76 | \code{bval} and \code{lambda} to zero. Default values are roughly 77 | optimized for the chess data analyzed in the file 78 | doc/ChessRatings.pdf, using the binomial deviance criterion. 79 | } 80 | \value{ 81 | A list object of class \code{"rating"} with the following 82 | components 83 | 84 | \item{ratings}{A data frame of the results at the end of the 85 | final time period. The variables are self explanatory except 86 | for \code{Lag}, which represents the number of time periods 87 | since the player last played a game. This is equal to zero 88 | for players who played in the latest time period, and is 89 | also zero for players who have not yet played any games.} 90 | \item{history}{A three dimensional array, or \code{NULL} if 91 | \code{history} is \code{FALSE}. The row dimension is the 92 | players, the column dimension is the time periods. The 93 | third dimension gives different parameters.} 94 | \item{gamma}{The player one advantage parameter.} 95 | \item{cval}{The c parameter.} 96 | \item{hval}{The h parameter.} 97 | \item{bval}{The bonus parameter.} 98 | \item{lambda}{The neighbourhood parameter.} 99 | \item{type}{The character string \code{"Stephenson"}.} 100 | } 101 | \references{ 102 | Glickman, M.E. (1999) 103 | Parameter estimation in large dynamic paired comparison experiments. 104 | J. R. Stat. Soc. Ser. C: Applied Statistics, 48(3), 377-394. 105 | 106 | Glickman, M.E. (2001) 107 | Dynamic paired comparison models with stochastic variances. 108 | Journal of Applied Statistics, 28, 673-689. 109 | } 110 | 111 | \seealso{\code{\link{glicko}}} 112 | 113 | \examples{ 114 | afl <- aflodds[,c(2,3,4,7)] 115 | robj <- steph(afl) 116 | robj 117 | 118 | robj <- steph(afl[afl$Week==1,]) 119 | for(i in 2:max(afl$Week)) robj <- steph(afl[afl$Week==i,], robj$ratings) 120 | robj 121 | } 122 | \keyword{models} 123 | 124 | 125 | 126 | 127 | -------------------------------------------------------------------------------- /src/PlayerRatings_init.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include // for NULL 4 | #include 5 | 6 | extern void elo_c(void *, void *, void *, void *, void *, void *, void *, void *); 7 | extern void elom_c(void *, void *, void *, void *, void *, void *, void *); 8 | extern void glicko_c(void *, void *, void *, void *, void *, void *, void *, void *, void *); 9 | extern void glicko2_c(void *, void *, void *, void *, void *, void *, void *, void *, void *); 10 | extern void stephenson_c(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); 11 | 12 | static const R_CMethodDef CEntries[] = { 13 | {"elo_c", (DL_FUNC) &elo_c, 8}, 14 | {"elom_c", (DL_FUNC) &elom_c, 7}, 15 | {"glicko_c", (DL_FUNC) &glicko_c, 9}, 16 | {"glicko2_c", (DL_FUNC) &glicko2_c, 9}, 17 | {"stephenson_c", (DL_FUNC) &stephenson_c, 10}, 18 | {NULL, NULL, 0} 19 | }; 20 | 21 | void R_init_PlayerRatings(DllInfo *dll) 22 | { 23 | R_registerRoutines(dll, CEntries, NULL, NULL, NULL); 24 | R_useDynamicSymbols(dll, TRUE); 25 | } 26 | -------------------------------------------------------------------------------- /src/ratings.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | void elo_c(int *np, int *nr, int *white, int *black, double *score, 5 | double *crats, double *gamma, double *dscore); 6 | 7 | void elom_c(int *np, int *nr, int *nn, int *player, double *score, 8 | double *crats, double *dscore); 9 | 10 | void glicko_c(int *np, int *nr, int *white, int *black, double *score, 11 | double *crats, double *gdevs, double *gamma, double *dscore); 12 | 13 | void glicko2_c(int *np, int *nr, int *white, int *black, double *score, 14 | double *crats, double *gdevs, double *gamma, double *dscore); 15 | 16 | void stephenson_c(int *np, int *nr, int *white, int *black, double *score, 17 | double *crats, double *gdevs, double *gamma, double *bval, double *dscore); 18 | 19 | void elo_c(int *np, int *nr, int *white, int *black, double *score, 20 | double *crats, double *gamma, double *dscore) 21 | { 22 | double *escore; 23 | double *ascore; 24 | int k; 25 | 26 | escore = (double *)R_alloc(*np, sizeof(double)); 27 | ascore = (double *)R_alloc(*np, sizeof(double)); 28 | 29 | for(k=0;k<*np;k++) { 30 | escore[k] = 0; 31 | ascore[k] = 0; 32 | } 33 | 34 | for(k=0;k<*nr;k++) { 35 | ascore[white[k]] = ascore[white[k]] + score[k]; 36 | escore[white[k]] = escore[white[k]] + 37 | 1/(1 + R_pow(10,(crats[black[k]] - crats[white[k]] - gamma[k])/400)); 38 | ascore[black[k]] = ascore[black[k]] + 1 - score[k]; 39 | escore[black[k]] = escore[black[k]] + 40 | 1/(1 + R_pow(10,(crats[white[k]] - crats[black[k]] + gamma[k])/400)); 41 | } 42 | for(k=0;k<*np;k++) dscore[k] = ascore[k] - escore[k]; 43 | } 44 | 45 | void elom_c(int *np, int *nr, int *nn, int *player, double *score, 46 | double *crats, double *dscore) 47 | { 48 | double *escore; 49 | double *ascore; 50 | double avetab; 51 | int k,p,ntp; 52 | 53 | escore = (double *)R_alloc(*np, sizeof(double)); 54 | ascore = (double *)R_alloc(*np, sizeof(double)); 55 | 56 | for(k=0;k<*np;k++) { 57 | escore[k] = 0; 58 | ascore[k] = 0; 59 | } 60 | 61 | for(k=0;k<*nr;k++) { 62 | avetab = 0; 63 | ntp = 0; 64 | for(p=0;p<*nn;p++) { 65 | if(player[*nn*k+p] != -1) { 66 | avetab = avetab + crats[player[*nn*k+p]]; 67 | ntp++; 68 | } 69 | } 70 | avetab = avetab / ntp; 71 | for(p=0;p<*nn;p++) { 72 | if(player[*nn*k+p] != -1) { 73 | ascore[player[*nn*k+p]] = ascore[player[*nn*k+p]] + score[*nn*k+p]; 74 | escore[player[*nn*k+p]] = escore[player[*nn*k+p]] + 75 | (crats[player[*nn*k+p]] - avetab)/40; 76 | } 77 | } 78 | } 79 | 80 | for(k=0;k<*np;k++) dscore[k] = ascore[k] - escore[k]; 81 | } 82 | 83 | void glicko_c(int *np, int *nr, int *white, int *black, double *score, 84 | double *crats, double *gdevs, double *gamma, double *dscore) 85 | { 86 | 87 | double *escore; 88 | double *ascore; 89 | double *dval; 90 | double escorek; 91 | double qv2 = R_pow(M_LN10/400, 2); 92 | int k; 93 | 94 | escore = (double *)R_alloc(*np, sizeof(double)); 95 | ascore = (double *)R_alloc(*np, sizeof(double)); 96 | dval = (double *)R_alloc(*np, sizeof(double)); 97 | 98 | for(k=0;k<*np;k++) { 99 | escore[k] = 0; 100 | ascore[k] = 0; 101 | dval[k] = 0; 102 | } 103 | 104 | 105 | for(k=0;k<*nr;k++) { 106 | ascore[white[k]] = ascore[white[k]] + score[k]; 107 | escorek = 1/(1 + R_pow(10,(gdevs[black[k]] * (crats[black[k]] - crats[white[k]] - gamma[k]))/400)); 108 | escore[white[k]] = escore[white[k]] + escorek; 109 | dval[white[k]] = dval[white[k]] + qv2 * R_pow(gdevs[black[k]],2) * escorek * (1-escorek); 110 | dscore[white[k]] = dscore[white[k]] + gdevs[black[k]] * (score[k] - escorek); 111 | 112 | ascore[black[k]] = ascore[black[k]] + 1 - score[k]; 113 | escorek = 1/(1 + R_pow(10,(gdevs[white[k]] * (crats[white[k]] - crats[black[k]] + gamma[k]))/400)); 114 | escore[black[k]] = escore[black[k]] + escorek; 115 | dval[black[k]] = dval[black[k]] + qv2 * R_pow(gdevs[white[k]],2) * escorek * (1-escorek); 116 | dscore[black[k]] = dscore[black[k]] + gdevs[white[k]] * (1 - score[k] - escorek); 117 | } 118 | for(k=0;k<*np;k++) dscore[k + *np] = dval[k]; 119 | } 120 | 121 | void glicko2_c(int *np, int *nr, int *white, int *black, double *score, 122 | double *crats, double *gdevs, double *gamma, double *dscore) 123 | { 124 | 125 | double *escore; 126 | double *ascore; 127 | double *dval; 128 | double escorek; 129 | int k; 130 | 131 | escore = (double *)R_alloc(*np, sizeof(double)); 132 | ascore = (double *)R_alloc(*np, sizeof(double)); 133 | dval = (double *)R_alloc(*np, sizeof(double)); 134 | 135 | for(k=0;k<*np;k++) { 136 | escore[k] = 0; 137 | ascore[k] = 0; 138 | dval[k] = 0; 139 | } 140 | 141 | for(k=0;k<*nr;k++) { 142 | ascore[white[k]] = ascore[white[k]] + score[k]; 143 | escorek = 1/(1 + exp(gdevs[black[k]] * (crats[black[k]] - crats[white[k]] - gamma[k]))); 144 | escore[white[k]] = escore[white[k]] + escorek; 145 | dval[white[k]] = dval[white[k]] + R_pow(gdevs[black[k]],2) * escorek * (1-escorek); 146 | dscore[white[k]] = dscore[white[k]] + gdevs[black[k]] * (score[k] - escorek); 147 | 148 | ascore[black[k]] = ascore[black[k]] + 1 - score[k]; 149 | escorek = 1/(1 + exp(gdevs[white[k]] * (crats[white[k]] - crats[black[k]] + gamma[k]))); 150 | escore[black[k]] = escore[black[k]] + escorek; 151 | dval[black[k]] = dval[black[k]] + R_pow(gdevs[white[k]],2) * escorek * (1-escorek); 152 | dscore[black[k]] = dscore[black[k]] + gdevs[white[k]] * (1 - score[k] - escorek); 153 | } 154 | for(k=0;k<*np;k++) dscore[k + *np] = dval[k]; 155 | } 156 | 157 | void stephenson_c(int *np, int *nr, int *white, int *black, double *score, 158 | double *crats, double *gdevs, double *gamma, double *bval, double *dscore) 159 | { 160 | 161 | double *escore; 162 | double *ascore; 163 | double *dval; 164 | double *l1t; 165 | double escorek, ascorek; 166 | double qv2 = R_pow(M_LN10/400, 2); 167 | int k; 168 | 169 | escore = (double *)R_alloc(*np, sizeof(double)); 170 | ascore = (double *)R_alloc(*np, sizeof(double)); 171 | dval = (double *)R_alloc(*np, sizeof(double)); 172 | l1t = (double *)R_alloc(*np, sizeof(double)); 173 | 174 | for(k=0;k<*np;k++) { 175 | escore[k] = 0; 176 | ascore[k] = 0; 177 | dval[k] = 0; 178 | l1t[k] = 0; 179 | } 180 | 181 | for(k=0;k<*nr;k++) { 182 | ascorek = score[k] + *bval; 183 | ascore[white[k]] = ascore[white[k]] + ascorek; 184 | escorek = 1/(1 + R_pow(10,(gdevs[black[k]] * (crats[black[k]] - crats[white[k]] - gamma[k]))/400)); 185 | escore[white[k]] = escore[white[k]] + escorek; 186 | dval[white[k]] = dval[white[k]] + qv2 * R_pow(gdevs[black[k]],2) * escorek * (1-escorek); 187 | dscore[white[k]] = dscore[white[k]] + gdevs[black[k]] * (ascorek - escorek); 188 | l1t[white[k]] = l1t[white[k]] + crats[black[k]] - crats[white[k]]; 189 | 190 | ascorek = 1 - score[k] + *bval; 191 | ascore[black[k]] = ascore[black[k]] + ascorek; 192 | escorek = 1/(1 + R_pow(10,(gdevs[white[k]] * (crats[white[k]] - crats[black[k]] + gamma[k]))/400)); 193 | escore[black[k]] = escore[black[k]] + escorek; 194 | dval[black[k]] = dval[black[k]] + qv2 * R_pow(gdevs[white[k]],2) * escorek * (1-escorek); 195 | dscore[black[k]] = dscore[black[k]] + gdevs[white[k]] * (ascorek - escorek); 196 | l1t[black[k]] = l1t[black[k]] + crats[white[k]] - crats[black[k]]; 197 | } 198 | for(k=0;k<*np;k++) { 199 | dscore[k + *np] = dval[k]; 200 | dscore[k + 2 * *np] = l1t[k]; 201 | } 202 | } 203 | -------------------------------------------------------------------------------- /vignettes/AFLRatings.Rnw: -------------------------------------------------------------------------------- 1 | \documentclass[12pt,a4paper]{article} 2 | \usepackage{amsmath,amssymb} 3 | 4 | \pagestyle{plain} 5 | \setlength{\parindent}{0in} 6 | \setlength{\parskip}{1.5ex plus 0.5ex minus 0.5ex} 7 | \setlength{\oddsidemargin}{0in} 8 | \setlength{\topmargin}{-0.5in} 9 | \setlength{\textwidth}{6.3in} 10 | \setlength{\textheight}{9.8in} 11 | 12 | %\VignetteIndexEntry{Rating Football Teams} 13 | 14 | \begin{document} 15 | \SweaveOpts{concordance=TRUE} 16 | 17 | \title{Rating Australian Rules Football Teams \\ With The \textbf{PlayerRatings} Package \\ \vspace*{0.5cm} \large Now updated for glicko-2} 18 | \author{Alec Stephenson} 19 | \maketitle 20 | 21 | \begin{center} 22 | \LARGE 23 | \textbf{Summary} \\ 24 | \end{center} 25 | \normalsize 26 | \vspace{0.5cm} 27 | This vignette presents a short example of the use of \textbf{PlayerRatings}, using a small dataset to demonstrate rating Australian football teams and predicting the winner of future games based on those ratings. A second more detailed analysis using a large dataset of chess matches is given in the file \texttt{doc/ChessRatings.pdf}. 28 | \normalsize 29 | 30 | \section{Functions and Datasets} 31 | 32 | The \textbf{PlayerRatings} package implements iterative updating systems for rating players (i.e.\ individuals or teams) in two-player games. These methods are fast and surprisingly accurate. The idea is that given games played in time period $t$, the ratings can be updated using only the information about the status of the system at the end of time period $t-1$, so that all games before $t$ can be ignored. The ratings can then be used to predict the result of games at time $t+1$. Comparing the game predictions with the actual results gives a method of evaluating the accuracy of the ratings as an estimate of a player's true skill. 33 | 34 | The result of a game is considered to be a value in the interval $[0,1]$. For the football data, we only use information on wins, draws and losses, so a value of one represents a win for the home team, a value of zero represents a win for the away team, and a value of one half represents a draw. The status of the system is typically a small number of features, such as player ratings, player rating (standard) deviations, and the number of games played. The more computationally intensive (and often slightly more accurate) approaches of using the full gaming history via a time decay weighting function is not considered here. 35 | 36 | The functions \texttt{elo} and \texttt{fide} implement the Elo system (Elo, 1978), the functions \texttt{glicko} and \texttt{glicko2} implement the Glicko (Glickman, 1999) and Glicko-2 (Glickman, 2001) systems, and the function \texttt{steph} implements the Stephenson system as detailed in the appendix of \texttt{doc/ChessRatings.pdf}. We only use the \texttt{steph} and \texttt{glicko2} functions in this vignette. 37 | 38 | 39 | \section{Modelling and Prediction} 40 | 41 | The \texttt{aflodds} dataset includes the results of Australian football games played from 26th March 2009 until 24th June 2012. We use the 2009 and 2010 games for our training data, the 2011 games for our test data and the 2012 data (which represents only the first half of the 2012 season) as our validation data. For the game results we will only use win, loss or draw information, ignoring the size of any victory. 42 | 43 | <<>>= 44 | library(PlayerRatings) 45 | afl <- aflodds[,c(2,3,4,7)] 46 | train <- afl[afl$Week < 100,] 47 | test <- afl[afl$Week >= 100 & afl$Week < 150,] 48 | valid <- afl[afl$Week >= 150,] 49 | head(train,12) 50 | @ 51 | 52 | All modelling functions in the package can be used to update player ratings over several time periods, or over individual time periods. For example, the following code uses \texttt{steph} to iteratively update the team ratings once every round in the \texttt{train} data. The state of the system is contained in the \texttt{ratings} component of the returned object, which can then be passed back into the function for subsequent updates. 53 | 54 | <<>>= 55 | sobj <- steph(train[train$Week==1,]) 56 | for(i in 2:80) sobj <- steph(train[train$Week==i,], sobj$ratings) 57 | @ 58 | 59 | More simply, we can call the function once to perform the same task. 60 | 61 | <<>>= 62 | sobj <- steph(train, history = TRUE) 63 | sobj 64 | @ 65 | 66 | In either case, the resulting \texttt{sobj} object is identical. It gives the current (i.e.\ the end of 2010) rating for all 16 teams, and also gives a deviation parameter, which is an assessment of the accuracy of the rating. The deviation parameters are similar since all teams play roughly the same number of games. The lag parameter shows the number of weeks since each team has played; the two zero lags are associated with the two teams that played in the grand final of 2010. Unusually, the grand final of 2010 was drawn and was replayed the following week, and therefore no team has a lag value of one. 67 | 68 | The following code uses the \texttt{plot} function to plot traces of the ratings across the 2009-2010 period for all 16 teams. We begin the period with no information, and therefore initially the rating changes are large. As the system learns about the teams the rating traces begin to stabilize. Flat lines denote the periods of inactivity that occur for teams not involved in the finals series, which takes place following the regular season. 69 | 70 | <>= 71 | plot(sobj, npl=16) 72 | abline(v=c(27,55),lty=2,lwd=2,col="grey") 73 | text(c(14,42),c(2500,2500),c("2009","2010"),cex=1.5) 74 | @ 75 | 76 | \begin{figure}[ht] 77 | \begin{center} 78 | <>= 79 | <> 80 | @ 81 | \end{center} 82 | \vspace{-1cm} 83 | \caption{Plots of ratings traces for the 16 teams during 2009-2010, beginning with no information.} 84 | \label{inffig} 85 | \end{figure} 86 | 87 | The \texttt{predict} function gives predictions of future matches, expressed as a value in the interval $[0,1]$. In this vignette we use the argument \texttt{thresh} to instead produce binary values representing the predicted winner. This example predicts the results of round one in 2011 and compares the predictions to the actual outcomes. A new team was introduced in 2011; by default the prediction of matches involving new teams (less than 15 games) will be missing. We override this behaviour using the argument \texttt{trat}, which sets the parameters of new teams\footnote{The new team did not play in round one and therefore in this particular case the argument makes no difference to the output.} for prediction purposes. 88 | 89 | <<>>= 90 | test1 <- test[test$Week==min(test$Week),] 91 | pred <- predict(sobj, test1, trat = c(1900,300), thresh = 0.5) 92 | cbind(test1, Predict = pred) 93 | @ 94 | 95 | We now combine the above code snippets in order to predict all games in the test set. We first run the system on the training data, and then loop through each round of the test set. 96 | 97 | <<>>= 98 | sobj <- steph(train, init = c(2200,300), cval = 8, 99 | hval = 8, lambda = 5) 100 | pred <- NULL 101 | for(i in unique(test$Week)) { 102 | testi <- test[test$Week == i,] 103 | predi <- predict(sobj, testi, trat = c(1900,300), gamma = 30, 104 | thresh = 0.5) 105 | pred <- c(pred, predi) 106 | sobj <- steph(testi, sobj$ratings, init = c(2200,300), cval = 8, 107 | hval = 8, lambda = 5) 108 | } 109 | table(Result=test$Score, Predictions=pred) 110 | @ 111 | 112 | We now make a couple of adjustments to the above. Firstly, we better account for new teams entering the system. In Australian football, the two new teams introduced in 2011 and 2012 were largely made up of younger players and were expected to me much weaker. To account for this, we create our own starting object \texttt{st0} to initialize the system, allowing the \texttt{init} argument to apply to the new teams only, and hence allowing us to account for this expected weakness. 113 | 114 | Secondly, we focus on the \texttt{gamma} argument to \texttt{predict}, which accounts for the home team advantage. In Australian football teams are often from the same location or share the same ground, in which case the home advantage is likely to be zero. We can account for this, with a little work, by passing a vector to gamma. We first define a helper function which returns a logical vector to indicate whether the away team is travelling. 115 | 116 | <<>>= 117 | trav <- function(dat) { 118 | teams <- sort(unique(afl$HomeTeam)) 119 | locs <- c("Ade","Bri","Mel","Mel","Mel","Per","Gel","Bri","Syd", 120 | "Mel","Mel","Mel","Ade","Mel","Mel","Syd","Per","Mel") 121 | (locs[factor(dat$HomeTeam,levels=teams)] 122 | != locs[factor(dat$AwayTeam,levels=teams)]) 123 | } 124 | @ 125 | 126 | In the code below, we multiply our original \texttt{gamma} value by \texttt{trav(testi)} in order to specify a zero home advantage when the away team does not travel. 127 | 128 | <<>>= 129 | st0 <- data.frame(Player=sort(unique(train$HomeTeam)), Rating=2200, 130 | Deviation=300, stringsAsFactors=FALSE) 131 | sobj <- steph(train, st0, init = c(1900,300), cval = 8, 132 | hval = 8, lambda = 5) 133 | pred <- NULL 134 | for(i in unique(test$Week)) { 135 | testi <- test[test$Week == i,] 136 | predi <- predict(sobj, testi, trat = c(1900,300), 137 | gamma = 30*trav(testi), thresh = 0.5) 138 | pred <- c(pred, predi) 139 | sobj <- steph(testi, sobj$ratings, init = c(1900,300), cval = 8, 140 | hval = 8, lambda = 5) 141 | } 142 | rp <- table(Result=test$Score, Predictions=pred) 143 | rp 144 | round(100*(rp[1,2]+rp[nrow(rp),1])/sum(rp), 2) 145 | @ 146 | 147 | The mis-classification percentage as given above (which counts draws as correctly classified) may be overly optimistic since we roughly chose our parameters to be optimal over the test data\footnote{The football dataset is much smaller and contains far less information than the chess dataset, and therefore different parameter combinations often yield similar predictions.}. We therefore combine our training and test datasets to predict results on the validation data using the same parameters. In other words, we use the 2009-2011 results to predict the results in the first half of the 2012 season. 148 | 149 | <<>>= 150 | st0 <- data.frame(Player=sort(unique(train$HomeTeam)), Rating=2200, 151 | Deviation=300, stringsAsFactors=FALSE) 152 | sobj <- steph(rbind(train,test), st0, init = c(1900,300), cval = 8, 153 | hval = 8, lambda = 5) 154 | pred <- NULL 155 | for(i in unique(valid$Week)) { 156 | testi <- valid[valid$Week == i,] 157 | predi <- predict(sobj, testi, trat = c(1900,300), 158 | gamma = 30*trav(testi), thresh = 0.5) 159 | pred <- c(pred, predi) 160 | sobj <- steph(testi, sobj$ratings, init = c(1900,300), cval = 8, 161 | hval = 8, lambda = 5) 162 | } 163 | rp <- table(Result=valid$Score, Predictions=pred) 164 | rp 165 | round(100*(rp[1,2]+rp[nrow(rp),1])/sum(rp), 2) 166 | sobj 167 | @ 168 | 169 | The code takes less than one-tenth of one second on my machine. We correctly predict $72.2\%$ of the game results in the first half of 2012. We show above the current ratings as of 24th June 2012. We see that the two new teams (the lowest rated) have larger deviation values because they have played less games. 170 | 171 | We finish by showing plots of the rating traces for the 16 established teams from mid-2010 to mid-2012. The rating trace plots require the full history of the process to be retained, which requires re-running the updates with the argument \texttt{history} set to \texttt{TRUE}. The current top eight teams are plotted first, with the remainder plotted second. 172 | 173 | <<>>= 174 | sobj <- steph(rbind(train,test,valid), st0, init = c(1900,300), cval = 8, 175 | hval = 8, lambda = 5, history = TRUE) 176 | p1 <- sobj$ratings[1:8,1]; p2 <- sobj$ratings[9:16,1] 177 | @ 178 | <>= 179 | plot(sobj, t0 = 40, players = p1, ylim = c(2050,2350),lwd = 2) 180 | abline(v=c(55,83),lty=2,lwd=2,col="grey") 181 | legend(70,2160,p1,lty=1:5,col=1:6,lwd=3,cex=0.8) 182 | text(c(47,70,90),rep(2320,3),c("2010","2011","2012"),cex=1.5) 183 | @ 184 | <>= 185 | plot(sobj, t0 = 40, players = p2, ylim = c(2050,2350),lwd = 2) 186 | abline(v=c(55,83),lty=2,lwd=2,col="grey") 187 | legend(68,2350,p2,lty=1:5,col=1:6,lwd=3,cex=0.8) 188 | text(c(47,70,90),rep(2070,3),c("2010","2011","2012"),cex=1.5) 189 | @ 190 | 191 | \begin{figure}[ht] 192 | \begin{center} 193 | <>= 194 | <> 195 | @ 196 | \end{center} 197 | \vspace{-1cm} 198 | \caption{Plots of ratings traces for eight football teams from mid-2010 to mid-2012.} 199 | \end{figure} 200 | 201 | \begin{figure}[ht] 202 | \begin{center} 203 | <>= 204 | <> 205 | @ 206 | \end{center} 207 | \vspace{-1cm} 208 | \caption{Plots of ratings traces for eight football teams during mid-2010 to mid-2012.} 209 | \end{figure} 210 | 211 | \section{Glicko-2 Ratings} 212 | 213 | In the Glicko-2 rating system each team has a volatility parameter in addition to a deviation parameter. The calculation of the volatility requires a single parameter function optimization for each team within each time period, and will therefore be slower than Glicko or Stephenson. 214 | 215 | <<>>= 216 | library(PlayerRatings) 217 | afl <- aflodds[,c(2,3,4,7)] 218 | train <- afl[afl$Week < 100,] 219 | test <- afl[afl$Week >= 100 & afl$Week < 150,] 220 | valid <- afl[afl$Week >= 150,] 221 | sobj <- glicko2(train, history = TRUE) 222 | print(sobj, cols=1:4) 223 | @ 224 | 225 | The traces of the ratings for the Glicko-2 system are given below. Glicko-2 is primarily designed for situations where a player (or team) plays several games in any single time period. This is not the case here, and therefore the volatilities show little movement. This can be seen from plotting the volatility traces using \texttt{plot(sobj, npl=16, which = "Volatility")}. 226 | 227 | <>= 228 | plot(sobj, npl=16) 229 | abline(v=c(27,55),lty=2,lwd=2,col="grey") 230 | text(c(14,42),c(2500,2500),c("2009","2010"),cex=1.5) 231 | @ 232 | 233 | \begin{figure}[ht] 234 | \begin{center} 235 | <>= 236 | <> 237 | @ 238 | \end{center} 239 | \vspace{-1cm} 240 | \caption{Plots of Glicko-2 ratings traces for the 16 teams during 2009-2010, beginning with no information.} 241 | \label{inffig2} 242 | \end{figure} 243 | 244 | The code in the previous section can be replicated for Glicko-2, with only minor alterations. The volatility parameter must be included in the status object and in the \texttt{init} vector. The Glicko-2 system parameter is called \texttt{tau}; smaller values of \texttt{tau} restrict the movement of the volatilities. If \texttt{tau} is zero or negative, then the volatilities are never updated. The code below provides an example. 245 | 246 | <<>>= 247 | st0 <- data.frame(Player=sort(unique(train$HomeTeam)), Rating=2200, 248 | Deviation=300, Volatility=0.15, stringsAsFactors=FALSE) 249 | sobj <- glicko2(train, st0, init = c(1900,300,0.15), tau = 1.2) 250 | pred <- NULL 251 | for(i in unique(test$Week)) { 252 | testi <- test[test$Week == i,] 253 | predi <- predict(sobj, testi, trat = c(1900,300), 254 | gamma = 30*trav(testi), thresh = 0.5) 255 | pred <- c(pred, predi) 256 | sobj <- glicko2(testi, sobj$ratings, init = c(1900,300,0.15), 257 | tau = 1.2) 258 | } 259 | rp <- table(Result=test$Score, Predictions=pred) 260 | rp 261 | round(100*(rp[1,2]+rp[nrow(rp),1])/sum(rp), 2) 262 | @ 263 | 264 | \section*{Bibliography} 265 | 266 | Elo, A. (1978) \textit{The Rating of Chessplayers, Past and Present}. Arco. ISBN 0-668-04721-6 267 | 268 | Glickman, M. E. (1999) Parameter estimation in large dynamic paired comparison experiments. \textit{Applied Statistics}, \textbf{48}, 377--394. 269 | 270 | Glickman, M.E. (2001) Dynamic paired comparison models with stochastic variances. \textit{Journal of Applied Statistics}, \textbf{28}, 673-689. 271 | 272 | \end{document} 273 | 274 | 275 | 276 | 277 | 278 | 279 | --------------------------------------------------------------------------------