如何使用map,sapply为R中的元素智能操作构建有效的循环

2019年7月28日 228次阅读

我有一个约200k行的数据集,我想计算多个变量的百分位数.我使用的方法需要大约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()可以做同样的事情,但我关注的是,即使是一个简单的操作,当迭代变量的每个元素时也需要时间.可能是我做错了什么.

以下是我的会话信息：

> 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

最佳答案 在我看来你正在实现(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))
点赞