按组滚动/移动平均

Posted 2023-02-16

【中文标题】按组滚动/移动平均

【英文标题】：Rolling / moving avg by group

【发布时间】：2015-01-18 14:28:42

【问题描述】：

如何使用分组数据生成滚动平均值。这是数据

set.seed(31)
dd<-matrix(sample(seq(1:20),30,replace=TRUE),ncol=3)

添加组标识符，并按组标识符排序

du<-sample(seq(1:4),10,replace=TRUE)
d<-cbind(du,dd)
d<-d[order(d[,1]),]

这给出了滚动平均值，但忽略了组边界

d_roll_mean <- apply(d[,2:4], 2, 
                   function(x) 
                     rollapply(zoo(x), 3, mean, partial=TRUE, align='right')
                   
)

这给出了下面的结果

# cbind(d,d_roll_mean)
# [1,]  1  3  3 12  3.000000  3.000000 12.000000
# [2,]  2 10 13  8  6.500000  8.000000 10.000000
# [3,]  2 17  2 17 10.000000  6.000000 12.333333
# [4,]  3 14  6  3 13.666667  7.000000  9.333333
# [5,]  3  6 20  1 12.333333  9.333333  7.000000
# [6,]  3  1 16 19  7.000000 14.000000  7.666667
# [7,]  3 19  2 11  8.666667 12.666667 10.333333
# [8,]  4 12  1  9 10.666667  6.333333 13.000000
# [9,]  4 10 13 12 13.666667  5.333333 10.666667
# [10,]  4  8 20  7 10.000000 11.333333  9.333333  

这是目标，按组边界滚动平均值

# Desired
# [1,]  1  3  3 12  3.000000  3.000000 12.000000
# [2,]  2 10 13  8 10.000000 13.000000  8.000000
# [3,]  2 17  2 17 13.500000  7.500000 12.500000
# [4,]  3 14  6  3 14.000000  6.000000  3.000000
# [5,]  3  6 20  1 10.000000 13.000000  2.000000
# [6,]  3  1 16 19  7.000000 14.000000  7.666667
# [7,]  3 19  2 11  8.666667 12.666667 10.333333
# [8,]  4 12  1  9 12.000000  1.000000  9.000000
# [9,]  4 10 13 12 11.000000  7.000000 10.500000
# [10,]  4  8 20  7 10.000000 8.000000  9.333333

这很接近，但会按因子生成列表，而不是矩阵

doApply <- function(x) 
  apply(x, 2, 
        function(y) 
          rollapply(zoo(y), 3, mean, partial=TRUE, align='right')
        )


d2_roll_mean <- by(d[,2:4], d[,1], doApply)

所以有一些问题的答案，这是它们在执行时间上的比较

set.seed(31)

nrow=20000
ncol=600
nun=350
nValues = 20
dd<-matrix(sample(seq(1:nValues),nrow*ncol,replace=TRUE),ncol=ncol)
du<-sample(seq(1:nun),nrow,replace=TRUE)
d<-cbind(du,dd)
d<-d[order(d[,1]),]
library(zoo)
doApply <- function(x) 
  apply(x, 2, 
        function(y) 
          rollapply(zoo(y), 3, mean, partial=TRUE, align='right')
        )

library(data.table)
library(caTools)

fun1<-function(d) by(d[,-1], d[,1], doApply)
fun2<- function(d)
  DT <- data.table(d, key='du')
  DT[, lapply(.SD, function(y) 
    runmean(y, 3, alg='fast',align='right')), by=du]


system.time(d2_roll_mean <- fun1(d))
system.time(d2_roll_mean2 <- fun2(d))

时序表明使用数据表比rollapply快10倍左右。

          user   system  elapsed 
fun1  1048.910    0.378 1049.158 
fun2   107.296    0.097  107.392 

我没有得到平等，但通过检查，它们看起来是一样的......

d2a<-do.call(rbind,d2_roll_mean)
d2b<-cbind(1,d2a)
d2c<-data.table(d2b)
setnames(d2c,names(d2c),names(d2_roll_mean2))

all.equal(d2c,d2_roll_mean2)

all equal的输出是

[1] "Attributes: < Length mismatch: comparison on first 1 components >"
[2] "Component “du”: Mean relative difference: 175.6631"               

将上述方法应用于数据时，产生以下错误

Error in `[<-`(`*tmp*`, (k2 + 1):n, , value = 2) : 
  subscript out of bounds 

此错误是由于某些因素导致的行数太少。这些行已被删除，并且该过程有效。参考：How to drop factors that have fewer than n members

【参考方案1】：

使用data.table 和caTools

library(data.table)
library(caTools)
DT <- data.table(d, key='du')
DT[, lapply(.SD, function(y) 
       runmean(y, 3, alg='fast',align='right')), by=du]

更新

如果要在现有数据集中创建新列

 nm1 <- paste0('V', 2:4)
 nm2 <- paste0("V", 4:6)
 DT[, (nm1):=lapply(.SD, as.numeric), .SDcols=nm1][,
      (nm2):=lapply(.SD, function(y) runmean(y, 3, alg='fast',
                             align='right')), by=du]

【参考方案2】：

唯一缺少的是do.call(rbind,d2_roll_mean)。添加原始数据：

cbind(d,do.call(rbind,d2_roll_mean))

编辑：我通过system.time() 运行了一个更大的例子，它确实花了很多时间：

set.seed(31)
dd <- matrix(sample(seq(1:20),20000*500,replace=TRUE),ncol=500)
du <- sample(seq(1:350),20000,replace=TRUE)
d <- cbind(du,dd)
d <- d[order(d[,1]),]

system.time(d2_roll_mean <- by(d[,-1], d[,1], doApply))
       User      System      elapsed 
     399.60        0.57       409.91

by() 和 apply() 不是最快的函数。实际上，使用for 循环遍历列并通过蛮力执行此操作实际上可能更快，这取决于d 按ID 排序的事实。

【讨论】：

如果我有 20000 行、500 列和 350 个组 ID，效率如何？不同的方法更快吗？

我看到其他人使用“过滤器”，这可能比rollapply更快。

你在运行什么机器？我走开了，但已经超过 7 分钟了……我现在要去吃午饭了，希望我回来时已经完成了……