Nothing
moving_holiday_pattern <- function(x){
# UseMethod("moving_holiday_pattern", x)
if(!all(c("preprocessing.model.mhe_f") %in% names(x$user_defined))){
if(inherits(x, "X13")){
my_spec <- RJDemetra::x13_spec(x)
x <- RJDemetra::x13(x$final$series[,"y"], my_spec,
userdefined = "preprocessing.model.mhe_f")
}else if(inherits(x, "TRAMO_SEATS ")){
my_spec <- RJDemetra::tramoseats_spec(x)
x <- RJDemetra::tramoseats(x$final$series[,"y"], my_spec,
userdefined = "preprocessing.model.mhe_f")
}else{
stop("Wrong type of object")
}
}
is_multiplicative <- x$regarima$model$spec_rslt[, "Log transformation"]
mhe <- x$regarima$model$effects[,"ee"]
last_date <- time(mhe)[length(time(mhe))]
mhe <- window(mhe, start = last_date - 1 + deltat(mhe))
freq <- frequency(mhe)
if (is_multiplicative) {
mhe <- exp(mhe)
}
estimated_values <- as.numeric(mhe)
evolution <- c(tail(mhe, 2),
head(x$user_defined$preprocessing.model.mhe_f,1))
if (!is_multiplicative) {
series_mean <- mean(x$final$series[,"y"],
na.rm = TRUE)
estimated_values <- as.numeric(estimated_values) / series_mean + 1
evolution <- evolution/series_mean + 1
}
if (freq == 12) {
names(estimated_values) <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep",
"Oct", "Nov", "Dec")[cycle(mhe)]
period <- "Month"
}else{
names(estimated_values) <- sprintf("Q%i",1:4)[cycle(mhe)]
period <- "Quarter"
}
estimated_values <- (estimated_values - 1) * 100
evolution <- (evolution - 1) * 100
evolution <- data.frame(Evolution = evolution,
row.names = sprintf("%s %s",
c("Previous", "Current", "Next"),
period))
result <- list(estimated_values = estimated_values, evolution = evolution)
class(result) <- c("moving_holiday_pattern", class(result))
result
}
# moving_holiday_pattern.X13 <- function(x){
# if (!all(c("preprocessing.model.mhe_f") %in% names(x$user_defined))) {
# my_spec <- RJDemetra::x13_spec(x)
# x <- RJDemetra::x13(x$final$series[,"y"], my_spec,userdefined = "preprocessing.model.mhe_f")
# }
#
# mhe <- x$regarima$model$effects[,"ee"]
# last_date <- tail(time(mhe), 1)
# mhe <- window(mhe, start = last_date - 1 + deltat(mhe))
# is_multiplicative <- x$regarima$model$spec_rslt[, "Log transformation"]
#
# freq <- frequency(mhe)
#
# estimated_values <- as.numeric(mhe)
# evolution <- c(tail(mhe, 2),
# head(x$user_defined$preprocessing.model.mhe_f,1))
# if (!is_multiplicative) {
# series_mean <- mean(x$final$series[,"y"],
# na.rm = TRUE)
# estimated_values <- as.numeric(estimated_values) / series_mean + 1
# evolution <- evolution/series_mean + 1
# }
#
# if (freq == 12) {
# names(estimated_values) <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep",
# "Oct", "Nov", "Dec")[cycle(mhe)]
# period <- "Month"
# }else{
# names(estimated_values) <- sprintf("Q%i",1:4)[cycle(mhe)]
# period <- "Quarter"
# }
# estimated_values <- (estimated_values - 1) * 100
# evolution <- (evolution - 1) * 100
# evolution <- data.frame(Evolution = evolution,
# row.names = sprintf("%s %s",
# c("Previous", "Current", "Next"),
# period))
# result <- list(estimated_values = estimated_values, evolution = evolution)
# class(result) <- c("moving_holiday_pattern", class(result))
# result
# }
# moving_holiday_pattern.TRAMO_SEATS <- function(x){
# if (!all(c("preprocessing.model.mhe_f") %in% names(x$user_defined))) {
# my_spec <- RJDemetra::tramoseats_spec(x)
# x <- RJDemetra::tramoseats(x$final$series[,"y"], my_spec,
# userdefined = "preprocessing.model.mhe_f")
# }
# is_multiplicative <- x$regarima$model$spec_rslt[, "Log transformation"]
#
# mhe <- x$regarima$model$effects[,"ee"]
# last_date <- tail(time(mhe), 1)
# mhe <- window(mhe, start = last_date - 1 + deltat(mhe))
# freq <- frequency(mhe)
#
# if (is_multiplicative) {
# mhe <- exp(mhe)
# }
#
# estimated_values <- as.numeric(mhe)
# evolution <- c(tail(mhe, 2),
# head(x$user_defined$preprocessing.model.mhe_f,1))
# if (!is_multiplicative) {
# series_mean <- mean(x$final$series[,"y"],
# na.rm = TRUE)
# estimated_values <- as.numeric(estimated_values) / series_mean + 1
# evolution <- evolution/series_mean + 1
# }
#
# if (freq == 12) {
# names(estimated_values) <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep",
# "Oct", "Nov", "Dec")[cycle(mhe)]
# period <- "Month"
# }else{
# names(estimated_values) <- sprintf("Q%i",1:4)[cycle(mhe)]
# period <- "Quarter"
# }
# estimated_values <- (estimated_values - 1) * 100
# evolution <- (evolution - 1) * 100
# evolution <- data.frame(Evolution = evolution,
# row.names = sprintf("%s %s",
# c("Previous", "Current", "Next"),
# period))
# result <- list(estimated_values = estimated_values, evolution = evolution)
# class(result) <- c("moving_holiday_pattern", class(result))
# result
# }
#'@exportS3Method NULL
plot.moving_holiday_pattern <- function(x, ...){
if(is.null(x$evolution)){
plot(0,type='n',axes=FALSE,main="Moving Holiday Pattern")
plot.new()
return(invisible(NULL))
}
data_table <- round(x$evolution, 1)
if(data_table$Evolution[3] > 0){
title = expression("Moving Holiday Effects: " %dblup% " expected")
}else if (data_table$Evolution[3] < 0){
title = expression("Moving Holiday Effects: " %dbldown% " expected")
}else{
title = expression("Moving Holiday Effects: " %=>% " expected")
}
data_table$Evolution <- sprintf("%+.1f%%",data_table$Evolution)
mai <- par("mai")
barplot(x$estimated_values, names.arg=names(x$estimated_values),ann=FALSE,
main = "Moving Holiday Pattern")
par(mai = c(0,0,0,0))
plot(0,type='n',axes=FALSE,ann = F, xlim = c(0,1), ylim = c(0,1))
plotrix::addtable2plot(0.5, 0.5,
data_table[-3,, drop=FALSE], bty = "o", display.rownames = TRUE, hlines = TRUE,
display.colnames = FALSE,
vlines = TRUE,title = title, xjust = 0.5, yjust = 0.5)
par(mai = mai)
}
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.