How to create efficient loops for elementary operations in R using a map, sapply

Question

I have a data set with ~ 200 thousand rows, and I want to calculate the percentile points for several variables. The method I use takes ~ 10 minutes for one variable. Is there an effective way to do this. Below is a fake dataset of my 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)
}

First method:

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

Conclusion:

Time difference of 10.51337 mins

Second method:

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

Conclusion:

Time difference of 6.86872 mins

The third method:

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

Conclusion:

Time difference of 11.1495 mins

Next I tried a simple elemental operation, but it still took time

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

There is percent_rank () in dplyr that does the same thing, but my concern here is that even a simple operation takes time when iterating over each element of the variable is performed. Maybe I'm doing something wrong.

The following is session information:

> 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

, (rank(DATA$Var) - 0.5) / length(DATA$Var).

:

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