#' seasonal_ad
#'
#' seasonally adjust a series as aruments series output a dataframe containing
#' the seasonal factor and the seasonally adjusted series
#'
#' @param x
#' @param meffects
#' @param qeffects
#'
#' @return
#' @export
#'
#' @examples
seasonal_ad <- function (x,
meffects = c("const", "easter[8]", "thank[5]"),
qeffects = c("const", "easter[8]", "tdnolpyear")) {
#stores the name
holdn <- names(x)
print(holdn)
# trims the NAs from the series
# I commented this out while doing the host work because it was causing the
# seasonal factors to be shifted, and not aligned with the proper dates
# I didn't have this issue before I guess because things all tended to
# start at the same date
# x <- na.trim(x)
# this series y is used in the output, just outputs the original series
y <- x
y <- xts(y)
# http://stackoverflow.com/questions/15393749/get-frequency-for-ts-from-and-xts-for-x12
freq <- switch(periodicity(x)$scale,
daily=365,
weekly=52,
monthly=12,
quarterly=4,
yearly=1)
plt_start <- as.POSIXlt(start(x))
start <- c(plt_start$year+1900,plt_start$mon+1)
print(start)
# creates a time series object using start date and frequency
# declared it as a global object by using <<- because I couldn't figure out
# how to handle environments. It seems like the issue I was having is that
# I define the seasonal_ad function, but then when it tries to run the
# seas function within that it is referrring to a different environment
# and can't seem to find the object that I want to give as an argument to
# seas. This is a temporary fix. Long term I should figure out how to handle
# so that I'm not defining a global object from within the function, but
# should be fine for now.
temp_seasonal_a <<- ts(as.numeric(x), start=start, frequency=freq)
print(head(temp_seasonal_a))
print(str(temp_seasonal_a))
print(freq)
if (freq == '12') regressvar <<- meffects
if (freq == '4') regressvar <<- qeffects
print(regressvar)
print("checking")
print(head(temp_seasonal_a))
print(str(temp_seasonal_a))
mp <- seasonal::seas(temp_seasonal_a,
transform.function = "log",
regression.aictest = NULL,
regression.variables = regressvar, #c("const", "easter[8]", "thank[3]"),
identify.diff = c(0, 1),
identify.sdiff = c(0, 1),
forecast.maxlead = 30, # extends 30 quarters ahead
x11.appendfcst = "yes", # appends the forecast of the seasonal factors
estimate.maxiter = 5000, # increased from default of 1500 as suggested in following link
# https://github.com/christophsax/seasonal/wiki/Breaking-Examples-(and-Possible-Solutions)
dir = "output_data/"
)
#inspect(mp)
# removes series that is no longer needed
# doesn't seem to work, maybe because I don't understand environments
# rm(temp_seasonal_a)
# grabs the seasonally adjusted series
tempdata_sa <- seasonal::series(mp, c("d11")) # seasonally adjusted series
tempdata_sf <- seasonal::series(mp, c("d16")) # seasonal factors
tempdata_fct <- seasonal::series(mp, "forecast.forecasts") # forecast of nonseasonally adjusted series
tempdata_irreg <- seasonal::series(mp, c("d13")) # final irregular component
# creates xts objects
tempdata_sa <- as.xts(tempdata_sa)
tempdata_sf <- as.xts(tempdata_sf)
# in the following, we just want the forecast series, not the ci bounds
# I had to do in two steps, I'm not sure why
tempdata_fct <- as.xts(tempdata_fct)
tempdata_fct <- as.xts(tempdata_fct$forecast)
tempdata_irreg <- as.xts(tempdata_irreg)
# names the objects
names(tempdata_sa) <- paste(holdn,"_sa",sep="")
names(tempdata_sf) <- paste(holdn,"_sf",sep="")
names(tempdata_fct) <- paste(holdn,"_fct",sep="")
names(tempdata_irreg) <- paste(holdn,"_irreg",sep="")
# merges the adjusted series onto the existing xts object with the unadjusted
# series
out_sa <- merge(y, tempdata_sa, tempdata_sf, tempdata_fct, tempdata_irreg)
return(out_sa)
}
#' modified version of seasonal_ad
#' Uses a holiday regressor argument,
#' also set up to use seats, following the way I had set things up in my more structured approach
#'
#' @param x
#' @param meffects
#' @param qeffects
#' @param hold_reg
#'
#' @return
#' @export
#'
#' @examples
seasonal_ad_2 <- function (x,
meffects = c("tdnolpyear", "ls2001.Sep"),
qeffects = c("tdnolpyear", "ls2001.Sep"),
hold_reg) {
#stores the name
holdn <- names(x)
print(holdn)
# trims the NAs from the series
# I commented this out while doing the host work because it was causing the
# seasonal factors to be shifted, and not aligned with the proper dates
# I didn't have this issue before I guess because things all tended to
# start at the same date
# x <- na.trim(x)
# this series y is used in the output, just outputs the original series
y <- x
y <- xts(y)
# http://stackoverflow.com/questions/15393749/get-frequency-for-ts-from-and-xts-for-x12
freq <- switch(periodicity(x)$scale,
daily=365,
weekly=52,
monthly=12,
quarterly=4,
yearly=1)
plt_start <- as.POSIXlt(start(x))
start <- c(plt_start$year+1900,plt_start$mon+1)
print(start)
# creates a time series object using start date and frequency
# declared it as a global object by using <<- because I couldn't figure out
# how to handle environments. It seems like the issue I was having is that
# I define the seasonal_ad function, but then when it tries to run the
# seas function within that it is referrring to a different environment
# and can't seem to find the object that I want to give as an argument to
# seas. This is a temporary fix. Long term I should figure out how to handle
# so that I'm not defining a global object from within the function, but
# should be fine for now.
temp_seasonal_a <<- ts(as.numeric(x), start=start, frequency=freq)
print(head(temp_seasonal_a))
print(str(temp_seasonal_a))
print(freq)
if (freq == '12') regressvar <<- meffects
if (freq == '4') regressvar <<- qeffects
print(regressvar)
print("checking")
print(head(temp_seasonal_a))
print(str(temp_seasonal_a))
mp <- seas(temp_seasonal_a,
transform.function = "log",
regression.aictest = NULL,
regression.variables = regressvar, #c("const", "easter[8]", "thank[3]"),
forecast.maxlead = 48, # extends 30 quarters ahead
seats.appendfcst = "yes", # appends the forecast of the seasonal factors
dir = "output_data/",
xreg = hold_reg,
regression.usertype = c("holiday", "holiday2", "holiday3")
)
#inspect(mp)
# removes series that is no longer needed
# doesn't seem to work, maybe because I don't understand environments
# rm(temp_seasonal_a)
tempdata_sa <- as.zoo(final(mp)) # seasonally adjusted series
tempdata_sf <- as.zoo(series(mp, "s16")) # seasonal factors
# creates xts objects
tempdata_sa <- tempdata_sa %>%
as.xts(order.by = as.yearmon(index(.)))
tempdata_sf <- tempdata_sf %>%
as.xts(order.by = as.yearmon(index(.)))
# names the objects
names(tempdata_sa) <- paste(holdn,"_sa",sep="")
names(tempdata_sf) <- paste(holdn,"_sf",sep="")
# merges the adjusted series onto the existing xts object with the unadjusted
# series
out_sa <- merge(y, tempdata_sa, tempdata_sf) #, tempdata_irreg , tempdata_fct
return(out_sa)
}
#' skip seasonal adjustment
#'
#' skip seasonal adjustment but still output series that are the same format as
#' what would be exported by the seasonal adjustment function in other words
#' copy the unadjusted series as the seasonally adjusted, create seasonal
#' factors equal to 1 and create a temporary fct series
#'
#' @param x
#'
#' @return
#' @export
#'
#' @examples
skip_seasonal_ad <- function (x) {
# stores the name
holdn <- names(x)
print(holdn)
# trims the NAs from the series
x <- na.trim(x)
# sets up a variable with the end of the historical data
# and then the start of the forecast in the month after
end <- end(x)
library(lubridate)
d <- ymd(end)
d <- d + months(1)
startd <- as.Date(d)
startd
# this series y is used in the output, just outputs the original series
y <- x
tempdata_sa <- y
# seasonal factor is unadjusted series divided by adjusted
# though in this case that's just 1
tempdata_sf <- y/y
# just out of habit, forecast the seasonally adjusted series
# which is just the nsa series anyway
tempdata_fct <- forecast(tempdata_sa,h=30)$mean
plot(tempdata_fct)
head(tempdata_fct)
tail(y)
# start forecast in the month after
temp2 <- zooreg(1:30, start = as.yearmon(startd), frequency = 12)
temp3 <- as.Date(index(temp2))
temp4 <- xts(tempdata_fct, temp3)
head(temp4)
tail(temp4)
tempdata_fct <- rbind(y, temp4)
plot(tempdata_fct)
# converts the forecast to an nsa version (even though it's the same)
tempdata_fct <- tempdata_fct * tempdata_sf
# creates xts objects
tempdata_sa <- as.xts(tempdata_sa)
tempdata_sf <- as.xts(tempdata_sf)
tempdata_fct <- as.xts(tempdata_fct)
# names the objects
names(tempdata_sa) <- paste(holdn,"_sa",sep="")
names(tempdata_sf) <- paste(holdn,"_sf",sep="")
names(tempdata_fct) <- paste(holdn,"_fct",sep="")
# merges the adjusted series onto the existing xts object with the unadjusted
# series
out_sa <- merge(y, tempdata_sa, tempdata_sf, tempdata_fct)
return(out_sa)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.