## Do not edit this file manually.
## It has been automatically generated from *.org sources.
setGeneric("filterOrder", def = function(object, ...){ standardGeneric("filterOrder") })
setGeneric("filterCoef",
def = function(object, convention, ...){ standardGeneric("filterCoef") } )
setGeneric("filterPolyCoef",
function(object, lag_0 = TRUE, ...){ standardGeneric("filterPolyCoef") })
setGeneric("filterPoly",
function(object, ...){ standardGeneric("filterPoly") })
setClass("VirtualMonicFilter", contains = c("VIRTUAL"))
setClass("VirtualSPFilter", contains = c("VirtualMonicFilter", "VIRTUAL"))
setClass("VirtualBJFilter", contains = c("VirtualMonicFilter", "VIRTUAL"))
setMethod("filterCoef", c("VirtualBJFilter", "character"),
function(object, convention){
co <- filterCoef(object) # use a generic to access the raw coef
switch(convention,
"BJ" = , "--" = , "-" = co,
"SP" = , "++" = , "+" = - co,
## else error
stop("invalid value for argument `convention'.")
)
}
)
setMethod("filterCoef", c("VirtualSPFilter", "character"),
function(object, convention){
co <- filterCoef(object) # use a generic to access the raw coef
switch(convention,
"BJ" = , "--" = , "-" = - co,
"SP" = , "++" = , "+" = co,
## else error
stop("invalid value for argument `convention'.")
)
}
)
setMethod("filterPolyCoef", "VirtualBJFilter",
function(object, lag_0 = TRUE){
co <- filterCoef(object)
if(lag_0)
c(1, - co)
else
- co
}
)
setMethod("filterPolyCoef", "VirtualSPFilter",
function(object, lag_0 = TRUE){
co <- filterCoef(object)
if(lag_0)
c(1, co)
else
co
}
)
setClass("VirtualMonicFilterSpec", contains = "VIRTUAL",
slots = c(coef = "ANY", order = "numeric"),
prototype = list(coef = numeric(0), order = 0)
)
setMethod("filterOrder", "VirtualMonicFilterSpec",
function(object) object@order )
setMethod("filterCoef", c("VirtualMonicFilterSpec", "missing"),
function(object) object@coef )
setMethod("filterPoly", "VirtualMonicFilterSpec",
function(object) polynom(filterPolyCoef(object)))
setClass("MonicFilterSpec", contains = c("VirtualMonicFilterSpec", "VIRTUAL"),
slots = c(coef = "numeric")
)
setClass("BJFilter", contains = c("MonicFilterSpec", "VirtualBJFilter"))
setClass("SPFilter", contains = c("MonicFilterSpec", "VirtualSPFilter"))
setMethod("initialize", "MonicFilterSpec",
function(.Object, coef, order, ...){
.Object <- callNextMethod()
if(missing(coef)){
if(.Object@order > 0)
.Object@coef <- rep(NA_real_, .Object@order)
}else if(missing(order))
.Object@order <- length(.Object@coef)
.Object
}
)
setMethod("show", signature(object = "MonicFilterSpec"),
function (object)
{
cat("order: ", object@order, "\n")
cat("Coefficients:", "\n")
print(object@coef)
}
)
setAs("numeric", "BJFilter", function(from) new("BJFilter", coef = from))
setAs("numeric", "SPFilter", function(from) new("SPFilter", coef = from))
setAs("BJFilter", "SPFilter", function(from) new("SPFilter", coef = - from@coef))
setAs("SPFilter", "BJFilter", function(from) new("BJFilter", coef = - from@coef))
setMethod("filterCoef", c("BJFilter", "character"),
function(object, convention){
switch(convention,
"BJ" = , "--" = , "-" = object@coef, # get the slot directly
"SP" = , "++" = , "+" = - object@coef,
## else error
stop("invalid value for argument `convention'.")
)
}
)
setMethod("filterCoef", c("SPFilter", "character"),
function(object, convention){
switch(convention,
"BJ" = , "--" = , "-" = - object@coef,
"SP" = , "++" = , "+" = object@coef,
## else error
stop("invalid value for argument `convention'.")
)
}
)
setMethod("filterPolyCoef", "BJFilter",
function(object, lag_0 = TRUE){
if(lag_0)
c(1, - object@coef)
else
- object@coef
}
)
setMethod("filterPolyCoef", "SPFilter",
function(object, lag_0 = TRUE){
if(lag_0)
c(1, object@coef)
else
object@coef
}
)
setMethod("filterPoly", "BJFilter", function(object) polynom(c(1, - object@coef)) )
setMethod("filterPoly", "SPFilter", function(object) polynom(c(1, object@coef)) )
setMethod("show", signature(object = "BJFilter"),
function (object)
{
.reportClassName(object, "BJFilter")
callNextMethod()
}
)
setMethod("show", signature(object = "SPFilter"),
function (object)
{
.reportClassName(object, "SPFilter")
callNextMethod()
}
)
setClass("VirtualArmaFilter", contains = c("VirtualMonicFilter", "VIRTUAL"),
slots = c(ar = "VirtualMonicFilter", ma = "VirtualMonicFilter"),
# need prototype since otherwise the slots are "<S4 Type Object>"
# which causes problems
prototype = list(ar = new("BJFilter"), ma = new("SPFilter"))
)
setMethod("filterOrder", "VirtualArmaFilter",
function(object){
list(ar = filterOrder(object@ar),
ma = filterOrder(object@ma) )
}
)
setMethod("filterPoly", "VirtualArmaFilter",
function(object){
list(ar = filterPoly(object@ar),
ma = filterPoly(object@ma) )
}
)
setMethod("filterPolyCoef", "VirtualArmaFilter",
function(object, lag_0 = TRUE, ...){
list(ar = filterPolyCoef(object@ar, lag_0 = lag_0, ...),
ma = filterPolyCoef(object@ma, lag_0 = lag_0, ...) )
}
)
setMethod("filterCoef", c("VirtualArmaFilter", "missing"),
function(object){
list(ar = filterCoef(object@ar),
ma = filterCoef(object@ma) )
}
)
setMethod("filterCoef", c("VirtualArmaFilter", "character"),
function(object, convention){
switch(convention,
"BJ" = , "--" = , "SP" = , "++" =
list(ar = filterCoef(object@ar, convention = convention),
ma = filterCoef(object@ma, convention = convention) ),
"-+" = , "BD" =
list(ar = filterCoef(object@ar, convention = "-"),
ma = filterCoef(object@ma, convention = "+") ),
"+-" = list(ar = filterCoef(object@ar, convention = "+"),
ma = filterCoef(object@ma, convention = "-") ),
## TODO: more informative message in this case:
"+" = , "-" =
stop("invalid value for argument `convention'."),
## default:
## would like to try to convert to a class, not appropriate here:
## filterCoef(object, new(convention))
stop("invalid value for argument `convention'.")
)
}
)
setMethod("nSeasons", "VirtualArmaFilter", function(object) nSeasons(object@ar))
setAs("VirtualArmaFilter", "list",
function(from){
filterCoef(from)
}
)
setMethod("show", signature(object = "VirtualArmaFilter"),
function (object)
{
cat('\nslot "ar":\n')
show(object@ar)
cat('\nslot "ma":\n')
show(object@ma)
}
)
setClass("ArmaFilter", contains = "VirtualArmaFilter",
slots = c(ar = "BJFilter", ma = "SPFilter"),
)
setMethod("initialize", "ArmaFilter",
function(.Object, ..., ar, ma){ # 2017-05-27 moved ar, ma after ...
## .Object <- callNextMethod()
if(!missing(ar))
.Object@ar <- as(ar, "BJFilter")
if(!missing(ma))
.Object@ma <- as(ma, "SPFilter")
.Object <- callNextMethod(.Object, ...)
.Object
}
)
setMethod("show", signature(object = "ArmaFilter"),
function (object)
{
.reportClassName(object, "ArmaFilter")
callNextMethod()
}
)
setClass("ArFilter", contains = "ArmaFilter" )
setClass("MaFilter", contains = "ArmaFilter" )
setMethod("initialize", "ArFilter",
function(.Object, ...){
.Object <- callNextMethod()
if(.Object@ma@order > 0)
stop("Non-trivial moving average part.")
.Object
}
)
setMethod("initialize", "MaFilter",
function(.Object, ...){
.Object <- callNextMethod()
if(.Object@ar@order > 0)
stop("Non-trivial autoregressive part.")
.Object
}
)
setClass("VirtualCascadeFilter", contains = c("VirtualMonicFilter", "VIRTUAL"))
## setClass("CascadeFilter", contains = c("VirtualCascadeFilter", "list"),
## ## prototype = list( list() )
## )
##
## setClass("ArCascadeFilter", contains = "CascadeFilter")
## setClass("MaCascadeFilter", contains = "CascadeFilter")
setClass("VirtualSarimaFilter", contains = c("VirtualCascadeFilter", "VIRTUAL"))
setGeneric("iOrder", def = function(object){ standardGeneric("iOrder") })
setGeneric("siOrder", def = function(object){ standardGeneric("siOrder") })
setGeneric("anyUnitRoots", def = function(object){ standardGeneric("anyUnitRoots") })
setMethod("anyUnitRoots", "VirtualSarimaFilter",
function(object){
iOrder(object) > 0 || siOrder(object) > 0
}
)
setClass("SarimaFilter", contains = "VirtualSarimaFilter",
slots = c(nseasons = "numeric",
iorder = "numeric",
siorder = "numeric",
ar = "BJFilter",
ma = "SPFilter",
sar = "BJFilter", ## TODO: special classes for seasonal filters?
sma = "SPFilter"
),
prototype = list(nseasons = NA_real_, iorder = 0, siorder = 0 )
## todo: write a validity method: if(is.na(nseasons) ...)
)
setMethod("initialize", "SarimaFilter",
function(.Object, ..., ar, ma, sar, sma){ # .Object <- callNextMethod()
.Object <- callNextMethod(.Object, ...)
if(!missing(ar)) .Object@ar <- as(ar, "BJFilter")
if(!missing(ma)) .Object@ma <- as(ma, "SPFilter")
if(!missing(sar)) .Object@sar <- as(sar, "BJFilter")
if(!missing(sma)) .Object@sma <- as(sma, "SPFilter")
.Object
}
)
setMethod("nSeasons", "SarimaFilter", function(object) object@nseasons)
setMethod("iOrder", "SarimaFilter", function(object) object@iorder)
setMethod("siOrder", "SarimaFilter", function(object) object@siorder)
setReplaceMethod("nSeasons", "SarimaFilter",
function(object, ..., value){
object@nseasons <- value
object
})
setMethod("filterOrder", "SarimaFilter",
function(object){
list(nseasons = object@nseasons,
iorder = object@iorder,
siorder = object@siorder,
ar = object@ar@order, # no need for filterOrder() here
ma = object@ma@order, # since these slots have fixed classes
sar = object@sar@order, # in SarimaFilter
sma = object@sma@order
)
}
)
setMethod("filterCoef", c("SarimaFilter", "missing"), # "SarimaFilter", #
function(object){
list(nseasons = object@nseasons,
iorder = object@iorder,
siorder = object@siorder,
ar = filterCoef(object@ar ),
ma = filterCoef(object@ma ),
sar = filterCoef(object@sar),
sma = filterCoef(object@sma)
)
}
)
setMethod("filterCoef", c("SarimaFilter", "character"),
function(object, convention){
co <-
switch(convention,
"BJ" = , "--" = , "SP" = , "++" =
list(ar = filterCoef(object@ar, convention = convention),
ma = filterCoef(object@ma, convention = convention),
sar = filterCoef(object@sar, convention = convention),
sma = filterCoef(object@sma, convention = convention)
),
"-+" = , "BD" =
list(ar = filterCoef(object@ar, convention = "-"),
ma = filterCoef(object@ma, convention = "+"),
sar = filterCoef(object@sar, convention = "-"),
sma = filterCoef(object@sma, convention = "+")
),
"+-" = list(ar = filterCoef(object@ar, convention = "+"),
ma = filterCoef(object@ma, convention = "-"),
sar = filterCoef(object@sar, convention = "+"),
sma = filterCoef(object@sma, convention = "-")
),
"+" = , "-" = ## TODO: more informative message in this case:
stop("invalid value for argument `convention'."),
## default: try to convert 'convention' to a class
filterCoef(object, new(convention))
)
c(list(nseasons = object@nseasons,
iorder = object@iorder,
siorder = object@siorder),
co)
}
)
setMethod("filterPoly", "SarimaFilter",
function(object){
nseas <- object@nseasons
b1 <- polynom(c(0,1)) # B
arpoly <- filterPoly(object@ar ) # non-seasonal
mapoly <- filterPoly(object@ma )
aripoly <- (1-b1)^object@iorder
if(is.na(nseas)){ # no seasonal part
sarpoly <-
smapoly <-
sarpoly_expanded <-
smapoly_expanded <-
saripoly_expanded <- polynom(1)
fullarstatpoly <- arpoly
fullarpoly <- fullarstatpoly * aripoly
fullmapoly <- mapoly
}else{ # seasonal part present
bs <- polynom(c(rep(0, nseas), 1)) # B^s, nseas better be >1
sarpoly <- filterPoly(object@sar)
smapoly <- filterPoly(object@sma)
sarpoly_expanded <- predict(sarpoly,bs)
smapoly_expanded <- predict(smapoly,bs)
saripoly_expanded <- (1-bs)^object@siorder
fullarstatpoly <- arpoly * sarpoly_expanded
# fullarpoly <- arpoly * sarpoly_expanded * aripoly * saripoly_expanded
fullarpoly <- fullarstatpoly * aripoly * saripoly_expanded
fullmapoly <- mapoly * smapoly_expanded
}
list(nseasons = nseas,
iorder = object@iorder, # not polynomials but may be useful
siorder = object@siorder,
ipoly = aripoly,
sipoly = saripoly_expanded,
arpoly = arpoly,
mapoly = mapoly,
sarpoly = sarpoly_expanded, # 2016-11-01 - was: sarpoly
smapoly = smapoly_expanded, # smapoly
fullarstatpoly = fullarstatpoly, ## multiplied out all stationary AR factors
fullarpoly = fullarpoly, ## multiplied out all AR like
fullmapoly = fullmapoly, ## "" all MA
core_sarpoly = sarpoly, # 2016-11-01 new
core_smapoly = smapoly
)
}
)
setMethod("filterPolyCoef", "SarimaFilter",
function(object, lag_0 = TRUE){
res <- filterPoly(object)
# use the names of the fields to decide which are polynomials.
# TODO: use "is.polynomial" instead?
polycomp <- grep("poly", names(res), value = TRUE)
for(nam in polycomp){
res[[nam]] <- coef(res[[nam]])
}
if(!lag_0){
for(nam in polycomp){
res[[nam]] <- res[[nam]][-1]
}
}
res
}
)
summary.SarimaFilter <- function(object, ...){
.reportClassName(object, "SarimaFilter")
objpoly <- filterPoly(object)
res <- c(
if(!is.na(objpoly$nseasons)) paste0("Period: ", objpoly$nseasons)
else ""
, ""
, "Non-stationary part of model"
, paste0(" Order of differencing: ", objpoly$iorder)
, paste0(" Order of seasonal differencing: ", objpoly$siorder)
, paste0(" Differencing polynomial (ari): ", .capturePrint(objpoly$ipoly))
, paste0(" Seasonal differencing polynomial (sari): ",
.capturePrint(objpoly$sipoly))
, ""
, "Stationary part of model"
, .formatNameNumeric(" ar coefficients: ", filterCoef(object@ar))
, .formatNameNumeric(" ma coefficients: ", filterCoef(object@ma))
, .formatNameNumeric(" seasonal ar coefficients: ", filterCoef(object@sar))
, .formatNameNumeric(" seasonal ma coefficients: ", filterCoef(object@sma))
, ""
, paste0(" ar polynomial (non-seasonal): ", .capturePrint(objpoly$arpoly))
, paste0(" ma polynomial (non-seasonal): ", .capturePrint(objpoly$mapoly))
, paste0(" seasonal ar polynomial: ", .capturePrint(objpoly$sarpoly))
, paste0(" seasonal ma polynomial: ", .capturePrint(objpoly$smapoly))
, ""
, "Fully expanded polynomials:"
, paste0(" full ar polynomial: ", .capturePrint(objpoly$fullarpoly))
, paste0(" full ma polynomial: ", .capturePrint(objpoly$fullmapoly))
, "")
cat(res, sep="\n")
invisible(objpoly)
}
setMethod("show", signature(object = "SarimaFilter"),
function (object){
.reportClassName(object, "SarimaFilter")
seasflag <- !is.na(object@nseasons)
if(seasflag)
cat("Period: ", object@nseasons, "\n")
else cat("Non-seasonal model", "\n")
cat("Order of differencing: ", object@iorder, "\n")
if(seasflag)
cat("Order of seasonal differencing: ", object@siorder, "\n")
cat(c("", .formatNameNumeric("ar coefficients: ", filterCoef(object@ar)),
.formatNameNumeric("ma coefficients: ", filterCoef(object@ma))
), sep = "\n")
if(seasflag)
cat(.formatNameNumeric("seasonal ar coefficients: ",
filterCoef(object@sar)),
.formatNameNumeric("seasonal ma coefficients: ",
filterCoef(object@sma))
, sep = "\n")
invisible(NULL)
}
)
## TODO: provide methods for summary() and leave methods for show() simpler?
## Note: summary is S3 generic, so the methods should be S3.
## (Note summary is made S4 generic by stats4(?))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.