lapply ve do.call çok yavaş koşuyor mu?

Question

Yaklaşık 35.000 satır olan 7 sütuna sahip bir veri çerçevem ​​var. Bu gibi görünüyor:

kafa (nük)

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 yaklaşık 3.500 benzersiz düzeyi vardır bir etkendir. Her bir gen_id seviyesi için min(start), max(end), mean(pctAT), mean(pctGC) ve sum(length)'u almak istiyorum.

Bunun için lapply ve do.call kullanmayı denedim, ancak sonsuza dek sürmesi +30 dakika sürüyor. kullanıyorum kodudur:

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) 

Ben bu yavaşlatmak yanlış bir şey yapıyorum eminim. Daha hızlı olabileceğinden emin olmak için beklemedim. Herhangi bir fikir? Büyük nesnelerde son derece yavaş olabilir

Answer 1

... Burada hızlı data.table çözüm gibi görünür budur:

Diğerleri de söylediğim gibi

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

. Bunun, çağrıyı nasıl kurduğundan kaynaklandığını düşünüyorum, ama emin değilim. Daha hızlı bir alternatif, data.table paketi olabilir. Ya da, bir yorumda @Andrie önerdiği gibi, her bir hesap için tapply ve sonuçları cbind kullanın.

Geçerli uygulamanızla ilgili bir not: İşlevinizde altkümeyi yapmak yerine, data.frame'inizi döngü yapabileceğiniz bir data.frames listesine bölmek için split işlevini kullanabilirsiniz. Bir evangelizing havasında olduğum için

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

- do.call büyük nesnelerle sorunları vardır ve son zamanlarda Büyük veri kümelerinde tam olarak ne kadar yavaş olduğunu keşfetti. Sorunu göstermek için, burada büyük bir regresyon nesnesi ile basit bir özet çağrısı (rms-paketini kullanarak bir Cox regresyon) kullanarak bir benchamark var:

> 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 

data.table çözüm içermiyor yukarıda için mükemmel bir yaklaşım olmakla birlikte do.call'un tam işlevselliği ve bu yüzden benim fastDoCall işlevimi paylaşacağımı düşündüm - R-postalama listesinde Hadley Wickhams suggested hack. Gmisc paketi 1.0 sürümünde (henüz CRAN'da yayınlanmadı ancak here'u bulabilirsiniz) kullanılabilir. ölçüttür:

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

fonksiyonu için tam kod aşağıdaki gibidir:

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