How to add forecast accuracy to this loop for HoltWinters in R?

Question

A fully reproducible example.

library(forecast)
date = seq(as.Date("2019/01/01"), by = "month", length.out = 48)

productB = rep("B",48)
productB = rep("B",48)
productA = rep("A",48)
productA = rep("A",48)

subproducts1=rep("1",48)
subproducts2=rep("2",48)
subproductsx=rep("x",48)
subproductsy=rep("y",48)

b1 <- c(rnorm(30,5), rep(0,18))
b2 <- c(rnorm(30,5), rep(0,18))
b3 <-c(rnorm(30,5), rep(0,18))
b4 <- c(rnorm(30,5), rep(0,18))

Created the dataframe below

dfone <- data.frame("date"= rep(date,4),
            "product"= c(rep(productB,2),rep(productA,2)),
            "subproduct"= 
c(subproducts1,subproducts2,subproductsx,subproductsy),
            "actuals"= c(b1,b2,b3,b4))

export_df <- split(dfone[1:4], dfone[3])

Creation of data frames based off UNIQUE SUBPRODUCTS

dummy_list <- split(dfone[1:4], dfone[3]) %>% lapply( function(x) 
x[(names(x) %in% c("date", "actuals"))])
dummy_list <-  lapply(dummy_list, function(x) { x["date"] <- NULL; x })


list_dfs <- list()
for (i in 1:length(unique(dfone$subproduct))) {
  #assign(paste0("df", i), as.data.frame(dummy_list[[i]]))
  list_dfs <-append(list_dfs,dummy_list[[i]])
}

combined_dfs <- Reduce(function(x, y) merge(x, y, all = TRUE,  
by='date'), list(list_dfs))

Creating the time series

list_ts <- lapply(list_dfs, function(t) 
ts(t,start=c(2019,1),end=c(2021,6), frequency = 12)) %>%
  lapply( function(t) ts_split(t,sample.out=(0.2*length(t))))    # 
creates my train test split
list_ts <- do.call("rbind", list_ts)  #Creates a list of time series

Creation of many lists of time series. In this case creates 729 objects in the global environment.

n1 <- seq(0.1, 0.99, by = 0.1)
n2 <- seq(0.1, 0.99, by = 0.1)
n3 <- seq(0.1, 0.99, by = 0.1)

dat_n <- expand.grid(n1 = n1, n2= n2, n3 = n3) 
out<- lapply(seq_len(nrow(dat_n)), function(i) {
   c_triple_holtwinters_multiplicative <- lapply(list_ts[1: 
(length(list_ts)/2)], function(x) 
       forecast::forecast(HoltWinters(x,seasonal = "additive",alpha = 
dat_n$n1[i],beta=dat_n$n2[i],gamma=dat_n$n3[i])))
    c_triple_holtwinters_multiplicative <- 
 lapply(c_triple_holtwinters_multiplicative, "[", "mean")
  assign(paste0("c_triple_holtwinters_multiplicative", i), 
c_triple_holtwinters_multiplicative, envir = .GlobalEnv)
 c_triple_holtwinters_multiplicative})

I want to add the function below, where I can test each list object's training model data with accuracy for the test data and based off RMSE (list_ts[[4]] is the training and the test is list_ts[[8]] because there is 4 unique subproducts, it is 4+4=8.)

 forecast::accuracy(forecast::forecast(HoltWinters(list_ts[[4]],
 seasonal="multiplicative",alpha=.1,beta=.1,gamma=.2),h=24),list_ts[[8]])

        ME     RMSE      MAE         MPE      MAPE      MASE        ACF1 Theil's U
Training set    86.77923 2325.705 1476.658   -5.382147  32.47896 0.5611823 -0.05022049        
 NA
Test set     -3165.29871 6126.887 5389.800 -102.314548 129.32404 2.0483154  0.33876651  
 2.446896

The goal is to instead of having 729 objects, I want only 1 model object with the best RMSE on the test data for example.

Edit1: Take this out from the code above for now to use accuracy.

 c_triple_holtwinters_multiplicative <- 
     lapply(c_triple_holtwinters_multiplicative, "[", "mean")

Edit2: fixed the code This will now work and c_triple... is 1-4 and list_ts is 5-8 always.

forecast::accuracy(c_triple_holtwinters_multiplicative1[[1]],
 list_ts[[5]])[4] # pulls out the RMSE

