1is.regular <- function(x, strict = FALSE) {
2  UseMethod("is.regular")
3}
4
5is.regular.zoo <- function(x, strict = FALSE)
6{
7  delta <- suppressWarnings(try(diff(as.numeric(index(x))), silent = TRUE))
8  if(inherits(delta, "try-error") || anyNA(delta)) FALSE
9  else if(length(delta) < 1) FALSE
10  else if(strict) identical(all.equal(delta, rep.int(delta[1], length(delta))), TRUE)
11  else {
12    delta <- unique(delta)
13    rval <- identical(all.equal(delta/min(delta), round(delta/min(delta))), TRUE)
14    if(!rval && identical(all.equal(delta, round(delta)), TRUE)) rval <- TRUE
15    rval
16  }
17}
18
19is.regular.ts <- function(x, strict = FALSE) TRUE
20
21is.regular.zooreg <- function(x, strict = FALSE)
22{
23  if(strict) is.regular.zoo(x, strict = TRUE) else TRUE
24}
25
26is.regular.default <- function(x, strict = FALSE) {
27  is.regular(as.zoo(x), strict = strict)
28}
29
30frequency.zooreg <- function(x, ...)
31{
32  attr(x, "frequency")
33}
34
35frequency.zoo <- function(x, ...)
36{
37  ## check whether frequency is available
38  freq <- attr(x, "frequency")
39  if(!is.null(freq) || length(index(x)) < 2) return(freq)
40
41  ## check regularity
42  delta <- suppressWarnings(try(diff(as.numeric(index(x))), silent = TRUE))
43  reg <- if(inherits(delta, "try-error") || anyNA(delta)) FALSE
44  else {
45    delta <- unique(delta)
46    rval <- identical(all.equal(delta/min(delta), round(delta/min(delta))), TRUE)
47    if(rval) freq <- 1/min(delta)
48    else if(identical(all.equal(delta, round(delta)), TRUE)) {
49      ## special case: integer indexes
50      ## get frequency as greatest common divisor (of differences)
51      gcd <- function(x) {
52        gcd0 <- function(a, b) ifelse(b==0 | a==b, a, gcd0(b, a %% b))
53        if(length(x) < 2) x <- c(x, as.integer(0))
54        if(length(x) < 3) {
55          return(gcd0(x[1], x[2]))
56        } else {
57          x <- sapply(1:(length(x) - 1), function(i) gcd0(x[i], x[i+1]))
58          gcd(x)
59        }
60      }
61      freq <- 1/gcd(delta)
62      rval <- TRUE
63    }
64    rval
65  }
66  if(!reg) return(NULL)
67  if(freq > 1 && identical(all.equal(freq, round(freq)), TRUE)) freq <- round(freq)
68  return(freq)
69}
70
71"frequency<-" <- function(x, value)
72  UseMethod("frequency<-")
73
74"frequency<-.zoo" <- function(x, value) {
75  delta <- suppressWarnings(try(diff(as.numeric(index(x))), silent = TRUE))
76  freqOK <- if(inherits(delta, "try-error") || anyNA(delta)) FALSE
77    else if(length(delta) < 1) TRUE
78    else identical(all.equal(delta*value, round(delta*value)), TRUE)
79  stopifnot(freqOK)
80  if(value > 1 && identical(all.equal(value, round(value)), TRUE)) value <- round(value)
81  attr(x, "frequency") <- value
82  class(x) <- c("zooreg", "zoo")
83  return(x)
84}
85
86"frequency<-.zooreg" <- function(x, value) {
87  delta <- diff(as.numeric(index(x)))
88  stopifnot(identical(all.equal(delta*value, round(delta*value)), TRUE))
89  attr(x, "frequency") <- value
90  return(x)
91}
92
93deltat.zoo <- function(x, ...)
94{
95  rval <- frequency.zoo(x, ...)
96  if(is.null(rval)) NULL else 1/rval
97}
98
99deltat.zooreg <- function(x, ...)
100{
101  1/frequency.zooreg(x, ...)
102}
103
104cycle.zooreg <- function(x, ...)
105{
106  freq <- frequency(x)
107  ix <- as.numeric(index(x))
108  d <- diff(ix)
109  if(!identical(all.equal(freq*d, round(freq*d)), TRUE))
110    stop(paste(sQuote("cycle"), "not available for", sQuote("x")))
111  return(zoo(round((ix - floor(ix)) * freq) + 1, order.by = index(x), freq))
112}
113
114cycle.zoo <- function(x, ...)
115{
116  if(is.regular(x)) cycle.zooreg(x)
117    else stop(sQuote("x"), "is not regular")
118}
119