将这个丑陋的 for 循环转换为对 R 更友好的东西答案

【问题标题】：Converting this ugly for-loop to something more R-friendly将这个丑陋的 for 循环转换为对 R 更友好的东西
【发布时间】：2012-07-31 23:25:54
【问题描述】：

一直使用 SO 作为我工作的资源。感谢您将这样一个伟大的社区团结在一起。

我正在尝试做一些有点复杂的事情，而我现在唯一能想到的方法是使用一对嵌套的 for 循环（我知道这在 R 中是不受欢迎的）......我有记录300 万多门课程注册：学生用户 ID 与 CourseID 配对。在每一行中，都有一堆数据，包括开始/结束日期和分数等。我需要做的是，对于每次注册，计算该用户在注册课程之前所学课程的平均分数。

我用于 for 循环的代码如下：

data$Mean.Prior.Score <- 0
for (i in as.numeric(rownames(data)) {
    sum <- 0
    count <- 0
    for (j in as.numeric(rownames(data[data$UserID == data$UserID[i],]))) {
            if (data$Course.End.Date[j] < data$Course.Start.Date[i]) {
                sum <- sum + data$Score[j]
                count <- count + 1
            }
    }
if (count != 0)
    data$Mean.Prior.Score[i] <- sum / count
}

我很确定这会奏效，但它运行得非常慢...我的数据框有超过 300 万行，但经过 10 分钟的运行，外部循环只运行了 850 条记录。这似乎比时间复杂度所暗示的要慢得多，尤其是考虑到每个用户平均只有 5 或 6 门课程。

哦，我应该提到我在运行循环之前使用 as.POSIXct() 转换了日期字符串，所以日期比较步骤应该不会太慢......

必须有更好的方法来做到这一点......有什么建议吗？

编辑：按照 mnel 的要求……终于让dput 玩得很好。必须添加control = NULL。这里是：

structure(list(Username = structure(1:20, .Label = c("100225", 
"100226", "100228", "1013170", "102876", "105796", "106753", 
"106755", "108568", "109038", "110150", "110200", "110350", "111873", 
"111935", "113579", "113670", "117562", "117869", "118329"), class = "factor"), 
User.ID = c(2313737L, 2314278L, 2314920L, 9708829L, 2325896L, 
2315617L, 2314644L, 2314977L, 2330148L, 2315081L, 2314145L, 
2316213L, 2317734L, 2314363L, 2361187L, 2315374L, 2314250L, 
2361507L, 2325592L, 2360182L), Course.ID = c(2106468L, 2106578L, 
2106493L, 5426406L, 2115455L, 2107320L, 2110286L, 2110101L, 
2118574L, 2106876L, 2110108L, 2110058L, 2109958L, 2108222L, 
2127976L, 2106638L, 2107020L, 2127451L, 2117022L, 2126506L
), Course = structure(c(1L, 7L, 10L, 15L, 11L, 19L, 4L, 6L, 
3L, 12L, 2L, 9L, 17L, 8L, 20L, 18L, 13L, 16L, 5L, 14L), .Label = c("ACCT212_A", 
"BIOS200_N", "BIS220_T", "BUSN115_A", "BUSN115_T", "CARD205_A", 
"CIS211_A", "CIS275_X", "CIS438_S", "ENGL112_A", "ENGL112_B", 
"ENGL227_K", "GM400_A", "GM410_A", "HUMN232_M", "HUMN432_W", 
"HUMN445_A", "MATH100_X", "MM575_A", "PSYC110_Y"), class = "factor"), 
Course.Start.Date = structure(c(1098662400, 1098662400, 1098662400, 
1309737600, 1099267200, 1098662400, 1099267200, 1099267200, 
1098662400, 1098662400, 1099267200, 1099267200, 1099267200, 
1098662400, 1104105600, 1098662400, 1098662400, 1104105600, 
1098662400, 1104105600), class = c("POSIXct", "POSIXt"), tzone = "GMT"), 
Term.ID = c(12056L, 12056L, 12056L, 66282L, 12057L, 12056L, 
12057L, 12057L, 12056L, 12056L, 12057L, 12057L, 12057L, 12056L, 
13469L, 12056L, 12056L, 13469L, 12056L, 13469L), Term.Name = structure(c(2L, 
2L, 2L, 4L, 1L, 2L, 1L, 1L, 2L, 2L, 1L, 1L, 1L, 2L, 3L, 2L, 
2L, 3L, 2L, 3L), .Label = c("Fall 2004", "Fall 2004 Session A", 
"Fall 2004 Session B", "Summer Session A 2011"), class = "factor"), 
Term.Start.Date = structure(c(1L, 1L, 1L, 4L, 2L, 1L, 2L, 
2L, 1L, 1L, 2L, 2L, 2L, 1L, 3L, 1L, 1L, 3L, 1L, 3L), .Label = c("2004-10-21", 
"2004-10-28", "2004-12-27", "2011-06-26"), class = "factor"), 
Score = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.125, 
0, 0, 0, 0, 0), First.Course.Date = structure(c(1L, 1L, 1L, 
4L, 2L, 1L, 2L, 2L, 1L, 1L, 2L, 2L, 2L, 1L, 3L, 1L, 1L, 3L, 
1L, 3L), .Label = c("2004-10-25", "2004-11-01", "2004-12-27", 
"2011-07-04"), class = "factor"), First.Term.Date = structure(c(1L, 
1L, 1L, 4L, 2L, 1L, 2L, 2L, 1L, 1L, 2L, 2L, 2L, 1L, 3L, 1L, 
1L, 3L, 1L, 3L), .Label = c("2004-10-21", "2004-10-28", "2004-12-27", 
"2011-06-26"), class = "factor"), First.Timer = c(TRUE, TRUE, 
TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, 
TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), Course.Code = structure(c(1L, 
6L, 9L, 13L, 9L, 17L, 4L, 5L, 3L, 10L, 2L, 8L, 15L, 7L, 18L, 
16L, 11L, 14L, 4L, 12L), .Label = c("ACCT212", "BIOS200", 
"BIS220", "BUSN115", "CARD205", "CIS211", "CIS275", "CIS438", 
"ENGL112", "ENGL227", "GM400", "GM410", "HUMN232", "HUMN432", 
"HUMN445", "MATH100", "MM575", "PSYC110"), class = "factor"), 
Course.End.Date = structure(c(1L, 1L, 1L, 4L, 2L, 1L, 2L, 
2L, 1L, 1L, 2L, 2L, 2L, 1L, 3L, 1L, 1L, 3L, 1L, 3L), .Label = c("2004-12-19", 
"2005-02-27", "2005-03-26", "2011-08-28"), class = "factor")), .Names = c("Username", 
"User.ID", "Course.ID", "Course", "Course.Start.Date", "Term.ID", 
"Term.Name", "Term.Start.Date", "Score", "First.Course.Date", 
"First.Term.Date", "First.Timer", "Course.Code", "Course.End.Date"
), row.names = c(NA, 20L), class = "data.frame")

