Comment construire des boucles efficaces pour les opérations élémentaires dans R en utilisant la carte, spply

Question

J'ai un ensemble de données avec ~ 200k lignes et je veux calculer des scores en percentile pour plusieurs variables. La méthode que j'utilise prend ~ 10 minutes pour une seule variable. Y a-t-il un moyen efficace de le faire? Voici un faux ensemble de données mon code.

library(dplyr) 
library(purrr) 

id <- c(1:200000) 
X <- rnorm(200000,mean = 5,sd=100) 
DATA <- data.frame(ID =id,Var = X) 

percentileCalc <- function(value){ 
    per_rank <- ((sum(DATA$Var < value)+(0.5*sum(DATA$Var == value)))/length(DATA$Var)) 
    return(per_rank) 
} 

Première méthode:

res <- numeric(length = length(DATA$Var)) 
sta <- Sys.time() 
for (i in seq_along(DATA$Var)) { 
    res[i]<-percentileCalc(DATA$Var[i]) 
} 
sto <- Sys.time() 
sto - sta 

sortie:

Time difference of 10.51337 mins 

Deuxième méthode:

sta <- Sys.time() 
res <- map(DATA$Var,percentileCalc) 
sto <- Sys.time() 
sto - sta 

sortie:

Time difference of 6.86872 mins 

Troisième méthode:

sta <- Sys.time() 
res <- sapply(DATA$Var,percentileCalc) 
sto <- Sys.time() 
sto - sta 

Sortie:

Time difference of 11.1495 mins 

Ensuite, j'ai essayé un élément simple opération sage, mais il a fallu du temps

simpleOperation <- function(value){ 
    per_rank <- sum(DATA$Var < value) 
    return(per_rank) 
} 

res <- numeric(length = length(DATA$Var)) 
sta <- Sys.time() 
for (i in seq_along(DATA$Var)) { 
    res[i]<-simpleOperation(DATA$Var[i]) 
} 
sto <- Sys.time() 
sto - sta 

Time difference of 3.369287 mins 

sta <- Sys.time() 
res <- map(DATA$Var,simpleOperation) 
sto <- Sys.time() 
sto - sta 

Time difference of 3.979965 mins 

sta <- Sys.time() 
res <- sapply(DATA$Var,simpleOperation) 
sto <- Sys.time() 
sto - sta 

Time difference of 6.535737 mins 

Il y a PERCENT_RANK() disponible en dplyr qui fait un peu la même chose, mais mon souci ici est que même une simple opération prend du temps lors de l'itération sur chaque élément d'une variable. Peut-être que je fais quelque chose de mal.

Ce qui suit est mon numéro de session:

> sessionInfo() 
R version 3.4.0 (2017-04-21) 
Platform: x86_64-w64-mingw32/x64 (64-bit) 
Running under: Windows 7 x64 (build 7601) Service Pack 1 

Matrix products: default 

locale: 
[1] LC_COLLATE=English_United States.1252 LC_CTYPE=English_United States.1252 
[3] LC_MONETARY=English_United States.1252 LC_NUMERIC=C       
[5] LC_TIME=English_United States.1252  

attached base packages: 
[1] stats  graphics grDevices utils  datasets methods base  

other attached packages: 
[1] purrr_0.2.2 dplyr_0.5.0 

loaded via a namespace (and not attached): 
[1] compiler_3.4.0 lazyeval_0.2.0 magrittr_1.5 R6_2.2.0  assertthat_0.1 DBI_0.5-1  tools_3.4.0 
[8] tibble_1.2  Rcpp_0.12.10 

Answer 1

me semble que vous implémentez (rank(DATA$Var) - 0.5)/length(DATA$Var).

Vérification avec vos données et certaines données avec non seulement des valeurs uniques:

N <- 1e4 
DATA <- data.frame(
    ID = 1:N, 
    Var = rnorm(N, mean = 5, sd = 100), 
    Var2 = sample(0:10, size = N, replace = TRUE) 
) 

percentileCalc <- function(value) { 
    (sum(DATA$Var < value) + 0.5 * sum(DATA$Var == value))/length(DATA$Var) 
} 
percentileCalc2 <- function(value) { 
    (sum(DATA$Var2 < value) + 0.5 * sum(DATA$Var2 == value))/length(DATA$Var2) 
} 

all.equal((rank(DATA$Var) - 0.5)/length(DATA$Var), 
      sapply(DATA$Var, percentileCalc)) 
all.equal((rank(DATA$Var2) - 0.5)/length(DATA$Var2), 
      sapply(DATA$Var2, percentileCalc2)) 

---

simpleOperation <- function(value) { 
    sum(DATA$Var < value) 
} 
simpleOperation2 <- function(value) { 
    sum(DATA$Var2 < value) 
} 

all.equal(rank(DATA$Var, ties.method = "min") - 1, 
      sapply(DATA$Var, simpleOperation)) 
all.equal(rank(DATA$Var2, ties.method = "min") - 1, 
      sapply(DATA$Var2, simpleOperation2))