R/lagged.R

In GeoBosh/lagged: Classes and Methods for Lagged Objects

## Do not edit this file manually.
## It has been automatically generated from *.org sources.

setClass("Lagged", slots = c(data = "ANY"), contains = "VIRTUAL")
                               # setClass("Lagged", slots = c(data = "vector") )
                               # setClass("Lagged", slots = c(data = "structure") )

                                               # setClass("X", slots = c(data = "structure"))
setClass("Lagged1d", contains = "Lagged", slots = c(data = "vector") )
setClass("Lagged2d", contains = "Lagged", slots = c(data = "matrix") )
setClass("Lagged3d", contains = "Lagged", slots = c(data = "array") )
                     # TODO: check validity for Lagged3d: 3 dimensional.

setClass("FlexibleLagged", contains = "Lagged", slots = c(data = "Lagged"),
         prototype = list(data = new("Lagged1d")) )

.whichNativeLagged <- function(x){
    if(is(x, "Lagged"))
        "FlexibleLagged"
    else if(is.vector(x))
        "Lagged1d"
    else if(is.matrix(x))
        "Lagged2d"
    else if(is.array(x)  && length(dim(x)) == 3)
        "Lagged3d"
    else
        NA

}

setMethod("initialize", "FlexibleLagged",
          function(.Object, ..., data){
              if(missing(data)){
                  res <- callNextMethod(.Object, ...)
                  return(res)
              }

              while(is(data, "FlexibleLagged"))
                  data <- data@data

              if(!is(data, "Lagged")){
                  clname <- .whichNativeLagged(data)
                  if(!is.na(clname))
                      data <- new(clname, data = data)
                  ##else don't know what to do with data, pass it on
                  ##     and let others complain if not appropriate.
              }
              .Object <- callNextMethod(.Object, data = data, ...)

              .Object
          }
          )

setMethod("[", c(x = "Lagged", i = "missing"), function(x) x@data )
setMethod("[", c(x = "FlexibleLagged", i = "missing", j = "missing"), function(x) x@data[] )
setMethod("[", c(x = "FlexibleLagged", i = "missing", j = "ANY"), 
          function(x, i, j, ..., drop) x@data[ , j, ..., drop] )

setMethod("[", c(x = "FlexibleLagged", i = "numeric", j = "missing", drop = "missing"), 
          function(x, i, ..., drop = FALSE){
#browser()
              if(nargs() == 2)
                  x@data[i] 
              else
                  x@data[i, ] 
          }
          )
setMethod("[", c(x = "FlexibleLagged", i = "numeric", j = "missing", drop = "logical"), 
          function(x, i, ..., drop = FALSE)
              if(nargs() == 3)
                  x@data[i, drop = drop] 
              else
                  x@data[i, , drop = drop] 
          )

setReplaceMethod("[", c(x = "Lagged", i = "missing"),
          function(x, i, value){
              x@data <- value
              x
          })

setReplaceMethod("[", c(x = "FlexibleLagged", i = "missing"),
                 function(x, i, value){
                     if(is(value, "FlexibleLagged"))
                         x@data <- value@data
                     else if(is(value, "Lagged"))
                         x@data <- value
                     else{
                         clname <- .whichNativeLagged(value)
                         if(is.na(clname))
                             stop("Don't know what Lagged class to use for this value")
                         else
                             x@data <- new(clname, data = value) # as(value, clname)
                     }
                     x
                 })

setReplaceMethod("[", c(x = "FlexibleLagged", i = "numeric"),
                 function(x, i, value){
                     x@data[i] <- value # not i+1, since x@data is a "Lagged" object here.
                     x
          })

## Ne, tezi zasega ne gi pravya, pravya vischko bez "value = xxx" - tova pozvolyava da se
## definirat metodi ako tryabva.
##
## setReplaceMethod("[", c(x = "FlexibleLagged", i = "missing", value = "vector"),
##           function(x, i, value){
##               x@data <- as(value, "Lagged1d")
##               x
##           })
##
## setReplaceMethod("[", c(x = "FlexibleLagged", i = "missing", value = "matrix"),
##           function(x, i, value){
##               x@data <- as(value, "Lagged2d")
##               x
##           })

