From noreply at r-forge.r-project.org Sat Nov 2 16:45:40 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 2 Nov 2013 16:45:40 +0100 (CET) Subject: [Xts-commits] r796 - in pkg/xts: R src Message-ID: <20131102154540.C5C95186241@r-forge.r-project.org> Author: bodanker Date: 2013-11-02 16:45:40 +0100 (Sat, 02 Nov 2013) New Revision: 796 Modified: pkg/xts/R/xts.R pkg/xts/src/attr.c Log: - new ..xts() for testing to replace .xts() (most heavily used in Ops.xts) Modified: pkg/xts/R/xts.R =================================================================== --- pkg/xts/R/xts.R 2013-10-31 21:36:28 UTC (rev 795) +++ pkg/xts/R/xts.R 2013-11-02 15:45:40 UTC (rev 796) @@ -136,6 +136,49 @@ class=c('xts','zoo'), ...) } +`..xts` <- +function(x=NULL, index, tclass=c("POSIXt","POSIXct"), + tzone=Sys.getenv("TZ"), + check=TRUE, unique=FALSE, .indexCLASS=tclass, ...) { + if(check) { + if( !isOrdered(index, increasing=TRUE, strictly=unique) ) + stop('index is not in ',ifelse(unique, 'strictly', ''),' increasing order') + } + if(!is.numeric(index) && timeBased(index)) + index <- as.numeric(as.POSIXct(index)) + if(!is.null(x) && NROW(x) != length(index)) + stop("index length must match number of observations") + + if(!is.null(x)) { + if(!is.matrix(x)) + x <- as.matrix(x) + } else + if(length(x) == 0 && !is.null(x)) { + x <- vector(storage.mode(x)) + } else x <- numeric(0) + + # don't overwrite index tzone if tzone arg is missing + if(missing(tzone)) { + if(!is.null(index.tz <- attr(index,'tzone'))) + tzone <- index.tz + } + + # work-around for Ops.xts + dots.names <- eval(substitute(alist(...))) + if(hasArg(.indexFORMAT)) + .indexFORMAT <- eval(dots.names$.indexFORMAT,parent.frame()) + else + .indexFORMAT <- NULL + xx <- .Call("add_xtsCoreAttributes", x, index, .indexCLASS, tzone, tclass, + c('xts','zoo'), .indexFORMAT, PACKAGE='xts') + # remove .indexFORMAT and .indexTZ that come through Ops.xts + dots.names$.indexFORMAT <- dots.names$.indexTZ <- NULL + # set any user attributes + if(length(dots.names)) + attributes(xx) <- c(attributes(xx), ...) + xx +} + `reclass` <- function(x, match.to, error=FALSE, ...) { if(!missing(match.to) && is.xts(match.to)) { Modified: pkg/xts/src/attr.c =================================================================== --- pkg/xts/src/attr.c 2013-10-31 21:36:28 UTC (rev 795) +++ pkg/xts/src/attr.c 2013-11-02 15:45:40 UTC (rev 796) @@ -182,3 +182,35 @@ copy_xtsAttributes(x,y); return R_NilValue; } + +SEXP add_xtsCoreAttributes(SEXP _x, SEXP _index, SEXP _indexClass, SEXP _tzone, + SEXP _tclass, SEXP _class, SEXP _indexFormat) +{ + int P=0; + if(NAMED(_index) == 2) { + PROTECT(_index = duplicate(_index)); P++; + } + /* add tzone and tclass to index */ + setAttrib(_index, install("tclass"), _tclass); + setAttrib(_index, install("tzone"), _tzone); + + if(NAMED(_x) == 2) { + PROTECT(_x = duplicate(_x)); P++; + //_x = duplicate(_x); + } + setAttrib(_x, xts_IndexSymbol, _index); /* index */ + setAttrib(_x, xts_IndexClassSymbol, _indexClass); /* .indexClass */ + setAttrib(_x, xts_IndexTZSymbol, _tzone); /* .indexTZ */ + setAttrib(_x, install("tclass"), _tclass); /* tclass */ + setAttrib(_x, install("tzone"), _tzone); /* tzone */ + setAttrib(_x, R_ClassSymbol, _class); /* class */ + + /* .indexFormat is only here because it's set in Ops.xts + * This should go away once this attribute is on the index */ + if(_indexFormat != R_NilValue) + setAttrib(_x, xts_IndexFormatSymbol, _indexFormat); + + UNPROTECT(P); + return(_x); +} + From noreply at r-forge.r-project.org Mon Nov 18 16:02:24 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 18 Nov 2013 16:02:24 +0100 (CET) Subject: [Xts-commits] r797 - pkg/xts/src Message-ID: <20131118150224.47A31185B84@r-forge.r-project.org> Author: bodanker Date: 2013-11-18 16:02:23 +0100 (Mon, 18 Nov 2013) New Revision: 797 Modified: pkg/xts/src/rollfun.c Log: - adapt roll_sum to use Kahan summation correction; thanks to Ivan Popivanov Modified: pkg/xts/src/rollfun.c =================================================================== --- pkg/xts/src/rollfun.c 2013-11-02 15:45:40 UTC (rev 796) +++ pkg/xts/src/rollfun.c 2013-11-18 15:02:23 UTC (rev 797) @@ -23,9 +23,20 @@ #include #include "xts.h" +/* http://en.wikipedia.org/wiki/Kahan_summation_algorithm + * sum += x, and updates the accumulated error "c" */ +void kahan_sum(long double x, long double * c, long double * sum) +{ + /* Author: Ivan Popivanov */ + long double y = x - *c; + long double t = *sum + y; + *c = ( t - *sum ) - y; + *sum = t; +} + SEXP roll_sum (SEXP x, SEXP n) { - /* Author: Joshua Ulrich */ + /* Author: Joshua Ulrich, with contributions from Ivan Popivanov */ int i, P=0, nrs; nrs = nrows(x); @@ -38,7 +49,6 @@ int *int_result=NULL, *int_x=NULL; int int_sum = 0; double *real_result=NULL, *real_x=NULL; - double real_sum = 0.0; /* check for non-leading NAs and get first non-NA location */ SEXP first; @@ -47,6 +57,8 @@ if(int_n + int_first > nrs) error("not enough non-NA values"); + long double sum = 0.0; + long double comp = 0.0; switch(TYPEOF(x)) { case REALSXP: real_result = REAL(result); @@ -56,12 +68,14 @@ for(i=0; i= int_first) - real_sum += real_x[i]; + kahan_sum(real_x[i], &comp, &sum); } - real_result[ int_n + int_first - 1 ] = real_sum; + real_result[ int_n + int_first - 1 ] = (double)sum; /* loop over all other values */ for(i=int_n+int_first; i