zoo <-> xts conversion changes; handles _almost_ perfectly

some internal zoo inconsistenties with subsetting down to a 1x1 object - Names or no Names depending on NCOL of original [.xts fixed to handle zoo correctly, and all currently thought of uses git-svn-id: svn+ssh://svn.r-forge.r-project.org/svnroot/xts/pkg@46 edb9625f-4e0d-4859-8d74-9fd3b1da38cb
joshuaulrich · Feb 2, 2008 · 304aa0f · 304aa0f
1 parent e14d534
commit 304aa0f
Show file tree

Hide file tree

Showing 2 changed files with 41 additions and 23 deletions.
diff --git a/R/xts.methods.R b/R/xts.methods.R
@@ -28,7 +28,8 @@ function(x, i, j, drop = TRUE, ...)
     original.class <- class(x)
     original.cols <- NCOL(x)
     original.names <- colnames(x)
-    #original.rownames <- rownames(x)
+    original.CLASS <- CLASS(x)
+
     original.attr <- attributes(x)[!names(attributes(x)) %in% c('dim','dimnames','index','class')]
     if(length(original.attr) < 1) original.attr <- NULL
 
@@ -72,12 +73,23 @@ function(x, i, j, drop = TRUE, ...)
     class(x) <- "zoo"
 
     if (missing(j)) {
-        x <- x[i = i, drop = drop, ...]
+        if(original.cols == 1) {
+          # if data set only has one column:
+          # it is necessary to replace the dimnames removed by [.zoo
+          dn1 <- dimnames(x)[[1]]
+          x <- x[i = i, drop = drop, ...]
+          dim(x) <- c(NROW(x), NCOL(x))
+          dn <- list(dn1[i],colnames(x))
+          dimnames(x) <- dn
+        } else {
+          x <- x[i = i, drop = drop, ...]
+        }
+
         if(!is.null(original.attr)) {
           for(ii in 1:length(original.attr)) {
             if(names(original.attr)[[ii]] == 'names') {
               # specific issue to 'names' in zoo - must subset to correct size
-#tmp              attr(x,names(original.attr)[ii]) <- original.attr[[ii]][i]
+##              attr(x,names(original.attr)[ii]) <- original.attr[[ii]][i]
             } else attr(x,names(original.attr)[ii]) <- original.attr[[ii]]
 
 #           if(names(original.attr)[[ii]] %in%  c('.DIMNAMES','names')) {
@@ -95,9 +107,17 @@ function(x, i, j, drop = TRUE, ...)
         if(!is.null(original.cols)) j <- 1:original.cols
     }
     else {
-        x <- x[i = i, j = j, drop = drop, ...]
-        if (is.null(dim(x))) 
-            dim(x) <- c(NROW(x), NCOL(x))
+        if(length(j) == 1) {
+          # subsetting down to 1 cols - '[.zoo' will delete this info
+          dn1 <- dimnames(x)[[1]]
+          x <- x[i = i, j = j, drop = drop, ...]
+          dim(x) <- c(NROW(x), NCOL(x))
+          dn <- list(dn1[i],colnames(x))
+          dimnames(x) <- dn
+        } else {
+          x <- x[i = i, j = j, drop = drop, ...]
+        }
+
         if(!is.null(original.attr)) {
           for(ii in 1:length(original.attr)) {
 #           if(names(original.attr)[[ii]] %in%  c('.DIMNAMES','names')) {
@@ -110,10 +130,10 @@ function(x, i, j, drop = TRUE, ...)
 #             }
 #           } else attr(x,names(original.attr)[ii]) <- original.attr[[ii]]
 
-#tmp           if(names(original.attr)[[ii]] == 'names') {
-#tmp             # specific issue to 'names' in zoo - must subset to correct size
-#tmp             attr(x,names(original.attr)[ii]) <- original.attr[[ii]][i]
-#tmp          } else attr(x,names(original.attr)[ii]) <- original.attr[[ii]]
+           if(names(original.attr)[[ii]] == 'names') {
+             # specific issue to 'names' in zoo - must subset to correct size
+#             attr(x,names(original.attr)[ii]) <- original.attr[[ii]][i]
+          } else attr(x,names(original.attr)[ii]) <- original.attr[[ii]]
 
           }
         }
@@ -125,6 +145,7 @@ function(x, i, j, drop = TRUE, ...)
         #rownames(x) <- original.rownames[i]
     }
     indexClass(x) <- original.indexclass
+    CLASS(x) <- original.CLASS
     x
 }
 
diff --git a/R/zoo.R b/R/zoo.R
@@ -8,14 +8,11 @@ function(x,...) {
         order.by=index(x),
         ...)
 
-  dotNames <- attr(x,'names')
-  if(!is.null(dotNames)) {
-    xx <- structure(xx, .Names=dotNames)
+  if(length(dimnames(x)[[2]]) < 2) {
+    dimnames(xx) <- NULL
+    dim(xx) <- NULL
+    attr(xx,'names') <- dimnames(x)[[1]]
   }
-# if(is.null(dimnames(x)[2]) | length(dimnames(x)[2])==1) {
-#   dimnames(xx) <- NULL
-#   attr(xx,'names') <- dimnames(x)[1]
-# }
   xx
 }
 
@@ -26,13 +23,13 @@ function(x,order.by=index(x),frequency=NULL,...) {
             frequency=frequency,
             .CLASS='zoo',
             ...)
-#  attr(xx,'names') <- NULL
 
-# if(is.null(dimnames(x))) {
-#   if(!is.null(attr(x,'names')))  # trying to capture names -jar
-#     dimnames(xx)[1] <- attr(x,'names')
-#     dimnames(xx)[2] <- NULL
-# }
+  if(!is.null(attr(x,'names'))) {
+    dim(xx) <- c(NROW(xx),NCOL(xx))
+    dn <- list(attr(x,'names'),colnames(x))
+    dimnames(xx) <- dn
+  }
+
   xx
 }