Как повысить производительность работы цикла

Question

У меня проблема с производительностью моего кода R, который проверяет мой фрейм данных на комбинации с определенными условиями. Для каждой строки в моем фрейме данных мне нужны все комбинации, в которых переменная «A» этой строки больше или равна переменной «B» всех остальных строк. В конце мне нужна матрица, которая состоит из 3 столбцов со всеми комбинациями:

1. столбец: номер строки из переменной A
2. столбец: номер строки, в которой переменная B меньше, чем A
3. столбец: -1

И мне нужно это проверить для каждой строки. Может быть, моя проблема прояснится, когда вы увидите мой код.

Z <-data.frame(index1=NA,index2=NA,index3=NA)

for(i in 1:nrow(my.data)){

  interim_result <- my.data[i,"A"] >= my.data$B
  if(sum(is.na(interim_result))!=length(interim_result)){

    Y <- rbind(rep(i, sum(interim_result*1)), which(interim_result == TRUE), rep(-1, sum(interim_result)))
    print(i)
    Y <- t(Y)
    colnames(Y) <- c("index1","index2","index3")
    Z <- rbind(Z,Y)
  }
}

Я проверил свой код, и он отлично работает, но он слишком медленный. Мой фрейм данных имеет около 350 тыс. Строк, а вычисления занимают вечность. У кого-нибудь есть идея, что я могу ускорить это?

Answer 1

Используйте outer() и which().

set.seed(1)
n_rows <- 10
my.data <- data.frame(A = rnorm(n_rows), B = rnorm(n_rows))

mat <- which(outer(my.data[['A']], my.data[['B']], '>='), arr.ind = T)
colnames(mat) = c('index2', 'index1')

mat[, c('index1', 'index2')]

      index1 index2
 [1,]      1      4
 [2,]      2      4
 [3,]      2      7
 [4,]      2      8
 [5,]      2      9
 [6,]      3      2
 [7,]      3      4
 [8,]      3      5
 [9,]      3      7
... a total of 39 rows

Я не включил index3, потому что это константа. Если он всегда равен -1, то он не слишком полезен.

Мне удалось получить большую скорость с помощью цикла, добавив идентификатор к исходному data.frame и используя lapply. Это позволило мне пропустить вызов which, а также не беспокоиться о предварительном выделении для Z

  my.data$ID <- seq_len(nrow(my.data))
do.call(rbind
        , lapply(seq_len(nrow(my.data))
                 , function (i) {
                   interim_result <- my.data[['ID']][my.data[i, "A"] >= my.data[['B']]]
                   if (length(interim_result) != 0) {
                     cbind(index1 = i,index2 = interim_result,index3 = -1)
                   }
                   }
                 )
)

Наконец, если вы в data.table, вы можете использовать неэквивалентное объединение.

  dt <- as.data.table(my.data)

  dt[, ID := seq_len(.N)]

  dt[dt 
     , on = .(A >= B)
     , .(index1 = i.ID, index2 = ID, index3 = -1)
     , allow.cartesian = T
     ]

Производительность 10 строк data.frame:

Unit: microseconds
            expr     min         lq       mean     median         uq       max neval
   original_loop 12607.5 12687.6510 13420.3960 12843.0520 13260.4010 17939.301    20
      optim_loop   412.5   439.4515   695.5263   451.2510   462.0020  5345.802    20
          dt_way  3053.0  3140.7510  3269.0610  3268.9010  3351.2010  3667.601    20
 outer_statement    48.5    53.9005    65.7108    70.6505    72.7515    75.701    20

100 строк данных. Кадр:

Unit: microseconds
            expr       min        lq      mean     median        uq       max neval
   original_loop 42241.600 43560.001 48111.291 46051.7515 48297.301 79910.601    20
      optim_loop  3888.601  4010.551  4775.211  4107.6010  4299.400  9010.601    20
          dt_way  3356.902  3595.601  3857.906  3752.8505  3966.701  5330.101    20
 outer_statement   304.901   312.401   344.661   332.5005   348.701   473.000    20

1000 строк - удаление исходного цикла:

Unit: milliseconds
            expr     min       lq     mean   median       uq     max neval
      optim_loop 55.0290 58.18355 60.50015 60.08140 62.47300 66.6332    20
          dt_way 29.1114 29.66050 32.19182 30.00790 30.88125 45.7993    20
 outer_statement 24.2323 24.44935 26.87686 24.64055 27.48775 35.9967    20

10000 строк:

Unit: seconds
            expr      min       lq     mean   median       uq      max neval
      optim_loop 2.233144 2.277568 2.401055 2.382523 2.496764 2.615275     5
          dt_way 3.622701 3.638953 3.660230 3.639226 3.649577 3.750691     5
 outer_statement 3.250272 3.353263 3.369732 3.375544 3.409773 3.459810     5

Мой компьютер после этого разваливается. Удивительно для меня, оптимизированный цикл начинает продвигаться вперед.