Merge branch '245-move-index-attr'

Conflicts in R/toperiod.R related to:
 - #53 time-based to Date-based index causes duplicate index values)
 - #277 to.daily producing duplicates

Conflicts in R/xts.methods.R related to:
 - #193 time-of-day subset performance

Fixes #245.

NAMESPACE

@@ -96,6 +96,8 @@ export(CLASS)
 export('CLASS<-')
 export(indexFormat)
 export('indexFormat<-')
+export(tformat)
+export('tformat<-')
 
 export(indexClass)
 export('indexClass<-')
@@ -175,6 +177,7 @@ export(lag.xts)
 export(diff.xts)
 export(merge.xts)
 #export(mergeXts)
+S3method(all.equal, xts)
 S3method(split, xts)
 S3method(lag,xts)
 S3method(diff,xts)
@@ -228,14 +231,14 @@ S3method(window,xts)
 S3method(dimnames, xts)
 S3method('dimnames<-', xts)
 
-S3method('indexClass<-',xts)
+S3method(tclass,xts)
 S3method('tclass<-',xts)
 
-S3method('indexFormat',xts)
-S3method('indexFormat<-',xts)
+S3method(tformat,xts)
+S3method('tformat<-',xts)
 
-S3method(indexTZ,xts)
-S3method('indexTZ<-',xts)
+S3method(tzone, default)
+S3method('tzone<-', default)
 S3method(tzone,xts)
 S3method('tzone<-',xts)
 

R/Ops.xts.R

@@ -44,26 +44,32 @@ function(e1, e2)
     }
   }
   if(.Generic %in% c("+","-","*","/","^","%%","%/%")) {
-    if(length(e)==0)
-      attr(e,'index') <- numeric(0)
     #.Call('add_xts_class', e)
     .Call('add_class', e, CLASS, PACKAGE="xts")
   }
-  else 
+  if(length(e)==0) {
+    if(is.xts(e1)) {
+      idx <- .index(e1)
+    } else {
+      idx <- .index(e2)
+    }
+    idx[] <- idx[0]
+    attr(e,'index') <- idx
+  }
   if(is.null(attr(e,'index'))) {
     if(is.xts(e1)) {
-      .xts(e, .index(e1), 
-              .indexCLASS=indexClass(e1), 
-              .indexFORMAT=indexFormat(e1), 
-              .indexTZ=indexTZ(e1))
+      e <- .xts(e, .index(e1))
     } else {
-      .xts(e, .index(e2),
-              .indexCLASS=indexClass(e2), 
-              .indexFORMAT=indexFormat(e2), 
-              .indexTZ=indexTZ(e2)
-          )
+      e <- .xts(e, .index(e2))
     }
-  } else {
-  e
   }
+  if(!is.null(dimnames(e)[[1L]])) {
+    if(is.null(dimnames(e)[[2L]])) {
+      attr(e, "dimnames") <- NULL
+    } else {
+      dimnames(e)[[1]] <- list(NULL)
+    }
+  }
+  attr(e, "names") <- NULL
+  e
 }

R/align.time.R