【问题讨论】：

您可以输入(head(data, n=50)) 以便我们了解您的数据吗？一个 data.table 解决方案在招手。
完成...从一开始就应该这样做；对不起。
不要只显示它们，请在它们上使用 dput 以便我们重现它
或者只是data<-droplevels(data)
+1 表示响应迅速、礼貌并提供了可重复的示例。 FWIW，循环不被反对，如果你不预先分配你的对象，它只是次优的。我强烈推荐阅读 Patrick Burns 的《R inferno》（也经常光顾这个论坛）。

标签： r loops aggregate vectorization

【解决方案1】：

我发现data.table 运行良好。

# Create some data.
library(data.table)
set.seed(1)
n=3e6
numCourses=5 # Average courses per student
data=data.table(UserID=as.character(round(runif(n,1,round(n/numCourses)))),course=1:n,Score=runif(n),CourseStartDate=as.Date('2000-01-01')+round(runif(n,1,365)))
data$CourseEndDate=data$CourseStartDate+round(runif(n,1,100))
setkey(data,UserID)
# test=function(CourseEndDate,Score,CourseStartDate) sapply(CourseStartDate, function(y) mean(Score[y>CourseEndDate]))
# I vastly reduced the number of comparisons with a better "test" function.
test2=function(CourseEndDate,Score,CourseStartDate) {
    o.end = order(CourseEndDate)
    run.avg = cumsum(Score[o.end])/seq_along(CourseEndDate)
    idx=findInterval(CourseStartDate,CourseEndDate[o.end])
    idx=ifelse(idx==0,NA,idx)
    run.avg[idx]
}
system.time(data$MeanPriorScore<-data[,test2(CourseEndDate,Score,CourseStartDate),by=UserID]$V1) 
#  For three million courses, at an average of 5 courses per student:
#    user  system elapsed 
#    122.06    0.22  122.45

