R/irts.R

Defines functions points.irts lines.irts plot.irts approx.irts is.weekend is.businessday daysecond weekday write.irts read.irts print.irts time.irts value.irts as.irts.zoo as.irts.default as.irts is.irts irts

Documented in approx.irts as.irts as.irts.default as.irts.zoo daysecond irts is.businessday is.irts is.weekend lines.irts plot.irts points.irts print.irts read.irts time.irts value.irts weekday write.irts

## Copyright (C) 1997-2003  Adrian Trapletti
##
## This program is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2, or (at your option)
## any later version.
##
## This program is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
## General Public License for more details.
##
## A copy of the GNU General Public License is available via WWW at
## http://www.gnu.org/copyleft/gpl.html.  You can also obtain it by
## writing to the Free Software Foundation, Inc., 59 Temple Place,
## Suite 330, Boston, MA  02111-1307  USA.

##
## Irregular time series objects
##

value <- function (x, ...) UseMethod ("value")
                    
irts <-
function(time, value)
{
    if(inherits(time, "POSIXct")) {
        time <- as.numeric(time)
    }
    if(!is.vector(time))
        stop("time is not a vector")
    if(!is.vector(value) && !is.matrix(value))
        stop("value is not a vector and not a matrix")
    if(length(time) != NROW(value))
        stop("time and value have not the same number of rows")
    class(time) <- c("POSIXt", "POSIXct")
    irts <- list(time = time, value = value)
    class(irts) <- "irts"
    return(irts)
}

is.irts <-
function(object)
{
    return(inherits(object, "irts"))
}

as.irts <- function(object) UseMethod("as.irts")

as.irts.default <-
function(object)
{
    return(irts(object[,1], object[,-1]))
}

as.irts.zoo <-
function(object, ...)
{
    index <- attr(object, "index")
    stopifnot(inherits(index, "POSIXct"))
    attr(object, "index") <- NULL
    irts(index, unclass(object))  
}

value.irts <-
function(x, ...)
{
    if(!inherits(x, "irts"))
        stop("method is only for irts objects")
    return(x$value)
}

time.irts <-
function(x, ...)
{
    if(!inherits(x, "irts"))
        stop("method is only for irts objects")
    return(x$time)
}

print.irts <-
function(x, format = "%Y-%m-%d %H:%M:%S", tz = "GMT",
         usetz = TRUE, format.value = NULL, ...)
{
    if(!inherits(x, "irts"))
        stop("method is only for irts objects")
    n <- length(x$time)
    for(i in 1:n) {
        cat(format(x$time[i], format = format, tz = tz, usetz = usetz))
        cat(" ")
        if(is.vector(x$value))
            cat(formatC(x$value[i], format = format.value, ...))
        else
            cat(formatC(x$value[i,], format = format.value, ...))
        cat("\n")
    }
    invisible(x)
}

read.irts <-
function(file, format = "%Y-%m-%d %H:%M:%S", tz = "GMT", ...)
{
    seqN <- function(from, to) {
        if((0 == length(from)) || (0 == length(to)))
            NULL
        else if(to-from+1 <= 0) 
            NULL
        else seq(from, to)
    }
    
    data <- read.table(file, as.is = TRUE, ...)
    n <- length(unlist(strsplit(format, split = " ")))
    tmp <- data[,1]
    j <- 2
    while(j <= n) {
        tmp <- paste(tmp, data[,j])
        j <- j+1
    }
    time <- as.numeric(as.POSIXct(strptime(tmp, format = format), tz = tz))
    value <- as.matrix(data[,-seqN(1, n)])
    return(irts(time, value[,,drop = TRUE]))
}

write.irts <-
function(object, file = "", append = FALSE, quote = FALSE, sep = " ", eol = "\n",
         na = "NA", dec = ".", row.names = FALSE, col.names = FALSE, qmethod = "escape",
         format = "%Y-%m-%d %H:%M:%S", tz = "GMT", usetz = FALSE, format.value = NULL, ...)
{
    dataframe <- data.frame(time = format(object$time, format = format, tz = tz, usetz = usetz),
                            value = formatC(object$value, format = format.value, ...))
    write.table(dataframe, file = file, append = append, quote = quote, sep = sep, eol = eol,
                na = na, dec = dec, row.names = row.names, col.names = col.names, qmethod = qmethod)
    invisible(object)
}

weekday <-
function(object, tz = "GMT")
{
    if(!inherits(object, "irts"))
        stop("function is only for irts objects")
    return(as.POSIXlt(object$time, tz = tz)$wday)
}

daysecond <-
function(object, tz = "GMT")
{
    if(!inherits(object, "irts"))
        stop("function is only for irts objects")
    hour <- as.POSIXlt(object$time, tz = tz)$hour
    min <- as.POSIXlt(object$time, tz = tz)$min
    sec <- as.POSIXlt(object$time, tz = tz)$sec
    return(3600*hour+60*min+sec)
}

is.businessday <-
function(object, tz = "GMT")
{
    if(!inherits(object, "irts"))
        stop("function is only for irts objects")
    wday <- as.POSIXlt(object$time, tz = tz)$wday
    return((0 < wday) & (wday < 6))
}

