R: применение нескольких функций по группам столбцов по данным временных рядов

Question

У меня есть временные ряды данных на часовом уровне. Я пытаюсь построить прогноз для этих данных. Ниже приводится выборка данных:

sample <- 
structure(list(group_type = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L), .Label = c("Group 1", 
"Group 2", "Group 5"), class = "factor"), sub_group_type = structure(c(1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 
3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L), .Label = c("Sub Group 1", "Sub Group 2", "Sub Group 3"), 
class = "factor"), date = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 
2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L), .Label = c("1/1/17", 
"1/2/17", "1/3/17"), class = "factor"), hour = c(6L, 7L, 8L, 9L, 10L, 11L, 12L, 
6L, 7L, 8L, 9L, 10L, 11L, 12L, 6L, 7L, 8L, 9L, 10L, 11L, 12L, 6L, 7L, 8L, 9L, 
10L, 11L, 12L, 6L, 7L, 8L, 9L, 10L, 11L, 12L, 6L, 7L, 8L, 9L, 10L, 11L, 12L, 6L, 
7L, 8L, 9L, 10L, 11L, 12L, 6L, 7L, 8L, 9L, 10L, 11L, 12L, 6L, 7L, 8L, 9L, 10L, 
11L, 12L, 6L, 7L, 8L, 9L, 10L, 11L, 12L, 6L, 7L, 8L, 9L, 10L, 11L, 12L, 6L, 7L, 
8L, 9L, 10L, 11L, 12L, 6L, 7L, 8L, 9L, 10L, 11L, 12L, 6L, 7L, 8L, 9L, 10L, 11L, 
12L, 6L, 7L, 8L, 9L, 10L, 11L, 12L), weekday = structure(c(2L, 2L, 2L, 2L, 2L, 
2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 2L, 2L, 2L, 2L, 
2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 2L, 2L, 2L, 
2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 2L, 2L, 
2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 2L, 
2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 3L, 3L, 3L, 3L, 3L, 3L, 3L), 
.Label = c("Monday", "Sunday", "Tuesday"), class = "factor"), total = c(9L, 9L, 
10L, 6L, 2L, 14L, 3L, 11L, 12L, 12L, 0L, 10L, 8L, 13L, 14L, 17L, 12L, 5L, 9L, 7L, 
10L, 13L, 23L, 11L, 3L, 6L, 10L, 11L, 14L, 16L, 13L, 2L, 3L, 4L, 14L, 11L, 16L, 
8L, 12L, 7L, 6L, 13L, 13L, 22L, 12L, 7L, 9L, 8L, 14L, 9L, 16L, 15L, 6L, 7L, 6L, 
12L, 13L, 14L, 7L, 3L, 13L, 11L, 6L, 8L, 15L, 11L, 3L, 10L, 9L, 7L, 12L, 10L, 10L, 
3L, 14L, 8L, 12L, 10L, 20L, 5L, 4L, 8L, 12L, 3L, 0L, 4L, 5L, 1L, 6L, 7L, 0L, 3L, 
1L, 1L, 0L, 2L, 2L, 0L, 2L, 0L, 3L, 7L, 6L, 2L, 1L)), .Names = c("group_type", 
"sub_group_type", "date", "hour", "weekday", "total"), class = "data.frame", 
row.names = c(NA, -105L)) 

Я применяю следующие функции для приведенных выше данных:

models <- function(x){ 
    x <- msts(x, seasonal.periods=c(24,168)) 
    mod_exp <- ets(x, ic='aicc', restrict=T) 
    mod_hwa <- HoltWinters(x,seasonal = "additive") 
    mod_hwm <- HoltWinters(x,seasonal = "multiplicative") 
    mod_neural <- nnetar(x, p=7, size=25) 
    mod_tbats <- tbats(x, ic='aicc', seasonal.periods=7) 
    mod_bats <- bats(x, ic='aicc', seasonal.periods=7) 
    mod_stl <- stlm(x, s.window=7, ic='aicc', robust=TRUE, method='ets') 
    mod_sts <- StructTS(x) 
} 

test <- by(sample,list(sample$group_type,sample$sub_group_type,sample$date, sample$hour 
),models) 

Однако, я получаю следующее сообщение об ошибке:

Error in ets(x, ic = "aicc", restrict = T) : y should be a univariate time series 

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

