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和Name出現，但我們現在只擔心name），這將構成data中每個矩陣的唯一行。

從這里開始，我們檢查每個人的日期是否與已知最早的日期對齊，如果不是，則用一個空行填充他們的矩陣。

現在，我們循環搜索每個人中的每個日期，檢查他們的日期是否與要迭代的當前日期對齊（如果不是，則填充NA並轉到下一個（請參見下文）），然后計算該人的變化百分比已付款，具體取決於先前的值是多少（0和NA會導致問題，因此我們需要if此處使用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)
)