R: Implementing Elo ratings for team game; assigning values to multiple variables from within a loop

Question

I have data that looks like this:

  a1   a2   a3   a4   a5   h1   h2   h3   h4   h5 a.evt.score   h.evt.score
3311 4003 2737 3784 4177 2632  726  633  438 5444           0             1
1696  371 4471 2119  274 1947 5745 3622  438 5444           1             0           
1696  371 4471 1199 2230 1947 5745 3622 5034 4166           1             0 
3191 4471 2737  274 2230 3598  633 5034 5444 3485           1             0
3191 3685 3486 3784 4177 2632  726  633  438 5444           0             1 
127  713 1609 5444 4166 3311  371 4471 1199 2230           1             0
127  713 1609 2345 3485 1696 4003 2737 1199 2230           1             0
127  713 1609 2345 3485 1696 4003 2737 1199 2230           1             0
1947 5745 3622  438 5444 3311  371 4471 3784 4177           1             0
2632  726  633 5444 4166 3191 3685 3486  274 2230           0             1
2632  726  633  438 5444 3191 3685 3486 3784 4177           0             1
5745 3598 5198 4166 3485 1696 4003 2737  274 2230           0             1
2632  726  633 2345 5034 3311  371 4471 3784 4177           1             0
127 3859  726  438 5444 1696 4003 2737 2119  274           1             0
2632  713  633 5034 4166 3191 3685 3486 3784 4177           1             0

The numbers in the a1, a2, a3..., h4, h5 columns are unique ids of players. (a1, ... , a5) play on the "away" team, and (h1, ..., h5) are their opponents.

Each row is an event in the game.

"a.evt.score" indicates whether or not the away team "won" the event.

I would like to, for each player, calculate his Elo rating after every event (row) in the data.

The formula used to calculate a players' rating is:

R_new = R_old + k*(Score - Expected)

Where "Score" is 1 if the team wins the event, and 0 if not.

Let k be 30 (tells how much each event influences the overall rating).

And have every player start with an R_old of 2200.

"Expected", I calculate with the formula (say we are looking at player 1 on the away team):

h.R <- c(h1.R, h2.R, h3.R, h4.R, h5.R)
a1.E <- sum(1/(1+10^((h.R - a1.R)/400)))/5

So, a1's new rating would be:

a1.R <- a1.R + 30*(a.evt.score - a1.E)

I would like my end result to be a vector, for every player, of their history of Elo ratings.

So, for every row in the data, I would like to:

1. Get the most recent Elo for every player involved. Set this to R_old.
2. For each player, calculate a new Elo based on the result of the event.
3. Append this new rating (R_new) to the start of each players' history vector.

