R/fopts.R

Defines functions get_fopts add_fopts

get_fopts <- function(x){
 if (missing(x)){
  return(list(method = "user", 
              transform = "user", 
              arima = "user",
              outlier = "user",
              easter = "user", 
              td = "user"))
 } 

 z <- list()

  # method
  if (!is.null(x$spc$x11)){
    z$method <- "X11"
  } else {
    z$method <- "SEATS"
  }

  # transform
  if (x$spc$transform$`function` %in% c("log", "auto", "none", "sqrt")){
    z$transform <- x$spc$transform$`function`
  } else {
    z$transform <- "user"
  }

  # arima
  if (!is.null(x$spc$automdl)) {
    z$arima <- "auto"
  } else {
    if (!is.null(x$model$arima$model)){
      z$arima <- x$model$arima$model
    } else {
      z$arima <- "user"
    }
  }

  # outlier
  if (!is.null(x$spc$outlier)) {
    if (!is.null(x$spc$outlier$critical)){
      if (x$spc$outlier$critical %in% c(3, 4, 5)){
        z$outlier <- paste0("cv", x$spc$outlier$critical)
      } else {
        z$outlier <- "user"
      }
    } else {
      z$outlier <- "auto"
    }
  } else {
     z$outlier <- "none"
  }
  
  # easter and td: common preparations
  if (!is.null(x$spc$regression$aictest)){
     aic <- x$spc$regression$aictest
  } else {
     aic <- ""
  }
  
  if (!is.null(x$spc$regression$variables)){
     v <- x$spc$regression$variables
  } else {
     v <- ""
  }
  
  # easter
  g <- grepl("easter[", x$spc$regression$variables, fixed = TRUE)

  if (sum(g) > 1){
    z$easter <- "user"
  } else if ("easter" %in% aic & sum(g) == 0){
    z$easter <- "easter.aic"
  } else if (!"easter" %in% aic & sum(g) == 0 %in% v){
    z$easter <- "none"
  } else if (!"easter" %in% aic & "easter[1]" %in% v){
    z$easter <- "easter[1]"
  } else if (!"easter" %in% aic & "easter[8]" %in% v){
    z$easter <- "easter[8]"
  } else if (!"easter" %in% aic & "easter[15]" %in% v){
    z$easter <- "easter[15]"
  } else {
    z$easter <- "user"
  }

  if (z$easter == "none" & isTRUE(x$spc$regression$usertype == "holiday")){
    if (inherits(x$call$xreg, "name")){
      z$easter <- "user"
    } else if (isTRUE(try(as.character(x$call$xreg[[1]]) == "genhol"))){
      if (x$call$xreg$start == 0 & x$call$xreg$end == 0 & x$call$xreg$center == "calendar"){
        if (x$call$xreg[[2]] == "cny"){
          z$easter <- "cny"
        } else if (x$call$xreg[[2]] == "diwali"){
          z$easter <- "diwali"
        } else {
          z$easter <- "user"
        }
      } else {
        z$easter <- "user"
      }
    } else if (!is.null(x$call$xreg)) {
      z$easter <- "user"
    }
  } 

  g <- grepl("td", x$spc$regression$variables, fixed = TRUE)

  if (sum(g) > 1){
    z$td <- "user"
  } else if ("td" %in% aic & sum(g) == 0){
    z$td <- "td.aic"
  } else if (!"td" %in% aic & sum(g) == 0 %in% v){
    z$td <- "none"
  } else if (!"td" %in% aic & "td1coef" %in% v){
    z$td <- "td1coef"
  } else if (!"td" %in% aic & "td" %in% v){
    z$td <- "td"
  } else {
    z$td <- "user"
  }

  stopifnot(length(z) == 6)
  z
}

