Come utilizzare in modo efficiente Rprof in R?

Vorrei sapere se è ansible ottenere un profilo da R -Code in un modo simile al Profiler di matlab . Cioè, per sapere quali numeri di linea sono quelli che sono particolarmente lenti.

Ciò che ho ottenuto finora non è in qualche modo soddisfacente. Ho usato Rprof per farmi un file di profilo. Usando summaryRprof ho qualcosa del tipo:

 $by.self self.time self.pct total.time total.pct [.data.frame 0.72 10.1 1.84 25.8 inherits 0.50 7.0 1.10 15.4 data.frame 0.48 6.7 4.86 68.3 unique.default 0.44 6.2 0.48 6.7 deparse 0.36 5.1 1.18 16.6 rbind 0.30 4.2 2.22 31.2 match 0.28 3.9 1.38 19.4 [<-.factor 0.28 3.9 0.56 7.9 levels 0.26 3.7 0.34 4.8 NextMethod 0.22 3.1 0.82 11.5 ... 

e

 $by.total total.time total.pct self.time self.pct data.frame 4.86 68.3 0.48 6.7 rbind 2.22 31.2 0.30 4.2 do.call 2.22 31.2 0.00 0.0 [ 1.98 27.8 0.16 2.2 [.data.frame 1.84 25.8 0.72 10.1 match 1.38 19.4 0.28 3.9 %in% 1.26 17.7 0.14 2.0 is.factor 1.20 16.9 0.10 1.4 deparse 1.18 16.6 0.36 5.1 ... 

Per essere onesti, da questo output non capisco dove sono i miei colli di bottiglia perché (a) utilizzo abbastanza spesso data.frame e (b) non uso mai, per esempio. Inoltre, cosa è [ ?

Così ho provato il profr Hadley Wickham, ma non era più utile considerando il seguente grafico: alt text

C’è un modo più conveniente per vedere quali numeri di linea e chiamate di funzione particolari sono lenti?
O c’è qualche letteratura che dovrei consultare?

Ogni suggerimento è apprezzato.

MODIFICA 1:
Basandomi sul commento di Hadley, incollerò il codice del mio script qui sotto e la versione del grafico di base della trama. Ma nota, che la mia domanda non è legata a questo specifico script. È solo uno script casuale che ho scritto di recente. Sto cercando un modo generale per trovare i colli di bottiglia e accelerare R -code.

Il dato ( x ) si presenta così:

 type word response N Classification classN Abstract ANGER bitter 1 3a 3a Abstract ANGER control 1 1a 1a Abstract ANGER father 1 3a 3a Abstract ANGER flushed 1 3a 3a Abstract ANGER fury 1 1c 1c Abstract ANGER hat 1 3a 3a Abstract ANGER help 1 3a 3a Abstract ANGER mad 13 3a 3a Abstract ANGER management 2 1a 1a ... until row 1700 

Lo script (con brevi spiegazioni) è questo:

 Rprof("profile1.out") # A new dataset is produced with each line of x contained x$N times y <- vector('list',length(x[,1])) for (i in 1:length(x[,1])) { y[[i]] <- data.frame(rep(x[i,1],x[i,"N"]),rep(x[i,2],x[i,"N"]),rep(x[i,3],x[i,"N"]),rep(x[i,4],x[i,"N"]),rep(x[i,5],x[i,"N"]),rep(x[i,6],x[i,"N"])) } all <- do.call('rbind',y) colnames(all) <- colnames(x) # create a dataframe out of a word x class table table_all <- table(all$word,all$classN) dataf.all <- as.data.frame(table_all[,1:length(table_all[1,])]) dataf.all$words <- as.factor(rownames(dataf.all)) dataf.all$type <- "no" # get type of the word. words <- levels(dataf.all$words) for (i in 1:length(words)) { dataf.all$type[i] <- as.character(all[pmatch(words[i],all$word),"type"]) } dataf.all$type <- as.factor(dataf.all$type) dataf.all$typeN <- as.numeric(dataf.all$type) # aggregate response categories dataf.all$c1 <- apply(dataf.all[,c("1a","1b","1c","1d","1e","1f")],1,sum) dataf.all$c2 <- apply(dataf.all[,c("2a","2b","2c")],1,sum) dataf.all$c3 <- apply(dataf.all[,c("3a","3b")],1,sum) Rprof(NULL) library(profr) ggplot.profr(parse_rprof("profile1.out")) 

I dati finali assomigliano a questo:

 1a 1b 1c 1d 1e 1f 2a 2b 2c 3a 3b pa words type typeN c1 c2 c3 pa 3 0 8 0 0 0 0 0 0 24 0 0 ANGER Abstract 1 11 0 24 0 6 0 4 0 1 0 0 11 0 13 0 0 ANXIETY Abstract 1 11 11 13 0 2 11 1 0 0 0 0 4 0 17 0 0 ATTITUDE Abstract 1 14 4 17 0 9 18 0 0 0 0 0 0 0 0 8 0 BARREL Concrete 2 27 0 8 0 0 1 18 0 0 0 0 4 0 12 0 0 BELIEF Abstract 1 19 4 12 0 

La trama del grafico di base: alt text

L’esecuzione dello script oggi ha modificato anche il grafico ggplot2 (fondamentalmente solo le etichette), vedi qui.

I lettori attenti delle ultime notizie di ieri ( R 3.0.0 è finalmente uscito) potrebbero aver notato qualcosa di interessante che è direttamente rilevante per questa domanda:

  • La creazione di profili tramite Rprof () ora facoltativamente registra le informazioni a livello di istruzione, non solo il livello di funzione.

E in effetti, questa nuova funzione risponde alla mia domanda e mostrerò come.


Diciamo che vogliamo confrontare se la vettorizzazione e la pre-allocazione sono davvero migliori dei buoni vecchi “for-loops” e della costruzione incrementale di dati nel calcolo di una statistica riassuntiva come la media. Il codice, relativamente stupido, è il seguente:

 # create big data frame: n <- 1000 x <- data.frame(group = sample(letters[1:4], n, replace=TRUE), condition = sample(LETTERS[1:10], n, replace = TRUE), data = rnorm(n)) # reasonable operations: marginal.means.1 <- aggregate(data ~ group + condition, data = x, FUN=mean) # unreasonable operations: marginal.means.2 <- marginal.means.1[NULL,] row.counter <- 1 for (condition in levels(x$condition)) { for (group in levels(x$group)) { tmp.value <- 0 tmp.length <- 0 for (c in 1:nrow(x)) { if ((x[c,"group"] == group) & (x[c,"condition"] == condition)) { tmp.value <- tmp.value + x[c,"data"] tmp.length <- tmp.length + 1 } } marginal.means.2[row.counter,"group"] <- group marginal.means.2[row.counter,"condition"] <- condition marginal.means.2[row.counter,"data"] <- tmp.value / tmp.length row.counter <- row.counter + 1 } } # does it produce the same results? all.equal(marginal.means.1, marginal.means.2) 

Per usare questo codice con Rprof , dobbiamo parse . Cioè, deve essere salvato in un file e quindi chiamato da lì. Quindi, l'ho caricato su pastebin , ma funziona esattamente allo stesso modo con i file locali.

Ora noi

  • semplicemente creare un file di profilo e indicare che vogliamo salvare il numero di riga,
  • fonte il codice con l'incredibile combinazione eval(parse(..., keep.source = TRUE)) (apparentemente la famigerata fortune(106) non si applica qui, poiché non ho trovato un altro modo)
  • interrompere la profilazione e indicare che vogliamo l'output in base ai numeri di riga.

Il codice è:

 Rprof("profile1.out", line.profiling=TRUE) eval(parse(file = "http://pastebin.com/download.php?i=KjdkSVZq", keep.source=TRUE)) Rprof(NULL) summaryRprof("profile1.out", lines = "show") 

Che dà:

 $by.self self.time self.pct total.time total.pct download.php?i=KjdkSVZq#17 8.04 64.11 8.04 64.11  4.38 34.93 4.38 34.93 download.php?i=KjdkSVZq#16 0.06 0.48 0.06 0.48 download.php?i=KjdkSVZq#18 0.02 0.16 0.02 0.16 download.php?i=KjdkSVZq#23 0.02 0.16 0.02 0.16 download.php?i=KjdkSVZq#6 0.02 0.16 0.02 0.16 $by.total total.time total.pct self.time self.pct download.php?i=KjdkSVZq#17 8.04 64.11 8.04 64.11  4.38 34.93 4.38 34.93 download.php?i=KjdkSVZq#16 0.06 0.48 0.06 0.48 download.php?i=KjdkSVZq#18 0.02 0.16 0.02 0.16 download.php?i=KjdkSVZq#23 0.02 0.16 0.02 0.16 download.php?i=KjdkSVZq#6 0.02 0.16 0.02 0.16 $by.line self.time self.pct total.time total.pct  4.38 34.93 4.38 34.93 download.php?i=KjdkSVZq#6 0.02 0.16 0.02 0.16 download.php?i=KjdkSVZq#16 0.06 0.48 0.06 0.48 download.php?i=KjdkSVZq#17 8.04 64.11 8.04 64.11 download.php?i=KjdkSVZq#18 0.02 0.16 0.02 0.16 download.php?i=KjdkSVZq#23 0.02 0.16 0.02 0.16 $sample.interval [1] 0.02 $sampling.time [1] 12.54 

Il controllo del codice sorgente ci dice che la linea problematica (n. 17) è davvero lo stupido if -statement nel ciclo for. Rispetto a fondamentalmente non c'è tempo per il calcolo della stessa usando il codice vettoriale (riga # 6).

Non l'ho provato con nessuna uscita grafica, ma sono già molto impressionato da quello che ho ottenuto finora.

Aggiornamento: questa funzione è stata riscritta per gestire i numeri di riga. È su Github qui .

Ho scritto questa funzione per analizzare il file da Rprof e generare una tabella con risultati più chiari rispetto a summaryRprof . Visualizza l’intero stack di funzioni (e i numeri di riga se line.profiling=TRUE ) e il loro contributo relativo al tempo di esecuzione:

 proftable <- function(file, lines=10) { # require(plyr) interval <- as.numeric(strsplit(readLines(file, 1), "=")[[1L]][2L])/1e+06 profdata <- read.table(file, header=FALSE, sep=" ", comment.char = "", colClasses="character", skip=1, fill=TRUE, na.strings="") filelines <- grep("#File", profdata[,1]) files <- aaply(as.matrix(profdata[filelines,]), 1, function(x) { paste(na.omit(x), collapse = " ") }) profdata <- profdata[-filelines,] total.time <- interval*nrow(profdata) profdata <- as.matrix(profdata[,ncol(profdata):1]) profdata <- aaply(profdata, 1, function(x) { c(x[(sum(is.na(x))+1):length(x)], x[seq(from=1,by=1,length=sum(is.na(x)))]) }) stringtable <- table(apply(profdata, 1, paste, collapse=" ")) uniquerows <- strsplit(names(stringtable), " ") uniquerows <- llply(uniquerows, function(x) replace(x, which(x=="NA"), NA)) dimnames(stringtable) <- NULL stacktable <- ldply(uniquerows, function(x) x) stringtable <- stringtable/sum(stringtable)*100 stacktable <- data.frame(PctTime=stringtable[], stacktable) stacktable <- stacktable[order(stringtable, decreasing=TRUE),] rownames(stacktable) <- NULL stacktable <- head(stacktable, lines) na.cols <- which(sapply(stacktable, function(x) all(is.na(x)))) stacktable <- stacktable[-na.cols] parent.cols <- which(sapply(stacktable, function(x) length(unique(x)))==1) parent.call <- paste0(paste(stacktable[1,parent.cols], collapse = " > ")," >") stacktable <- stacktable[,-parent.cols] calls <- aaply(as.matrix(stacktable[2:ncol(stacktable)]), 1, function(x) { paste(na.omit(x), collapse= " > ") }) stacktable <- data.frame(PctTime=stacktable$PctTime, Call=calls) frac <- sum(stacktable$PctTime) attr(stacktable, "total.time") <- total.time attr(stacktable, "parent.call") <- parent.call attr(stacktable, "files") <- files attr(stacktable, "total.pct.time") <- frac cat("\n") print(stacktable, row.names=FALSE, right=FALSE, digits=3) cat("\n") cat(paste(files, collapse="\n")) cat("\n") cat(paste("\nParent Call:", parent.call)) cat(paste("\n\nTotal Time:", total.time, "seconds\n")) cat(paste0("Percent of run time represented: ", format(frac, digits=3)), "%") invisible(stacktable) } 

Eseguendo questo sul file di esempio di Henrik, ottengo questo:

 > Rprof("profile1.out", line.profiling=TRUE) > source("http://pastebin.com/download.php?i=KjdkSVZq") > Rprof(NULL) > proftable("profile1.out", lines=10) PctTime Call 20.47 1#17 > [ > 1#17 > [.data.frame 9.73 1#17 > [ > 1#17 > [.data.frame > [ > [.factor 8.72 1#17 > [ > 1#17 > [.data.frame > [ > [.factor > NextMethod 8.39 == > Ops.factor 5.37 == 5.03 == > Ops.factor > noNA.levels > levels 4.70 == > Ops.factor > NextMethod 4.03 1#17 > [ > 1#17 > [.data.frame > [ > [.factor > levels 4.03 1#17 > [ > 1#17 > [.data.frame > dim 3.36 1#17 > [ > 1#17 > [.data.frame > length #File 1: http://pastebin.com/download.php?i=KjdkSVZq Parent Call: source > withVisible > eval > eval > Total Time: 5.96 seconds Percent of run time represented: 73.8 % 

Si noti che la "Parent Call" si applica a tutti gli stack rappresentati sulla tabella. Questo rende utile quando il tuo IDE o qualsiasi altra cosa chiama il tuo codice lo avvolge in un sacco di funzioni.

Al momento ho disinstallato R qui, ma in SPlus puoi interrompere l’esecuzione con il tasto Esc, quindi eseguire traceback() , che ti mostrerà lo stack delle chiamate. Questo dovrebbe consentire di utilizzare questo pratico metodo .

Ecco alcuni motivi per cui gli strumenti basati sugli stessi concetti di gprof non sono molto utili per individuare i problemi di prestazioni.

Una soluzione diversa deriva da una domanda diversa: come utilizzare in modo efficace la library(profr) in R :

Per esempio:

 install.packages("profr") devtools::install_github("alexwhitworth/imputation") x <- matrix(rnorm(1000), 100) x[x>1] <- NA library(imputation) library(profr) a <- profr(kNN_impute(x, k=5, q=2), interval= 0.005) 

Non sembra (almeno per me), come le trame sono utili in questo caso (ad esempio la plot(a) ). Ma la stessa struttura dati sembra suggerire una soluzione:

 R> head(a, 10) level g_id t_id f start end n leaf time source 9 1 1 1 kNN_impute 0.005 0.190 1 FALSE 0.185 imputation 10 2 1 1 var_tests 0.005 0.010 1 FALSE 0.005  11 2 2 1 apply 0.010 0.190 1 FALSE 0.180 base 12 3 1 1 var.test 0.005 0.010 1 FALSE 0.005 stats 13 3 2 1 FUN 0.010 0.110 1 FALSE 0.100  14 3 2 2 FUN 0.115 0.190 1 FALSE 0.075  15 4 1 1 var.test.default 0.005 0.010 1 FALSE 0.005  16 4 2 1 sapply 0.010 0.040 1 FALSE 0.030 base 17 4 3 1 dist_q.matrix 0.040 0.045 1 FALSE 0.005 imputation 18 4 4 1 sapply 0.045 0.075 1 FALSE 0.030 base 

Soluzione di iterazione singola:

Questa è la struttura dei dati suggerisce l'uso di tapply per riassumere i dati. Questo può essere fatto semplicemente per una singola esecuzione di profr::profr

 t <- tapply(a$time, paste(a$source, a$f, sep= "::"), sum) t[order(t)] # time / function R> round(t[order(t)] / sum(t), 4) # percentage of total time / function base::! base::%in% base::| base::anyDuplicated 0.0015 0.0015 0.0015 0.0015 base::c base::deparse base::get base::match 0.0015 0.0015 0.0015 0.0015 base::mget base::min base::t methods::el 0.0015 0.0015 0.0015 0.0015 methods::getGeneric NA::.findMethodInTable NA::.getGeneric NA::.getGenericFromCache 0.0015 0.0015 0.0015 0.0015 NA::.getGenericFromCacheTable NA::.identC NA::.newSignature NA::.quickCoerceSelect 0.0015 0.0015 0.0015 0.0015 NA::.sigLabel NA::var.test.default NA::var_tests stats::var.test 0.0015 0.0015 0.0015 0.0015 base::paste methods::as<- NA::.findInheritedMethods NA::.getClassFromCache 0.0030 0.0030 0.0030 0.0030 NA::doTryCatch NA::tryCatchList NA::tryCatchOne base::crossprod 0.0030 0.0030 0.0030 0.0045 base::try base::tryCatch methods::getClassDef methods::possibleExtends 0.0045 0.0045 0.0045 0.0045 methods::loadMethod methods::is imputation::dist_q.matrix methods::validObject 0.0075 0.0090 0.0120 0.0136 NA::.findNextFromTable methods::addNextMethod NA::.nextMethod base::lapply 0.0166 0.0346 0.0361 0.0392 base::sapply imputation::impute_fn_knn methods::new imputation::kNN_impute 0.0392 0.0392 0.0437 0.0557 methods::callNextMethod kernlab::as.kernelMatrix base::apply kernlab::kernelMatrix 0.0572 0.0633 0.0663 0.0753 methods::initialize NA::FUN base::standardGeneric 0.0798 0.0994 0.1325 

Da questo, posso vedere che gli utenti più grandi sono kernlab::kernelMatrix e l'overhead di R per classi S4 e generici.

preferita:

Prendo atto che, data la natura stocastica del processo di campionamento, preferisco utilizzare le medie per ottenere un'immagine più robusta del profilo temporale:

 prof_list <- replicate(100, profr(kNN_impute(x, k=5, q=2), interval= 0.005), simplify = FALSE) fun_timing <- vector("list", length= 100) for (i in 1:100) { fun_timing[[i]] <- tapply(prof_list[[i]]$time, paste(prof_list[[i]]$source, prof_list[[i]]$f, sep= "::"), sum) } # Here is where the stochastic nature of the profiler complicates things. # Because of randomness, each replication may have slightly different # functions called during profiling sapply(fun_timing, function(x) {length(names(x))}) # we can also see some clearly odd replications (at least in my attempt) > sapply(fun_timing, sum) [1] 2.820 5.605 2.325 2.895 3.195 2.695 2.495 2.315 2.005 2.475 4.110 2.705 2.180 2.760 [15] 3130.240 3.435 7.675 7.155 5.205 3.760 7.335 7.545 8.155 8.175 6.965 5.820 8.760 7.345 [29] 9.815 7.965 6.370 4.900 5.720 4.530 6.220 3.345 4.055 3.170 3.725 7.780 7.090 7.670 [43] 5.400 7.635 7.125 6.905 6.545 6.855 7.185 7.610 2.965 3.865 3.875 3.480 7.770 7.055 [57] 8.870 8.940 10.130 9.730 5.205 5.645 3.045 2.535 2.675 2.695 2.730 2.555 2.675 2.270 [71] 9.515 4.700 7.270 2.950 6.630 8.370 9.070 7.950 3.250 4.405 3.475 6.420 2948.265 3.470 [85] 3.320 3.640 2.855 3.315 2.560 2.355 2.300 2.685 2.855 2.540 2.480 2.570 3.345 2.145 [99] 2.620 3.650 

Rimozione delle repliche insolite e conversione in data.frame s:

 fun_timing <- fun_timing[-c(15,83)] fun_timing2 <- lapply(fun_timing, function(x) { ret <- data.frame(fun= names(x), time= x) dimnames(ret)[[1]] <- 1:nrow(ret) return(ret) }) 

Unisci le repliche (quasi certamente potrebbe essere più veloce) ed esamina i risultati:

 # function for merging DF's in a list merge_recursive <- function(list, ...) { n <- length(list) df <- data.frame(list[[1]]) for (i in 2:n) { df <- merge(df, list[[i]], ... = ...) } return(df) } # merge fun_time <- merge_recursive(fun_timing2, by= "fun", all= FALSE) # do some munging fun_time2 <- data.frame(fun=fun_time[,1], avg_time=apply(fun_time[,-1], 1, mean, na.rm=T)) fun_time2$avg_pct <- fun_time2$avg_time / sum(fun_time2$avg_time) fun_time2 <- fun_time2[order(fun_time2$avg_time, decreasing=TRUE),] # examine results R> head(fun_time2, 15) fun avg_time avg_pct 4 base::standardGeneric 0.6760714 0.14745123 20 NA::FUN 0.4666327 0.10177262 12 methods::initialize 0.4488776 0.09790023 9 kernlab::kernelMatrix 0.3522449 0.07682464 8 kernlab::as.kernelMatrix 0.3215816 0.07013698 11 methods::callNextMethod 0.2986224 0.06512958 1 base::apply 0.2893367 0.06310437 7 imputation::kNN_impute 0.2433163 0.05306731 14 methods::new 0.2309184 0.05036331 10 methods::addNextMethod 0.2012245 0.04388708 3 base::sapply 0.1875000 0.04089377 2 base::lapply 0.1865306 0.04068234 6 imputation::impute_fn_knn 0.1827551 0.03985890 19 NA::.nextMethod 0.1790816 0.03905772 18 NA::.findNextFromTable 0.1003571 0.02188790 

risultati

Dai risultati emerge un quadro simile ma più robusto come in un singolo caso. Vale a dire, c'è un sacco di overhead da R e anche quella library(kernlab) mi sta rallentando. Da notare, poiché kernlab è implementato in S4, il sovraccarico in R è correlato poiché le classi S4 sono sostanzialmente più lente delle classi S3.

Vorrei anche notare che la mia opinione personale è che una versione ripulita di questo potrebbe essere una utile richiesta di pull come metodo di sintesi per profr . Anche se sarei interessato a vedere i suggerimenti degli altri!