как заменить цикл в R с оптимизированной функцией (lapply?)

Question

У меня есть фрейм данных с временными событиями в каждой строке. В одной строке у меня есть типы событий отправителя (typeid = 1), а в другой - события получателя (typeid = 2). Я хочу рассчитать задержку между отправителем и получателем (разница во времени).

Мои данные организованы в data.frame, как показано на следующем снимке:

dd[1:10,]
     timeid   valid typeid
1  18,00035 1,00000      1
2  18,00528 0,00493      2
3  18,02035 2,00000      1
4  18,02116 0,00081      2
5  18,04035 3,00000      1
6  18,04116 0,00081      2
7  18,06035 4,00000      1
8  18,06116 0,00081      2
9  18,08035 5,00000      1
10 18,08116 0,00081      2

calc_DelayVIDEO <- function (dDelay ){

        pktProcess <- TRUE
        nLost <- 0
        myDelay <- data.frame(time=-1, delay=-1, jitter=-1, nLost=-1)
        myDelay <- myDelay[-1, ]
        tini <- 0
        tend <- 0
        for (itr in c(1:length(dDelay$timeid))) {
           aRec <- dDelay[itr,]
           if (aRec$typeid == 1){
                tini <- as.numeric(aRec$timeid)
                if (!pktProcess ) {
                   nLost <- (nLost + 1)
                   myprt(paste("Packet Lost at time ", aRec$timeid, " lost= ", nLost, sep=""))
                }

                pktProcess <- FALSE 
           }else if (aRec$typeid == 2){

                tend <- as.numeric(aRec$timeid)
                dd <- tend - tini
                jit <- calc_Jitter(dant=myDelay[length(myDelay), 2], dcur=dd)
                myDelay <- rbind(myDelay, c(aRec$timeid, dd, jit, nLost))
                pktProcess <- TRUE
                #myprt(paste("time=", aRec$timeev, " delay=", dd, " Delay Var=", jit, " nLost=", nLost ))
           }
        }
        colnames(myDelay) <- c("time", "delay", "jitter", "nLost")
        return (myDelay)
}

Чтобы выполнить вычисления для задержки, я использую функцию calc_DelayVideo, тем не менее для фреймов данных с большим количеством записей (~ 60000) требуется много времени.

Как заменить цикл for более оптимизированными функциями R? Могу ли я использовать lapply для таких вычислений? Если да, можете ли вы привести мне пример?

Заранее спасибо,

Answer 1

Обычное решение - достаточно серьезно подумать над проблемой, чтобы найти что-то векторизованное.

Если это не удается, я иногда прибегаю к переписыванию цикла в C ++; пакет Rcpp может помочь с интерфейсом.

Answer 2

Как сказал Дирк: векторизация поможет. Примером этого может быть перемещение вызова на as.numeric из цикла (так как эта функция работает с векторами).

dDelay$timeid <- as.numeric(dDelay$timeid)

Другие вещи, которые могут помочь,

Не беспокоиться о строке aRec <- dDelay[itr,], поскольку вы можете просто получить доступ к строке dDelay, не создавая новую переменную.

Предварительное выделение myDelay, поскольку его рост внутри цикла, вероятно, является узким местом. Подробнее об этом см. В ответе Иисуса Навина.

Answer 3

Набор функций *apply не оптимизирован для циклов.Кроме того, я работал над проблемами, когда циклы for быстрее, чем apply, потому что apply использовал больше памяти и заставил мою машину поменяться.

Я бы предложил полностью инициализировать объект myDelay и избегать использованияrbind (который должен перераспределить память):

init <- rep(NA, length(dDelay$timeid))
myDelay <- data.frame(time=init, delay=init, jitter=init, nLost=init)

, а затем заменить:

myDelay <- rbind(myDelay, c(aRec$timeid, dd, jit, nLost))

на

myDelay[i,] <- c(aRec$timeid, dd, jit, nLost)

Answer 4

Другая оптимизация: если я правильно прочитал ваш код, вы можете легко вычислить вектор nLost, используя:

nLost <-cumsum(dDelay$typeid==1)

вне цикла. Тот, который вы можете просто добавить к кадру данных в конце. Экономит много времени уже. Если я использую ваш фрейм данных, то:

> nLost <-cumsum(dd$typeid==1)
> nLost
 [1] 1 1 2 2 3 3 4 4 5 5

Аналогично, время, в которое пакеты были потеряны, может быть рассчитано как:

> dd$timeid[which(dd$typeid==1)]
[1] 18,00035 18,02035 18,04035 18,06035 18,08035

на случай, если вы захотите сообщить о них где-нибудь тоже.

Для тестирования я использовал:

dd <- structure(list(timeid = structure(1:10, .Label = c("18,00035", 
"18,00528", "18,02035", "18,02116", "18,04035", "18,04116", "18,06035", 
"18,06116", "18,08035", "18,08116"), class = "factor"), valid = structure(c(3L, 
2L, 4L, 1L, 5L, 1L, 6L, 1L, 7L, 1L), .Label = c("0,00081", "0,00493", 
"1,00000", "2,00000", "3,00000", "4,00000", "5,00000"), class = "factor"), 
    typeid = c(1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L)), .Names = c("timeid", 
"valid", "typeid"), class = "data.frame", row.names = c("1", 
"2", "3", "4", "5", "6", "7", "8", "9", "10"))