R: przyspieszenie operacji "grupowo"

Kolejne 2x speedup i bardziej zwięzły kod:

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 

Mój pierwszy post, więc proszę bądź miły;)

From data.table v1.9.2, setDT wyeksportowana zostanie funkcja, która przekonwertuje data.frame na data.table przez odniesienie (zgodnie z data.table - wszystkie funkcje set* modyfikują obiekt przez odniesienie). Oznacza to, bez zbędnego kopiowania, a zatem jest szybki. Możesz to zmierzyć, ale to będzie niedbałe.

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 

Jest to w przeciwieństwie do 1.264 sekundy z rozwiązaniem OP powyżej, gdzie {[8] } jest używany do tworzenia dtb.

Chciałbym profilować z bazą 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

Na mojej maszynie zajmuje 5sec w porównaniu do 67sec z oryginalnym kodem.

EDIT Właśnie znalazłem kolejne przyspieszenie z rowsum funkcją:

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

It takes 3sec!

Czy używasz najnowszej wersji plyr (uwaga: to jeszcze nie dotarło do wszystkich luster CRAN)? Jeśli tak, możesz po prostu uruchomić to równolegle.

Oto przykład llply, ale to samo powinno dotyczyć 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óż, inne podejścia do pętli są gorsze, więc prawdopodobnie wymaga to albo (a) kodu C / C++ lub (b) bardziej fundamentalnego przemyślenia tego, jak to robisz. Nawet nie próbowałem używać by(), bo to bardzo powolne w moim doświadczenie.

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

Zwykle używam wektora indeksowego z tapply, gdy stosowana funkcja ma wiele wektorów args:

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 

Używam prostego wrappera, który jest równoważny, ale ukrywa bałagan:

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

Edytowano, aby dodać tmapply do komentarza poniżej:

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