add_fopts <- function(x, FOpts){

  # call in which all arguments are specified by their full names
  lc <- as.list(match.call(definition = seasonal::seas, x$call))

  if (is.null(FOpts$method)) FOpts$method <- "user"
  if (is.null(FOpts$transform)) FOpts$transform <- "user"
  if (is.null(FOpts$arima)) FOpts$arima <- "user"
  if (is.null(FOpts$outlier)) FOpts$outlier <- "user"
  if (is.null(FOpts$easter)) FOpts$easter <- "user"
  if (is.null(FOpts$td)) FOpts$td <- "user"

  if (FOpts$method == "X11"){
    # add empty x11 if no other x11 arg is specified
    if (!any(grepl("^x11\\.", names(lc))))  lc$x11 <- ""
    # rm all seats arg
    lc <- lc[!grepl("^seats\\.", names(lc))]
  } else if (FOpts$method == "SEATS"){
    lc$x11 <- NULL
    lc <- lc[!grepl("^x11\\.", names(lc))]

    # lc$forecast.maxback <- NULL
    # lc$forecast.backcasts <- NULL
  }

  if (FOpts$transform == "auto"){
    lc$transform.function <- NULL
  } else if (FOpts$transform != "user"){
    lc$transform.function <- FOpts$transform
  }

  if (FOpts$arima == "auto"){
    lc$arima.model <- NULL
  } else if (FOpts$arima != "user"){
    lc$arima.model <- FOpts$arima
  } 

  if (FOpts$outlier == "auto"){
    lc$outlier <- NULL
    lc$outlier.critical <- NULL
  } else if (FOpts$outlier == "none"){
    lc['outlier'] <- NULL
    lc$outlier.critical <- NULL
    names(lc['outlier']) <- "outlier"
  } else if (FOpts$outlier != "user"){
    lc$outlier.critical <- as.numeric(substr(FOpts$outlier, 3, 3))
  } 

  if (FOpts$easter %in% c("cny", "diwali")){
    lc$xreg <- as.call(parse(text = paste0('genhol(', FOpts$easter,', start = 0, end = 0, center = "calendar")')))[[1]]
    lc$regression.usertype = "holiday"
    FOpts$easter <- "none"
  } else if (FOpts$easter != "user"){
    lc$xreg <- NULL
    lc$regression.usertype = NULL
  }

  # calls to not work well with union, so covert them to character before
  C2C <- function(x){
    eval(parse(text = deparse(x)))
  }

  if (FOpts$easter %in% c("easter[1]", "easter[8]", "easter[15]", "none")){
    g <- grepl("easter[", lc$regression.variables, fixed = TRUE)
    if (sum(g) > 0){
      lc$regression.variables <- lc$regression.variables[!g]
    }
    if (FOpts$easter != "none"){
      lc$regression.variables <- union(C2C(lc$regression.variables), FOpts$easter)
    }

    if ("regression.aictest" %in% names(lc)){ # non default, specified
      lc$regression.aictest <- setdiff(lc$regression.aictest, "easter")
      if (length(lc$regression.aictest) == 0){
        lc['regression.aictest'] <- NULL
        names(lc['regression.aictest']) <- "regression.aictest"
      }
    } else {
      lc$regression.aictest <- "td"
    }

  } else if (FOpts$easter == "easter.aic") {
    g <- grepl("easter[", lc$regression.variables, fixed = TRUE)
    if (sum(g) > 0){
      lc$regression.variables <- lc$regression.variables[!g]
    }
    if (identical(lc$regression.aictest, "td")){
      # set default settings
      lc$regression.aictest <- NULL
    } else if ("regression.aictest" %in% names(lc)){ # non default, specified
      lc$regression.aictest <- union(C2C(lc$regression.aictest), "easter")
    }
  }

  if (FOpts$td %in% c("td", "td1coef", "none")){
    g <- grepl("td", lc$regression.variables)
    if (sum(g) > 0){
      lc$regression.variables <- lc$regression.variables[!g]
    }
    if (FOpts$td != "none"){
      lc$regression.variables <- union(C2C(lc$regression.variables), FOpts$td)
    }

    if ("regression.aictest" %in% names(lc)){ # non default, specified
      lc$regression.aictest <- setdiff(lc$regression.aictest, "td")
      if (length(lc$regression.aictest) == 0){
        lc['regression.aictest'] <- NULL
        names(lc['regression.aictest']) <- "regression.aictest"
      }
    } else {
      lc$regression.aictest <- "easter"
    }

  } else if (FOpts$td == "td.aic") {
    g <- grepl("td", lc$regression.variables)
    if (sum(g) > 0){
      lc$regression.variables <- lc$regression.variables[!g]
    }
    if (identical(lc$regression.aictest, "easter")){
      # set default settings
      lc$regression.aictest <- NULL
    } else if ("regression.aictest" %in% names(lc)){ # non default, specified
      lc$regression.aictest <- union(C2C(lc$regression.aictest), "td")
    }
  }

  if (length(lc$regression.variables) == 0){
    lc$regression.variables <- NULL
  }

  as.call(lc)
}

Try the seasonalview package in your browser

Any scripts or data that you put into this service are public.

seasonalview documentation built on May 2, 2019, 2:45 a.m.