SCM

SCM Repository

[rmetrics] View of /pkg/timeSeries/R/fin-daily.R
ViewVC logotype

View of /pkg/timeSeries/R/fin-daily.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4419 - (download) (annotate)
Tue Sep 22 23:03:43 2009 UTC (9 years, 5 months ago) by chalabi
File size: 10984 byte(s)
! added unsorted test in alignDailySeries
#
#  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 of the License, 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 at
#  ../../COPYING


################################################################################
# FUNCTION:                 DESCRIPTION:
#  alignDailySeries          Aligns a 'timeSeries' object to new positions
#  rollDailySeries           Rolls daily a 'timeSeries' on a given period
#  ohlcDailyPlot             Plots open high low close bar chart
#  .plotOHLC                 Plots open high low close bar chart
################################################################################


alignDailySeries <-
function (x, method = c("before", "after", "interp", "fillNA"),
    include.weekends = FALSE, units = NULL, zone = "", FinCenter = "")
{
    # A function implemented by Diethelm Wuertz

    # Description:
    #   Aligns an univariate 'timeSeries' object to new positions

    # Arguments:
    #   x - an object of class "timeSeries".
    #   method -
    #       "before" - use the data from the row whose position is
    #           just before the unmatched position;
    #       "after" - use the data from the row whose position is
    #           just after the unmatched position;
    #       "linear" - interpolate linearly between "before" and
    #           "after".
    #       "fillNA" - fill missing days with NA values
    #   include.weekends - a logical value. Should weekend dates be
    #       included or removed?

    # FUNCTION:

    # Settings:
    stopifnot(is.timeSeries(x))
    if (zone == "")
        zone <- getRmetricsOptions("myFinCenter")
    if (FinCenter == "")
        FinCenter <- getRmetricsOptions("myFinCenter")

    if (x@format == "counts")
        stop(as.character(match.call())[1], " is for time series and not for signal series.")

    method = match.arg(method)

    # check if series sorted
    if (is.unsorted(x))
        x <- sort(x)

    # Internal Function
    # Univariate Time Series Alignment:
    alignDailySeries.OneColumn =
    function (x, method, include.weekends, zone, FinCenter) {
        # Settings:
        units = x@units
        # Units:
        # myUnits <<- "days"
        myUnits <- "days"
        # Fill with NAs:
        if (method == "fillNA") {
            positions = time(x)
            u = as.integer(julian(positions))
            v = as.vector(series(x)[, 1])
            x = u[1]:u[length(u)]
            y = approx(u, v, xout = x, method = "linear", f = 0.5)$y
            y[!(x %in% u)] = NA
            poschar = as.character(positions)
            td = timeSeries(y, timeSequence(from = poschar[1],
                to = poschar[length(poschar)], FinCenter = FinCenter,
                format = "%Y-%m-%d"), FinCenter = FinCenter)
            td@format = "%Y-%m-%d"
        } else {
            # Interpolate with real Values:
            # Wich method ?
            if (method == "interp") {
                method = "linear"
                f = 0.5 }
            if (method == "before") {
                method = "constant"
                f = 0 }
            if (method == "after") {
                method = "constant"
                f = 1 }
            # Get Positions and Data:
            positions = time(x)
            u = as.integer(julian(positions))
            v = as.vector(series(x)[, 1])
            # Approximate:
            #   method - specifies the interpolation method to be used.
            #       Choices are "linear" or "constant".
            #   f - For method="constant" a number between 0 and 1 inclusive,
            #       indicating a compromise between left- and right-continuous
            #       step functions. If 'y0' and 'y1' are the values to the left
            #       and right of the point then the value is 'y0*(1-f)+y1*f' so
            #       that 'f=0' is right-continuous and 'f=1' is left-continuous.
            x = u[1]:u[length(u)]
            y = approx(u, v, xout = x, method = method, f = f)$y
            # Create timeSeries:
            poschar = as.character(positions)
            td = timeSeries(y, timeSequence(from = poschar[1],
                to = poschar[length(poschar)], FinCenter = FinCenter,
                format = "%Y-%m-%d"), FinCenter = FinCenter)
            td@format = "%Y-%m-%d" }
        # Handle Weekends:
        if (!include.weekends) {
            # Internal Functions:
            is.weekday = function(x) {
                # x - a 'timeDate' object
                wday = as.POSIXlt(as.POSIXct(x))$wday
                return(!(wday == 0 | wday == 6)) }
            # Test:
            test = is.weekday(time(td))
            td <- td[test, 1]
        }
        # Units:
        # td@units = units # unneeded because have colnames after
        colnames(td) = units
        ans = td
        # Return Value:
        ans
    }

    # First Column:
    ans = alignDailySeries.OneColumn(x = x[, 1], method = method,
        include.weekends = include.weekends, zone = zone,
        FinCenter = FinCenter)

    # Next Columns:
    DimX = dim(x)[2]
    if ( DimX > 1 ) {
        for ( i in 2:DimX ) {
            ans.add = alignDailySeries.OneColumn(x = x[, i],
                method = method, include.weekends = include.weekends,
                zone = zone, FinCenter = FinCenter)
            ans = merge(ans, ans.add) }
    }

    # Add New Units:
    if (!is.null(units)){
        colnames(ans) = units
    }

    # Return Value:
    ans
}


# ------------------------------------------------------------------------------


