R: ускорение операций «по группам»

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

Вот разумное упрощение того, что я пытаюсь сделать:

library(Hmisc) # Set up some example data year <- sample(1970:2008, 1e6, rep=T) state <- sample(1:50, 1e6, rep=T) group1 <- sample(1:6, 1e6, rep=T) group2 <- sample(1:3, 1e6, rep=T) myFact <- rnorm(100, 15, 1e6) weights <- rnorm(1e6) myDF <- data.frame(year, state, group1, group2, myFact, weights) # this is the step I want to make faster system.time(aggregateDF <- ddply(myDF, c("year", "state", "group1", "group2"), function(df) wtd.mean(df$myFact, weights=df$weights) ) ) 

Все советы или предложения оценены!

Вместо нормального кадра данных R вы можете использовать неизменяемый фрейм данных, который возвращает указатели на оригинал при подмножестве и может быть намного быстрее:

 idf <- idata.frame(myDF) system.time(aggregateDF <- ddply(idf, c("year", "state", "group1", "group2"), function(df) wtd.mean(df$myFact, weights=df$weights))) # user system elapsed # 18.032 0.416 19.250 

Если бы я должен был написать функцию plyr, настроенную именно для этой ситуации, я бы сделал что-то вроде этого:

 system.time({ ids <- id(myDF[c("year", "state", "group1", "group2")], drop = TRUE) data <- as.matrix(myDF[c("myFact", "weights")]) indices <- plyr:::split_indices(seq_len(nrow(data)), ids, n = attr(ids, "n")) fun <- function(rows) { weighted.mean(data[rows, 1], data[rows, 2]) } values <- vapply(indices, fun, numeric(1)) labels <- myDF[match(seq_len(attr(ids, "n")), ids), c("year", "state", "group1", "group2")] aggregateDF <- cbind(labels, values) }) # user system elapsed # 2.04 0.29 2.33 

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

Далее 2x ускорение и более сжатый код:

 library(data.table) dtb <- data.table(myDF, key="year,state,group1,group2") system.time( res <- dtb[, weighted.mean(myFact, weights), by=list(year, state, group1, group2)] ) # user system elapsed # 0.950 0.050 1.007 

Мой первый пост, поэтому, пожалуйста, будьте милы;)


Из data.table v1.9.2 setDT функция setDT, которая преобразует data.frame в data.table по ссылке (в соответствии с data.table - все set* функции изменяют объект по ссылке). Это означает, что нет ненужного копирования и, следовательно, быстро. Вы можете время, но это будет небрежно.

 require(data.table) system.time({ setDT(myDF) res <- myDF[, weighted.mean(myFact, weights), by=list(year, state, group1, group2)] }) # user system elapsed # 0.970 0.024 1.015 

Это в отличие от 1.264 секунды с решением OP выше, где data.table(.) Используется для создания dtb .

Я бы профиль с базой R

 g <- with(myDF, paste(year, state, group1, group2)) x <- with(myDF, c(tapply(weights * myFact, g, sum) / tapply(weights, g, sum))) aggregateDF <- myDF[match(names(x), g), c("year", "state", "group1", "group2")] aggregateDF$V1 <- x 

На моей машине это занимает 5 секунд по сравнению с 67сек с оригинальным кодом.

EDIT Просто нашел еще одну скорость с функцией rowsum :

 g <- with(myDF, paste(year, state, group1, group2)) X <- with(myDF, rowsum(data.frame(a=weights*myFact, b=weights), g)) x <- X$a/X$b aggregateDF2 <- myDF[match(rownames(X), g), c("year", "state", "group1", "group2")] aggregateDF2$V1 <- x 

Он занимает 3 секунды!

Используете ли вы последнюю версию plyr (обратите внимание: это еще не дошло до всех зеркал CRAN)? Если это так, вы можете просто запустить это параллельно.

Вот пример llply, но то же самое должно применяться к ddply:

  x <- seq_len(20) wait <- function(i) Sys.sleep(0.1) system.time(llply(x, wait)) # user system elapsed # 0.007 0.005 2.005 library(doMC) registerDoMC(2) system.time(llply(x, wait, .parallel = TRUE)) # user system elapsed # 0.020 0.011 1.038 

Редактировать:

Ну, другие петлевые подходы хуже, поэтому для этого, вероятно, требуется либо (a) код C / C ++, либо (б) более фундаментальное переосмысление того, как вы это делаете. Я даже не пытался использовать by() потому что это очень медленно в моем опыте.

 groups <- unique(myDF[,c("year", "state", "group1", "group2")]) system.time( aggregateDF <- do.call("rbind", lapply(1:nrow(groups), function(i) { df.tmp <- myDF[myDF$year==groups[i,"year"] & myDF$state==groups[i,"state"] & myDF$group1==groups[i,"group1"] & myDF$group2==groups[i,"group2"],] cbind(groups[i,], wtd.mean(df.tmp$myFact, weights=df.tmp$weights)) })) ) aggregateDF <- data.frame() system.time( for(i in 1:nrow(groups)) { df.tmp <- myDF[myDF$year==groups[i,"year"] & myDF$state==groups[i,"state"] & myDF$group1==groups[i,"group1"] & myDF$group2==groups[i,"group2"],] aggregateDF <- rbind(aggregateDF, data.frame(cbind(groups[i,], wtd.mean(df.tmp$myFact, weights=df.tmp$weights)))) } ) 

Обычно я использую индексный указатель, когда применимая функция имеет несколько векторных аргументов:

 system.time(tapply(1:nrow(myDF), myDF[c('year', 'state', 'group1', 'group2')], function(s) weighted.mean(myDF$myFact[s], myDF$weights[s]))) # user system elapsed # 1.36 0.08 1.44 

Я использую простую оболочку, которая эквивалентна, но скрывает беспорядок:

 tmapply(list(myDF$myFact, myDF$weights), myDF[c('year', 'state', 'group1', 'group2')], weighted.mean) 

Отредактировано для включения tmapply для комментариев ниже:

 tmapply = function(XS, INDEX, FUN, ..., simplify=T) { FUN = match.fun(FUN) if (!is.list(XS)) XS = list(XS) tapply(1:length(XS[[1L]]), INDEX, function(s, ...) do.call(FUN, c(lapply(XS, `[`, s), list(...))), ..., simplify=simplify) } 
  • C # vs C - Большая разница в производительности
  • Производительность MongoDB по агрегационным запросам
  • Является ли DateTime.Now лучшим способом измерения производительности функции?
  • Что лучше использовать в PHP $ array = $ value или array_push ($ array, $ value)?
  • Количество разделов в RDD и производительность в Spark
  • Как вы проверяете эффективность веб-сайта?
  • Отсутствие повышения производительности после использования openMP в программе оптимизируется для последовательного запуска
  • Использование команды сборки bts с компилятором gcc
  • Установка свойства изображения UIImageView вызывает серьезное отставание
  • Производительность HTTP против HTTPS
  • WPF VirtualizingStackPanel для повышения производительности
  • Давайте будем гением компьютера.