Как оптимизировать пакетное прогнозирование - PullRequest
Новая
       81

Как оптимизировать пакетное прогнозирование

6 голосов
/ 21 июня 2020

Я наткнулся на код Джозефа Оуэна здесь для пакетного прогнозирования. У меня есть набор данных, содержащий около ~ 19 тыс. Строк, но проблема в том, что даже с примененной методологией пакетного прогнозирования мой код все еще работает очень медленно.

Мне нужно оценить лучшую модель, для которой я использую MAPE в качестве оценивающей критерии, прежде чем делать фактический прогноз. Ниже приведен работоспособный фрагмент кода для того же. Мой вопрос: как оптимизировать приведенный ниже код, чтобы он работал в приемлемое время (менее 2 минут) 

 fcnChooseETS <- function(Ts){
       
  TsPositive <- ( min( as.numeric(Ts) ) > 0 ) # Check if all values of timeseries are positive or not
  
  ModelsUsed <- c("ANN","MNN","ANA","AAN","AAA","MAA","MNM","MMN","MMM","MNA","MAN","MAM")
  ModelsNonPositive <- c("ANN","ANA","AAN","AAA") # Multiplicative models cannot take non positive data
  
  if( !TsPositive ){
    ModelsUsed <- ModelsNonPositive
  }
  
  lAllModels <- lapply(ModelsUsed, function(M){
    ets(Ts, damped = NULL, model = M)
  })
  
  vecResult <- sapply(lAllModels, function(M) accuracy(M)[2])
  
  names(vecResult) <- ModelsUsed
  min(vecResult)      
}  

    fcnTrending <- function( dt){
      Ts <- lapply(transpose(dt), ts , frequency = 12 , end = FeedDate)
      fit <- lapply(Ts , fcnChooseETS ) 
    }

1 Ответ

3 голосов
/ 21 июня 2020

Следующий сценарий проверяет 3 различных способа подбора моделей в вопросе. Первый из них - это более идиоматическая c версия кода, опубликованного в вопросе, следующие две подходят для нескольких моделей параллельно.

Этот сценарий был сохранен в файле so_62497397.R и запускался, как показано ниже. 

#
# filename: so_62497397.R
# Test serial and two types of parallel execution of
# exponential smoothing time series fitting.

library(parallel)
library(foreach)
library(doParallel)
library(forecast)

fcnChooseETS <- function(Ts){

  TsPositive <- ( min( as.numeric(Ts) ) > 0 ) # Check if all values of timeseries are positive or not

  ModelsUsed <- c("ANN","MNN","ANA","AAN","AAA","MAA","MNM","MMN","MMM","MNA","MAN","MAM")
  ModelsNonPositive <- c("ANN","ANA","AAN","AAA") # Multiplicative models cannot take non positive data

  if( !TsPositive ){
    ModelsUsed <- ModelsNonPositive
  }

  lAllModels <- lapply(ModelsUsed, function(M){
    ets(Ts, damped = NULL, model = M)
  })

  vecResult <- sapply(lAllModels, function(M) accuracy(M)[2])

  names(vecResult) <- ModelsUsed
  vecResult[which.min(vecResult)]
}
fcnChooseETS2 <- function(Ts, Ncpus = 2){

  TsPositive <- ( min( as.numeric(Ts) ) > 0 ) # Check if all values of timeseries are positive or not

  ModelsUsed <- c("ANN","MNN","ANA","AAN","AAA","MAA","MNM","MMN","MMM","MNA","MAN","MAM")
  ModelsNonPositive <- c("ANN","ANA","AAN","AAA") # Multiplicative models cannot take non positive data

  if( !TsPositive ){
    ModelsUsed <- ModelsNonPositive
  }

  vecResult <- mclapply(ModelsUsed, function(M){
    fit <- ets(Ts, damped = NULL, model = M)
    accuracy(fit)[2]
  }, mc.cores = Ncpus)

  vecResult <- unlist(vecResult)
  names(vecResult) <- ModelsUsed
  vecResult[which.min(vecResult)]
}

fcnChooseETS3 <- function(Ts, Ncpus = 2){

  TsPositive <- ( min( as.numeric(Ts) ) > 0 ) # Check if all values of timeseries are positive or not

  ModelsUsed <- c("ANN","MNN","ANA","AAN","AAA","MAA","MNM","MMN","MMM","MNA","MAN","MAM")
  ModelsNonPositive <- c("ANN","ANA","AAN","AAA") # Multiplicative models cannot take non positive data

  if( !TsPositive ){
    ModelsUsed <- ModelsNonPositive
  }

  cl <- makeCluster(Ncpus)
  clusterExport(cl, 'ts')
  clusterEvalQ(cl, library(forecast))
  vecResult <- parLapply(cl, ModelsUsed, function(M){
    fit <- ets(Ts, damped = NULL, model = M)
    accuracy(fit)[2]
  })
  stopCluster(cl)

  vecResult <- unlist(vecResult)
  names(vecResult) <- ModelsUsed
  vecResult[which.min(vecResult)]
}

makeTestdata <- function(N){
  n <- length(USAccDeaths)
  m <- ceiling(log2(N/n))
  x <- as.numeric(USAccDeaths)
  for(i in seq_len(m)) x <- c(x, x)
  L <- length(x)/12 - 1
  x <- ts(x, start = 2000 - L, frequency = 12)
  x
}


numCores <- detectCores()
cat("numCores:", numCores, "\n")

x <- makeTestdata(5e3)

t1 <- system.time(
  res1 <- fcnChooseETS(x)
)
t2 <- system.time(
  res2 <- fcnChooseETS2(x, Ncpus = numCores)
)
t3 <- system.time(
  res3 <- fcnChooseETS3(x, Ncpus = numCores)
)

rbind(t.lapply = t1,
      t.mclapply = t2,
      t.parLapply = t3)

c(res1, res2, res3)

Запуск с Rscript на

  • устаревшем P C, процессоре Intel® Core ™ i3 CPU 540 @ 3,07 ГГц × 4 ядра,
  • R версии 4.0. 2 (2020-06-22)
  • Ubuntu 20.04.

Тайминги показывают, что mclapply - лучший вариант, хотя и ненамного быстрее parLapply. Из подогнанных моделей все выбранные с помощью MAPE такие же, как и должны быть. 

rui@rui:~$ Rscript --vanilla so_62497397.R
#Loading required package: iterators
#Registered S3 method overwritten by 'quantmod':
#  method            from
#  as.zoo.data.frame zoo 
#numCores: 4 
#            user.self sys.self elapsed user.child sys.child
#t.lapply       56.505    0.063  57.389      0.000      0.00
#t.mclapply      0.039    0.024  33.983     30.506      0.26
#t.parLapply     0.040    0.012  36.317      0.001      0.00
#     ANA      ANA      ANA 
#263.0876 263.0876 263.0876
...