lapply và do.call chạy rất chậm?

Question

Tôi có một khung dữ liệu có khoảng 35.000 hàng, bởi 7 cột. nó trông như thế này:

đầu (nuc)

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 là một yếu tố, đó có khoảng 3.500 mức độ độc đáo. Tôi muốn, đối với mỗi cấp độ gen_id có được min(start), max(end), mean(pctAT), mean(pctGC) và sum(length).

Tôi đã thử sử dụng lapply và do.call cho việc này, nhưng sẽ mất vĩnh viễn +30 phút để chạy. mã tôi đang sử dụng là:

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) 

Tôi chắc chắn mình đang làm điều gì đó sai để làm chậm việc này. Tôi đã không chờ đợi nó để kết thúc như tôi chắc chắn nó có thể được nhanh hơn. Bất kỳ ý tưởng?

Answer 1

Kể từ khi tôi đang ở trong một tâm trạng rao giảng Tin Mừng ... đây là những giải pháp nhanh data.table sẽ trông như thế:

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 có thể cực kỳ chậm trên các đối tượng lớn. Tôi nghĩ điều này là do nó xây dựng cuộc gọi như thế nào, nhưng tôi không chắc chắn. Giải pháp thay thế nhanh hơn sẽ là gói data.table. Hoặc, như @Andrie đã đề xuất trong một nhận xét, hãy sử dụng tapply cho mỗi phép tính và cbind kết quả.

Lưu ý về triển khai hiện tại của bạn: thay vì thực hiện việc đặt chức năng của bạn, bạn có thể sử dụng chức năng split để chia nhỏ dữ liệu của bạn.nhập thành danh sách dữ liệu.frames bạn có thể lặp lại.

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

Như những người khác đã đề cập - do.call có vấn đề với các đối tượng lớn, và tôi gần đây phát hiện chính xác tốc độ của nó trên các tập dữ liệu lớn. Để minh họa cho vấn đề, đây là một benchamark sử dụng một cuộc gọi đơn giản tóm tắt với một đối tượng hồi quy lớn (một hồi quy cox sử dụng rms gói):

> 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 

Trong khi các giải pháp data.table là một cách tiếp cận tuyệt vời để ở trên nó không chứa chức năng đầy đủ của do.call và do đó tôi nghĩ rằng tôi sẽ chia sẻ chức năng fastDoCall của mình - một sửa đổi của Hadley Wickhams suggested hack trong danh sách gửi thư R. Nó có sẵn trong phiên bản 1.0 gói Gmisc (chưa được phát hành trên CRAN nhưng bạn có thể tìm thấy nó here). Điểm chuẩn là:

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

Mã đầy đủ cho các chức năng như sau:

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