setMethod("[[", c(x = "Lagged", i = "numeric", j = "missing"),
          function(x, i, j){
              if(length(i) == 1)
                  x[i, drop = TRUE]
              else
                  stop("the length of argument `i' must be equal to one")
          }
          )

setMethod("[[", c(x = "FlexibleLagged", i = "ANY", j = "ANY"),
          function(x, i, j){
              x@data[[i, j]]
          }
          )
setMethod("[[", c(x = "FlexibleLagged", i = "missing", j = "numeric"),
          function(x, i, j){
              x@data[[ , j]]
          }
          )
setMethod("[[", c(x = "FlexibleLagged", i = "numeric", j = "missing"),
          function(x, i, j){
              if(nposargs(sys.call(-1)) == 2) # x[[i]]
                  x@data[[i]]
              else # x[i, ]
                  x@data[[i, ]]
          }
          )

setReplaceMethod("[[", c(x = "Lagged", i = "numeric"),
                 function(x, i, value){
                     if(length(i) == 1)
                         x[i] <- value
                     else
                         stop("the length of argument `i' must be equal to one")
                     x
                 })

setMethod("[[", c(x = "Lagged2d", i = "numeric", j = "missing"),
          function(x, i, j){
              if(length(i) == 1){
                  if(nposargs(sys.call(-1)) == 2) # x[i] - note the use of -1 in sys.call()
                      x@data[ , i + 1, drop = TRUE]
                  else             # x[i, ]
                      x@data[i, , drop = TRUE]
              }else
                  stop("the length of argument `i' must be equal to one")
          }
          )
setMethod("[[", c(x = "Lagged2d", i = "missing", j = "numeric"),
          function(x, i, j){
              if(length(j) == 1){
                      x@data[ , j + 1, drop = TRUE]
              }else
                  stop("the length of argument `j' must be equal to one")
          }
          )
setMethod("[[", c(x = "Lagged2d", i = "numeric", j = "numeric"),
          function(x, i, j){
              if(length(i) == 1)
                  x@data[i, j + 1, drop = TRUE]
              else
                  stop("the length of argument `i' must be equal to one")
          }
          )
setMethod("[[", c(x = "Lagged2d", i = "numeric", j = "logical"),
          function(x, i, j){
              if(length(i) == 1)
                  x@data[i, j, drop = TRUE]
              else
                  stop("the length of argument `i' must be equal to one")
          }
          )

setMethod("Ops", c(e1 = "Lagged", e2 = "missing"),
          function(e1){
                    # wrk <- callGeneric(e1@data)
                    # clname <- whichLagged(e1)
                    # new(clname, data = wrk)
              e1@data <- callGeneric(e1@data)
              e1
          })

## TODO: do not allow mixing Lagged1d with Lagged2d, etc.?
setMethod("Ops", c(e1 = "Lagged", e2 = "Lagged"),
          function(e1, e2){
              wrk <- if(length(e1@data) == length(e2@data) ) # TODO: allow %%==0 as elsewhere?
                         callGeneric(e1@data, e2@data)
                     else{
                         maxlag <- max(maxLag(e1), maxLag(e2))
                         v1 <- e1[0:maxlag]
                         v2 <- e2[0:maxlag]
                         callGeneric(v1, v2)
                     }
              clname <- whichLagged(e1, e2)
              new(clname, data = wrk)
          })

setMethod("Ops", c(e1 = "Lagged", e2 = "vector"),
          function(e1, e2){
              wrk <- if(length(e2) == 1  || length(e1@data) == length(e2)
                             # 2017-05-20 was:
                             #    || length(e2) > 0  && (length(e1@data) %% length(e2)) == 0
                        || length(e2) > 0  && length(e1[[0]]) == length(e2))
                         callGeneric(e1@data, e2)
                     else
                         stop("Incompatible length of operands in a binary operation")

              new(whichLagged(e1), data = wrk)
          })

