R 适用于嵌套循环

Question

我有一个庞大的数据集，我想对其执行一些操作。使用我当前的代码（如下所示）需要超过 3 个小时（尚未完成）。我通过对较小数据集的一些测试将其缩小到这个嵌套循环，并且需要使用apply 系列函数之一来提高性能（希望如此）和代码清洁度。

file <- read.csv("file.csv")
dates <- unique(file$date)
names <- unique(file$name)

data<-c()
mat<-matrix(,nrow=length(dates),ncol=length(names)) # store % change for all names

# loop for every person
for (i in 1:length(names)) { 
  data[[names[i]]] <- file[file$name == names[i],]
  align = 0 # no data for some dates, need alignment score to align later on

  # if this object does not start on the same date as the earliest date we know,
  # then pad this object with a null row at the top
  if (!rownames(mat)[1] %in% data[[names[i]]]$date) {
    data[[names[i]]] <- rbind(c("0000-00-00",0,as.character(data[[names[i]]]$name[1]),NA,FALSE),data[[names[i]]])
  }

  # loop for every date, beginning at 2 because the first date will not be used
  for (j in 2:length(dates)) {
    if (!rownames(mat)[j] %in% data[[names[i]]]$date) {
      mat[j,i] = NA
      align <- align + 1
      next
    }

    current <- as.numeric(data[[names[i]]]$price[j-align])
    previous <- as.numeric(data[[names[i]]]$price[j-1-align])

    # actions based on current and previous cell values
    if (is.na(previous)) { 
      mat[j,i] <- NA
    } else if (current == 0 & previous == 0) {
      mat[j,i] <-  0
    } else if (current == 0) {
      mat[j,i] <- NA 
    } else if (previous == 0) { 
      mat[j,i] <- NA
    } else {
      mat[j,i] <- current/previous-1 
    }
  }
}

文件看起来像：

         date id      name price  paid
1  2001-01-01  1  redacted  0.00  TRUE     
2  2001-01-02  2  redacted  0.05  TRUE      
3  2001-01-03  1  redacted 200.0 FALSE   

纲要：
我们为每个人循环，将他们的数据存储在一个名为data的矩阵列表中自己的位置。人们不止一次出现（通过 ID 和名称，但我们现在只担心名称），这将构成 data 中每个矩阵的唯一行。

从这里，我们检查每个人的日期是否与已知最早的日期一致，如果不是，则用一个空行填充他们的矩阵。

现在我们循环每个人的每个日期，检查他们的日期是否与当前迭代的日期一致（如果不是，则用 NA 填充并继续下一步（见下文）），然后计算如何变化的百分比这个人已经支付了很多，这取决于之前的值是多少（0 ​​和 NA 会导致问题，所以我们需要if 声明），即。如果他们在 2000 年 1 月 1 日支付了 20 美元，在 2000 年 1 月 2 日支付了 40 美元，那么变化百分比为 100%（显示为 1），因为他们支付了两倍。

所以最终结果 mat 看起来类似于：

              redacted    redacted      redacted
2001-01-01          NA          NA            NA          
2001-01-02           1         0.3           0.2       
2001-01-03         0.5           0            NA

有人可以帮忙吗？我尝试了许多apply 变体，但似乎都没有工作或让我更接近解决方案。我知道这是一个巨大的阅读/问题，所以任何帮助或提示将不胜感激！

似乎我可能需要嵌套apply，每个循环一个？

谢谢！

Answer 1

这是一个解决方案，尽管它需要几个非基础包：

price_diff <- function(x) {  
  zeroes <- sum(which(x == 0))
  if(zeroes == 1) NA else if (zeroes == 2) 0 else x[2] / x[1] - 1
}
file.dt <- data.table(file)[order(date)]
changes <- file.dt[, list(date, change=rollapply(price, 2, price_diff, align="right", fill=NA)),by=name]
dcast(changes, date ~ name, value.var="change")  

结果：

#           date          Bat          Kat           Kit
# 1   2013-01-01           NA           NA            NA
# 2   2013-01-02 -0.044461024  0.391059725  0.0806087565
# 3   2013-01-03 -0.114559555 -0.342706723 -0.1174446516
# ... 197 more rows ...

这产生了与您的方法相同的结果，尽管我必须对您的方法进行一些修复才能使其运行。在我的 200 天 3 人样本中，这也快了大约 20 倍。

我在这里做的是使用data.table 按人拆分数据，然后为每个人使用rollapply 将price_diff 函数应用于2 天窗口，最后data.table 重新-组装这一切。这一切都发生在changes 代码行上。最后dcast这一步，就是把数据转成你想要的格式（不用再计算了，就是从长格式变成宽格式）。

所需的包：

library(data.table)
library(zoo)
library(reshape2)

制作像你一样的数据：

dt.start <- as.Date("2013-01-01")
days <- 200
names <- c("Kat", "Kit", "Bat")
file <- data.frame(
  date=rep(seq(dt.start, length.out=days, by="+1 day"), each=length(names)),
  id=rep(1:length(names), each=days),
  name=rep(names, days),
  price=c(5, 10, 20) + runif(days * length(names), -3, 3),
  paid=sample(c(T, F), days * length(names), replace=T)
)