R/class-deseats_fc.R

In deseats: Data-Driven Locally Weighted Regression for Trend and Seasonality in TS

setClass("deseats_fc",
  slots = c(
    pred = "ts",
    interv = "ts",
    obs = "ts",
    ts_name = "character"
  )
)


create_deseats_fc <- function(pred, interv, obs, ts_name) {
  
  methods::new("deseats_fc",
    pred = pred,
    interv = interv,
    obs = obs,
    ts_name = ts_name
  )
  
}

#'Exponentiate \code{deseats} Forecasts
#'
#'Exponentiate, i.e. as act of retransformation, (point and interval) forecasts 
#'obtained via the \code{deseats} package.
#'
#'@param object an object of class \code{"deseats_fc"}.
#'@param ... currently without purpose; included for compatibility only.
#'
#'@export
#'
#'@return
#'An object of class \code{"deseats_fc"} is returned.
#'
#'@examples
#'\donttest{
#'est <- s_semiarma(log(EXPENDITURES), set_options(order_poly = 3))
#'fc <- predict(est, n.ahead = 8)
#'fc2 <- expo(fc)
#'fc2
#'}
#'

setMethod("expo", "deseats_fc", function(object, ...) {
  
  object@pred <- exp(object@pred)
  object@interv <- exp(object@interv)
  object@obs <- exp(object@obs)
  object@ts_name <- paste0("exp(", object@ts_name, ")")
  object
  
})

#'Plot Method for Class \code{"deseats_fc"}
#'
#'Create basic R plots for forecasting objects of class \code{"deseats_fc"}.
#'
#'@param x an object of class \code{"deseats_fc"}, for example generated by a 
#'call to \code{\link{predict,s_semiarma-method}}.
#'@param y currently without use; for compatibility only.
#'@param ... further arguments of \code{\link[stats]{plot.ts}} to adjust 
#'for example the axis limits via \code{xlim} and \code{ylim}.
#'
#'@details
#'This is a plot method to visualize the forecasting results for a Seasonal 
#'Semi-ARMA model. Common plot arguments can be implemented to change the 
#'appearance.
#'
#'@return
#'This method returns \code{NULL}.
#'
#'@author
#'\itemize{
#'\item Dominik Schulz (Research Assistant) (Department of Economics, Paderborn
#'University), \cr
#'Author and Package Creator
#'}
#'
#'@export
#'
#'@examples
#'\donttest{
#'est <- s_semiarma(log(EXPENDITURES))
#'fc <- predict(est, n.ahead = 4)
#'fc_e <- expo(fc)
#'plot(fc_e)
#'}
#'

setMethod("plot", "deseats_fc", function(x, y = NULL, ...) {
  
  dots <- list(...)
  defaults <- list(
    xlab = "Time",
    main = paste0('The observations of "', x@ts_name, '" together with point and interval forecasts'),
    ylab = x@ts_name,
    xlim = c(c(time(x@obs))[[1]], utils::tail(c(time(x@pred)), 1)),
    ylim = c(min(x@obs, x@interv), max(x@obs, x@interv))
  )
  dots <- set_default(dots, defaults)
  if (!is.null(dots[["col"]])) {
    col <- dots$col
    col1 <- col[[1]]
    col2 <- col[[2]]
    dots[["col"]] <- NULL
  } else {
    col1 <- "black"
    col2 <- "blue"
  } 
  dots[["type"]] = "n"
  dots[["x"]] <- 0
  dots[["y"]] <- 0
  do.call(plot, args = dots)
  m <- length(x@interv[1, ])
  n <- m / 2
  if (n > 1) {
    for (i in 1:(n - 1)) {
      t <- c(time(x@interv))
      graphics::polygon(c(t, rev(t)), c(c(x@interv[, m - i]), rev(c(x@interv[, m - (i - 1)]))),
              border = NA, col = ggplot2::alpha(col2, 0.1 + (i - 1) * 0.15))
      graphics::polygon(c(t, rev(t)), c(c(x@interv[, i]), rev(c(x@interv[, i + 1]))),
              border = NA, col = ggplot2::alpha(col2, 0.1 + (i - 1) * 0.15))      
    }
  }
  i <- n
  graphics::polygon(c(t, rev(t)), c(c(x@interv[, i]), rev(c(x@interv[, i + 1]))),
    border = NA, col = ggplot2::alpha(col2, 0.1 + (i - 1) * 0.15))   
  
  graphics::lines(c(time(x@obs)), c(x@obs), col = col1)
  graphics::lines(c(time(x@pred)), c(x@pred), col = col2)  
  
})


