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

Question

У меня есть симуляция, которая имеет огромный агрегат и совмещает шаг прямо посередине. Я прототипировал этот процесс, используя функцию 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) 
           ) 
      ) 

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

Answer 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 

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

Answer 2

Вы используете последнюю версию 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:

Ну, другие зацикливания подходы хуже, так что это, вероятно, потребует либо (а) C/C++ или (b) более фундаментальное переосмысление того, как вы это делаете. Я даже не пытался использовать 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)))) 
} 
) 

Answer 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с сравнить 67sec с оригинальным кодом.

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сек!

Answer 4

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

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 = 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) 
} 

Answer 5

Далее 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.