@@ -25,7 +25,7 @@ align.time <- function(x, ...) {
 
 align.time.xts <- function(x, n=60, ...) {
   if(n <= 0) stop("'n' must be positive")
-  .xts(x, .index(x) + (n-.index(x) %% n), tzone=indexTZ(x), tclass=indexClass(x))
+  .xts(x, .index(x) + (n-.index(x) %% n), tzone=tzone(x), tclass=tclass(x))
 }
 
 align.time.POSIXct <- function(x, n=60, ...) {
@@ -43,7 +43,7 @@ shift.time <- function(x, n=60, ...) {
 }
 
 shift.time.xts <- function(x, n=60, ...) {
-  .xts(x, .index(x) + n, tzone=indexTZ(x), tclass=indexClass(x))
+  .xts(x, .index(x) + n, tzone=tzone(x), tclass=tclass(x))
 }
 
 is.index.unique <- is.time.unique <- function(x) {

R/all.equal.R

@@ -0,0 +1,34 @@
+#
+#   xts: eXtensible time-series
+#
+#   Copyright (C) 2019 Joshua M. Ulrich
+#
+#   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.
+#
+#   You should have received a copy of the GNU General Public License
+#   along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+all.equal.xts <-
+function(target,
+         current,
+         ...,
+         check.attributes = TRUE)
+{
+    if (isTRUE(check.attributes)) {
+        # Remove potential index attributes on the objects
+        attrNames <- c(".indexCLASS", ".indexTZ", "tclass", "tzone")
+        for (aname in attrNames) {
+            attr(target, aname) <- NULL
+            attr(current, aname) <- NULL
+        }
+    }
+    NextMethod("all.equal")
+}

R/coredata.xts.R

@@ -23,15 +23,15 @@ coredata.xts <- function(x, fmt=FALSE, ...) {
   x.attr <- attributes(x)
 
   if(is.character(fmt)) {
-    indexFormat(x) <- fmt
+    tformat(x) <- fmt
     fmt <- TRUE
   }
 
   if(length(x) > 0 && fmt) {
-    if(!is.null(indexFormat(x))) {
-      x.attr$dimnames <- list(format(index(x), format=indexFormat(x)),
+    if(!is.null(tformat(x))) {
+      x.attr$dimnames <- list(format(index(x), format=tformat(x)),
                               dimnames(x)[[2]])
-      indexFormat(x) <- NULL  # remove before printing
+      tformat(x) <- NULL  # remove before printing
     } else {
       x.attr$dimnames <- list(format(index(x)),dimnames(x)[[2]])
     }
@@ -53,6 +53,7 @@ coredata.xts <- function(x, fmt=FALSE, ...) {
     xx <- NextMethod(x)
     attr(xx, ".indexCLASS") <- NULL
     attr(xx, "tclass") <- NULL
+    # Remove tz attrs (object created before 0.10-3)
     attr(xx, ".indexTZ") <- NULL
     attr(xx, "tzone") <- NULL
     return(xx)
@@ -106,7 +107,7 @@ function(x, user=NULL) {
   else
   if(user) {
   # Only user attributes
-    rm.attr <- c(rm.attr,'.CLASS','.CLASSnames','.ROWNAMES', '.indexCLASS', '.indexFORMAT','.indexTZ','tzone','tclass', 
+    rm.attr <- c(rm.attr,'.CLASS','.CLASSnames','.ROWNAMES', '.indexCLASS', '.indexFORMAT','.indexTZ','tzone','tclass',
                  x.attr$.CLASSnames)
     xa <- x.attr[!names(x.attr) %in% rm.attr]
   } else {
@@ -131,9 +132,16 @@ function(x,value) {
     }
   } else
   for(nv in names(value)) {
-    if(!nv %in% c('dim','dimnames','index','class','.CLASS','.ROWNAMES','.CLASSnames',
-                  '.indexCLASS','.indexFORMAT','.indexTZ'))
+    if(!nv %in% c('dim','dimnames','index','class','.CLASS','.ROWNAMES','.CLASSnames'))
       attr(x,nv) <- value[[nv]]
   }
+  # Remove tz attrs (object created before 0.10-3)
+  attr(x, ".indexTZ") <- NULL
+  attr(x, "tzone") <- NULL
+  # Remove index class attrs (object created before 0.10-3)
+  attr(x, ".indexCLASS") <- NULL
+  attr(x, "tclass") <- NULL
+  # Remove index format attr (object created before 0.10-3)
+  attr(x, ".indexFORMAT") <- NULL
   x
 }

R/endpoints.R

@@ -39,7 +39,7 @@ function(x,on='months',k=1) {
   # posixltindex is costly in memory (9x length of time)
   # make sure we really need it
   if(on %in% c('years','quarters','months','weeks','days'))
-    posixltindex <- as.POSIXlt(.POSIXct(.index(x)),tz=indexTZ(x))
+    posixltindex <- as.POSIXlt(.POSIXct(.index(x)),tz=tzone(x))
 
   switch(on,
     "years" = {

R/index.R

@@ -21,10 +21,10 @@
 
 index.xts <- time.xts <-
 function(x, ...) {
-  value <- indexClass(x)
+  value <- tclass(x)
   if(is.null(value))
     return(.index(x))
-  #  if indexClass is Date, POSIXct time is set to 00:00:00 GMT. Convert here
+  #  if tclass is Date, POSIXct time is set to 00:00:00 GMT. Convert here
   #  to avoid ugly and hard to debug TZ conversion.  What will this break? 
   if(value[[1]] == "Date")
     #return( as.Date(.index(x)/86400) )
@@ -61,7 +61,7 @@ function(x, ...) {
     #Date = as.Date(as.character(x.index)),  # handled above
     yearmon = as.yearmon(x.index),
     yearqtr = as.yearqtr(x.index),
-    stop(paste('unsupported',sQuote('indexClass'),'indexing type:',value[[1]]))
+    stop(paste('unsupported',sQuote('tclass'),'indexing type:',value[[1]]))
   )
 }
 
@@ -81,13 +81,13 @@ function(x, ...) {
   if(!isOrdered(.index(x), strictly=FALSE))
     stop("new index needs to be sorted")
 
-  # set the .indexCLASS/tclass attribute to the end-user specified class
-  attr(x, '.indexCLASS') <- class(value)
+  # set tzone attribute
   if(any(class(value) %in% .classesWithoutTZ)) {
     attr(.index(x), 'tzone') <- 'UTC'
   } else {
     attr(.index(x), 'tzone') <- attr(value, 'tzone')
   }
+  # set tclass attribute to the end-user specified class
   attr(.index(x), 'tclass') <- class(value)
   return(x)
 }
@@ -113,36 +113,35 @@ function(x, ...) {
 }
 
 `.indexsec` <- function(x) {
-  as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$sec
+  as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$sec
 }
 `.indexmin` <- function(x) {
-  as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$min
+  as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$min
 }
 `.indexhour` <- function(x) {
-  as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$hour
+  as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$hour
 }
 `.indexmday` <- function(x) {
-  as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$mday
+  as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$mday
 }
 `.indexmon` <- function(x) {
-  as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$mon
+  as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$mon
 }
 `.indexyear` <- function(x) {
-  as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$year
+  as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$year
 }
 `.indexwday` <- function(x) {
-  as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$wday
+  as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$wday
 }
 `.indexbday` <- function(x) {
   # is business day T/F
-  as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$wday %% 6 > 0
+  as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$wday %% 6 > 0
 }
 `.indexyday` <- function(x) {
-  as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$yday
+  as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$yday
 }
 `.indexisdst` <- function(x) {
-  as.POSIXlt(.POSIXct(.index(x), tz=indexTZ(x)))$isdst
-}
+  as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$isdst }
 `.indexDate` <- `.indexday` <- function(x) {
   .index(x) %/% 86400L
 }

R/irts.R

@@ -26,7 +26,7 @@ function(x,...) {
   if(!requireNamespace('tseries', quietly=TRUE))
     irts <- function(...) message("package 'tseries' is required for re.irts")
 
-  indexClass(x) <- "POSIXct"
+  tclass(x) <- "POSIXct"
   xx <- coredata(x)
 #  rownames(xx) <- attr(x,'irts.rownames')
   tseries::irts(index(x),xx)

R/lag.xts.R

@@ -99,7 +99,7 @@ diff.xts <- function(x, lag=1, differences=1, arithmetic=TRUE, log=FALSE, na.pad
     stop("'differences' must be integer")
 
   if(is.logical(x))
-    x <- .xts(matrix(as.integer(x),ncol=NCOL(x)), .index(x), indexClass(x))
+    x <- .xts(matrix(as.integer(x),ncol=NCOL(x)), .index(x), tclass(x))
 
   if(lag < 1 || differences < 1)
     stop("'diff.xts' defined only for positive lag and differences arguments")

R/matrix.R

@@ -36,7 +36,7 @@ function(x, ...) {
       colnames(y) <- cnx
     } else {
       cn <- deparse(substitute(x), width.cutoff = 100, nlines = 1)
-      if (ncol(x) == 1) {
+      if (NCOL(x) == 1) {
         colnames(y) <- cn
       } else {
         colnames(y) <- paste(cn, 1:ncol(x), sep = ".")

R/periodicity.R

@@ -115,7 +115,7 @@ function (x, ...)
     if(!is.xts(x)) x <- as.xts(x)
 
     # convert if necessary to usable format
-    if(!indexClass(x)[[1]] %in% c('Date','POSIXt')) indexClass(x) <- "POSIXct"
+    if(!tclass(x)[[1]] %in% c('Date','POSIXt')) tclass(x) <- "POSIXct"
 
     # this takes a long time on big data - possibly use some sort of sampling instead???
     p <- median(diff(time(x)))

R/plot.R

@@ -612,7 +612,7 @@ addSeries <- function(x, main="", on=NA, type="l", col=NULL, lty=1, lwd=1, pch=1
     } else {
       subset.range <- paste(start(xDataSubset), end(xDataSubset),sep="/")
     }
-    ta.y <- merge(ta, .xts(,.index(xDataSubset), tzone=indexTZ(xdata)))[subset.range]
+    ta.y <- merge(ta, .xts(,.index(xDataSubset), tzone=tzone(xdata)))[subset.range]
     chart.lines(ta.y, type=type, col=col, lty=lty, lwd=lwd, pch=pch, ...)
   }
 
@@ -741,7 +741,7 @@ addEventLines <- function(events, main="", on=0, lty=1, lwd=1, col=1, ...){
                           end(xdata[xsubset]),sep="/")
     ta.adj <- merge(n=.xts(1:NROW(xdata[xsubset]),
                            .index(xdata[xsubset]), 
-                           tzone=indexTZ(xdata)),
+                           tzone=tzone(xdata)),
                     .xts(rep(1, NROW(events)),# use numeric for the merge
                          .index(events)))[subset.range]
     # should we not merge and only add events that are in index(xdata)?
@@ -952,7 +952,7 @@ addPolygon <- function(x, y=NULL, main="", on=NA, col=NULL, ...){
                           end(xdata[xsubset]),sep="/")
     ta.adj <- merge(n=.xts(1:NROW(xdata[xsubset]),
                            .index(xdata[xsubset]), 
-                           tzone=indexTZ(xdata)),ta)[subset.range]
+                           tzone=tzone(xdata)),ta)[subset.range]
     ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) )
     # NAs in the coordinates break the polygon which is not the behavior we want
     ta.y <- na.omit(ta.adj[,-1])

R/print.R

@@ -23,7 +23,7 @@
 function(x,fmt,...) {
   check.TZ(x)
   if(missing(fmt)) 
-    fmt <- indexFormat(x)
+    fmt <- tformat(x)
   if(is.null(fmt))
     fmt <- TRUE
 

R/str.R

@@ -31,8 +31,8 @@ function(object,...) {
   cat(paste("  Data:"))
   str(coredata(object))
   cat(paste("  Indexed by objects of class: "))
-  cat(paste('[',paste(indexClass(object),collapse=','),'] ',sep=''))
-  cat(paste("TZ: ", indexTZ(object), "\n", sep=""))
+  cat(paste('[',paste(tclass(object),collapse=','),'] ',sep=''))
+  cat(paste("TZ: ", tzone(object), "\n", sep=""))
   if(!is.null(CLASS(object)))
     cat(paste("  Original class: '",CLASS(object),"' ",sep=""),"\n")
   cat(paste("  xts Attributes: "),"\n")