From 5520157efaf727cb9fa4890173b5368e21374426 Mon Sep 17 00:00:00 2001 From: Joshua Ulrich Date: Sun, 5 Aug 2018 07:35:11 -0500 Subject: [PATCH] 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 | 2 +- inst/unitTests/runit.xts.methods.R | 84 +++++++++++++++++------------- src/binsearch.c | 39 ++++++++++---- 3 files changed, 79 insertions(+), 46 deletions(-) diff --git a/R/xts.methods.R b/R/xts.methods.R index e8bc1675..c94ac6b5 100644 --- a/R/xts.methods.R +++ b/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] diff --git a/inst/unitTests/runit.xts.methods.R b/inst/unitTests/runit.xts.methods.R index b8b402c4..eb1d72d0 100644 --- a/inst/unitTests/runit.xts.methods.R +++ b/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")) + } } diff --git a/src/binsearch.c b/src/binsearch.c index 7102571f..152b4986 100644 --- a/src/binsearch.c +++ b/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