Quanto segue è un sottoinsieme di Frame di grandi dimensioni con osservazioni 158K di nome "sh_data".
Patient_ID Age_in_days DEMAdmNo
396076 28542 0
396076 28570 0
396076 28598 0
396076 28626 0
396076 28654 0
396076 28682 0
396076 28710 0
396076 28738 0
396076 28766 0
396076 28794 0
396076 28822 0
396076 28850 0
396076 28878 0
396076 28906 0
396076 28934 0
396076 28962 0
396076 28990 0
396076 29018 0
396076 29046 0
396076 29074 0
396076 29102 1
396076 29165 0
396076 29200 0
396076 29228 0
396076 29263 0
396076 29200 0
396076 29228 0
396076 29263 0
Sto cercando di calcolare il numero di istanzeper un record negli ultimi sei mesi in cui 3a colonna è 1 (indicato come LACE_E). Quindi per il primo record, dove l'età è minima, sarà zero. E per il secondo record se la differenza di età in giorni è <= 183 giorni e la colonna 3 per il primo record è zero, allora sarà uno e così via.
Accolgo la seguente domanda in R:
LACE_E <- numeric(0)
for(i in 1:length(sh_data[,1]))
{
LACE_E[i] = 0
for(j in 1:length(sh_data[,1]))
{
if(sh_data$Patient_ID[i] == sh_data$Patient_ID[j] & sh_data$Age_in_days[i] > sh_data$Age_in_days[j] & (sh_data$Age_in_days[i]- sh_data$Age_in_days[j])<= 183 & sh_data$DEMAdmNo[j] == 1)
{LACE_E[i] = LACE_E[i] + 1}
}
}
Questa query richiede molto tempo per essere elaborata. 1 ora per elaborare 100 righe nel mio sistema. Per favore aiuto!!
risposte:
5 per risposta № 1Non hai bisogno di andare a Rcpp o data.table ottenere miglioramenti molto significativi.
Prendendo i tuoi dati originali e replicandoli per ottenere tempi più utilizzabili:
d <- read.table(head = TRUE, text =
"Patient_ID Age_in_days DEMAdmNo
396076 28542 0
396076 28570 0
396076 28598 0
396076 28626 0
396076 28654 0
396076 28682 0
396076 28710 0
396076 28738 0
396076 28766 0
396076 28794 0
396076 28822 0
396076 28850 0
396076 28878 0
396076 28906 0
396076 28934 0
396076 28962 0
396076 28990 0
396076 29018 0
396076 29046 0
396076 29074 0
396076 29102 1
396076 29165 0
396076 29200 0
396076 29228 0
396076 29263 0
396076 29200 0
396076 29228 0
396076 29263 0 ")
d <- rbind(d, d, d, d, d, d, d, d, d, d)
Il tuo codice originale come funzione e una corsa temporale:
f0 <- function(sh_data) {
LACE_E <- numeric(0)
for(i in 1:length(sh_data[,1])) {
LACE_E[i] = 0
for(j in 1:length(sh_data[,1])) {
if(sh_data$Patient_ID[i] == sh_data$Patient_ID[j] &
sh_data$Age_in_days[i] > sh_data$Age_in_days[j] &
(sh_data$Age_in_days[i]- sh_data$Age_in_days[j])<= 183 &
sh_data$DEMAdmNo[j] == 1) {
LACE_E[i] = LACE_E[i] + 1
}
}
}
}
system.time(v0 <- f0(d))
## user system elapsed
## 4.803 0.007 4.812
Il profilo mostra circa il 90% del tempo speso nell'estrazione delle colonne con $ nel ciclo interno:
Rprof()
v0 <- f0(d)
Rprof(NULL)
head(summaryRprof()$by.total)
## "f0" 4.94 100.00 0.60 12.15
## "$" 4.24 85.83 0.72 14.57
## "$.data.frame" 3.52 71.26 0.36 7.29
## "[[" 3.16 63.97 0.46 9.31
## "[[.data.frame" 2.70 54.66 0.96 19.43
## "%in%" 0.92 18.62 0.22 4.45
Lo spostamento delle estrazioni della colonna dai loop migliora sostanzialmente le prestazioni:
f1 <- function(sh_data) {
LACE_E <- numeric(0)
Patient_ID <- sh_data$Patient_ID
Age_in_days <- sh_data$Age_in_days
DEMAdmNo <- sh_data$DEMAdmNo
for(i in 1:length(sh_data[,1])) {
LACE_E[i] = 0
for(j in 1:length(sh_data[,1])) {
if(Patient_ID[i] == Patient_ID[j] &
Age_in_days[i] > Age_in_days[j] &
(Age_in_days[i]- Age_in_days[j])<= 183 &
DEMAdmNo[j] == 1) {
LACE_E[i] = LACE_E[i] + 1
}
}
}
}
system.time(v1 <- f1(d))
## user system elapsed
## 0.163 0.000 0.164
È quasi sempre una cattiva idea iniziare con un risultato vuoto e coltivarlo; pre-allocare il risultato è una pratica migliore. In questo caso l'algoritmo è già O(n^2) quindi non te ne accorgi, ma fa la differenza, soprattutto dopo aver aggiunto altri miglioramenti. f2 pre-alloca il risultato:
f2 <- function(sh_data) {
n <- nrow(sh_data)
LACE_E <- numeric(n)
Patient_ID <- sh_data$Patient_ID
Age_in_days <- sh_data$Age_in_days
DEMAdmNo <- sh_data$DEMAdmNo
for(i in 1:n) {
LACE_E[i] = 0
for(j in 1:n) {
if(Patient_ID[i] == Patient_ID[j] &
Age_in_days[i] > Age_in_days[j] &
(Age_in_days[i]- Age_in_days[j])<= 183 &
DEMAdmNo[j] == 1) {
LACE_E[i] = LACE_E[i] + 1
}
}
}
}
system.time(v2 <- f2(d))
## user system elapsed
## 0.147 0.000 0.148
Utilizzando l'operatore logico giusto && invece di & migliora ulteriormente le cose:
f3 <- function(sh_data) {
n <- nrow(sh_data)
LACE_E <- numeric(n)
Patient_ID <- sh_data$Patient_ID
Age_in_days <- sh_data$Age_in_days
DEMAdmNo <- sh_data$DEMAdmNo
for(i in 1:n) {
LACE_E[i] = 0
for(j in 1:n) {
if(Patient_ID[i] == Patient_ID[j] &&
Age_in_days[i] > Age_in_days[j] &&
(Age_in_days[i] - Age_in_days[j]) <= 183 &&
DEMAdmNo[j] == 1) {
LACE_E[i] = LACE_E[i] + 1
}
}
}
}
system.time(v3 <- f3(d))
## user system elapsed
## 0.108 0.002 0.111
Questi sono tutti i passaggi che devi seguire per andare Rcpp, ma non hai bisogno di andare a Rcpp prenderli
Per ottenere un po 'più di velocità è possibile compilare i byte:
f3c <- compiler::cmpfun(f3)
system.time(v3 <- f3c(d))
## user system elapsed
## 0.036 0.000 0.036
Questi calcoli sono stati fatti in R 3.1.3. UN microbenchmark sommario:
microbenchmark(f0(d), f1(d), f2(d), f3(d), f3c(d), times = 10)
## Unit: milliseconds
## expr min lq mean median uq max neval cld
## f0(d) 5909.39756 5924.8493 5963.63608 5947.23469 6011.94567 6048.03571 10 d
## f1(d) 196.16466 197.3252 200.22471 197.93345 202.49236 210.22011 10 c
## f2(d) 187.68169 190.5644 194.02454 192.47596 195.63821 204.27415 10 c
## f3(d) 109.17816 110.6695 112.55218 111.93915 114.43341 116.92342 10 b
## f3c(d) 37.37348 38.8757 39.34564 39.58563 40.50597 40.58568 10 a
R.version$version.string
## [1] "R version 3.1.3 Patched (2015-03-16 r68072)"
La versione R 3.2.0 rilasciata ad aprile ha una serie di miglioramenti al motore interprete e byte code, che migliora ulteriormente le prestazioni:
## Unit: milliseconds
## expr min lq mean median uq max neval cld
## f0(d) 4351.33908 4429.71559 4471.32960 4479.13901 4499.39769 4601.05390 10 d
## f1(d) 183.57765 184.68961 190.10391 187.30951 199.56235 200.57238 10 c
## f2(d) 177.47063 181.09790 189.78291 185.58951 190.34782 233.90264 10 c
## f3(d) 105.79767 108.02553 114.48950 110.17056 112.85710 149.42474 10 b
## f3c(d) 14.41182 14.43227 14.70098 14.49289 14.84504 15.67709 10 a
R.version$version.string
## [1] "R Under development (unstable) (2015-03-24 r68072)"
Così buone pratiche di programmazione R e l'uso di strumenti di analisi delle prestazioni possono portarvi molto lontano. Se vuoi ulteriori miglioramenti, puoi andare a Rcpp ma questo potrebbe essere sufficiente per i tuoi scopi.
2 per risposta № 2
Penso che questo sia meglio ottenuto usando Rcpp e data.table. Non hai davvero bisogno di fare i for-loop in R per questo problema.
Il mio suggerisco il seguente approccio?
Crea un nuovo source.cpp file come segue (la directory di esempio è C: Projects)
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
List myFunction(NumericVector x,NumericVector y) {
const int n(x.size());
NumericVector res(n);
// x is age_in_days
// y is DEMAAdmNo
for (int i=1; i<n; i++) {
res[i]=0;
for (int j=1; j<j; j++) {
if ( (x[i]>x[j]) & ((x[i]-x[j])<=183) & (y[j]==1)) {
res[i]=res[i]+1;
}
}
}
return Rcpp::List::create(_["res"] = res);
}
se non hai il Rcpp pacchetto installato, si prega di farlo e caricare il file cpp creato sopra in questo modo:
Rcpp::sourceCpp("C:/Projects/source.cpp")
Quindi, nel tuo file principale, fai quanto segue:
library(data.table) #If not installed, do install.packages("data.table")
sh_data=fread("C:/Projects/data3.csv") #Please put your correct file path here
sh_data[, LACE_E := myFunction(Age_in_days, DEMAdmNo), by=Patient_ID]
Non ho potuto verificare i numeri perché non hai specificato quale output vuoi, quindi per favore aggiusta il file if dichiarazione nel cpp file.
In ogni caso, una combinazione di Rcpp e data.table ti farà risparmiare molto tempo. Altamente raccomandato.
Spero che questo ti aiuti.