运行测试以查看它是否与您的代码相同：

set.seed(1)
n=1e2
data=data.table(UserID=as.character(round(runif(n,1,1000))),course=1:n,Score=runif(n),CourseStartDate=as.Date('2000-01-01')+round(runif(n,1,365)))
data$CourseEndDate=data$CourseStartDate+round(runif(n,1,100))
setkey(data,UserID)
data$MeanPriorScore<-data[,test2(CourseEndDate,Score,CourseStartDate),by=UserID]$V1
data["246"]
#   UserID course     Score CourseStartDate CourseEndDate MeanPriorScore
#1:    246     54 0.4531314      2000-08-09    2000-09-20      0.9437248
#2:    246     89 0.9437248      2000-02-19    2000-03-02             NA

# A comparison with your for loop (slightly modified)
data$MeanPriorScore.old<-NA # Set to NaN instead of zero for easy comparison.
# I think you forgot a bracket here. Also, There is no need to work with the rownames.
for (i in seq(nrow(data))) { 
    sum <- 0
    count <- 0
    # I reduced the complexity of figuring out the vector to loop through.
    # It will result in the exact same thing if there are no rownames.
    for (j in which(data$UserID == data$UserID[i])) {
            if (data$CourseEndDate[j] <= data$CourseStartDate[i]) {
                sum <- sum + data$Score[j]
                count <- count + 1
            }
    }
    # I had to add "[i]" here. I think that is what you meant.
    if (count != 0) data$MeanPriorScore.old[i] <- sum / count 
}
identical(data$MeanPriorScore,data$MeanPriorScore.old)
# [1] TRUE

【讨论】：

我有兴趣对此进行测试，但似乎数据在data[,...,by=X] 中重新排序，因此 V1 的分配与原始未排序的数据不一致。我尝试使用MeanPriorScore:=...，但显然没有实现。有什么想法可以让它发挥作用吗？
抱歉，test 函数中有一个小错字。我添加了一个较小的测试集，并输出结果。只要您调用setkey，数据就会重新排序。但是MeanPriorScore的顺序应该和新的顺序正确对齐，如上图。
最后，我在test函数中使用findInterval大大提高了速度。
为了更公平的比较，我平均每个学生有 5 门课程。
非常感谢，@nograpes...这是一个很好的解决方案。关于行名的东西完全被黑了，其他的错误只是我在打字时犯的愚蠢错误；甚至不在我正在运行的脚本中。

【解决方案2】：

我无法真正对此进行测试，因为您的数据似乎不满足任何组合的不等式，但我会尝试这样的事情：

library(plyr)
res <- ddply(data, .(User.ID), function(d) {
   with(subset(merge(d, d, by=NULL, suffixes=c(".i", ".j")),
               Course.End.Date.j < Course.Start.Date.i),
        c(Mean.Prior.Score = mean(Score.j)))
})
res$Mean.Prior.Score[is.nan(res$Mean.Prior.Score)] = 0

这是它的工作原理：

ddply： 按User.ID 对数据进行分组，并对d 行的每个子集执行函数User.ID
合并： 为一位用户创建两份数据副本，一份以.i 为后缀，另一份以.j 为后缀
子集：从这个外连接中，只选择那些匹配给定不等式的人
mean：计算匹配行的均值
c(...): 为结果列命名
res: 将是一个带有User.ID 和Mean.Prior.Score 列的data.frame
is.nan: mean 将为零长度向量返回 NaN，将它们更改为零

如果每个User.ID 没有太多行，我想这可能会相当快。如果这还不够快，其他答案中提到的data.tables 可能会有所帮助。

您的代码在所需输出上有点模糊：您将data$Mean.Prior.Score 视为长度为一的变量，但在循环的每次迭代中都分配给它。我假设此分配仅适用于一行。您需要数据框每一行的均值，还是每个用户只需要一个均值？

【讨论】：

【解决方案3】：

拥有 300 万行数据，也许数据库会有所帮助。这是一个 sqlite 示例，我相信它会创建类似于您的 for 循环的内容：

