R/filterClasses.R

Defines functions summary.SarimaFilter

Documented in summary.SarimaFilter

## 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)

                  fullarpoly <- arpoly * 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

                  fullarpoly <- arpoly * sarpoly_expanded * 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

                   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(?))

Try the sarima package in your browser

Any scripts or data that you put into this service are public.

sarima documentation built on Aug. 23, 2018, 9:03 a.m.