R/forecast_tables.R

Defines functions forecast_tables

#' @export
forecast_tables <- function(models_list, end, n_ahead, 
                            consensus, index_x, index_y) {
    if (n_ahead > 1) {
        forecast_all_models <- t(
            data.frame(
                row.names = (end - n_ahead + 1):end,
                sapply(models_list, function(x) x$mean)
            )
        )
    } else {
        forecast_all_models <- t(t(sapply(models_list, function(x) x$mean)))
        colnames(forecast_all_models) <- (end - n_ahead + 1):end
        rownames(forecast_all_models) <- names(models_list)
    }
    
    all_forecasts = t(
        data.frame(
            row.names = (end - n_ahead + 1):end,
            t(forecast_all_models),
            consensus = consensus$forecast[setdiff(index_x, index_y), ]
        )
    )
    
    for (i in c('lower', 'upper')) {
        exc_models <- !grepl(x = names(models_list), pattern = 'nnar', ignore.case = TRUE)
        assign(
            x = if (i == 'lower') {
                k <- 'forecasts_lower'
            } else {
                k <- 'forecasts_upper'
            },
            value = t(
                if (n_ahead > 1) {
                    data.frame(
                        sapply(
                            models_list[exc_models],
                            function(x) x[[i]][, 2]
                        ), 
                        row.names = (end - n_ahead + 1):end
                    )
                } else {
                    t(
                        sapply(
                            models_list[exc_models],
                            function(x) x[[i]][, 2]
                        )
                    )
                }
            )
        )
        if (n_ahead == 1 & i == 'lower') {
            colnames(forecasts_lower) <- (end - n_ahead + 1):end
            rownames(forecasts_lower) <- names(models_list[exc_models])
        } else if (n_ahead == 1 & i == 'upper') {
            colnames(forecasts_upper) <- (end - n_ahead + 1):end
            rownames(forecasts_upper) <- names(models_list[exc_models])
        }
    }
    
    return(list(
        all_forecasts = forecast_all_models,
        forecast_all_models = forecast_all_models,
        forecasts_lower = forecasts_lower, 
        forecasts_upper = forecasts_upper))
}
faganok/scenario documentation built on Nov. 28, 2017, 4:06 p.m.