R: Beschleunigung "Gruppe von" Operationen

Question

Ich habe eine Simulation, die eine große Aggregat und Schritt in der Mitte kombinieren hat. Ich habe diesen Prozess mit der plpl ddply() -Funktion erstellt, die für einen großen Teil meiner Bedürfnisse funktioniert. Aber ich brauche diesen Aggregationsschritt, um schneller zu sein, da ich 10K-Simulationen ausführen muss. Ich skaliere die Simulationen bereits parallel, aber wenn dieser Schritt schneller wäre, könnte ich die Anzahl der Knoten, die ich brauche, stark reduzieren.

Hier ist eine vernünftige Vereinfachung dessen, was ich zu tun versucht:

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

Alle Tipps oder Anregungen geschätzt werden!

Answer 1

Anstelle der normalen R-Datenrahmen, können Sie einen unveränderlichen Datenrahmen verwendet werden, die Zeiger auf die ursprüngliche zurückgibt, wenn Sie Teilmenge und kann schneller viel:

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 

Wenn ich ein schreiben wurde plyr Funktion angepasst genau auf diese Situation, würde ich so etwas tun:

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 

es ist so viel schneller, weil es vermeidet, die Daten zu kopieren, nur die Teilmenge für jede Berechnung benötigt Extrahieren wenn es berechnet wird. Das Umschalten der Daten in die Matrixform ergibt eine weitere Geschwindigkeitsverstärkung, da die Matrix-Teilmengenbildung viel schneller ist als die Datenrahmen-Teilmengenbildung.

Answer 2

Verwenden Sie die neueste Version von plyr (Anmerkung: Dies ist noch nicht an allen CRAN-Spiegeln angekommen)? Wenn ja, könnten Sie das einfach parallel ausführen.

Hier ist das llply Beispiel, aber das gleiche sollte ddply gelten:

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:

Nun, andere Looping Ansätze sind noch schlimmer, so erfordert dies wahrscheinlich entweder (a) C/C++ - Code oder (b) ein grundlegendes Umdenken darüber, wie Sie es tun. Ich habe nicht einmal versucht, by() zu verwenden, weil das in meiner Erfahrung sehr langsam ist.

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

würde ich mit Basis R Profil

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 

Auf meinem Rechner dauert es 5 Sekunden vergleichen mit Original-Code 67sec.

EDIT fand gerade eine andere Geschwindigkeit, mit rowsum Funktion auf:

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 

Es dauert 3 Sekunden!

Answer 4

I in der Regel ein Indexvektor mit Tapply verwenden, wenn die Funktion hat, mehrere Vektor args angewendet:

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 

I verwenden eine einfache Hülle, die äquivalent ist aber versteckt die Mess:

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

---

Bearbeitet, um tmapply für Kommentar unten einzuschließen:

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

Weitere 2x Speedup und prägnanter Code:

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 

Mein erster Beitrag, also bitte schön;)

---

Von data.table v1.9.2 wird setDT Funktion exportiert, dass data.frame konvertieren werde zu data.tabledurch Bezugnahme (in mit data.table parlance halten - alle Funktionen set* das Objekt durch Bezugnahme ändern). Dies bedeutet, kein unnötiges Kopieren und ist daher schnell. Du kannst es tun, aber es wird nachlässig sein.

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 

Dies ist im Gegensatz zu 1,264 Sekunden mit OP-Lösung über, wo data.table(.) verwendet wird dtb zu erstellen.