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-01-01支付20美元，在2000-01-02支付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，每個循環一個？

謝謝！

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) 
)