R: Внедрение рейтингов Эло для командной игры; присвоение значений нескольким переменным из цикла

Лучше всего, что, вероятно, есть возможности для улучшения.

Основная идея состоит в том, чтобы создать список игроков с одной записью по идентификатору игрока для хранения истории очков игрока.

Новый подсчет баллов выполняется в отдельной функции, возможно, я не совсем понял то, что вы хотели сделать. Надеюсь, я прокомментировал достаточно, чтобы объяснить, что происходит.

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
}

Результат

> 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

Использованные данные:

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)

Я составляю и поддерживаю отдельный текущий список рейтингов каждого игрока после каждого события. Таким образом, вы можете обратиться к нему для расчета в следующем мероприятии.

Во-первых, загрузка всех данных, параметров и пакетов.

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

Затем две локальные вспомогательные функции для вычисления математического ожидания.

# 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))
}

Затем настройте список, который обновляется после каждого события (т. Е. Список рейтингов и, возможно, результат после каждого события). Здесь мы начинаем с пустого списка рейтингов, но если у вас есть существующий список рейтингов, вы можете легко начать с этого фрейма данных в качестве первого элемента в списке.

# 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

Теперь основная суть: перебирать все данные событий, то есть crosstab, и обрабатывать каждое событие, создавая одну запись в ratings (и, возможно, rosters) после каждого события.

Вы заметите, что после того, как я построил список, у меня нет разных строк кода для расчета рейтингов или ожиданий для игроков в командах «a» или «h». Это должно упростить адаптацию этого кода к событиям, в которых участвует более двух команд (например, лига).

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))

}

Результатом будет список ratings с 16 элементами и rosters с 15 элементами. Элемент x в ratings - это рейтинг до события номер x, а элемент x в rosters - результат после события номер x.

Возьмем, к примеру, событие 2 (т.е. вторую строку в вашей таблице).

> 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

При первичной проверке кажется, что все в порядке: 8 игроков, которые ранее не играли, имеют стартовый рейтинг 2200, два игрока, которые ранее были в команде-победителе, имеют рейтинг> 2200. Ожидание новых игроков в команде «h» - 0,5, потому что у них такие же рейтинги, как и у всех игроков в команде «а» (все новые).

Рейтинги после события 2 будут рейтингами до события 3 (включая игроков как из события 1, так и из события 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

В конце концов, в ratings[[16]] 33 игрока с рейтингом, что должно соответствовать общему количеству уникальных номеров игроков в вашей таблице.

РЕДАКТИРОВАТЬ: Я упустил из виду, что желаемый результат - это вектор истории рейтингов игроков (спасибо @Tensibai за указание на это). Для этого я создаю вспомогательную функцию, которая вытаскивает историю любого игрока по его идентификатору.

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)
}

Вы можете позвонить напрямую, например,

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

Обратите внимание, что в этом векторе 16 значений, поскольку они являются оценками до события. Итак, первое NA связано с отсутствием стартового рейтинга, следующие два NA связаны с тем, что игрок «5034» впервые играл в событии 3, поэтому первый доступный рейтинг имеется перед событием 4. Когда игрок не играл в событии событие, его рейтинг остается прежним.

Вы можете использовать вспомогательную функцию, чтобы вывести всю историю рейтингов в список.

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

Затем вы можете получить то же самое, позвонив в список.

> 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