rollDailySeries <-
function(x, period = "7d", FUN, ...)
{
    # A function implemented by Diethelm Wuertz

    # Description:
    #   Rolls daily a 'timeSeries' on a given period

    # Arguments:
    #   x - an univariate "timeSeries" object or a numeric vector.
    #   n - an integer specifying the number of periods or
    #       terms to use in each rolling/moving sample.
    #   trim - a logical flag: if TRUE, the first n-1 missing values in
    #       the returned object will be removed; if FALSE, they will
    #       be saved in the returned object. The default is TRUE.
    #   FUN - the rolling function, arguments to this function can be
    #       passed through the \code{\dots} argument.

    # FUNCTION:

    stopifnot(is.timeSeries(x))
    if (x@format == "counts")
        stop(as.character(match.call())[1], " is for time series and not for signal series.")

    # Fix missing matrix method for quantile(), still to do ...
    .quantile.matrix = function(x, probs = 0.95, ...) {
        apply(as.matrix(x), 2, quantile, probs = probs) }

    # Settings:
    periodLength = as.numeric(substr(period, 1, nchar(period) - 1))
    periodUnit = substr(period, nchar(period), nchar(period))
    N = nrow(x)
    Start = start(x) + (periodLength-1)*24*3600
    Positions = time(x)
    to = Positions[Positions > Start]
    from = to - periodLength*24*3600

    # Apply Function:
    ans = applySeries(x = x, from = from, to = to, FUN = FUN, ...)

    # Return Value:
    ans
}


# ------------------------------------------------------------------------------


ohlcDailyPlot <-
function(x, volume = TRUE, colOrder = c(1:5), units = 1e6, xlab =
    c("Date", "Date"), ylab = c("Price", "Volume"),
    main = c("O-H-L-C", "Volume"), grid.nx = 7, grid.lty = "solid", ...)
{
    # A function implemented by Diethelm Wuertz

    # Description:
    #   Plots open | high | low | close bar chart

    # Arguments:
    #   x - an S4 object of class 'timeSeries' with named entries:
    #       Open, High, Low, Close, and Volume

    # Reference:
    #   Build on top of Adrian Trapletti's plotOHLC()
    #   function from his R-package "tseries".

    # FUNCTION:
    stopifnot(is.timeSeries(x))
    if (x@format == "counts")
        stop(as.character(match.call())[1],
            " is for time series and not for signal series.")

    # Next:
    x.filled = alignDailySeries(x, method = "fillNA", include.weekends = TRUE)
    jul = as.integer(julian(time(x.filled)))
    X = ts(as.matrix(x.filled)[, 1:4], start = min(jul), end = max(jul))

    # Plot OHLC:
    .plotOHLC(X, origin = "1970-01-01", xlab = xlab[1], ylab = ylab[1])
    # print(axTicks(1))
    # print(axTicks(2))
    title(main = main[1])
    grid(nx = grid.nx, ny = NULL, lty = grid.lty, ...)

    # Include Volume?
    if (volume) {
        Volume = x[, 5]/units
        plot(Volume, type = "h", xlab = xlab[2], ylab = ylab[2])
        title(main = main[2])
        grid(nx = grid.nx, ny = NULL, lty = grid.lty, ...) }

    # Return value:
    invisible()
}


# ------------------------------------------------------------------------------


.plotOHLC =
function (x, xlim = NULL, ylim = NULL, xlab = "Time", ylab, col = par("col"),
    bg = par("bg"), axes = TRUE, frame.plot = axes, ann = par("ann"),
    main = NULL, date = c("calendar", "julian"), format = "%Y-%m-%d",
    origin = "1899-12-30", ...)
{
    # A Copy from Contributed R Package 'tseries'

    # Description:

    # FUNCTION:

    # Check for mts:
    if ((!is.mts(x)) || (colnames(x)[1] != "Open") || (colnames(x)[2] !=
        "High") || (colnames(x)[3] != "Low") || (colnames(x)[4] !=
        "Close"))
        stop("x is not a open/high/low/close time series")
    xlabel <- if (!missing(x)) deparse(substitute(x)) else NULL
    if (missing(ylab)) ylab <- xlabel
    date <- match.arg(date)
    time.x <- time(x)
    dt <- min(lag(time.x) - time.x)/3
    if (is.null(xlim)) xlim <- range(time.x)
    if (is.null(ylim)) ylim <- range(x[is.finite(x)])
    plot.new()
    plot.window(xlim, ylim, ...)
    segments(time.x, x[, "High"], time.x, x[, "Low"], col = col[1],
        bg = bg)
    segments(time.x - dt, x[, "Open"], time.x, x[, "Open"], col = col[1],
        bg = bg)
    segments(time.x, x[, "Close"], time.x + dt, x[, "Close"],
        col = col[1], bg = bg)
    if (ann) title(main = main, xlab = xlab, ylab = ylab, ...)
    if (axes) {
        if (date == "julian") {
            axis(1, ...)
            axis(2, ...)
        }
        else {
            n <- NROW(x)
            lab.ind <- round(seq(1, n, length = 5))
            D <- as.vector(time.x[lab.ind] * 86400) + as.POSIXct(origin,
                tz = "GMT")
            DD <- format.POSIXct(D, format = format, tz = "GMT")
            axis(1, at = time.x[lab.ind], lab = DD, ...)
            axis(2, ...)
        }
    }
    if (frame.plot) box(...)

    # Return Value:
    invisible()
}


################################################################################


R-Forge@R-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge