Restore support for both index types in window()

Moving the duplicate index value handling to C created an error when
the index type was integer. This was not caught in the unit tests.
Add a loop around the window/subset unit tests that run them on both
index types (double and integer). Add support for both index types to
the fill_window_dups_rev() C function.

Change the scalar '1' to '1L' in the pmax() call after findInterval()
to ensure that 'base_index' is not coerced to double from integer.

See #251.

R/xts.methods.R

@@ -260,7 +260,7 @@ window_idx <- function(x, index. = NULL, start = NULL, end = NULL)
  }
  # Fast search on index., faster than binsearch if index. is sorted (see findInterval)
  base_idx <- findInterval(index., idx)
- base_idx <- pmax(base_idx, 1)
+ base_idx <- pmax(base_idx, 1L)
  # Only include indexes where we have an exact match in the xts series
  match <- idx[base_idx] == index.
  base_idx <- base_idx[match]

inst/unitTests/runit.xts.methods.R

@@ -219,44 +219,56 @@ test.subset_i_datetime_or_character <- function() {
  # Note that "2001-01-11" is not in the series. Skipped by convention.
  d <- c("2001-01-10", "2001-01-11", "2001-01-12", "2001-01-13")
 
- # Test scalar
- bin <- window(x, start = d[1], end = d[1])
- checkIdentical(bin, x[d[1], ], "character scalar")
- checkIdentical(bin, x[I(d[1]), ], "as-is character scalar")
- checkIdentical(bin, x[as.POSIXct(d[1]), ], "POSIXct scalar")
- checkIdentical(bin, x[as.Date(d[1]), ], "Date scalar")
-
- # Test vector
- bin <- window(x, start = d[1], end = d[length(d)])
- checkIdentical(bin, x[d, ], "character vector")
- checkIdentical(bin, x[I(d), ], "as-is character vector")
- checkIdentical(bin, x[as.POSIXct(d), ], "POSIXct vector")
- checkIdentical(bin, x[as.Date(d), ], "Date vector")
-
- # Test character dates, and single column selection
- y <- xts(rep(2, length(dts)), dts)
- z <- xts(rep(3, length(dts)), dts)
- x2 <- cbind(y, x, z)
- sub <- x2[d, 2] # Note that "2001-01-11" is not in the series. Skipped by convention.
- bin <- window(x, start = d[1], end = d[length(d)])
- checkTrue(nrow(sub) == nrow(bin), "Test character dates, and single column selection")
- checkTrue(all(sub == bin), "Test character dates, and single column selection")
+ for (type in c("double", "integer")) {
+ storage.mode(.index(x)) <- type
+
+ # Test scalar
+ msg <- paste("scalar,", type, "index")
+ bin <- window(x, start = d[1], end = d[1])
+ checkIdentical(bin, x[d[1], ], paste("character", msg))
+ checkIdentical(bin, x[I(d[1]), ], paste("as-is character", msg))
+ checkIdentical(bin, x[as.POSIXct(d[1]), ], paste("POSIXct", msg))
+ checkIdentical(bin, x[as.Date(d[1]), ], paste("Date", msg))
+
+ # Test vector
+ msg <- paste("vector,", type, "index")
+ bin <- window(x, start = d[1], end = d[length(d)])
+ checkIdentical(bin, x[d, ], paste("character", msg))
+ checkIdentical(bin, x[I(d), ], paste("as-is character", msg))
+ checkIdentical(bin, x[as.POSIXct(d), ], paste("POSIXct", msg))
+ checkIdentical(bin, x[as.Date(d), ], paste("Date", msg))
+
+ # Test character dates, and single column selection
+ y <- xts(rep(2, length(dts)), dts)
+ z <- xts(rep(3, length(dts)), dts)
+ x2 <- cbind(y, x, z)
+ sub <- x2[d, 2] # Note that "2001-01-11" is not in the series. Skipped by convention.
+ bin <- window(x, start = d[1], end = d[length(d)])
+ checkTrue(nrow(sub) == nrow(bin), "Test character dates, and single column selection")
+ checkTrue(all(sub == bin), "Test character dates, and single column selection")
+ }
 }
 
 test.subset_i_ISO8601 <- function() {
- # Test Date Ranges
  x <- xts(1:1000, as.Date("2000-01-01")+1:1000)
- sub <- x['200001'] # January 2000
- bin <- window(x, start = "2000-01-01", end = "2000-01-31")
- checkIdentical(bin, sub, "Test Date Ranges")
-
- # Test Date Ranges 2
- sub <- x['1999/2000'] # All of 2000 (note there is no need to use the exact start)
- bin <- window(x, start = "2000-01-01", end = "2000-12-31")
- checkIdentical(bin, sub, "Test Date Ranges 2")
-
- # Test Date Ranges 3
- sub <- x['1999/200001'] # January 2000
- bin <- window(x, start = "2000-01-01", end = "2000-01-31")
- checkIdentical(bin, sub, "Test Date Ranges 3")
+
+ for (type in c("double", "integer")) {
+ storage.mode(.index(x)) <- type
+
+ fmt <- paste("Test date range, %s;", type, "index")
+ # Test Date Ranges
+ sub <- x['200001'] # January 2000
+ bin <- window(x, start = "2000-01-01", end = "2000-01-31")
+ checkIdentical(bin, sub, sprintf(fmt, "2000-01"))
+
+ # Test Date Ranges 2
+ sub <- x['1999/2000'] # All of 2000 (note there is no need to use the exact start)
+ bin <- window(x, start = "2000-01-01", end = "2000-12-31")
+ checkIdentical(bin, sub, sprintf(fmt, "1999/2000"))
+
+ # Test Date Ranges 3
+ sub <- x['1999/200001'] # January 2000
+ bin <- window(x, start = "2000-01-01", end = "2000-01-31")
+ checkIdentical(bin, sub, sprintf(fmt, "1999/2000-01"))
+ }
 }

