Альтернатива сложному циклу для повышения производительности

Question

В следующем коде используется кадр данных 20x1, чтобы проверять каждую строку, если какая-либо из 6 строк ниже (то есть строки i + 1 до i + 7) больше трех строк ниже на 2 пункта (например, i + 1 - i + 4> 2). Если true, то 1 записывается во вновь созданный столбец Signal.

Например, для строки один, он проверяет, если:

• строка 2> строка 5 + 2 ИЛИ
• строка 3> строка 6 + 2 ИЛИ

...

• строка 7> строка 10 + 2

Если возможно, я хотел бы найти альтернативный подход к циклу for. Я запускаю этот код шаблона в большой базе данных, и цикл может занять несколько часов. Обратите внимание, что код для цикла является немного сложным, чтобы избежать перехода цикла из-за границы. Большое спасибо @Gregor за его огромную помощь в объединении.

#Data 
df <- data.frame(Price = c(1221, 1220, 1220, 1217, 1216, 1218 , 1216, 1216, 1217, 1220, 1219, 1218, 1220, 1216, 1217, 1218, 1218, 1207, 1206, 1205)) 

#Inputs 
Window = 6    # check up to this far below current row 
IndexDifference = 3  # check row against another this far down 
ValueDifference = 2  # for difference at least this big 

#Define loop boundaries 
base_rows = 1:(nrow(df) - IndexDifference) # can't check more than this 
candidate_max = pmin(base_rows + Window, nrow(df) - IndexDifference) # for a given base row, this is the maximum row to start checking against 

#Make Signal variable 
df$Signal = rep(NA, nrow(df)) #pre-allocate variable 
for (i in seq_along(base_rows)) { 
    df$Signal[i] = as.numeric(
    any(
     df$Price[(i + 1):candidate_max[i]] - 
     df$Price[((i + 1):candidate_max[i]) + IndexDifference] > ValueDifference))} 

Answer 1

Одним из решений этой проблемы является построение двух матриц отстающих столбцов и вычитание одного из другого. Это делает использование векторизации в R и должно быть быстрым.

df0 <- cbind(df$Price[-(1)][1:nrow(df)], sapply(2:Window, function(i)df$Price[-(1:i)][1:nrow(df)])) 
df1 <- sapply((IndexDifference+1):(IndexDifference+Window), function(i)df$Price[-(1:i)][1:nrow(df)]) 
df$Signal <- as.numeric(apply((df0 - df1) > ValueDifference, 1, any, na.rm = TRUE)) 
df$Signal 

Заметим, что это не дает точно такой же результат, как ваш код, вероятно, потому что, когда

i = 17 
(i + 1):candidate_max[i] 

вычисляется как c(18, 17), который, вероятно, не то, что вы хотите.

Answer 2

В вашей петле большинство Price[i] - Price[i + IndexDifference] > ValueDifference вычисляются более одного раза; в этом случае (код в конце) большинство сравнений сделаны в 6 раз:

# [i] [i + IndexDifference] [times calculated] 
# Var1 Var2 Freq 
#70  2 5 1 
#88  3 6 2 
#106 4 7 3 
#124 5 8 4 
#142 6 9 5 
#160 7 10 6 
#178 8 11 6 
#196 9 12 6 
#214 10 13 6 
#232 11 14 6 
#250 12 15 6 
#268 13 16 6 
#286 14 17 6 
#304 15 18 6 
#322 16 19 6 
#340 17 20 6 

Кроме того, я думаю, это не только повторные вычисления сами по себе, но повторяющиеся присвоившей (и Подменю) к «data.frame «s.

Вместо этого вы могли бы вычислить различия и сравнение сразу:

tmp = (df$Price[2:(nrow(df) - IndexDifference)] - 
     df$Price[(2 + IndexDifference):nrow(df)]) > ValueDifference 

И применяешься в прокатной моде, any (с учетом уведомления вашего комментария о не выходя за пределы):

as.integer(sapply(seq_along(tmp), 
        function(i) any(tmp[i:min(length(tmp), (i + (Window - 1)))]))) 
#[1] 1 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 
       #and 4 values are left (rows 17:20 that cannot be 
       #calculated based on the conditions) to be added as `NA` 

Табулирование сравнения:

#re-calculcated your 'base_rows' to not include row 17 as it exceeds tha 'IndexDifference' 
base_rows = 1:(nrow(df) - IndexDifference - 1L) 
candidate_max = pmin(base_rows + Window, nrow(df) - IndexDifference) 

