优化R中的for循环

Question

DUMMY DATA SET :(与我的数据集不同的是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 seconds循环数据帧需要多长时间(循环500行).

EDIT_IMPORTANT:但是对于上面给出的虚拟数据集,所有需​​要的是1.10 seconds得到输出 >这可能是因为有item_code的字符串？是否需要花费大量时间来处理字符串item_code.(我没有使用假人数据集的字符串,因为我不知道如何有500个独特的字符串item_code中in_cluster,并且具有相同的字符串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]])

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

在这种情况下是否可以使用lapply？我尝试下面的代码并得到一个错误:

filter_impl(.data,dots)中的错误:$运算符对原子向量无效

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]]而且每行都mean_trajectory与循环无关？你可以在之后分配它).
5. 而这样的例子不胜枚举...

我建议一个替代的简单data.table解决方案,它会表现得更好.我们的想法是首先在in_cluster和之间建立二进制连接real_sales(并在连接时运行所有操作,而不创建额外的数据帧然后绑定它们).然后,只运行一次所有mean_trajectory相关的行.(我忽略了training_df[nrow(training_df) + 1, ] <- c(0, 0, mean_trajectory$sales[[1]], 0, 0, 19)初始化,因为它在这里无关紧要,你可以在之后使用和添加它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秒,而你的解决方案无休止地运行直到我杀了它(半小时后).