setMethod("Ops", c(e1 = "vector", e2 = "Lagged"),
          function(e1, e2){
              wrk <- if(length(e1) == 1  || length(e1) == length(e2@data)
                             # 2017-05-20 was:
                             #    || length(e1) > 0  && (length(e2@data) %% length(e1)) == 0
                        || length(e1) > 0  && length(e2[[0]]) == length(e1))
                         callGeneric(e1, e2@data)
                     else
                         stop("Incompatible length of operands in a binary operation")

              new(whichLagged(e2), data = wrk)
          })

setMethod("Ops", c(e1 = "FlexibleLagged", e2 = "Lagged"),
          function(e1, e2){
              callGeneric(e1@data, e2)
          })

setMethod("Ops", c(e1 = "Lagged", e2 = "FlexibleLagged"),
          function(e1, e2){
              callGeneric(e1, e2@data)
          })

setMethod("Ops", c(e1 = "FlexibleLagged", e2 = "FlexibleLagged"),
          function(e1, e2){
              callGeneric(e1@data, e2@data)
          })


setMethod("Ops", c(e1 = "FlexibleLagged", e2 = "vector"),
          function(e1, e2){
              callGeneric(e1@data, e2)
          })

setMethod("Ops", c(e1 = "vector", e2 = "FlexibleLagged"),
          function(e1, e2){
              callGeneric(e1, e2@data)
          })

setMethod("Math", c(x = "Lagged"),
          function(x){
              x@data <- callGeneric(x@data)
              x
          })

setMethod("Math2", c(x = "Lagged"),
          function(x, digits){
              x@data <- callGeneric(x@data, digits)
              x
          })

setMethod("Summary", c(x = "Lagged"),
          function(x, ..., na.rm = FALSE){
              callGeneric(x@data)
          })

## TODO: check if the S3 methods understand S4 inheritance (I think they do)
as.vector.Lagged <- function(x, mode) as.vector(x@data) # todo: use mode?
as.double.Lagged <- function(x, ...)  as.double(x@data ) # note: this is for as.numeric()
as.matrix.Lagged <- function(x, ...)  as.matrix(x@data)
 as.array.Lagged <- function(x, ...)  as.array(x@data)

as.vector.Lagged1d <- function(x, mode) x@data
as.matrix.Lagged2d <- function(x, ...) x@data
as.array.Lagged3d  <- function(x, ...) x@data

setAs("Lagged", "vector", function(from) as.vector(from) )
setAs("Lagged", "matrix", function(from) as.matrix(from) )
setAs("Lagged", "array",  function(from) as.array(from) )

maxLag <- function(object, ...){
   if(inherits(object, "acf"))
       dim(object$acf)[1] - 1
   else
       stop("No applicable method to compute maxLag")
}

setGeneric("maxLag")

setGeneric("maxLag<-", def = function(object, ..., value){ standardGeneric("maxLag<-") } )

setReplaceMethod("maxLag", "Lagged",
                 function(object, ..., value){
                     object@data <- object[0:value]
                     object
                 }
                 )

setReplaceMethod("maxLag", "FlexibleLagged",
                 function(object, ..., value){
                     maxLag(object@data) <- value
                     object
                 }
                 )

setMethod("maxLag", c(object = "vector"), function(object) length(object) - 1)
setMethod("maxLag", c(object = "matrix"), function(object) ncol(object) - 1 )
setMethod("maxLag", c(object = "array"),
          function(object){
                  d <- dim(object)
                  d[length(d)] - 1
          })

setMethod("maxLag", c(object = "Lagged"), function(object) maxLag(object@data) )

length.Lagged <- function(x) maxLag(x) + 1

setMethod("[", c(x = "Lagged1d", i = "numeric"),
          function(x, i, drop) x@data[i+1] )

setMethod("[", c(x = "Lagged2d", i = "numeric", j = "missing", drop = "missing"),
          function(x, i, ..., drop = FALSE){
              if(nargs() == 2)              # x[i]
                  x@data[ , i+1, drop = FALSE] 
              else                          # x[i, ]
                  x@data[i, , drop = FALSE] 
          }
          )

