From e3a586261b8ce165dda75f3408f189d881cc0abe Mon Sep 17 00:00:00 2001 From: Joshua Ulrich Date: Mon, 3 Jun 2024 09:38:17 -0500 Subject: [PATCH] Do not use SET_TYPEOF() In R-devel r86639 SET_TYPEOF() errors if you try to convert a REAL to and INTEGER. Create the xts object without using SET_TYPEOF(). Fixes #419. --- inst/tinytest/test-merge.R | 1 - src/merge.c | 23 +++++++++++++++-------- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/inst/tinytest/test-merge.R b/inst/tinytest/test-merge.R index b6f43db2..8317f994 100644 --- a/inst/tinytest/test-merge.R +++ b/inst/tinytest/test-merge.R @@ -245,7 +245,6 @@ empty_with_dims_3x <- structure(integer(0), dim = c(0L, 9L), index = .index(x0), dimnames = list(NULL, c("a", "b", "c", "a.1", "b.1", "c.1", "a.2", "b.2", "c.2")), class = c("xts", "zoo")) -storage.mode(.index(empty_with_dims_3x)) <- "integer" ## FIXME: this should be 'numeric expect_identical(xm6, empty_with_dims_3x, info = "merge.xts([empty_xts_with_dims 3x]) has correct dims") diff --git a/src/merge.c b/src/merge.c index 7d2a5349..9b9675fe 100644 --- a/src/merge.c +++ b/src/merge.c @@ -366,15 +366,22 @@ SEXP do_merge_xts (SEXP x, SEXP y, /* do the inputs have any data to merge? */ len = nrx + nry; if (len < 1 && ncx < 1 && ncy < 1) { - /* nothing to do, return empty xts object */ - SEXP s, t; - PROTECT(s = t = allocList(1)); p++; - SET_TYPEOF(s, LANGSXP); - SETCAR(t, install("xts")); - SEXP out = PROTECT(eval(s, env)); p++; - SET_TYPEOF(out, TYPEOF(x)); + + /* return empty xts object if there are no rows or columns */ + PROTECT(result = allocVector(TYPEOF(x), 0)); p++; + PROTECT(index = allocVector(TYPEOF(xindex), 0)); p++; + setAttrib(index, xts_IndexTzoneSymbol, getAttrib(xindex, xts_IndexTzoneSymbol)); + setAttrib(index, xts_IndexTclassSymbol, getAttrib(xindex, xts_IndexTclassSymbol)); + setAttrib(index, xts_IndexTformatSymbol, getAttrib(xindex, xts_IndexTformatSymbol)); + setAttrib(result, xts_IndexSymbol, index); + + if (LOGICAL(retclass)[0]) { + setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol)); + } + setAttrib(result, xts_ClassSymbol, getAttrib(x, xts_ClassSymbol)); + UNPROTECT(p); - return out; + return result; } /* Ensure both indexes are REAL if they are not the same type. */