Nothing
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)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.