setMethod("[", c(x = "Lagged2d", i = "numeric", j = "missing", drop = "logical"),
          function(x, i, ..., drop = FALSE){
              if(nposargs(sys.call()) == 2) # x[i]
                  x@data[ , i+1, drop = drop]
              else                          # x[i, ]
                  x@data[i, , drop = drop]
          } 
          )

setMethod("[", c(x = "Lagged2d", i = "character", j = "missing", drop = "missing"),
          function(x, i, ..., drop = FALSE){
              if(nargs() == 2)              # x[i]
                  ## no need (and can't) to add one here
                  x@data[ , i, drop = FALSE] 
              else                          # x[i, ]
                  x@data[i, , drop = FALSE] 
          }
          )

setMethod("[", c(x = "Lagged2d", i = "character", j = "missing", drop = "logical"),
          function(x, i, ..., drop = FALSE){
              if(nposargs(sys.call()) == 2) # x[i]
                  x@data[ , i, drop = drop]
              else                          # x[i, ]
                  x@data[i, , drop = drop]
          } 
          )

setMethod("[", c(x = "Lagged2d", i = "numeric", j = "numeric", drop = "missing"),
          function(x, i, j, ..., drop = FALSE)  
              x@data[i, j + 1, drop = FALSE]
          )
setMethod("[", c(x = "Lagged2d", i = "missing", j = "numeric", drop = "missing"),
          function(x, i, j, ..., drop = FALSE)  
              x@data[ , j + 1, drop = FALSE]
          )

setMethod("[", c(x = "Lagged2d", i = "character", j = "numeric", drop = "missing"),
          function(x, i, j, ..., drop = FALSE)  
              x@data[i, j+1, drop = FALSE]
          )
setMethod("[", c(x = "Lagged2d", i = "character", j = "character", drop = "missing"),
          function(x, i, j, ..., drop = FALSE)  
              x@data[i, j, drop = FALSE]
          )
setMethod("[", c(x = "Lagged2d", i = "numeric", j = "character", drop = "missing"),
          function(x, i, j, ..., drop = FALSE)  
              x@data[i, j, drop = FALSE]
          )
setMethod("[", c(x = "Lagged2d", i = "missing", j = "character", drop = "missing"),
          function(x, i, j, ..., drop = FALSE)  
              x@data[ , j, drop = FALSE]
          )

setMethod("[", c(x = "Lagged2d", i = "ANY", j = "ANY", drop = "character"),
          ## very old code, modelled after the method for 'slMatrix'
          function(x, i, j, ..., drop = "sl"){  
              ## for now, don't write about this method in the documentation;
              ## it will certainly change

              y <- x@data
              period <- nrow(y)
              if(missing(i))
                  i <- 1:nrow(y)
              if(missing(j))
                  j <- 0:maxLag(x)

              ## TODO: should set 'drop = FALSE' when extracting below but keep it for now in
              ##    case old code depends on the current. In particular this is almost
              ##    certainly so when extracting single values.
              switch(drop,
                     ## "sl" is for completeness, it is the default without this method
                     "sl" = {
                         season <- i
                         lag <- pc.omitneg(j, ncol(x)-1)
                         res <- y[season, lag+1]   # lag+1 because lags start from zero
                     },
                     "tt" = {
                         res <- myouter(i, j, function(ii, jj){
                             wrk <- toSeasonPair(ii, jj, period)
                             season <- wrk$season
                             lag <- wrk$lag
                             y[season, lag + 1]
                         }
                         )
                     },
                     "tl" = {
                         season <- toSeason(i, period)
                         lag <- j
                         res <- y[season, lag + 1]      # lag+1 because lags start from zero.
                     },
                     "tl+-" = {
                         if(length(j) == 1){
                             if(j>=0){                   # this works only for scalar  j
                                 season <- toSeason(i, period)
                                 lag <- j
                             }else{
                                 season <- toSeason(i - j, period)
                                 lag <- -j
                             }
                             res <- y[season, lag+1] # lag+1 because lags start from zero.
                         }else{
                             res <- matrix(NA, nrow = length(i), ncol = length(j))
                             for(k in 1:length(j)){
                                 if(j[k] >= 0){         # this works only for scalar  j
                                     season <- toSeason(i, period)
                                     lag <- j[k]
                                 }else{
                                     season <- toSeason(i - j[k], period)
                                     lag <- -j[k]
                                 }
                                 res[ , k] <- y[season, lag+1]#lag+1 as lags start from zero.
                             }
                         }
                     },
                     "t+l,l+-" = {
                         res <- matrix(NA, nrow = length(i), ncol = length(j))
                         for(k in 1:length(j)){
                             res[ , k] <- x[i + j[k], j[k], drop = "tl+-"]
                         }
                     },
                     ## 2016-01-01 TODO: case "co" seems to be meant for j - scalar.
                     "co" = {
                         season <- toSeason(i, period)
                         lag <- j
                         if(lag < 0 || lag > maxLag(x) )
                             res <- 0
                         else{
                             res <- y[season, lag + 1] # lag+1 because lags start from zero.
                         }
                     },
                     stop("Invalid arg. type, must be one of \"sl\", \"tt\" or \"tl\".")
                     )
              res
          }
          )

