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)
)
)
Все советы или предложения приветствуются!
Ответы
Ответ 1
Вместо обычного кадра данных 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
Это намного быстрее, потому что оно позволяет избежать копирования данных, а только извлекать подмножество, необходимое для каждого вычисления при его вычислении. Переключение данных в матричную форму дает еще одно ускорение скорости, поскольку подмножество матриц намного быстрее, чем подмножество фреймов.
Ответ 2
Далее 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, которая преобразует data.frame в data.table по ссылке (в соответствии с data.table parlance - все 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.
Ответ 3
Я бы профиль с базой 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 секундами с исходным кодом.
ИЗМЕНИТЬ
Просто нашел еще одну скорость с функцией 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 секунды!
Ответ 4
Используете ли вы последнюю версию 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
Edit:
Ну, другие подходы к циклу хуже, поэтому для этого, вероятно, требуется либо (a) код 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))))
}
)
Ответ 5
Обычно я использую индексный вектор, когда применимая функция имеет несколько векторных аргументов:
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)
}
