r - 如何使用 map,sapply 为 R 中的元素操作构建高效循环

Question

我有一个约 20 万行的数据集，我想计算多个变量的百分位数。对于单个变量，我使用的方法需要大约 10 分钟。有什么有效的方法可以做到这一点。以下是我的代码的虚假数据集。

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

第一种方法:

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

输出:

Time difference of 10.51337 mins

第二种方法:

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

输出:

Time difference of 6.86872 mins

第三种方法:

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

输出:

Time difference of 11.1495 mins

接下来我尝试了一个简单的元素智能操作，但仍然需要时间

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

dplyr 中有可用的 percent_rank() 可以做同样的事情，但我担心的是，即使是简单的操作在迭代变量的每个元素时也需要时间。可能是我做错了什么。

以下是我的 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

在我看来，您正在实现 (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))