# data.frame for testing
user <- sample.int(10000, 100)
course <- sample.int(10000, 100)
c_start <- sample(
  seq(as.Date("2004-01-01"), by="3 months", length.ou=12), 
  100, replace=TRUE
)
c_end <- c_start + as.difftime(11, units="weeks")
c_idx <- sample.int(100, 1000, replace=TRUE)
enroll <- data.frame(
  user=sample(user, 1000, replace=TRUE), 
  course=course[c_idx], 
  c_start=as.character(c_start[c_idx]), 
  c_end=as.character(c_end[c_idx]), 
  score=runif(1000),
  stringsAsFactors=FALSE
)

#variant 1: for-loop
system.time({
enroll$avg.p.score <- NA
for (i in 1:nrow(enroll)) {
  sum <- 0
  count <- 0
  for (j in which(enroll$user==enroll$user[[i]])) 
    if (enroll$c_end[[j]] < enroll$c_start[[i]]) {
      sum <- sum + enroll$score[[j]]
      count <- count + 1
    }
  if(count !=0) enroll$avg.p.score[[i]] <- sum / count
} 
})

#variant 2: sqlite
system.time({
library(RSQLite)
con <- dbConnect("SQLite", ":memory:")
dbWriteTable(con, "enroll", enroll, overwrite=TRUE)

sql <- paste("Select e.user, e.course, Avg(p.score)",
             "from enroll as e",
             "cross join enroll as p", 
             "where e.user=p.user and p.c_end < e.c_start",
             "group by e.user, e.course;")
res <- dbSendQuery(con, sql)
dat <- fetch(res, n=-1)
})

在我的机器上，sqlite 快十倍。如果这还不够，还可以索引数据库。

【讨论】：

【解决方案4】：

我认为这样的方法应该可行，尽管每个用户拥有多个课程的测试数据会很有帮助。也可能需要在 findInterval 中的开始日期 +1 以使条件为 End.Date

# in the test data, one is POSIXct and the other a factor
data$Course.Start.Date = as.Date(data$Course.Start.Date)
data$Course.End.Date = as.Date(data$Course.End.Date)
data = data[order(data$Course.End.Date), ]
data$Mean.Prior.Score = ave(seq_along(data$User.ID), data$User.ID, FUN=function(i)
    c(NA, cumsum(data$Score[i]) / seq_along(i))[1L + findInterval(data$Course.Start.Date[i], data$Course.End.Date[i])])

【讨论】：

【解决方案5】：

这只是我认为解决方案可能需要的概要。为了简单起见，我将使用plyr 来说明所需的步骤。

我们只限于一个学生的情况。如果我们可以为一个学生计算这个，那么通过某种拆分应用来扩展它将是微不足道的。

假设我们有一个特定学生的分数，按课程结束日期排序：

d <- sample(seq(as.Date("2011-01-01"),as.Date("2011-01-31"),by = 1),100,replace = TRUE)
dat <- data.frame(date = sort(d),val = rnorm(100))

首先，我认为您需要按日期对此进行总结，然后计算累积运行平均值：

dat_sum <- ddply(dat,.(date),summarise,valsum = sum(val),n = length(val))
dat_sum$mn <- with(dat_sum,cumsum(valsum) / cumsum(n))

最后，您将这些值合并回具有重复日期的原始数据：

dat_merge <- merge(dat,dat_sum[,c("date","mn")])

我可能会在 data.table 中使用匿名函数来编写执行此操作的所有步骤，但我怀疑其他人可能能够更好地执行简洁快速的操作。（特别是，我不建议实际使用 plyr 来解决这个问题，因为我怀疑它仍然会非常慢。）

【讨论】：

【解决方案6】：

这似乎是你想要的

library(data.table) 
# create a data.table object
DT <- data.table(data)
# key by userID 
setkeyv(DT, 'userID')

# for each userID, where the Course.End.Date < Course.Start.Date
# return the mean score

# This is too simplistic
# DT[Course.End.Date < Course.Start.Date,
#   list(Mean.Prior.Score = mean(Score)) , 
#   by = list(userID)]

根据@jorans 的评论，这将比上面的代码更复杂。

【讨论】：

我无法让 dput 在这个数据表上工作，因为所有的列都是因子，它想要写入所有级别，无论我采用什么子集......
@AndrewSannier 使用 subset() 和参数 drop = TRUE
@shujaa 那也不行。我猜你的意思是dput(subset(data[1:50,], drop = T))...？
data_50 <- head(data, 50) for(.col in names(data_50)){ if(is.factor(data_50[[.col]])){ data_50[[.col]] <- droplevels(data_50[[.col]]) } }
你也可以用as.character代替droplevels。