src/binsearch.c

@@ -159,8 +159,7 @@ SEXP fill_window_dups_rev(SEXP _x, SEXP _index)
  * This is necessary to handle duplicate dates in the xts index.
  */
  int n_x = length(_x);
- double *x = REAL(_x);
- double *index = REAL(_index);
+ int *x = INTEGER(_x);
 
  if (length(_index) < 1) {
  return allocVector(INTSXP, 0);
@@ -169,14 +168,36 @@ SEXP fill_window_dups_rev(SEXP _x, SEXP _index)
  SEXP _out = PROTECT(allocVector(INTSXP, length(_index)));
  int *out = INTEGER(_out);
 
- /* Loop over locations in _x in reverse order */
  int i, xi, j, k = 0;
- for (i = n_x; i > 0; i--) {
- xi = x[i-1];
- j = xi;
- do {
- out[k++] = j--;
- } while (j > 0 && index[xi-1] == index[j-1]);
+ switch (TYPEOF(_index)) {
+ case REALSXP:
+ {
+ double *index = REAL(_index);
+ /* Loop over locations in _x in reverse order */
+ for (i = n_x; i > 0; i--) {
+ xi = x[i-1];
+ j = xi;
+ do {
+ out[k++] = j--;
+ } while (j > 0 && index[xi-1] == index[j-1]);
+ }
+ }
+ break;
+ case INTSXP:
+ {
+ int *index = INTEGER(_index);
+ /* Loop over locations in _x in reverse order */
+ for (i = n_x; i > 0; i--) {
+ xi = x[i-1];
+ j = xi;
+ do {
+ out[k++] = j--;
+ } while (j > 0 && index[xi-1] == index[j-1]);
+ }
+ }
+ break;
+ default:
+ error("unsupported index type");
  }
 
  /* truncate so length(_out) = k