When we find the lowest RMSE we want to add back the mean function to create the model to the glb environment

Edit3:

dat_n <- expand.grid(n1 = n1, n2= n2, n3 = n3) 
out<- lapply(seq_len(nrow(dat_n)), function(i) {
  c_triple_holtwinters_additive <- lapply(list_ts[1: 
(length(list_ts)/2)], function(x) 
      forecast::forecast(HoltWinters(x,seasonal = "additive",alpha = 
dat_n$n1[i],beta=dat_n$n2[i],gamma=dat_n$n3[i])))
 #    c_triple_holtwinters_additive <- 
 # lapply(c_triple_holtwinters_additive, "[", "mean")
 assign(paste0("c_triple_holtwinters_additive", i), 
c_triple_holtwinters_additive, envir = .GlobalEnv)
 c_triple_holtwinters_additive})

forecast::accuracy(c_triple_holtwinters_additive1[[1]],list_ts[[5]])[4]

Answer 1

We can use

out1 <- lapply(seq_len(nrow(dat_n)), function(i) {
    c_triple_holtwinters_additive <- lapply(list_ts[1: 
  (length(list_ts)/2)], function(x) 
        forecast::forecast(HoltWinters(x,seasonal = "additive",alpha = 
  dat_n$n1[i],beta=dat_n$n2[i],gamma=dat_n$n3[i])))

    c_triple_holtwinters_additive1 <- 
         lapply(c_triple_holtwinters_additive, "[", "mean")
    
    acc1 <- unlist(Map(function(x, y)

         forecast::accuracy(x,y )[4],
                 c_triple_holtwinters_additive,  list_ts[5:8]
              ))
    ind1 <- which.min(acc1)
    nm1 <- paste0("c_triple_holtwinters_additive", i)
    
    
     assign(nm1[ind1], 
        c_triple_holtwinters_additive1[[ind1]], envir = .GlobalEnv)

    c_triple_holtwinters_additive1[[ind1]]
   })

-checking

head(out1, 5)
[[1]]
[[1]]$mean
          Jan      Feb      Mar      Apr      May      Jun      Jul      Aug      Sep      Oct      Nov      Dec
2021 3.992136 4.551152 4.819030 2.722871 3.429581 5.088622 3.169820 5.611467 5.198844 3.475341 3.554109 5.348270
2022 3.335633 3.894648 4.162526 2.066368 2.773077 4.432118 2.513316 4.954963 4.542341 2.818837 2.897606 4.691766


[[2]]
[[2]]$mean
          Jan      Feb      Mar      Apr      May      Jun      Jul      Aug      Sep      Oct      Nov      Dec
2021 3.973570 4.537064 4.810701 2.720144 3.431003 5.093744 3.176812 5.638199 5.244988 3.506140 3.572943 5.374759
2022 3.363802 3.927296 4.200934 2.110376 2.821235 4.483976 2.567044 5.028431 4.635220 2.896372 2.963175 4.764991


[[3]]
[[3]]$mean
          Jan      Feb      Mar      Apr      May      Jun      Jul      Aug      Sep      Oct      Nov      Dec
2021 4.045785 4.619027 4.903568 2.823377 3.542898 5.213984 3.303773 5.790314 5.418427 3.663552 3.723406 5.541533
2022 3.546085 4.119327 4.403867 2.323676 3.043197 4.714283 2.804073 5.290613 4.918727 3.163851 3.223705 5.041832


[[4]]
[[4]]$mean
          Jan      Feb      Mar      Apr      May      Jun      Jul      Aug      Sep      Oct      Nov      Dec
2021 4.126131 4.707987 5.002172 2.930755 3.657247 5.335301 3.430712 5.941848 5.587022 3.810281 3.864567 5.703121
2022 3.722981 4.304837 4.599022 2.527605 3.254097 4.932151 3.027563 5.538699 5.183873 3.407132 3.461417 5.299972


[[5]]
[[5]]$mean
          Jan      Feb      Mar      Apr      May      Jun      Jul      Aug      Sep      Oct      Nov      Dec
2021 4.171013 4.757059 5.056343 2.988862 3.717521 5.398159 3.495038 6.027034 5.681583 3.874808 3.923682 5.783772
2022 3.811419 4.397465 4.696749 2.629268 3.357928 5.038565 3.135444 5.667440 5.321989 3.515214 3.564088 5.424178