計算R中的移動新近加權平均值

Question

我想計算一匹馬的移動新近加權平均完成位置給出馬匹參與的一系列比賽的時間（日）和結束位置（pos）。 這些統計數據在設定障礙方面很有用。

目前，我正在使用“loop-inside-a-loop”方法。 是否有更快或更優雅的R語言方法來解決這個問題？

#
# Test data
#

day <- c(0, 6, 10, 17, 21, 26, 29, 31, 34, 38, 41, 47, 48, 51, 61)
pos <- c(3, 5, 6, 1, 1, 3, 4, 1, 2, 2, 2, 6, 4, 5, 6)
testdata <- data.frame(id = 1, day = day, pos = pos, wt.pos = NA)

#
# No weight is given to observations earlier than cutoff
#

cutoff <- 30

#
# Rolling recency-weighted mean (wt.pos)
#

for(i in 2:nrow(testdata)) {
  wt <- numeric(i-1)
  for(j in 1:(i-1))
    wt[j] <- max(0, cutoff - day[i] + day[j] + 1)
    if (sum(wt) > 0)
      testdata$wt.pos[i] <- sum(pos[1:j] * wt) / sum(wt)
}

> testdata

   id day pos   wt.pos
1   1   0   3       NA
2   1   6   5 3.000000
3   1  10   6 4.125000
4   1  17   1 4.931034
5   1  21   1 3.520548
6   1  26   3 2.632911
7   1  29   4 2.652174
8   1  31   1 2.954128
9   1  34   2 2.436975
10  1  38   2 2.226891
11  1  41   2 2.119048
12  1  47   6 2.137615
13  1  48   4 3.030534
14  1  51   5 3.303704
15  1  61   6 4.075000

Answer 1

我會去的

# Calculate `wt` for all values of `i` in one go
wt <- lapply(2:nrow(testdata), function(i)
    pmax(0, cutoff - day[i] + day[1:(i-1)] + 1))

# Fill in the column
testdata$wt.pos[-1] <- mapply(
    function(i, w) if(sum(w) > 0) sum(pos[1:i]*w)/sum(w) else NA,
    1:(nrow(testdata)-1), wt)

請注意，通過計算同時j所有值的第二個參數max ，我們已經對計算進行了矢量化，從而將速度提高了許多個數量級。

我發現沒有簡單的方法來矢量化外部循環和if情況（除了在C中重寫它看起來像是矯枉過正），但是lapply ， mapply和類似仍然比for循環更快。

Answer 2

此版本演示了如何計算1個或多個變量（例如，完成位置，速度等級）和1個或更多個主題（馬）的移動新近度加權平均值。

library(plyr)

day <- c(0, 6, 10, 17, 21, 26, 29, 31, 34, 38, 41, 47, 48, 51, 61)
pos <- c(3, 5, 6, 1, 1, 3, 4, 1, 2, 2, 2, 6, 4, 5, 6)
dis <- 100 + 0.5 * (pos - 1)
testdata1 <- data.frame(id = 1, day = day, pos = pos, dis = dis)
day <- c(0, 4, 7, 14, 22, 23, 31, 38, 42, 47, 52, 59, 68, 69, 79)
pos <- c(1, 3, 2, 6, 4, 5, 2, 1, 4, 5, 2, 1, 5, 5, 2)
dis <- 100 + 0.5 * (pos - 1)
testdata2 <- data.frame(id = 2, day = day, pos = pos, dis = dis)
testdata <- rbind(testdata1, testdata2)

# Moving recency-weighted mean
rollmean <- function(day, obs, cutoff = 90) {
  obs <- as.matrix(obs)
  wt <- lapply(2:nrow(obs), function(i)
    pmax(0, cutoff - day[i] + day[1:(i-1)] + 1))
  wt.obs <- lapply(1:(nrow(obs)-1), FUN =
    function(i)
      if(sum(wt[[i]]) > 0) {
        apply(obs[1:i, , drop = F] * wt[[i]], 2, sum) / sum(wt[[i]])
      } else {
        rep(NA, ncol(obs))
      }
  )
  answer <- rbind(rep(NA, ncol(obs)), do.call(rbind, wt.obs))
  if (!is.null(dimnames(answer)))
    dimnames(answer)[[2]] <- paste("wt", dimnames(answer)[[2]], sep = ".")
  return(answer)
}

x <- dlply(testdata, .(id), .fun =
  function(DF) rollmean(DF$day, DF[, c("pos", "dis"), drop = F])
)
y <- do.call(rbind, x)