R/filterClasses.R

In GeoBosh/sarima: Simulation and Prediction with Seasonal ARIMA Models

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