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