R/is.regular.R

In parsifal9/test: S3 Infrastructure for Regular and Irregular Time Series (Z's Ordered Observations)

is.regular <- function(x, strict = FALSE) {
  UseMethod("is.regular")
}

is.regular.zoo <- function(x, strict = FALSE)
{
  delta <- suppressWarnings(try(diff(as.numeric(index(x))), silent = TRUE))
  if(inherits(delta, "try-error") || anyNA(delta)) FALSE
  else if(length(delta) < 1) FALSE
  else if(strict) identical(all.equal(delta, rep.int(delta[1], length(delta))), TRUE)
  else {
    delta <- unique(delta)
    rval <- identical(all.equal(delta/min(delta), round(delta/min(delta))), TRUE)
    if(!rval && identical(all.equal(delta, round(delta)), TRUE)) rval <- TRUE
    rval
  }
}

is.regular.ts <- function(x, strict = FALSE) TRUE

is.regular.zooreg <- function(x, strict = FALSE)
{
  if(strict) is.regular.zoo(x, strict = TRUE) else TRUE
}

is.regular.default <- function(x, strict = FALSE) {
  is.regular(as.zoo(x), strict = strict)
}

frequency.zooreg <- function(x, ...) 
{
  attr(x, "frequency")
}

frequency.zoo <- function(x, ...)
{
  ## check whether frequency is available
  freq <- attr(x, "frequency")
  if(!is.null(freq) || length(index(x)) < 2) return(freq)

  ## check regularity
  delta <- suppressWarnings(try(diff(as.numeric(index(x))), silent = TRUE))
  reg <- if(inherits(delta, "try-error") || anyNA(delta)) FALSE
  else {
    delta <- unique(delta)
    rval <- identical(all.equal(delta/min(delta), round(delta/min(delta))), TRUE)
    if(rval) freq <- 1/min(delta)
    else if(identical(all.equal(delta, round(delta)), TRUE)) {
      ## special case: integer indexes
      ## get frequency as greatest common divisor (of differences)
      gcd <- function(x) {	
        gcd0 <- function(a, b) ifelse(b==0 | a==b, a, gcd0(b, a %% b))
        if(length(x) < 2) x <- c(x, as.integer(0))
        if(length(x) < 3) {
          return(gcd0(x[1], x[2]))
        } else {
          x <- sapply(1:(length(x) - 1), function(i) gcd0(x[i], x[i+1]))
          gcd(x)
        }
      }
      freq <- 1/gcd(delta)
      rval <- TRUE
    }
    rval
  }
  if(!reg) return(NULL)
  if(freq > 1 && identical(all.equal(freq, round(freq)), TRUE)) freq <- round(freq)
  return(freq)
}

"frequency<-" <- function(x, value)
  UseMethod("frequency<-")
  
"frequency<-.zoo" <- function(x, value) {
  delta <- suppressWarnings(try(diff(as.numeric(index(x))), silent = TRUE))
  freqOK <- if(inherits(delta, "try-error") || anyNA(delta)) FALSE
    else if(length(delta) < 1) TRUE
    else identical(all.equal(delta*value, round(delta*value)), TRUE)
  stopifnot(freqOK)
  if(value > 1 && identical(all.equal(value, round(value)), TRUE)) value <- round(value)
  attr(x, "frequency") <- value
  class(x) <- c("zooreg", "zoo")
  return(x)
}

"frequency<-.zooreg" <- function(x, value) {
  delta <- diff(as.numeric(index(x)))
  stopifnot(identical(all.equal(delta*value, round(delta*value)), TRUE))
  attr(x, "frequency") <- value
  return(x)
}

deltat.zoo <- function(x, ...)
{
  rval <- frequency.zoo(x, ...)
  if(is.null(rval)) NULL else 1/rval
}

deltat.zooreg <- function(x, ...)
{
  1/frequency.zooreg(x, ...)
}

cycle.zooreg <- function(x, ...)
{
  freq <- frequency(x)
  ix <- as.numeric(index(x))
  d <- diff(ix)
  if(!identical(all.equal(freq*d, round(freq*d)), TRUE))
    stop(paste(sQuote("cycle"), "not available for", sQuote("x")))  
  return(zoo(round((ix - floor(ix)) * freq) + 1, order.by = index(x), freq))
}

cycle.zoo <- function(x, ...)
{
  if(is.regular(x)) cycle.zooreg(x)
    else stop(sQuote("x"), "is not regular")
}