setMethod("[", c(x = "Lagged3d", i = "numeric", j = "missing", drop = "missing"),
          function(x, i, ..., drop = FALSE) x@data[, , i+1, drop = FALSE] )
setMethod("[", c(x = "Lagged3d", i = "numeric", j = "missing", drop = "logical"),
          function(x, i, ..., drop = FALSE) x@data[, , i+1, drop = drop] )

.matLagged <- matrix("FlexibleLagged", 4, 4)
diag(.matLagged) <- c("FlexibleLagged", "Lagged1d", "Lagged2d", "Lagged3d")

rownames(.matLagged) <- c("FlexibleLagged", "Lagged1d", "Lagged2d", "Lagged3d")
colnames(.matLagged) <- c("FlexibleLagged", "Lagged1d", "Lagged2d", "Lagged3d")


whichLagged <- function(x, y){
    .matLagged[whichLagged(x), whichLagged(y)]
}
setGeneric("whichLagged")

## TODO: define methods for "numeric", "matrix", etc?
setMethod("whichLagged", c(x = "ANY"     , y = "missing"), function(x) "FlexibleLagged")
setMethod("whichLagged", c(x = "Lagged1d", y = "missing"), function(x) "Lagged1d")
setMethod("whichLagged", c(x = "Lagged2d", y = "missing"), function(x) "Lagged2d")
setMethod("whichLagged", c(x = "Lagged3d", y = "missing"), function(x) "Lagged3d")

setReplaceMethod("[", c(x = "Lagged", i = "missing"),
          function(x, i, value){
              x[0:maxLag(x)] <- value
              x
          })

setReplaceMethod("[", c(x = "Lagged1d", i = "numeric"),
          function(x, i, value){
              x@data[i+1] <- value
              x
          })

setReplaceMethod("[", c(x = "Lagged2d", i = "numeric"), #Include value = "matrix" in signature?
          function(x, i, value){
              x@data[ , i+1]  <- value
              x
          })

## Include value = "array" in the signature? Will still need to check the dimensions
setReplaceMethod("[", c(x = "Lagged3d", i = "numeric"),
          function(x, i, value){
                      # was: x@data[i+1, , ]  <- value
              x@data[ , , i+1]  <- value
              x
          })

## .printVecOrArray <- function(x){
##     if(is.vector(x)){
##         if(is.null(names(x)) || length(names(x)) == 0)
##             names(x) <- paste0("Lag_", 0:(length(x) - 1))
##         print(x)
##     }else if(is.matrix(x)){
##         ## TODO:
##         print(x)
##     }else if(is.array(x)){
##         ## TODO:
##         print(x)
##     }else
##         print(x)
## }