sub_sample_1 <- sample[sample$group_type == "Group 1" & sample$sub_group_type == "Sub Group 1",6] 
x <- msts(sub_sample_1, seasonal.periods=24) 
mod_arima <- auto.arima(x, ic='aicc', stepwise=F) 
mod_exp <- ets(x, ic='aicc', restrict=T) 
mod_hwa <- HoltWinters(x,seasonal = "additive") 
mod_hwm <- HoltWinters(x,seasonal = "multiplicative") 
mod_neural <- nnetar(x, p=24, size=10) 
mod_tbats <- tbats(x, ic='aicc', seasonal.periods=24) 
mod_bats <- bats(x, ic='aicc', seasonal.periods=24) 
mod_stl <- stlm(x, s.window=24, ic='aicc', robust=TRUE, method='ets') 
mod_sts <- StructTS(x) 

Есть ли какие-либо работы вокруг так, что Могу ли я применять модели по группам столбцов без каких-либо ошибок?

Кроме того, не все модели работают для всех групп. Для данных sub_sample_1, HoltWinters, neuralnet, летучие мыши и СТЛ дают мне ошибку и другие работают

> mod_hwa <- HoltWinters(x,seasonal = "additive") 
Error in decompose(ts(x[1L:wind], start = start(x), frequency = f), seasonal) : 
time series has no or less than 2 periods 

> mod_hwm <- HoltWinters(x,seasonal = "multiplicative") 
Error in HoltWinters(x, seasonal = "multiplicative") : 
data must be non-zero for multiplicative Holt-Winters 

> mod_bats <- bats(x, ic='aicc', seasonal.periods=24) 
Error in optim(par = param.vector$vect, fn = calcLikelihoodNOTransformed, : 
function cannot be evaluated at initial parameters 

Я могу понять, почему эти модели не работают для моих данных. Как я могу исключить их, когда они дают ошибки, когда я применяю эту функцию?

Заранее благодарим за помощь!

Этот вопрос похож (расширение возможно) на мой другой вопрос here

Answer 1

Некоторых проблемы возникают из текущей настройки:

1. Функция возвращает последнюю строку, если нет return() не указан. Таким образом, ваша первая попытка потеряет все линии, за исключением mod_sts, которая будет равна test для каждого подмножества by.

2. В коде подмножества вы фактически передаете 6-й столбец (атомный вектор), тогда как вы передаете все столбцы данных в своей первой попытке кода. Это может быть причиной вашей ошибки, где вход должен быть согласно msts документов:

   A numeric vector, ts object, matrix or data frame. It is intended that the time series data is univariate, otherwise treated the same as ts().

3. Вашего by получает четыре группировки, group_type, sub_group_type, даты и часа в отличие от вашего второй код подмножества двух. Если ваши данные не очень велики, эти многочисленные группировки могут возникать с несколькими строками или без строк и, следовательно, не достаточными точками данных для типовых процедур, как кажется вашему предыдущему блоку кода.

С учетом сказанного рассмотрим следующую корректировку при возврате списка именованных элементов по первым двум группировкам с указанием шестого столбца.И поскольку by принимает комбинации факторов, которые в подмножестве данных могут не содержать строк, ниже используется tryCatch, чтобы фиксировать любые ошибки и возвращать пустые списки для фильтрации в окончательной строке.

models <- function(x){ 
    x <- msts(x, seasonal.periods=c(24,168)) 
    list(
    mod_exp = ets(x, ic='aicc', restrict=T), 
    mod_hwa = HoltWinters(x,seasonal = "additive"), 
    mod_hwm = HoltWinters(x,seasonal = "multiplicative"), 
    mod_neural = nnetar(x, p=7, size=25), 
    mod_tbats = tbats(x, ic='aicc', seasonal.periods=7), 
    mod_bats = bats(x, ic='aicc', seasonal.periods=7), 
    mod_stl = stlm(x, s.window=7, ic='aicc', robust=TRUE, method='ets'), 
    mod_sts = StructTS(x) 
) 
} 

# TRY/CATCH TO CAPTURE ERRORS AND RETURN EMPTY LIST 
test <- by(sample[,6], list(sample$group_type, sample$sub_group_type), 
      function(x) tryCatch({ models(x) 
           }, error=function(e) return(list(NA)))) 

# TO REMOVE NULLs AND NAs (EMPTY ITEMS) 
test <- Filter(function(i) length(i) > 0, test)