R：爲團隊遊戲實施Elo評級;從環

Question

內分配值，以多個變量我有一個看起來像這樣的數據：

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）在「客場」球隊上場，（h1，...，h5）是他們的對手。

每一行都是遊戲中的事件。

「a.evt.score」表示客隊是否贏得了比賽。

我想爲每個玩家計算數據中每個事件（行）後的Elo分級。

用於計算玩家的等級的公式爲：

ř _new = ř _old + K *（分數 - 預期）

其中 「分數」如果該隊贏得該事件則爲1，否則爲0。

設k爲30（說明每個事件對整體評級的影響程度）。

並擁有每一個玩家與2200

「預期」的R_old開始，我計算與公式（說我們是在客隊看着球員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）/ apply函數，或者如何將計算的評級附加到變量。

我該如何去做上述事情？

Answer 1

我最好打賭，可能還有改進的空間。

其主要思想是建立一個玩家列表，其中一個玩家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) 

Answer 2

我建立並保持在每個事件後每個玩家的等級的一個獨立的運行列表。這樣你可以在下一個事件中引用它來計算。

首先，加載所有的數據，參數和包。

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

} 

的輸出將是一個列表ratings用16族元素，和rosters具有15個元素。 ratings中的元素x是在事件編號x之前的等級，而rosters中的元素x是在事件編號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，因爲他們與團隊「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個額定播放器，這應該與表中唯一玩家號碼的總數相匹配。

編輯：我錯過了期望的輸出是球員評級歷史的向量（謝謝@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