перевести эту петлю в мурлыканье?

Question

Я пытаюсь создать обучающий пример по выборке для учащихся, но результат получается слишком медленным, когда число итераций исчисляется тысячами (реальный фрейм данных df имеет несколько миллионов строк).

Могу ли я ускорить это с purr?

library(tidyverse)
set.seed(1432)
df <- data.frame(v1 = sample(1:10, 100, replace=TRUE),
                 v2 = c(rep("A", 50), rep("B", 50))
)

output <- NULL

for (i in 1:10) {
  set.seed(i)
  d <- df %>%
    filter(v2=="A") %>%
    sample_n(20, replace=FALSE)

  mean = mean(d$v1)
  output <- c(output, mean)
}

output

Answer 1

Вы можете использовать purrr следующим образом.

map_dbl(1:10, function(x){
  set.seed(x)
  d <- df %>%
    filter(v2=="A") %>%
    sample_n(20, replace=FALSE)

  return(mean(d$v1))
})
# [1] 5.15 5.90 5.70 5.55 5.60 4.95 5.40 5.40 5.65 5.40

Answer 2

purrr не обязательно быстрее, но более читабелен, чем базовые управляющие структуры в R. Когда дело доходит до замены цикла, вот что вы можете сделать в базе R:

sapply(1:10, function(x){
  set.seed(x)
  d <- df %>%
    filter(v2=="A") %>%
    sample_n(20, replace=FALSE)
  mean(d$v1)
})

ОБНОВЛЕНИЕ То, что вы используете dplyr и purrr, не гарантирует, что ваш код будет быстрым. IMO, эти пакеты были разработаны для улучшения читабельности кода, а не для ускорения дорогостоящих вычислений. Вы можете добиться значительного ускорения, если будете осторожно использовать базовые структуры данных R. d - это исходный цикл, a и b - решения для функционального программирования, а f - оптимизированное решение:

a <- function(y){sapply(1:y, function(x){
  set.seed(x)
  d <- df %>%
    filter(v2=="A") %>%
    sample_n(20, replace=FALSE)
    mean(d$v1)
})}

b <- function(y) {map_dbl(1:y, function(x){
  set.seed(x)
  d <- df %>%
    filter(v2=="A") %>%
    sample_n(20, replace=FALSE)

  return(mean(d$v1))
})}

d <- function(y){
  output <- NULL
  for (i in 1:y) {
    set.seed(i)
    d <- df %>%
      filter(v2=="A") %>%
      sample_n(20, replace=FALSE)
    output <- c(output, mean(d$v1))
  }

  output
}

f <- function(y){
  output <- vector("list", y)
  for (i in 1:y) {
    set.seed(i)
    d <- df[df$v2 == "A", ]
    d <- d[sample(1:nrow(d), 20, replace = FALSE), ]

    output[[i]] <- mean(d$v1)
  }

  output
}

microbenchmark::microbenchmark(a(100),b(100),d(100), f(100))

Unit: milliseconds
   expr       min        lq      mean    median        uq       max neval
 a(100) 172.06305 187.95053 205.19531 199.84411 210.55501 306.41906   100
 b(100) 171.86030 186.18869 206.50518 196.07746 213.79044 397.87859   100
 d(100) 174.45273 191.01706 208.07125 199.12653 216.54543 365.55107   100
 f(100)  14.62159  15.80092  20.96736  19.14848  24.16181  37.54095   100

Обратите внимание, что f почти в 10 раз быстрее, чем d, в то время как a, b и d имеют почти одинаковую скорость.