r - 优化R中的for循环

Question

虚拟数据集:(与我的数据集不同的是，在我的情况下，item_code 是字符串)

in_cluster <- data.frame(item_code = c(1:500))
in_cluster$cluster <-
        sample(5, size = nrow(in_cluster), replace = TRUE)
real_sales <- data.frame(item_code = numeric(0), sales = numeric(0))
real_sales <-
    data.frame(
            item_code = sample(500, size = 100000, replace = TRUE),
            sales = sample(500, size = 100000, replace = TRUE)
    )

mean_trajectory <- data.frame(sales = c(1:52))
mean_trajectory$sales <- sample(500, size = 52, replace = TRUE)
training_df <- data.frame(
        LTF_t_minus_1 = numeric(0),
        LTF_t = numeric(0),
        LTF_t_plus_1 = numeric(0),
        RS_t_minus_1 = numeric(0),
        RS_t = numeric(0),
        STF_t_plus_1 = numeric(0)
)
training_df[nrow(training_df) + 1, ] <-
        c(0, 0, mean_trajectory$sales[[1]], 0, 0, 19) # week 0

week = 2

我在 R 中有一个简单的函数，我所做的就是:

system.time({
    for (r in 1:nrow(in_cluster)) {
            item <- in_cluster[r,]
            sale_row <-
                    dplyr::filter(real_sales, item_code == item$item_code)
            if (nrow(sale_row) > 2) {
                    new_df <- data.frame(
                            LTF_t_minus_1 = mean_trajectory$sales[[week - 1]],
                            LTF_t = mean_trajectory$sales[[week]],
                            LTF_t_plus_1 = mean_trajectory$sales[[week + 1]],
                            RS_t_minus_1 = sale_row$sales[[week - 1]],
                            RS_t = sale_row$sales[[week]],
                            STF_t_plus_1 = sale_row$sales[[week + 1]]
                    )
                    training_df <-
                            bind_rows(training_df, new_df)
            }
    }
}) 

我对 R 很陌生，发现这真的很奇怪，看看数据到底有多小，但循环数据帧需要多长时间(421.59 秒循环 500 行) 。

编辑重要:但是，对于上面给定的虚拟数据集，只需要 1.10 秒 即可获得输出> 这可能是因为 item_code 有字符串吗？处理一个字符串 item_code 需要那么多时间吗？ (我没有将字符串用于虚拟数据集，因为我不知道如何在 in_cluster 中为 item_code 提供 500 个唯一字符串，并在 中具有相同的字符串real_sales 作为 item_code)

我阅读了几篇其他文章，其中建议了优化 R 代码的方法，并使用 bind_rows 而不是 rbind 或使用:

training_df[nrow(training_df) + 1,] <-
    c(mean_trajectory$sales[[week-1]], mean_trajectory$sales[[week]], mean_trajectory$sales[[week+1]], sale_row$sales[[week-1]], sale_row$sales[[week]], sale_row$sales[[week+1]])

在循环 500 行数据帧时，使用 bind_rows 似乎将性能提高了 36 秒in_cluster

在这种情况下可以使用 lapply 吗？我尝试了下面的代码并收到错误:

Error in filter_impl(.data, dots) : $ operator is invalid for atomic vectors

myfun <- function(item, sales, mean_trajectory, week) {
sale_row<- filter(sales, item_code == item$item_code)
data.frame(
  LTF_t_minus_1 = mean_trajectory$sales[[week-1]],
  LTF_t = mean_trajectory$sales[[week]],
  LTF_t_plus_1 = mean_trajectory$sales[[week+1]],
  RS_t_minus_1 = sale_row$sales[[week-1]],
  RS_t = sale_row$sales[[week]],
  STF_t_plus_1 = sale_row$sales[[week+1]])  
}

system.time({
      lapply(in_cluster, myfun, sales= sales, mean_trajectory = mean_trajectory) %>% bind_rows()
})

有关 lapply 的帮助将不胜感激，但我的主要目标是加快循环速度。

Answer 1

好的，所以您的代码中有很多不好的做法。

