[Xts-commits] r796 - in pkg/xts: R src

[noreply at 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);
+}
+