#set-up the tabulations for each comparison  
table_diffs = matrix(0L, 
        base_rows[length(base_rows)] + 1L, 
        candidate_max[length(candidate_max)] + IndexDifference) 
for(i in seq_along(base_rows)) { 
    ij = cbind((i + 1):candidate_max[i], ((i + 1):candidate_max[i]) + IndexDifference) 
    table_diffs[ij] = table_diffs[ij] + 1L 
} 
#format 
subset(transform(as.data.frame(as.table(table_diffs)), 
       Var1 = as.integer(Var1), 
       Var2 = as.integer(Var2)), 
     Freq != 0L) 

Answer 3

Это немного поздно, но в случае, если это полезно.

Я согласен с @alexis_laz, что вычисляется больше сравнений, чем необходимо. Я думаю, что идея может быть сделана еще дальше, потому что, если any применяется катящимся образом, это также приводит к ненужным вычислениям.

Ключ в том, что данная строка всегда сравнивается с другой определенной строкой (ниже в примере ниже).Как только мы узнаем, соответствует ли эквивалентность этой строке, любые другие строки, содержащие ее в данном окне, должны иметь значение 1 (TRUE).

Полезный ярлык здесь является то, что если эквивалентность имеет место для ряда j и что делает ряд i TRUE, и ряд j также в окне строки i+1, то i+1 также TRUE (без необходимости знать о статусе другие точки в окне). Я получаю то, что нам не нужно определять any для окна каждой строки. Если мы знаем, сколько TRUE есть в строке i, для строки i+1 нам просто нужно определить, была ли точка, покидающая окно, ИСТИНА, и имеет ли точка, входящая в окно TRUE. По сути, мы фильтруем вектор с полем Window -width, а затем просто проверяем, какие записи имеют по крайней мере одно значение TRUE в своем окне (это может быть сделано за один проход, но давайте проигнорируем это, поскольку дополнительное время незначительный).

Используя скользящую сумму, мы можем эффективно вычислить это, просто выполнив подсчет и включив/удалив точки, входящие/выходящие из окна. Именно здесь происходит наблюдение @ alexis_laz: состояние точек входа/выхода может быть предварительно рассчитано.

Чтобы сделать вещи более конкретными, вот какой-то код. Во-первых, позвольте мне скопировать ваш исходный цикл, ответ @Richard Telford и ответ @ alexis_laz и включить их в функции (с небольшими перезаписями в основном для личного удобства, поэтому формат вывода совпадает, и, надеюсь, без добавления каких-либо ошибок):

f_G <- function(x, window, idiff, valdiff){ 
    base_rows = 1:(NROW(x) - idiff - 1) # can't check more than this 
candidate_max = pmin(base_rows + window, NROW(x) - idiff) # maximum row to start checking against 
    out = rep(0, NROW(x)) #pre-allocate variable 
    for (i in seq_along(base_rows)) { 
    out[i] = as.numeric(any(x[(i + 1):candidate_max[i]] 
      - x[((i + 1):candidate_max[i]) + idiff] > valdiff))} 
    return(out) 
} 

f_RT <- function(x, window, idiff, valdiff){ 
    x0 <- cbind(x[-(1)][1:NROW(x)], sapply(2:window, 
             function(i)x[-(1:i)][1:NROW(x)])) 
    x1 <- sapply((idiff+1):(idiff+window), 
       function(i)x[-(1:i)][1:NROW(x)]) 
    out <- as.numeric(apply((x0 - x1) > valdiff, 1, any, na.rm = TRUE)) 
    return(out) 
} 

f_AL <- function(x, window, idiff, valdiff){ 
    check = (x[2:(NROW(x) - idiff)] - x[(2 + idiff):NROW(x)]) > valdiff 
    check <- c(check, rep(FALSE, idiff+1)) 
    out <- as.integer(sapply(seq_along(check), 
         function(i) any(check[i:min(length(check), (i + (window - 1)))]))) 
    return(out) 
} 

Тогда вот две функции для вычисления суммы прокатки, описанной выше, над вектором с заранее рассчитанными отличиями (например, предложенным @alexis_laz). Первая использует функцию filter, а вторая использует roll_sum из пакета RcppRoll.