#'\code{ggplot2} Plot Method for Class \code{"deseats_fc"}
#'
#'Create \code{ggplot2} R plots for forecasting objects of class 
#'\code{"deseats_fc"}.
#'
#'@param object an object of class \code{"deseats_fc"}, for example generated by a 
#'call to \code{\link{predict,s_semiarma-method}}.
#'@param ... currently without use; implemented for compatibility.
#'
#'@details
#'This is a plot method to visualize the forecasting results for a Seasonal 
#'Semi-ARMA model. Common plot arguments can be implemented to change the 
#'appearance.
#'
#'@return
#'This method returns a \code{ggplot2} plot object, i.e. an object of classes 
#'\code{"gg"} and \code{"ggplot"}.
#'
#'@author
#'\itemize{
#'\item Dominik Schulz (Research Assistant) (Department of Economics, Paderborn
#'University), \cr
#'Author and Package Creator
#'}
#'
#'@export
#'
#'@examples
#'\donttest{
#'est <- s_semiarma(log(EXPENDITURES))
#'fc <- predict(est, n.ahead = 4)
#'fc_e <- expo(fc)
#'autoplot(fc_e)
#'}
#'

setMethod("autoplot", "deseats_fc", function(object, ...) {
  
  .df1 <- data.frame(
    Time = c(time(object@obs)),
    Observations = c(object@obs),
    Color = "1"
  )
  .df2 <- data.frame(
    Time = c(time(object@pred)),
    Forecasts = c(object@pred),
    Color = "2"
  )
  .df3 <- as.data.frame(object@interv)
  
  cnames <- colnames(object@interv)
  n <- length(object@interv[1, ])
  m <- n / 2  
  
   # ymax = c(unname(unlist(.df3[, n:(n - m + 1)]))),  
  


  p_out <- ggplot2::ggplot(.df1) +
    ggplot2::geom_line(ggplot2::aes(x = .data[["Time"]], y = .data[["Observations"]], color = .data[["Color"]]))
  
  if (m > 1) {  
  
    .df4 <- data.frame(
      ymin = c(unname(unlist(.df3[, 1:(m - 1)]))),
      ymax = c(unname(unlist(.df3[, 2:m]))),
      Time = rep(c(time(object@pred)), m - 1),
      Case = rev(rep(as.character(2:m), each = length(object@pred)))
    )
  
    .df5 <- data.frame(
      ymin = c(unname(unlist(.df3[, (m + 1):(n - 1)]))),
      ymax = c(unname(unlist(.df3[, (m + 2):n]))),
      Time = rep(c(time(object@pred)), m - 1),
      Case = rev(rep(as.character(m:2), each = length(object@pred)))
    )      
    
    p_out <- p_out +
      ggplot2::geom_ribbon(data = .df4, ggplot2::aes(x = .data[["Time"]], ymin = .data[["ymin"]], ymax = .data[["ymax"]],
                                                            fill = .data[["Case"]]),
                           inherit.aes = FALSE, show.legend = FALSE) +
      ggplot2::geom_ribbon(data = .df5, ggplot2::aes(x = .data[["Time"]], ymin = .data[["ymin"]], ymax = .data[["ymax"]],
                                                            fill = .data[["Case"]]),
                           inherit.aes = FALSE, show.legend = FALSE)
  }
  
  .df6 <- data.frame(
    ymin = c(unname(unlist(.df3[, m]))),
    ymax = c(unname(unlist(.df3[, m + 1]))),
    Time = rep(c(time(object@pred)), 1),
    Case = rep(as.character(1), each = length(object@pred))
  )
  
  p_out <- p_out + 
    ggplot2::geom_ribbon(data = .df6, ggplot2::aes(x = .data[["Time"]], ymin = .data[["ymin"]], ymax = .data[["ymax"]],
      fill = .data[["Case"]]), inherit.aes = FALSE)
    
  fill_color <- ggplot2::alpha("blue", rev(seq(0.1, 0.1 + (m - 1) * 0.15, 0.15)))
  names(fill_color) <- 1:m
  labels_legend <- rev(paste0((1 - 2 * (as.numeric(substr(cnames[1:m], 1, nchar(cnames[1:m]) - 1)) / 100)) * 100, "%"))
  names(labels_legend) <- 1:m  
  
  p_out <- p_out +
    ggplot2::geom_line(data = .df2, ggplot2::aes(x = .data[["Time"]], y = .data[["Forecasts"]], color = .data[["Color"]]),
                       inherit.aes = FALSE) +
    ggplot2::xlab("Time") +
    ggplot2::ylab(object@ts_name) +
    ggplot2::ggtitle(paste0('The observations of "', object@ts_name, '" together with point and interval forecasts')) +
    ggplot2::scale_color_manual(name = "Series", values = c("black", "blue"), 
                                labels = c("Observations", "Forecasts")) +    
    ggplot2::scale_fill_manual(name = "Intervals", values = fill_color,
                               labels = labels_legend) +
    ggplot2::guides(color = ggplot2::guide_legend(order = 1),
                    fill = ggplot2::guide_legend(order = 2))

  
  p_out
  
})