R:为团队游戏实施 Elo 评级;在循环中为多个变量赋值

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

我有这样的数据:

  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

a1,a2,a3...,h4,h5栏中的数字是玩家的唯一id。 (a1, ... , a5)在"away"队打球,(h1, ..., h5)是他们的对手。

每一行都是游戏中的一个事件。

"a.evt.score"表示客队是否"won"赛事

我想为每个玩家在数据中的每个事件(行)后计算他的 Elo 评分。

用于计算玩家评分的公式为:

R_new = R_old + k*(分数 - 预期)

如果球队赢得比赛,"Score" 为 1,否则为 0。

设 k 为 30(表示每个事件对整体评分的影响程度)。

并让每位玩家的初始 R_old 为 2200。

"Expected",我用公式计算(假设我们正在看客队球员1):

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

因此,a1 的新评级为:

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

我希望我的最终结果是一个向量,对于每个玩家, 他们的 Elo 评级历史。

因此,对于数据中的每一行,我想:

  1. 获取每个参与的玩家的最新 Elo。将其设置为 R_old.
  2. 对于每个玩家,根据事件的结果计算一个新的 Elo。
  3. 将这个新评级 (R_new) 附加到每个玩家历史向量的开头。

我 运行 遇到的问题是当我无法弄清楚如何从命名变量(给定玩家的 Elo 历史向量)中提取值 (R_old) 时'm 在 loop/apply 函数中,或者如何将计算出的评分附加到变量。

我怎样才能完成上述操作?

我最好的选择,可能还有改进的余地。

主要思想是建立一个玩家列表,其中一个条目由玩家 id 存储玩家得分历史记录。

新的分数计算是在一个单独的函数中完成的,也许我没有完全明白你想要做什么。我希望我的评论足以解释发生了什么。

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" 球队球员的评分或期望值。这将使此代码更容易适应超过 2 支球队的赛事(例如联赛)。

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

}

输出将是一个包含 16 个元素的列表 ratings,以及包含 15 个元素的 rostersratings 中的元素 x 是 before 事件编号 x 中的元素 x,而 rosters 中的元素 x 是 after 事件的结果数字 x.

让我们以事件 2 为例(即 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

初看似乎一切正常:8名早前未上场的选手起始rating为2200,2名早前在获胜队伍中的选手rating > 2200。对新队员的期待"h" 是 0.5,因为他们与团队 "a" 中所有球员(都是新人)的评分相同。

活动 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 名被评分的球员,这应该与您的 table.

中唯一球员号码的总数相匹配

编辑: 我错过了所需的输出是玩家评级历史的向量(感谢@Tensibai 指出这一点)。为此,我创建了一个辅助函数来通过他的 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)
}

您可以直接调用例如

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