f_filt <- function(x, window, idiff, valdiff){ 
    ## calculate idiff differences once 
    check = as.integer((x[2:(NROW(x) - idiff)] - x[(2 + idiff):NROW(x)]) > valdiff) 
    ## extend series to filter 
    check <- c(check, rep(0, window+idiff)) 
    ## reverse series due to filter using "past" values 
    ffilt <- rev(filter(rev(check), rep(1, window), sides=1)) 
    ## check if at least one 
    out <- ifelse(na.omit(ffilt) > 0, 1, 0) 
    return(out) 
} 

library(RcppRoll) 
f_roll <- function(x, window, idiff, valdiff){ 
    ## calculate idiff differences once 
    check = as.integer((x[2:(NROW(x) - idiff)] - x[(2 + idiff):NROW(x)]) > valdiff) 
    ## extend series to filter 
    check <- c(check, rep(0, window+idiff)) 
    ## rolling window sum 
    froll <- roll_sum(check, n=window, align="right") 
    out <- ifelse(froll > 0, 1, 0) 
    return(out) 
} 

Как быстро проверить, мы можем проверить, что все функции дают одинаковые ответы:

f_G(df$Price, Window, IndexDifference, ValueDifference) 
# 1 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 
f_RT(df$Price, Window, IndexDifference, ValueDifference) 
# 1 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 
f_AL(df$Price, Window, IndexDifference, ValueDifference) 
# 1 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 
f_filt(df$Price, Window, IndexDifference, ValueDifference) 
# 1 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 
f_roll(df$Price, Window, IndexDifference, ValueDifference) 
# 1 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 

позволит теперь сравнить их. Я также увеличу количество строк для тестирования.

library(microbenchmark) 
w <- Window 
idiff <- IndexDifference 
vdiff <- ValueDifference 

df2 <- rep(df$Price, 5000) #100,000 entries 
microbenchmark(f_G(df2, w, idiff, vdiff), 
       f_RT(df2, w, idiff, vdiff), 
       f_AL(df2, w, idiff, vdiff), 
       f_filt(df2, w, idiff, vdiff), 
       f_roll(df2, w, idiff, vdiff) 
       ) 
Unit: milliseconds 
         expr  min  lq  mean median  uq  max neval cld 
    f_G(df2, w, idiff, vdiff) 395.80227 412.05120 419.88554 413.55551 417.84907 479.47306 100  e 
    f_RT(df2, w, idiff, vdiff) 154.43919 192.99473 193.10029 195.61031 197.95933 236.27244 100 c 
    f_AL(df2, w, idiff, vdiff) 233.30237 244.01664 249.75449 245.07001 248.51249 319.04956 100 d 
f_filt(df2, w, idiff, vdiff) 21.53997 22.51582 25.38218 22.59477 23.56873 63.48320 100 b 
f_roll(df2, w, idiff, vdiff) 14.26333 14.35543 16.99302 15.24879 15.45127 55.49886 100 a  

Наконец, мы видим, что мы получаем довольно хорошее ускорение скорости, делая это. Другая аккуратная вещь о том, чтобы приближаться к ней таким образом, заключается в том, что она остается такой же эффективной, независимо от размера окна (в частности, непосредственно делая текущую сумму, используя filter, немного замедляется, хотя она все еще довольно быстро).

w <- 25 #Window 
df3 <- rep(df$Price, 5000) #100,000 entries 
microbenchmark(f_G(df3, w, idiff, vdiff), 
       f_RT(df3, w, idiff, vdiff), 
       f_AL(df3, w, idiff, vdiff), 
       f_filt(df3, w, idiff, vdiff), 
       f_roll(df3, w, idiff, vdiff) 
       ) 
Unit: milliseconds 
         expr  min  lq  mean median  uq  max neval cld 
    f_G(df3, w, idiff, vdiff) 487.65798 516.67700 537.54019 541.34459 551.52128 592.05720 100  e 
    f_RT(df3, w, idiff, vdiff) 328.44934 366.76176 389.08534 401.39053 409.49376 518.94535 100 d 
    f_AL(df3, w, idiff, vdiff) 240.99006 258.66045 263.21317 260.09258 263.75917 319.02493 100 c 
f_filt(df3, w, idiff, vdiff) 37.32291 37.41098 38.97167 37.47234 38.40989 79.51684 100 b 
f_roll(df3, w, idiff, vdiff) 15.49264 15.52950 15.86283 15.55252 15.62852 19.77415 100 a