setMethod("show", "Lagged1d",
          function(object){
              .reportClassName(object, "Lagged1d")
              cat("Slot *data*:", "\n")

              ## 2017-05-24 was:
              ##     x <- object@data
              ##     if(is.null(names(x)) || length(names(x)) == 0)
              ##         names(x) <- paste0("Lag_", 0:(length(x) - 1))
              x <- dataWithLagNames(object)
              print(x)
              ## cat("\n")
          }
          )

setMethod("show", "Lagged2d",
          function(object){
              .reportClassName(object, "Lagged2d")
              cat("Slot *data*:", "\n")

              x <- dataWithLagNames(object)
              print(x)
              ## cat("\n")
          }
          )

setMethod("show", "Lagged3d",
          function(object){
              .reportClassName(object, "Lagged3d")
              cat("Slot *data*:", "\n")

              ## x <- object@data
              ## if(is.null(dimnames(x)) || length(dimnames(x)) == 0){
              ##     d <- dim(x)
              ##     dimnames(x) <- list(rep("", d[1]), rep("", d[2]),
              ##                         paste0("Lag_", 0:(d[3] - 1)) )
              ## }
              x <- dataWithLagNames(object)
              print(x)
              ## cat("\n")
          }
          )

## Commenting out since causes trouble by precluding default methods from printing.
##
## setMethod("show", "Lagged",
##           function(object){
##               ## .reportClassName(object, "Lagged") # this is silly: never writes!
##               ## callNextMethod()
##               wrk <- object@data
##               cat("Slot *data*:", "\n")
##               .printVecOrArray(wrk)
##               cat("\n")
##               ## callNextMethod() # in case the object inherits from other classes
##               ##                  # unfortunately, it prints slot data again.
##           }
##           )

setMethod("show", "FlexibleLagged",
          function(object){
              .reportClassName(object, "FlexibleLagged")
              cat("Slot *data*:", "\n")
              show(object@data)
          }
          )

acf2Lagged <- function(x){
    acv <- x$acf
    d <- dim(acv)
    if(d[2] == 1 && d[3] == 1){
        data <- as.vector(acv)
        if(x$type == "partial") # lag-0 is missing, insert it
            data <- c(1, data)
        new("Lagged1d", data = data)
    }else{
        ## transpose to make the 3rd index corresponding to lag.
        ##   (taken from acfbase2sl() in package pcts, see the comments there)
        ##
        ## TODO: test!
        ## Note: in pcts:::acfbase2sl() the analogous command is aperm(acv, c(3,2,1))
        ##       i.e. R[k] is transposed => check if that is correct!
        data <- aperm(acv, c(2, 3, 1))

        if(x$type == "partial"){ # lag-0 is missing, insert it
            datanew <- array(NA_real_, dim(data) + c(0,0,1) )
            datanew[ , , -1] <- data
            data <- datanew
        }

        new("Lagged3d", data = data)
    }
}

Lagged <- function(data, ...){
    if(inherits(data, "acf")){    # for S3 class "acf"
        acf2Lagged(data)
    }else if(is.vector(data)){
        new("Lagged1d", data = data, ...)
    }else if(is.matrix(data)){
        new("Lagged2d", data = data, ...)
    }else if(is.array(data)){
        new("Lagged3d", data = data, ...)
    }else if(is(data, "Lagged")){
        new("FlexibleLagged", data = data, ...)
    ## }else if(inherits(data, "acf")){    # for S3 class "acf"
    ##     acf2Lagged(data)
    }else
        stop("I don't know how to create a Lagged object from the given data")
}

dataWithLagNames <- function(object, prefix = "Lag_"){
    x <- object[]
    if(length(x) == 0)
        return(x)

    if(is.array(x)){
        d <- dim(x)
        nd <- length(d)

        xwithnams <- provideDimnames(x, base = list(""), unique = FALSE)
        dimnames(xwithnams)[[nd]] <- paste0(prefix, 0:(d[nd] - 1))
        xwithnams
    }else{
        if(is.null(names(x)) || length(names(x)) == 0)
            names(x) <- paste0(prefix, 0:(length(x) - 1))
        x
    }
}