1. 您正在按行进行操作
2. 您每行创建 2(!) 个新数据帧(非常昂贵)
3. 您正在循环中生长对象)training_df <- bind_rows(training_df, new_df)在每次迭代中不断增长，同时运行相当昂贵的操作 ( bind_rows ))
4. 当您只能运行一次时，您会一遍又一遍地运行相同的操作(为什么每行运行 mean_trajectory$sales[[week-1]] 和 al 而 mean_trajectory 与循环无关？您可以在之后分配它)。
5. 这样的例子不胜枚举......

我建议一个简单的替代方案 data.table性能会更好的解决方案。这个想法是首先在 in_cluster 之间进行二进制连接。和real_sales (并在加入时运行所有操作，而无需创建额外的数据帧然后绑定(bind)它们)。然后，运行所有 mean_trajectory相关行仅一次。 (我忽略了 training_df[nrow(training_df) + 1, ] <- c(0, 0, mean_trajectory$sales[[1]], 0, 0, 19) 初始化，因为它在这里无关紧要，您可以使用 and rbind 之后添加它)

library(data.table) #v1.10.4
## First step
res <-
  setDT(real_sales)[setDT(in_cluster), # binary join
                  if(.N > 2) .(RS_t_minus_1 = sales[week - 1], # The stuff you want to do
                               RS_t = sales[week],             # by condition
                               STF_t_plus_1 = sales[week + 1]), 
                  on = "item_code", # The join key
                  by = .EACHI] # Do the operations per each join

## Second step (run the `mean_trajectory` only once)
res[, `:=`(LTF_t_minus_1 = mean_trajectory$sales[week - 1],
           LTF_t = mean_trajectory$sales[week],
           LTF_t_plus_1 = mean_trajectory$sales[week + 1])]

---

一些基准:

### Creating your data sets
set.seed(123)
N <- 1e5
N2 <- 5e7

in_cluster <- data.frame(item_code = c(1:N))

real_sales <-
  data.frame(
    item_code = sample(N, size = N2, replace = TRUE),
    sales = sample(N, size = N2, replace = TRUE)
  )

mean_trajectory <- data.frame(sales = sample(N, size = 25, replace = TRUE))

training_df <- data.frame(
  LTF_t_minus_1 = numeric(0),
  LTF_t = numeric(0),
  LTF_t_plus_1 = numeric(0),
  RS_t_minus_1 = numeric(0),
  RS_t = numeric(0),
  STF_t_plus_1 = numeric(0)
)
week = 2

###############################
################# Your solution
system.time({
  for (r in 1:nrow(in_cluster)) {
    item <- in_cluster[r,, drop = FALSE]
    sale_row <-
      dplyr::filter(real_sales, item_code == item$item_code)
    if (nrow(sale_row) > 2) {
      new_df <- data.frame(
        LTF_t_minus_1 = mean_trajectory$sales[[week - 1]],
        LTF_t = mean_trajectory$sales[[week]],
        LTF_t_plus_1 = mean_trajectory$sales[[week + 1]],
        RS_t_minus_1 = sale_row$sales[[week - 1]],
        RS_t = sale_row$sales[[week]],
        STF_t_plus_1 = sale_row$sales[[week + 1]]
      )
      training_df <-
        bind_rows(training_df, new_df)
    }
  }
}) 
### Ran forever- I've killed it after half an hour


######################
########## My solution
library(data.table)
system.time({
res <-
  setDT(real_sales)[setDT(in_cluster), 
                  if(.N > 2) .(RS_t_minus_1 = sales[week - 1],
                               RS_t = sales[week],
                               STF_t_plus_1 = sales[week + 1]), 
                  on = "item_code",
                  by = .EACHI]
res[, `:=`(LTF_t_minus_1 = mean_trajectory$sales[week - 1],
           LTF_t = mean_trajectory$sales[week],
           LTF_t_plus_1 = mean_trajectory$sales[week + 1])]
})

# user  system elapsed 
# 2.42    0.05    2.47 

---

因此，对于 50MM 行， data.table解决方案运行了大约 2 秒，而你的解决方案则无休止地运行，直到我杀死它(半小时后)。