`dimnames<-.xts` changes shared objects

[joshuaulrich]

Calling "dimnames<-" on a shared xts object will change the column names for all shared objects. Only the object "dimnames<-" is called with should be changed. I.e., it should be duplicated() before dimnames are changed. The relevant code is in the C function xts_set_dimnames().

x <- .xts(cbind(1:2, 1:2), 1:2, dimnames = list(NULL, c("a", "b")))
z <- y <- x
colnames(x)  # [1] "a" "b"
colnames(y)  # [1] "a" "b"
`dimnames<-`(z, NULL)
colnames(x)  # NULL
colnames(y)  # NULL

Session Info

version 3.5.3 (2019-03-11)
Platform: x86_64-pc-linux-gnu (64-bit)
Running under: Ubuntu 18.04.2 LTS

Matrix products: default
BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.7.1
LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.7.1

locale:
 [1] LC_CTYPE=en_US.UTF-8       LC_NUMERIC=C              
 [3] LC_TIME=en_US.UTF-8        LC_COLLATE=en_US.UTF-8    
 [5] LC_MONETARY=en_US.UTF-8    LC_MESSAGES=en_US.UTF-8   
 [7] LC_PAPER=en_US.UTF-8       LC_NAME=C                 
 [9] LC_ADDRESS=C               LC_TELEPHONE=C            
[11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C       

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
[1] xts_0.11-2 zoo_1.8-6 

loaded via a namespace (and not attached):
[1] compiler_3.5.3  tools_3.5.3     grid_3.5.3      lattice_0.20-38

[joshuaulrich]

I'm not sure this is a bug in xts, or a bug at all. I added the following code to the top of src/dimnames.c:

  if (MAYBE_SHARED(x)) {
    x = duplicate(x);
  }

But then "dimnames<-"(z, NULL) no longer mutated x or y, but it also didn't update z like it should have.

[joshuaulrich]

I also tried to only duplicate when "dimnames<-"(x, NULL) was called, but not when dimnames(x) <- NULL was called. The results were the same as in the previous comment. Patch below:

diff --git a/R/dimnames.R b/R/dimnames.R
index 82bf759..a9810ce 100644
--- a/R/dimnames.R
+++ b/R/dimnames.R
@@ -31,5 +31,6 @@ function(x) {

 `dimnames<-.xts` <-
 function(x, value) {
-  .Call("xts_set_dimnames", x, value, PACKAGE = "xts")
+  duplicate.x <- match.call()$x != as.symbol("*tmp*")
+  .Call("xts_set_dimnames", x, value, duplicate.x, PACKAGE = "xts")
 }
diff --git a/inst/include/xts.h b/inst/include/xts.h
index d94ed22..d38328c 100644
--- a/inst/include/xts.h
+++ b/inst/include/xts.h
@@ -98,7 +98,7 @@ SEXP xts_period_max(SEXP data, SEXP index);
 SEXP xts_period_sum(SEXP data, SEXP index);
 SEXP xts_period_prod(SEXP data, SEXP index);

-SEXP xts_set_dimnames(SEXP x, SEXP value);
+SEXP xts_set_dimnames(SEXP x, SEXP value, SEXP duplicate_x);

 void copyAttributes(SEXP x, SEXP y);    // internal only
diff --git a/inst/unitTests/runit.xts.methods.R b/inst/unitTests/runit.xts.methods.R
index eb1d72d..a76ed65 100644
--- a/inst/unitTests/runit.xts.methods.R
+++ b/inst/unitTests/runit.xts.methods.R
@@ -1,7 +1,5 @@
 #
 # RUnit tests for the following 'xts' methods:
-# rbind
-# cbind
 #
 test.rbind_zero_length_non_zero_length_POSIXct_errors <- function() {
   xpz <- xts( , as.POSIXct("2017-01-01"))
@@ -272,3 +270,23 @@ test.subset_i_ISO8601 <- function() {
     checkIdentical(bin, sub, sprintf(fmt, "1999/2000-01"))
   }
 }
+
+test.set_dimnames_does_not_mutate <- function() {
+  dn <- list(NULL, c("a", "b"))
+  z <- y <- x <- .xts(cbind(1:2, 1:2), 1:2, dimnames = dn)
+  DN <- list(NULL, toupper(dn[[2]]))
+  dimnames(y) <- DN
+  RUnit::checkIdentical(dimnames(x), dn)
+  RUnit::checkIdentical(dimnames(y), DN)
+  RUnit::checkIdentical(dimnames(z), dn)
+}
+
+test.set_dimnames_backtick_does_not_mutate <- function() {
+  dn <- list(NULL, c("a", "b"))
+  z <- y <- x <- .xts(cbind(1:2, 1:2), 1:2, dimnames = dn)
+  DN <- list(NULL, toupper(dn[[2]]))
+  `dimnames<-`(y, DN)
+  RUnit::checkIdentical(dimnames(x), dn)
+  RUnit::checkIdentical(dimnames(y), DN)
+  RUnit::checkIdentical(dimnames(z), dn)
+}
diff --git a/src/dimnames.c b/src/dimnames.c
index 856b76d..fb0e1c1 100644
--- a/src/dimnames.c
+++ b/src/dimnames.c
@@ -25,7 +25,10 @@ SEXP dimnames_zoo (SEXP x) {
   return(getAttrib(x, R_DimNamesSymbol));
 }

-SEXP xts_set_dimnames (SEXP x, SEXP value) {
+SEXP xts_set_dimnames (SEXP x, SEXP value, SEXP duplicate_x) {
+  if (LOGICAL(duplicate_x)[0]) {
+    x = duplicate(x);
+  }
   if (R_NilValue == value) {
     setAttrib(x, R_DimNamesSymbol, R_NilValue);
   } else {
diff --git a/src/init.c b/src/init.c
index 005d155..aaea950 100644
--- a/src/init.c
+++ b/src/init.c
@@ -43,7 +43,7 @@ R_CallMethodDef callMethods[] = {
   {"xts_period_max",        (DL_FUNC) &xts_period_max,          2},
   {"xts_period_sum",        (DL_FUNC) &xts_period_sum,          2},
   {"xts_period_prod",       (DL_FUNC) &xts_period_prod,         2},
-  {"xts_set_dimnames",      (DL_FUNC) &xts_set_dimnames,        2},
+  {"xts_set_dimnames",      (DL_FUNC) &xts_set_dimnames,        3},
   {NULL,                    NULL,                               0}
 };