### R code from vignette source 'zoo-faq.Rnw' ################################################### ### code chunk number 1: preliminaries ################################################### library("zoo") Sys.setenv(TZ = "GMT") suppressWarnings(RNGversion("3.5.0")) ################################################### ### code chunk number 2: duplicates1 ################################################### z <- suppressWarnings(zoo(1:8, c(1, 2, 2, 2, 3, 4, 5, 5))) z ################################################### ### code chunk number 3: duplicates2 ################################################### aggregate(z, identity, mean) ################################################### ### code chunk number 4: duplicates3 ################################################### aggregate(z, identity, tail, 1) ################################################### ### code chunk number 5: duplicates4 ################################################### time(z) <- na.approx(ifelse(duplicated(time(z)), NA, time(z)), na.rm = FALSE) ################################################### ### code chunk number 6: duplicates5 ################################################### z[!is.na(time(z))] ################################################### ### code chunk number 7: duplicates ################################################### Lines <- "1|BHARTIARTL|EQ|18:15:05|600|1 2|BHARTIARTL|EQ|18:15:05|600|99 3|GLENMARK|EQ|18:15:05|238.1|5 4|HINDALCO|EQ|18:15:05|43.75|100 5|BHARTIARTL|EQ|18:15:05|600|1 6|BHEL|EQ|18:15:05|1100|11 7|HINDALCO|EQ|18:15:06|43.2|1 8|CHAMBLFERT|EQ|18:15:06|46|10 9|CHAMBLFERT|EQ|18:15:06|46|90 10|BAJAUTOFIN|EQ|18:15:06|80|100" library("zoo") library("chron") tail1 <- function(x) tail(x, 1) cls <- c("NULL", "NULL", "NULL", "character", "numeric", "numeric") nms <- c("", "", "", "time", "value", "volume") z <- read.zoo(text = Lines, aggregate = tail1, FUN = times, sep = "|", colClasses = cls, col.names = nms) z2 <- read.zoo(text = Lines, aggregate = sum, FUN = times, sep = "|", colClasses = cls, col.names = nms) z$volume <- z2$volume z ################################################### ### code chunk number 8: readsplit ################################################### Lines <- "Date Stock Price 2000-01-01 IBM 10 2000-01-02 IBM 11 2000-01-01 ORCL 12 2000-01-02 ORCL 13" stocks <- read.zoo(text = Lines, header = TRUE, split = "Stock") stocks ################################################### ### code chunk number 9: log-plot ################################################### z <- zoo(1:100) plot(z, log = "y", panel = function(..., log) lines(...)) ################################################### ### code chunk number 10: plot-axes (eval = FALSE) ################################################### ## set.seed(1) ## z.Date <- as.Date(paste(2003, 02, c(1, 3, 7, 9, 14), sep = "-")) ## z <- zoo(cbind(left = rnorm(5), right = rnorm(5, sd = 0.2)), z.Date) ## ## plot(z[,1], xlab = "Time", ylab = "") ## opar <- par(usr = c(par("usr")[1:2], range(z[,2]))) ## lines(z[,2], lty = 2) ## ## axis(side = 4) ## legend("bottomright", lty = 1:2, legend = colnames(z), bty="n") ## par(opar) ################################################### ### code chunk number 11: plot-axes1 ################################################### set.seed(1) z.Date <- as.Date(paste(2003, 02, c(1, 3, 7, 9, 14), sep = "-")) z <- zoo(cbind(left = rnorm(5), right = rnorm(5, sd = 0.2)), z.Date) plot(z[,1], xlab = "Time", ylab = "") opar <- par(usr = c(par("usr")[1:2], range(z[,2]))) lines(z[,2], lty = 2) axis(side = 4) legend("bottomright", lty = 1:2, legend = colnames(z), bty="n") par(opar) ################################################### ### code chunk number 12: factor1 ################################################### DF <- data.frame(time = 1:4, x = 1:4, f = factor(letters[c(1, 1, 2, 2)])) zx <- zoo(DF$x, DF$time) zf <- zoo(DF$f, DF$time) ################################################### ### code chunk number 13: factor2 ################################################### DF2 <- data.frame(x = zx, f = zf) ################################################### ### code chunk number 14: factor3 ################################################### z <- zoo(data.matrix(DF[-1]), DF$time) ################################################### ### code chunk number 15: lags ################################################### z <- zoo(11:15, as.Date("2008-01-01") + c(-4, 1, 2, 3, 6)) zr <- as.zooreg(z) lag(z) lag(zr) diff(log(z)) diff(log(zr)) ################################################### ### code chunk number 16: subtract-monthly-means ################################################### set.seed(123) z <- zoo(rnorm(100), as.Date("2007-01-01") + seq(0, by = 10, length = 100)) z.demean1 <- z - ave(z, as.yearmon(time(z))) ################################################### ### code chunk number 17: subtract-monthly-means2 ################################################### z.demean2 <- z - ave(z, format(time(z), "%m")) ################################################### ### code chunk number 18: yearmon2 ################################################### as.yearmon2 <- function(x, ...) UseMethod("as.yearmon2") as.yearmon2.Date <- function(x, ...) { y <- as.yearmon(with(as.POSIXlt(x, tz = "GMT"), 1900 + year + mon/12)) names(y) <- x structure(y, class = c("yearmon2", class(y))) } ################################################### ### code chunk number 19: yearmon2-inverse ################################################### as.Date.yearmon2 <- function(x, frac = 0, ...) { if (!is.null(names(x))) return(as.Date(names(x))) x <- unclass(x) year <- floor(x + .001) month <- floor(12 * (x - year) + 1 + .5 + .001) dd.start <- as.Date(paste(year, month, 1, sep = "-")) dd.end <- dd.start + 32 - as.numeric(format(dd.start + 32, "%d")) as.Date((1-frac) * as.numeric(dd.start) + frac * as.numeric(dd.end), origin = "1970-01-01") } ################################################### ### code chunk number 20: yearmon2-example ################################################### dd <- seq(as.Date("2000-01-01"), length = 5, by = 32) z <- zoo(1:5, as.yearmon2(dd)) z aggregate(z, as.Date, identity) ################################################### ### code chunk number 21: single-panel ################################################### z <- zoo(0:500, as.Date(0:500)) plot(z, xaxt = "n") tt <- time(z) m <- unique(as.Date(as.yearmon(tt))) jan <- format(m, "%m") == "01" mlab <- substr(months(m[!jan]), 1, 1) axis(side = 1, at = m[!jan], labels = mlab, tcl = -0.3, cex.axis = 0.7) axis(side = 1, at = m[jan], labels = format(m[jan], "%y"), tcl = -0.7) axis(side = 1, at = unique(as.Date(as.yearqtr(tt))), labels = FALSE) abline(v = m, col = grey(0.8), lty = 2) ################################################### ### code chunk number 22: multiplesingleplot ################################################### z3 <- cbind(z1 = z, z2 = 2*z, z3 = 3*z) opar <- par(mfrow = c(2, 2)) tt <- time(z) m <- unique(as.Date(as.yearmon(tt))) jan <- format(m, "%m") == "01" mlab <- substr(months(m[!jan]), 1, 1) for(i in 1:ncol(z3)) { plot(z3[,i], xaxt = "n", ylab = colnames(z3)[i], ylim = range(z3)) axis(side = 1, at = m[!jan], labels = mlab, tcl = -0.3, cex.axis = 0.7) axis(side = 1, at = m[jan], labels = format(m[jan], "%y"), tcl = -0.7) axis(side = 1, at = unique(as.Date(as.yearqtr(tt))), labels = FALSE) } par(opar) ################################################### ### code chunk number 23: multipanelplot ################################################### plot(z3, screen = 1:3, xaxt = "n", nc = 2, ylim = range(z3), panel = function(...) { lines(...) panel.number <- parent.frame()$panel.number nser <- parent.frame()$nser # place axis on bottom panel of each column only if (panel.number %% 2 == 0 || panel.number == nser) { tt <- list(...)[[1]] m <- unique(as.Date(as.yearmon(tt))) jan <- format(m, "%m") == "01" mlab <- substr(months(m[!jan]), 1, 1) axis(side = 1, at = m[!jan], labels = mlab, tcl = -0.3, cex.axis = 0.7) axis(side = 1, at = m[jan], labels = format(m[jan], "%y"), tcl = -0.7) axis(side = 1, at = unique(as.Date(as.yearqtr(tt))), labels = FALSE) } }) ################################################### ### code chunk number 24: plot-with-na ################################################### z <- zoo(c(1, NA, 2, NA, 3)) plot(z) ################################################### ### code chunk number 25: plot-with-na1 ################################################### plot(z, type = "p") ################################################### ### code chunk number 26: plot-with-na2 ################################################### plot(na.omit(z)) ################################################### ### code chunk number 27: plot-with-na3 ################################################### plot(na.approx(z)) ################################################### ### code chunk number 28: plot-with-na4 ################################################### plot(z, type = "p") lines(na.omit(z)) ################################################### ### code chunk number 29: Rmetrics ################################################### library("timeDate") dts <- c("1989-09-28", "2001-01-15", "2004-08-30", "1990-02-09") tms <- c( "23:12:55", "10:34:02", "08:30:00", "11:18:23") td <- timeDate(paste(dts, tms), format = "%Y-%m-%d %H:%M:%S") library("zoo") z <- zoo(1:4, td) zz <- merge(z, lag(z)) plot(zz) library("timeSeries") zz as.timeSeries(zz) as.zoo(as.timeSeries(zz)) ################################################### ### code chunk number 30: Rmetrics-detach ################################################### detach("package:timeSeries") detach("package:timeDate") ################################################### ### code chunk number 31: ifelse ################################################### z <- zoo(c(1, 5, 10, 15)) # wrong !!! ifelse(diff(z) > 4, -z, z) # ok ifelse.zoo(diff(z) > 4, -z, z) # or if we merge first we can use ordinary ifelse xm <- merge(z, dif = diff(z)) with(xm, ifelse(dif > 4, -z, z)) # or in this case we could also use orindary ifelse if we # use fill = NA to ensure all three have same index ifelse(diff(z, fill = NA) > 4, -z, z) ################################################### ### code chunk number 32: fillin ################################################### # April is missing zym <- zoo(1:5, as.yearmon("2000-01-01") + c(0, 1, 2, 4, 5)/12) g <- seq(start(zym), end(zym), by = 1/12) na.locf(zym, xout = g) ################################################### ### code chunk number 33: fillin-2 ################################################### z <- zoo(1:3, as.Date(c("2000-01-15", "2000-03-3", "2000-04-29"))) g <- seq(as.yearmon(start(z)), as.yearmon(end(z)), by = 1/12) na.locf(z, x = as.yearmon, xout = g) ################################################### ### code chunk number 34: fillin-3 ################################################### Lines <- "Time,Value 2009-10-09 5:00:00,210 2009-10-09 5:05:00,207 2009-10-09 5:17:00,250 2009-10-09 5:30:00,193 2009-10-09 5:41:00,205 2009-10-09 6:00:00,185" library("chron") z <- read.zoo(text = Lines, FUN = as.chron, sep = ",", header = TRUE) g <- seq(start(z), end(z), by = times("00:10:00")) na.locf(z, xout = g) ################################################### ### code chunk number 35: date ################################################### z <- zoo(1:2, c("2000-01-01", "2000-01-02")) aggregate(z, function(x) as.Date(x, origin = "1970-01-01")) ################################################### ### code chunk number 36: date-2 ################################################### aggregate(z, as.Date) ################################################### ### code chunk number 37: date-3 ################################################### Lines <- "2000-01-01 12:00:00,12 2000-01-02 12:00:00,13" read.zoo(text = Lines, sep = ",", FUN = function(x) as.Date(x, origin = "1970-01-01")) ################################################### ### code chunk number 38: date-4 ################################################### read.zoo(text = Lines, sep = ",", FUN = as.Date) ################################################### ### code chunk number 39: indexing ################################################### n <- 50 z <- zoo(1:n, c(1:3, seq(4, by = 2, length = n-3))) system.time({ zz <- sapply(seq_along(z), function(i) sum(z[time(z) <= time(z)[i] & time(z) > time(z)[i] - 3])) z1 <- zoo(zz, time(z)) }) system.time({ zc <- coredata(z) tt <- time(z) zr <- sapply(seq_along(zc), function(i) sum(zc[tt <= tt[i] & tt > tt[i] - 3])) z2 <- zoo(zr, tt) }) identical(z1, z2)