Nothing
## 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(?))
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.