is.weekend <- function(object, tz = "GMT")
{
    if(!inherits(object, "irts"))
        stop("function is only for irts objects")
    wday <- as.POSIXlt(object$time, tz = tz)$wday
    return((0 == wday) | (wday == 6))
}

"[.irts" <-
function(x, i, j, ...)
{
    if(!inherits(x, "irts"))
        stop("method is only for irts objects")
    if(is.vector(x$value)) {
        if(nargs() > 2) {   
            stop("incorrect number of dimensions")
        }
        if(missing(i)) {
            return(x)
        } else {
            return(irts(as.numeric(x$time)[i], x$value[i]))
        }
    } else {
        if(missing(i)) {
            if(missing(j)) {
                return(x)
            } else {
                return(irts(as.numeric(x$time), x$value[,j,drop = FALSE]))
            }
        } else {
            if(missing(j)) {
                return(irts(as.numeric(x$time)[i], x$value[i,,drop = FALSE]))
            } else {
                return(irts(as.numeric(x$time)[i], x$value[i,j,drop = FALSE]))
            }
        }
    }
}

approx.irts <-
function(object, time, ...)
{
    if(!inherits(object, "irts"))
        stop("function is only for irts objects")
    if(!inherits(time, "POSIXct"))
        stop("time is not of class POSIXct")
    ovalue <- as.matrix(object$value)
    otime <- as.numeric(object$time)
    time <- as.numeric(time)
    value <- matrix(0, NROW(time), NCOL(ovalue))
    for(i in 1:NCOL(ovalue)) {
        result <- approx(otime, ovalue[,i,drop = TRUE], time, ...)
        value[,i] <- result$y
    }
    return(irts(time, value[,,drop = TRUE]))
}

plot.irts <-
function(x, type = "l", plot.type = c("multiple", "single"),
         xlab = "Time", ylab = NULL, main = NULL, ylim = NULL,
         oma = c(6, 0, 5, 0), ...)
{
    seqN <- function(from, to) {
        if((0 == length(from)) || (0 == length(to)))
            NULL
        else if(to-from+1 <= 0) 
            NULL
        else seq(from, to)
    }
    
    addmain <- function(main, cex.main = par("cex.main"),
                        font.main = par("font.main"), 
                        col.main = par("col.main"), ...) {
        mtext(main, 3, 3, cex = cex.main, font = font.main, col = col.main, ...)
    }
    
    if(!inherits(x, "irts"))
        stop("method is only for irts objects")
    t <- time(x)
    v <- value(x)
    nser <- NCOL(v)
    if(is.null(main)) 
        main <- deparse(substitute(x))
    if(nser == 1) {
        if(is.null(ylab))
            ylab <- "Series"
        if(is.null(ylim))
            ylim <- range(v[is.finite(v)])
        plot(t, v, type = type, xlab = xlab, ylab = ylab,
             main = main, ylim = ylim, ...)
    } else if(nser <= 10) {
        plot.type <- match.arg(plot.type)
        if(is.null(ylab)) {
            ylab <- colnames(v)
            if(is.null(ylab)) 
                ylab <- paste("Series", 1:nser)
        }
        if(plot.type == "single") {
            if(is.null(ylim))
                ylim <- range(v[is.finite(v)])
            plot.default(t, v[,1], type = type, xlab = xlab, ylab = ylab,
                         main = main, ylim = ylim, xaxt = "n", ...) 
            for(i in seqN(2, nser)) {
                points(t, v[,i], type = type, xaxt = "n") 
            }
            axis.POSIXct(1, t)
        } else if(plot.type == "multiple") {
            oldpar <- par("mar", "oma", "mfcol")
            on.exit(par(oldpar))
            par(mar = c(0, 5.1, 0, 2.1), oma = oma)
            nc <- if(nser > 4) 2 else 1
            nr <- ceiling(nser/nc)
            par(mfcol = c(nr, nc))
            for(i in seqN(1, nser)) {
                plot.default(t, v[,i], type = type, xlab = xlab, ylab = "", xaxt = "n", ...)
                mtext(ylab[i], 2, 3)
                if((i%%nr == 0) || (i == nser))
                    axis.POSIXct(1, t)
            }
            if(!is.null(main)) {
                par(mfcol = c(1, 1))
                addmain(main, ...)
            }
        }
    } else {
        stop("cannot plot more than 10 series")
    }
    invisible(x)
}

lines.irts <-
function(x, type = "l", ...)
{
    if(!inherits(x, "irts"))
        stop("method is only for irts objects")
    t <- time(x)
    v <- value(x)
    nser <- NCOL(v)
    if(nser == 1) {
        lines(t, v, type = type, ...)
    } else {
        stop("cannot plot multivariate irregular time-series object")
    }
    invisible(x)
}

points.irts <-
function(x, type = "p", ...)
{
    if(!inherits(x, "irts"))
        stop("method is only for irts objects")
    t <- time(x)
    v <- value(x)
    nser <- NCOL(v)
    if(nser == 1) {
        points(t, v, type = type, ...)
    } else {
        stop("cannot plot multivariate irregular time-series object")
    }
    invisible(x)
}

Try the tseries package in your browser

Any scripts or data that you put into this service are public.

tseries documentation built on Oct. 10, 2022, 5:06 p.m.