# This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # METHOD: MATHEMATICAL OPERATIONS ON DATA: # Ops.timeSeries Returns group 'Ops' for a 'timeSeries' object # Math.timeSeries Returns group Math for a 'timeSeries' object # Math2.timeSeries Returns group Math2 for a 'timeSeries' object # Summary.timeSeries Returns group Summary for a 'timeSeries' object # diff.timeSeries Differences a 'timeSeries' object # scale.timeSeries Centers and/or scales a 'timeSeries' object # quantile.timeSeries Returns quantiles of an univariate 'timeSeries' ################################################################################ Ops.timeSeries = function(e1, e2 = 1) { # A function implemented by Diethelm Wuertz # Modified by Yohan Chalabi # Description: # Uses group 'Ops' generic functions for 'timeSeries' objects # Arguments: # e1, e2 - two objects of class 'timeSeries'. # Value: # Returns an object of class 'timeSeries'. # FUNCTION: # Save: s1 = e1 s2 = e2 # Which one is a 'timeSeries' object? i1 = inherits(e1, "timeSeries") i2 = inherits(e2, "timeSeries") # Match positions and FinCenter? if (i1 && i2) { if (nrow(e1@Data) == nrow(e2@Data) && !identical(as.vector(e1@positions), as.vector(e2@positions))) stop("positions slot must match") if (!identical(e1@FinCenter, e2@FinCenter)) stop("FinCenter slot must match") } # Extract Data Slot: if (i1 && sum(dim(e1)) == 2) { e1 = as.double(e1@Data) i1 = FALSE } else if (i1) { e1 = e1@Data } if (i2 && sum(dim(e2)) == 2) { e2 = as.double(e2@Data) i2 = FALSE } else if (i2) { e2 = e2@Data } # Compute: s = NextMethod(.Generic) # Make timeSeries: if ( i1) { s1@Data = s; s = s1 } if (!i1 && i2) { s2@Data = s; s = s2 } if ( i1 && !i2) s@units = s1@units if (!i1 && i2) s@units = s2@units if ( i1 && i2) s@units = paste(s1@units, "_", s2@units, sep = "") colnames(s@Data) = s@units df = data.frame() if (i1) { if (dim(s1@recordIDs)[1] > 0) df = s1@recordIDs } if (i2) { if (dim(s2@recordIDs)[1] > 0) df = s2@recordIDs } if (i1 & i2) { if (dim(s1@recordIDs)[1] > 0 & dim(s2@recordIDs)[1] > 0) df = data.frame(s1@recordIDs, s2@recordIDs) } s@recordIDs = df # Return Value: s } # ------------------------------------------------------------------------------ Math.timeSeries <- function(x, ...) { s <- x x <- x@Data ans <- NextMethod(.Generic, ...) s@Data <- ans s } # ------------------------------------------------------------------------------ Math2.timeSeries <- function(x, digits) { s <- x x <- x@Data ans <- NextMethod(.Generic, digits = digits) s@Data <- ans s } # ------------------------------------------------------------------------------ Summary.timeSeries <- function(x, ..., na.rm = FALSE) { x <- x@Data ans <- NextMethod(.Generic, ..., na.rm = na.rm) ans } # ------------------------------------------------------------------------------ diff.timeSeries <- function(x, lag = 1, diff = 1, trim = FALSE, pad = NA, ...) { # A function implemented by Diethelm Wuertz # Modified by Yohan Chalabi # Description: # Difference 'timeSeries' objects. # Arguments: # x - a 'timeSeries' object. # lag - an integer indicating which lag to use. # By default 1. # diff - an integer indicating the order of the difference. # By default 1. # trim - a logical. Should NAs at the beginning of the # series be removed? # pad - a umeric value with which NAs should be replaced # at the beginning of the series. # Value: # Returns a differenced object of class 'timeSeries'. # FUNCTION: # Convert: y = as.matrix(x) # Check NAs: # if (any(is.na(y))) stop("NAs are not allowed in time series") # Difference: z = diff(y, lag = lag, difference = diff) # Trim: if (!trim) { diffNums = dim(y)[1] - dim(z)[1] zpad = matrix(0*y[1:diffNums, ] + pad, nrow = diffNums) rownames(zpad) = rownames(y)[1:diffNums] z = rbind(zpad, z) } # Record IDs: df = x@recordIDs if (trim) { if (sum(dim(df)) > 0) { TRIM = dim(df)[1] - dim(z)[1] df = df[-(1:TRIM), ] } } # Return Value: timeSeries(data = z, charvec = rownames(z), units = colnames(z), format = x@format, zone = x@FinCenter, FinCenter = x@FinCenter, recordIDs = df, title = x@title, documentation = x@documentation) } # ------------------------------------------------------------------------------ scale.timeSeries <- function(x, center = TRUE, scale = TRUE) { # A function implemented by Diethelm Wuertz # Modified by Yohan Chalabi # Description: # Centers and/or scales a 'timeSeries' object. # Arguments: # FUNCTION: # Scale: x@Data = scale(x = x@Data, center = center, scale = scale) # Return Value: x } # ------------------------------------------------------------------------------ quantile.timeSeries <- function(x, ...) { # A function implemented by Diethelm Wuertz # Modified by Yohan Chalabi # Description: # Returns quantiles of an univariate 'timeSeries # Arguments: # FUNCTION: # Check: stopifnot(NCOL(x) == 1) # Quantiles: ans = quantile(x = as.vector(x), ...) # Return Value: ans } ################################################################################