Генерация интерактивных графиков частичной зависимости в R с использованием цикла очень медленно - PullRequest
Новая
       17

Генерация интерактивных графиков частичной зависимости в R с использованием цикла очень медленно

3 голосов
/ 21 марта 2019

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

Воспроизводимый пример: 

library(pdp)
library(xgboost)
library(Matrix)
library(ggplot2)
library(plotly)

data(mtcars)
target <- mtcars$mpg
mtcars$mpg <- NULL

mtcars.sparse <- sparse.model.matrix(target~., mtcars)

fit <- xgboost(data=mtcars.sparse, label=target, nrounds=100)

for (i in seq_along(names(mtcars))){
  p1 <- pdp::partial(fit,
                     pred.var = names(mtcars)[i],
                     pred.grid = data.frame(unique(mtcars[names(mtcars)[i]])),
                     train = mtcars.sparse,
                     type = "regression",
                     cats = c("cyl", "vs", "am", "gear", "carb"),
                     plot = FALSE)
  p2 <- ggplot(aes_string(x = names(mtcars)[i] , y = "yhat"), data = p1) +
    geom_line(color = '#E51837', size = .6) +
    labs(title = paste("Partial Dependence plot of", names(mtcars)[i] , sep = " ")) +
    theme(text = element_text(color = "#444444", family = 'Helvetica Neue'),
          plot.title = element_text(size = 13, color = '#333333'))

  print(ggplotly(p2, tooltip = c("x", "y")))

}

Цикл построения моего реального набора данных(~ 22 тыс. Строк, 30 столбцов) занимает около 2 часов.Есть идеи, как это ускорить?

1 Ответ

1 голос
/ 22 марта 2019

Из-за того, как структуры данных используются в R, циклы for() могут быть мучительно медленными, если вы не будете осторожны.Если вы хотите узнать больше о технических причинах этого, взгляните на Advanced R от Hadley Wickham.

Практически, есть два основных подхода к ускорению того, что вы хотите сделать: оптимизация цикла for() и использование семейства функций apply().Хотя оба подхода могут работать хорошо, метод apply(), как правило, работает быстрее, даже чем оптимально записанный цикл for(), поэтому я буду придерживаться этого решения.

метод apply: 

plotFunction <- 
  function(x) {
    p1 <- pdp::partial(fit,
                       pred.var = x,
                       pred.grid = data.frame(unique(mtcars[x])),
                       train = mtcars.sparse,
                       type = "regression",
                       cats = c("cyl", "vs", "am", "gear", "carb"),
                       plot = FALSE)
    p2 <- ggplot(aes_string(x = x , y = "yhat"), data = p1) +
      geom_line(color = '#E51837', size = .6) +
      labs(title = paste("Partial Dependence plot of", x , sep = " ")) +
      theme(text = element_text(color = "#444444", family = 'Helvetica Neue'),
            plot.title = element_text(size = 13, color = '#333333'))
    return(p2)
  }


plot.list <- lapply(varNames, plotFunction)

system.time(lapply(varNames, plotFunction))
   user  system elapsed 
  0.471   0.004   0.488

Выполнение того же теста в цикле for() дало: 

   user  system elapsed 
  3.945   0.616   3.519

Как вы заметите, это примерно в 10 раз быстрее, просто вставив код цикла вфункция, с небольшими изменениями.

Если вам нужна дополнительная скорость, есть несколько настроек, которые вы можете внести в свою функцию, но, возможно, самый мощный аспект подхода apply() заключается в том, что он хорошо подходит для распараллеливания, что можно сделать с помощьюпакеты типа pbmcapply

, реализующие pbmcapply, дают вам еще большую скорость; 

library(pdp)
library(xgboost)
library(Matrix)
library(ggplot2)
library(plotly)
library(pbmcapply)

# Determines the number of cores you want to use for paralell processing
# I like to leave two of mine available, but you can get away with 1
nCores <-  detectCores() - 1

data(mtcars)
target <- mtcars$mpg
mtcars$mpg <- NULL

mtcars.sparse <- sparse.model.matrix(target~., mtcars)

fit <- xgboost(data=mtcars.sparse, label=target, nrounds=100)

varNames <- 
  names(mtcars) %>%
  as.list

plotFunction <- 
  function(x) {
    p1 <- pdp::partial(fit,
                       pred.var = x,
                       pred.grid = data.frame(unique(mtcars[x])),
                       train = mtcars.sparse,
                       type = "regression",
                       cats = c("cyl", "vs", "am", "gear", "carb"),
                       plot = FALSE)
    p2 <- ggplot(aes_string(x = x , y = "yhat"), data = p1) +
      geom_line(color = '#E51837', size = .6) +
      labs(title = paste("Partial Dependence plot of", x , sep = " ")) +
      theme(text = element_text(color = "#444444", family = 'Helvetica Neue'),
            plot.title = element_text(size = 13, color = '#333333'))
    return(p2)
  }


plot.list <- pbmclapply(varNames, plotFunction, mc.cores = nCores)

Давайте посмотрим, как это удалось 

   user  system elapsed 
  0.842   0.458   0.320

Небольшое улучшение по сравнению с lapply(), но это улучшение должно масштабироваться с вашим большим набором данных.Надеюсь, это поможет!

...