lapply und do.call läuft sehr langsam?

Question

Ich habe einen Datenrahmen, der etwa 35.000 Zeilen ist, um 7 Spalten. es sieht wie folgt aus:

Kopf (Nuk)

chr feature start  end gene_id pctAT pctGC length 
1 1  CDS 67000042 67000051 NM_032291 0.600000 0.400000  10 
2 1  CDS 67091530 67091593 NM_032291 0.609375 0.390625  64 
3 1  CDS 67098753 67098777 NM_032291 0.600000 0.400000  25 
4 1  CDS 67101627 67101698 NM_032291 0.472222 0.527778  72 
5 1  CDS 67105460 67105516 NM_032291 0.631579 0.368421  57 
6 1  CDS 67108493 67108547 NM_032291 0.436364 0.563636  55 

gene_id ist ein Faktor, der etwa 3.500 einzigartige Levels hat. Ich möchte für jede Ebene von gen_id die min(start), max(end), mean(pctAT), mean(pctGC) und sum(length) bekommen.

Ich habe versucht, mit lapply und do.call dafür, aber es dauert ewig +30 Minuten zu laufen. der Code Ich verwende ist:

nuc_prof = lapply(levels(nuc$gene_id), function(gene){ 
    t = nuc[nuc$gene_id==gene, ] 
    return(list(gene_id=gene, start=min(t$start), end=max(t$end), pctGC = 
       mean(t$pctGC), pct = mean(t$pctAT), cdslength = sum(t$length))) 
}) 
nuc_prof = do.call(rbind, nuc_prof) 

Ich bin sicher, dass ich diese etwas falsch zu verlangsamen mache. Ich habe nicht darauf gewartet, dass es fertig ist, da ich mir sicher bin, dass es schneller gehen kann. Irgendwelche Ideen?

Answer 1

Da ich in einer Evangelisation Stimmung bin ... hier ist es, was die schnelle data.table Lösung aussehen würde:

library(data.table) 
dt <- data.table(nuc, key="gene_id") 

dt[,list(A=min(start), 
     B=max(end), 
     C=mean(pctAT), 
     D=mean(pctGC), 
     E=sum(length)), by=key(dt)] 
#  gene_id  A  B   C   D E 
# 1: NM_032291 67000042 67108547 0.5582567 0.4417433 283 
# 2:  ZZZ 67000042 67108547 0.5582567 0.4417433 283 

Answer 2

do.call kann bei großen Objekten extrem langsam sein. Ich denke, das liegt daran, wie es den Anruf konstruiert, aber ich bin mir nicht sicher. Eine schnellere Alternative wäre das data.table Paket. Oder, wie @Andrie in einem Kommentar vorgeschlagen hat, verwenden Sie tapply für jede Berechnung und cbind die Ergebnisse.

Ein Hinweis zu Ihrer aktuellen Implementierung: Anstatt die Teilmenge in Ihrer Funktion zu verwenden, können Sie die Datei split in eine Liste von data.frames aufteilen, die Sie durchlaufen können.

g <- function(tnuc) { 
    list(gene_id=tnuc$gene_id[1], start=min(tnuc$start), end=max(tnuc$end), 
     pctGC=mean(tnuc$pctGC), pct=mean(tnuc$pctAT), cdslength=sum(tnuc$length)) 
} 
nuc_prof <- lapply(split(nuc, nuc$gene_id), g) 

Answer 3

Wie andere erwähnt haben - do.call Probleme mit großen Objekten hat, und ich vor kurzem genau herausgefunden, wie langsam es auf großen Datensätzen ist. Um das Problem zu veranschaulichen, hier ein benchamark eine einfache Zusammenfassung Aufruf mit einem großen Regression-Objekt (eine cox Regression des Effektiv-Paket mit):

> model <- cph(Surv(Time, Status == "Cardiovascular") ~ 
+    Group + rcs(Age, 3) + cluster(match_group), 
+    data=full_df, 
+    x=TRUE, y=TRUE) 

> system.time(s_reg <- summary(object = model)) 
    user system elapsed 
    0.00 0.02 0.03 
> system.time(s_dc <- do.call(summary, list(object = model))) 
    user system elapsed 
282.27 0.08 282.43 
> nrow(full_df) 
[1] 436305 

Während die data.table Lösung ist ein ausgezeichneter Ansatz darüber nicht enthalten die volle Funktionalität der do.call und ich dachte daher, dass ich meine fastDoCall Funktion teilen - eine Modifikation von Hadley Wickhams suggested hack auf der R-Mailing-Liste. Es ist verfügbar in der Gmisc-Paket 1.0-Version (noch nicht auf CRAN freigegeben, aber Sie können es finden here). Die Benchmark ist:

> system.time(s_fc <- fastDoCall(summary, list(object = model))) 
    user system elapsed 
    0.03 0.00 0.06 

Der vollständige Code für die Funktion ist wie folgt:

fastDoCall <- function(what, args, quote = FALSE, envir = parent.frame()){ 
    if (quote) 
    args <- lapply(args, enquote) 

    if (is.null(names(args))){ 
    argn <- args 
    args <- list() 
    }else{ 
    # Add all the named arguments 
    argn <- lapply(names(args)[names(args) != ""], as.name) 
    names(argn) <- names(args)[names(args) != ""] 
    # Add the unnamed arguments 
    argn <- c(argn, args[names(args) == ""]) 
    args <- args[names(args) != ""] 
    } 

    if (class(what) == "character"){ 
    if(is.character(what)){ 
     fn <- strsplit(what, "[:]{2,3}")[[1]] 
     what <- if(length(fn)==1) { 
     get(fn[[1]], envir=envir, mode="function") 
     } else { 
     get(fn[[2]], envir=asNamespace(fn[[1]]), mode="function") 
     } 
    } 
    call <- as.call(c(list(what), argn)) 
    }else if (class(what) == "function"){ 
    f_name <- deparse(substitute(what)) 
    call <- as.call(c(list(as.name(f_name)), argn)) 
    args[[f_name]] <- what 
    }else if (class(what) == "name"){ 
    call <- as.call(c(list(what, argn))) 
    } 

    eval(call, 
     envir = args, 
     enclos = envir) 
}