The issue I'm running into is that I can't figure out how to pull a value (R_old) from a named variable (a given player's Elo history vector) when I'm inside a loop/apply function, or how to append the calculated rating to the variable.

How can I go about doing the above?

Answer 1

My best bet, there's probably room for improvement.

The main idea is to build a list of players, with one entry by player id to store the player score history.

The new score calculation is done in a separate function, maybe I didn't get exactly what you're wishing to do. I hope I commented enough to explain what's going on.

k<-30
ateam<-paste0("a",1:5)
hteam<-paste0("h",1:5)
playersid <- unique(unname( unlist( datas[, c(ateam,hteam) ] ) ))
scores=as.list(rep(2200,length(playersid)))
names(scores)<-playersid

getPlayerScore <- function(player,team_score,opponents_scores) {
  old_score <- scores[[as.character(player)]][1]
  expect <- sum(1/10^((opponents_scores - old_score)/400))/5
  return(old_score + k*(team_score - expect))
}

updateTeamPlayersScore<-function(row,team) {
  opteam<-ifelse(team=="a","h","a") # get the team we're against
  players <- unlist(row[get(paste0(team,"team"))]) # get the players list
  opponents <- unlist(row[get(paste0(opteam,"team"))]) # get the oppenents list
  # Get the oppents scores 
  opponents_score <- sapply(scores[as.character(opponents)],function(x) { x[[1]] } ) 
  # loop over the players and return the list of updated scores
  r<-lapply(players,function(x) {
    new_score <- getPlayerScore(x,as.numeric(row[paste0(team,".evt.score")]),opponents_score)
    c(new_score,scores[[as.character(x)]])
  })
  # Update the list names
  names(r) <- as.character(opponents)
  r # return the new scores list
}

# loop over the rows.
# The update is done after calculation to avoid side-effect on h scores with updated a scores
for (i in 1:nrow(datas)) {
  row <- datas[i,]
  # Get updated scores for team a
  new_a <- updateTeamPlayersScore(row,"a")
  # Get updated scores for team h
  new_h <- updateTeamPlayersScore(row,"h")
  # update team 'a' scores
  scores[names(new_a)] <- new_a
  # update team 'h' scores
  scores[names(new_h)] <- new_h
}

Result

> head(scores)
$`3311`
[1] 2124.757 2119.203 2111.189 2136.164 2165.133 2200.000

$`1696`
[1] 2135.691 2135.032 2170.030 2168.635 2200.000 2200.000

$`3191`
[1] 2142.342 2141.330 2176.560 2174.560 2170.000 2200.000

$`127`
[1] 2098.406 2123.018 2158.292 2193.603 2200.000

$`1947`
[1] 2158.292 2193.603 2200.000

$`2632`
[1] 2100.837 2132.849 2168.509 2173.636 2170.000 2200.000

Data used:

datas<-read.table(text="  a1   a2   a3   a4   a5   h1   h2   h3   h4   h5 a.evt.score   h.evt.score
    3311 4003 2737 3784 4177 2632  726  633  438 5444           0             1
    1696  371 4471 2119  274 1947 5745 3622  438 5444           1             0           
    1696  371 4471 1199 2230 1947 5745 3622 5034 4166           1             0 
    3191 4471 2737  274 2230 3598  633 5034 5444 3485           1             0
    3191 3685 3486 3784 4177 2632  726  633  438 5444           0             1 
    127  713 1609 5444 4166 3311  371 4471 1199 2230           1             0
    127  713 1609 2345 3485 1696 4003 2737 1199 2230           1             0
    127  713 1609 2345 3485 1696 4003 2737 1199 2230           1             0
    1947 5745 3622  438 5444 3311  371 4471 3784 4177           1             0
    2632  726  633 5444 4166 3191 3685 3486  274 2230           0             1
    2632  726  633  438 5444 3191 3685 3486 3784 4177           0             1
    5745 3598 5198 4166 3485 1696 4003 2737  274 2230           0             1
    2632  726  633 2345 5034 3311  371 4471 3784 4177           1             0
    127 3859  726  438 5444 1696 4003 2737 2119  274           1             0
    2632  713  633 5034 4166 3191 3685 3486 3784 4177           1             0",header=T)

Answer 2

I build and maintain a separate running list of ratings of every player after every event. That way you can refer to it for calculation in the next event.

First, loading all data , parameters and packages.

library(tidyr)
library(dplyr)

crosstab <- read.table(header=T,
                       text="  a1   a2   a3   a4   a5   h1   h2   h3   h4   h5 a.evt.score   h.evt.score
                       3311 4003 2737 3784 4177 2632  726  633  438 5444           0             1
                       1696  371 4471 2119  274 1947 5745 3622  438 5444           1             0           
                       1696  371 4471 1199 2230 1947 5745 3622 5034 4166           1             0 
                       3191 4471 2737  274 2230 3598  633 5034 5444 3485           1             0
                       3191 3685 3486 3784 4177 2632  726  633  438 5444           0             1 
                       127  713 1609 5444 4166 3311  371 4471 1199 2230           1             0
                       127  713 1609 2345 3485 1696 4003 2737 1199 2230           1             0
                       127  713 1609 2345 3485 1696 4003 2737 1199 2230           1             0
                       1947 5745 3622  438 5444 3311  371 4471 3784 4177           1             0
                       2632  726  633 5444 4166 3191 3685 3486  274 2230           0             1
                       2632  726  633  438 5444 3191 3685 3486 3784 4177           0             1
                       5745 3598 5198 4166 3485 1696 4003 2737  274 2230           0             1
                       2632  726  633 2345 5034 3311  371 4471 3784 4177           1             0
                       127 3859  726  438 5444 1696 4003 2737 2119  274           1             0
                       2632  713  633 5034 4166 3191 3685 3486 3784 4177           1             0")

#parameters
k <- 30
seed.rating <- 2200   # default used if a player is not found on ratings table

Next, two local helper functions to do the expectation calculations.

# calculate expected win against an opponent
calcExpect <- function(rating, opp.rating) {
  return(1/(1+10^((opp.rating-rating)/400)))
}

# calculate average expectation of a player against all opponents in current event
compileExpect <- function(id) {
  rowno <- which(roster$playerid==id)
  opp <- roster %>% filter(ah!=roster$ah[rowno])
  all.expected <- sapply(opp$rating,
                         function(x) calcExpect(roster$rating[rowno], x))
  return(mean(all.expected))
}

Then setup the list that is updated after every event (i.e. ratings list, and optionally result after every event). Here we start with an empty ratings list, but if you have an existing rating list, you can easily start with that data frame as the first element in the list.

# start with a blank rating list; can always start with the latest ELO table
ratings <- list(data.frame(playerid=integer(0), rating=numeric(0)))

# optional for logging result for every round, for error checking
rosters <- NULL

Now the main meat: loop through the entire events data i.e. crosstab and processing each event, creating one entry in ratings (and optionally rosters) after every event.

You will notice that after I built the roster, I don't have different code lines to calculate ratings or expectation for players on "a" or "h" teams. This should make this code easier to adapt for events where there are more than 2 teams (e.g. a league).

for (i in seq_len(nrow(crosstab))) {

  # get latest ratings
  elo <- as.data.frame(tail(ratings, 1))

  # take one row of data corresponding to an event
  event <- crosstab[i, ]

  # spread the row into a player roster
  roster <- event %>% gather(key=no, value=playerid, a1:h5) %>%
    mutate(ah = substr(no, 1, 1),    # away or home team
           score = ifelse(ah=="a", a.evt.score, h.evt.score)) %>%   #win or lose
    select(playerid, ah, score) %>%
    left_join(elo)  # get current rating

  # unrated players assigned base rating
  roster$rating[is.na(roster$rating)] <- seed.rating

  # calculate expected and new ratings of event participants
  roster$expected <- sapply(roster$playerid, compileExpect)
  roster$new.rating <- with(roster, rating + k*(score-expected))

  # calculate new overall ratings
  new.ratings <- roster %>% select(playerid, new.rating) %>%
    rename(rating=new.rating) %>%
    rbind(elo) %>%
    filter(!duplicated(playerid))  # remove old ratings of player

  #update ratings
  ratings <- c(ratings, list(new.ratings))

  # Optional for error checking: update log of result every round
  rosters <- c(rosters, list(roster))

}

The output would be a list ratings with 16 elements, and rosters with 15 elements. Element x in ratings is the ratings before event number x, while element x in rosters is the outcome after event number x.

Let's take for example event 2 (i.e. second row in your table).

> rosters[[2]]
   playerid ah score rating  expected new.rating
1      1696  a     1   2200 0.4913707   2215.259
2       371  a     1   2200 0.4913707   2215.259
3      4471  a     1   2200 0.4913707   2215.259
4      2119  a     1   2200 0.4913707   2215.259
5       274  a     1   2200 0.4913707   2215.259
6      1947  h     0   2200 0.5000000   2185.000
7      5745  h     0   2200 0.5000000   2185.000
8      3622  h     0   2200 0.5000000   2185.000
9       438  h     0   2215 0.5215733   2199.353
10     5444  h     0   2215 0.5215733   2199.353

Initial inspection seems that everything is in order: 8 players who didn't play earlier have starting rating of 2200, two players who were on the winning team earlier have rating > 2200. Expectation for new players in team "h" is 0.5, because they have same ratings as all players in team "a" (who are all new).

Ratings after event 2 would be the ratings before event 3 (which include players from both event 1 and event 2):

> ratings[[3]]
   playerid   rating
1       438 2199.353
2      1947 2185.000
3      2632 2215.000
4      2119 2215.259
5      3622 2185.000
6      3311 2185.000
7      4003 2185.000
8       726 2215.000
9      5444 2215.000
10     1696 2215.259
11      371 2215.259
12      274 2215.259
13     3784 2185.000
14     4471 2215.259
15     4177 2185.000
16     5745 2185.000
17      633 2215.000
18     2737 2185.000

At the end of it all, there are 33 rated players in ratings[[16]], which should match the total number of unique player numbers in your table.

EDIT: I missed out that the desired output is vector of player rating history (thanks @Tensibai for pointing that out). To do that, I create a helper function to pull out any players history by his id.

getPlayerHistory <- function(id) {
  # pull all ratings of the player
  temp <- lapply(ratings, function(x) x$rating[x$playerid==id])
  # coerce into vector with same length as the list, forcing parts with no values into NA
  vec <- do.call(c, lapply(temp, function(x) {length(x) <- 1; return(x)}))
  return(vec)
}

You can call up directly e.g.

getPlayerHistory("5034")
 [1]       NA       NA       NA 2185.395 2171.403 2171.403 2171.403 2171.403 2171.403
[10] 2171.403 2171.403 2171.403 2171.403 2186.862 2186.862 2202.293

Note that there are 16 values in this vector, because they are ratings before an event. So the first NA is because there was no starting rating, the next two NAs are because player "5034" played for the first time in event 3, so the first rating available is before event 4. When the player didn't play in an event, his rating stays the same.

You can use the helper function to pull the entire rating history into a list.

idList <- tail(ratings, 1)[[1]]$playerid   # get the latest ratings list
ratList <- lapply(idList, getPlayerHistory)
names(ratList) <- idList

Then you can get the same by calling the list.

> ratList[["5034"]]
 [1]       NA       NA       NA 2185.395 2171.403 2171.403 2171.403 2171.403 2171.403
[10] 2171.403 2171.403 2171.403 2171.403 2186.862 2186.862 2202.293