Почему мой код так медленно выполняется в R?

Question

Пожалуйста, у меня есть датафрейм, который содержит список продуктов. Для каждого продукта я делаю экстраполяцию, чтобы найти пропущенные значения (столбец должен быть списком от 1 до 20 ). Затем я также проверяю, было ли определенное значение в a дублировано много раз, поэтому я создайте новый столбец, чтобы подсчитать его. В конце каждый продукт будет иметь только одну строку с 20 кулонами b и 20 столбцами подсчета избыточности каждого класса

Код запущен и работает, однако он так долго выполнить :

Похожие данные:

a<-c(1, 3, 4, 8.7, 8.7, 9, 10, 12, 19.3, 20,5, 7, 8, 9, 9.1, 11, 11, 11, 12, 14)
b<-c(10, 30, 40, 60, 87, 90, 100, 120, 190, 200,8, 3, 5, 60, 87, 90, 130, 120, 190, 200)
prod_id<-c(1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2)
df<-data.frame(a=a, b=b, prod=prod_id)

Манипуляции:

  df_result<- data.frame()
prods<- dplyr::distinct(df,prod_id)$prod_id #Distinct Prod_ID
for(j in 1:NROW(prods)) {
  dfj<- filter(df, prod_id==prods[j]) 
  sdf<-as.data.frame(Hmisc::approxExtrap(dfj$a, dfj$b, xout = c(1:20))) #Extrapolating
  sdf$z<-stack(pmax(table(factor(as.integer(dfj$a), levels = 1:20)), 1))[2:1]$values - 1 #Increment if a value was there more than 1 time
  sdf<-select_(sdf,"y","z") 
  sdf<-as.data.frame(t(unlist(sdf))) 
  df_result<-rbind(df_result,sdf)

}

результат выглядит следующим образом

> df_result
  y1   y2 y3   y4       y5       y6       y7       y8 y9       y10 y11 y12     y13      y14      y15      y16      y17      y18      y19 y20 z1 z2 z3 z4 z5 z6
1 10 20.0 30 40.0 44.25532 48.51064 52.76596 57.02128 90 100.00000 110 120 129.589 139.1781 148.7671 158.3562 167.9452 177.5342 187.1233 200  0  0  0  0  0  0
2 18 15.5 13 10.5  8.00000  5.50000  3.00000  5.00000 60  88.42105  90 190 195.000 200.0000 205.0000 210.0000 215.0000 220.0000 225.0000 230  0  0  0  0  0  0
  z7 z8 z9 z10 z11 z12 z13 z14 z15 z16 z17 z18 z19 z20
1  0  1  0   0   0   0   0   0   0   0   0   0   0   0
2  0  0  1   0   2   0   0   0   0   0   0   0   0   0

Answer 1

Вот новое решение с data.table:

  dt <- as.data.table(df)

  do_stuff <- function(a, b) {
    sdf <- Hmisc::approxExtrap(a, b, xout = c(1:20))
    sdf$z <- stack(pmax(table(factor(as.integer(a), levels = 1:20)), 1))$values - 1
    sdf <- as.data.frame(t(unlist(sdf[c("y", "z")]))) 
    sdf
  }

  df_result <- dt[, do_stuff(a, b), by = prod_id]

и эталон с оригиналом :

library(microbenchmark)
library(dplyr)
library(data.table)

microbenchmark(
"original" = {
  df_result <- data.frame()
  prods<- dplyr::distinct(df,prod_id)$prod_id #Distinct Prod_ID
  for(j in 1:NROW(prods)) {
    dfj<- filter(df, prod_id==prods[j]) 
    sdf<-as.data.frame(Hmisc::approxExtrap(dfj$a, dfj$b, xout = c(1:20))) #Extrapolating
    sdf$z<-stack(pmax(table(factor(as.integer(dfj$a), levels = 1:20)), 1))[2:1]$values - 1 #Increment if a value was there more than 1 time
    sdf<-select_(sdf,"y","z") 
    sdf<-as.data.frame(t(unlist(sdf))) 
    df_result<-rbind(df_result,sdf)
  }
},
"new" = {
  dt <- as.data.table(df)

  do_stuff <- function(a, b) {
    sdf <- Hmisc::approxExtrap(a, b, xout = c(1:20))
    sdf$z <- stack(pmax(table(factor(as.integer(a), levels = 1:20)), 1))$values - 1
    sdf <- as.data.frame(t(unlist(sdf[c("y", "z")]))) 
    sdf
  }

  df_result <- dt[, do_stuff(a, b), by = prod_id]
}
)

Результаты:

Unit: milliseconds
     expr       min        lq     mean    median        uq       max neval
 original 20.090200 20.841403 22.63290 21.705137 23.479769 32.535576   100
      new  2.063369  2.279269  2.61532  2.411447  2.538806  9.312241   100