Correct time of day subsetting when using hours.

R/xts.methods.R

@@ -20,19 +20,70 @@
 #   along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 .subsetTimeOfDay <- function(x, fromTimeString, toTimeString) {
-  timestringToSeconds <- function(timeString) {
-    # "09:00:00" to seconds of day
-    origin <- paste("1970-01-01", timeString)
-    as.numeric(as.POSIXct(origin, "UTC")) %% 86400L
+  validateTimestring <- function(time) {
+    h    <- "(?:[01]?\\d|2[0-3])"
+    hm   <- paste0(h, "(?::?[0-5]\\d)")
+    hms  <- paste0(hm, "(?::?[0-5]\\d)")
+    hmsS <- paste0(hms, "(?:\\.\\d{1,9})?")
+    pattern <- paste(h, hm, hms, hmsS, sep = ")$|^(")
+    pattern <- paste0("^(", pattern, "$)")
+
+    if (!grepl(pattern, time)) {
+      # FIXME: this isn't necessarily true...
+      # colons aren't required, and neither are all of the components
+      stop("Supply time-of-day subsetting in the format of T%H:%M:%OS/T%H:%M:%OS",
+           call. = FALSE)
+    }
   }
 
-  # handle timezone
+  validateTimestring(fromTimeString)
+  validateTimestring(toTimeString)
+
+  getTimeComponents <- function(time) {
+    # split on decimal point
+    time. <- strsplit(time, ".", fixed = TRUE)[[1]]
+    hms <- time.[1L]
+
+    # ensure hms string has even nchar
+    nocolon <- gsub(":", "", hms, fixed = TRUE)
+    if (nchar(nocolon) %% 2 > 0) {
+      # odd nchar means leading zero is omitted from hours
+      # all other components require zero padding
+      hms <- paste0("0", hms)
+    }
+    # add colons
+    hms <- gsub("(.{2}):?", ":\\1", hms, perl = TRUE)
+    # remove first character (a colon)
+    hms <- substr(hms, 2, nchar(hms))
+
+    # extract components
+    comp <- strsplit(hms, ":", fixed = TRUE)[[1]]
+    complist <-
+      list(hour = comp[1L],
+           min = comp[2L],
+           sec = comp[3L],
+           subsec = time.[2L])
+    # remove all missing components
+    complist <- complist[!vapply(complist, is.na, logical(1))]
+    # convert to numeric
+    complist <- lapply(complist, as.numeric)
+
+    # add timezone and return
+    c(tz = "UTC", complist)
+  }
+
+  # first second in period (no subseconds)
+  from <- do.call(firstof, getTimeComponents(fromTimeString)[-5L])
+  secBegin <- as.numeric(from) %% 86400L
+
+  # last second in period
+  to <- do.call(lastof, getTimeComponents(toTimeString))
+  secEnd <- as.numeric(to) %% 86400L
+
+  # do subsetting
   tz <- tzone(x)
   secOfDay <- as.POSIXlt(index(x), tz = tz)
-  secOfDay <- secOfDay$hour*60*60 + secOfDay$min*60 + secOfDay$sec
-
-  secBegin <- timestringToSeconds(fromTimeString)
-  secEnd   <- timestringToSeconds(toTimeString)
+  secOfDay <- secOfDay$hour * 60 * 60 + secOfDay$min * 60 + secOfDay$sec
 
   if (secBegin <= secEnd) {
     i <- secOfDay >= secBegin & secOfDay <= secEnd

inst/unitTests/runit.irts.R

@@ -17,21 +17,21 @@ test.convert_irts_to_xts_i1 <- function() {
 test.convert_irts_to_xts_i1j1 <- function() {
   checkIdentical(sample.irts.xts[1,1],as.xts(sample.irts)[1,1])
 }
-test.irts_reclass <- function() {
-  DEACTIVATED("irts forces rownames, xts disallows rownames. Unable to test")
-  checkIdentical(sample.irts,reclass(try.xts(sample.irts)))
-}
-test.irts_reclass_subset_reclass_j1 <- function() {
-  DEACTIVATED("irts forces rownames, xts disallows rownames. Unable to test")
-  checkIdentical(sample.irts[,1],reclass(try.xts(sample.irts))[,1])
-}
-test.irts_reclass_subset_as.xts_j1 <- function() {
-  DEACTIVATED("irts forces rownames, xts disallows rownames. Unable to test")
-  checkIdentical(sample.irts[,1],reclass(try.xts(sample.irts)[,1]))
-}
-test.irts_reclass_subset_irts_j1 <- function() {
-  DEACTIVATED("irts forces rownames, xts disallows rownames. Unable to test")
-  checkIdentical(sample.irts[,1],reclass(try.xts(sample.irts[,1])))
-}
+# test.irts_reclass <- function() {
+#   DEACTIVATED("irts forces rownames, xts disallows rownames. Unable to test")
+#   checkIdentical(sample.irts,reclass(try.xts(sample.irts)))
+# }
+# test.irts_reclass_subset_reclass_j1 <- function() {
+#   DEACTIVATED("irts forces rownames, xts disallows rownames. Unable to test")
+#   checkIdentical(sample.irts[,1],reclass(try.xts(sample.irts))[,1])
+# }
+# test.irts_reclass_subset_as.xts_j1 <- function() {
+#   DEACTIVATED("irts forces rownames, xts disallows rownames. Unable to test")
+#   checkIdentical(sample.irts[,1],reclass(try.xts(sample.irts)[,1]))
+# }
+# test.irts_reclass_subset_irts_j1 <- function() {
+#   DEACTIVATED("irts forces rownames, xts disallows rownames. Unable to test")
+#   checkIdentical(sample.irts[,1],reclass(try.xts(sample.irts[,1])))
+# }
 
 }  # requireNamespace

inst/unitTests/runit.parseISO8601.R

@@ -51,19 +51,19 @@ test.start_end_dates_do_not_exist <- function() {
   checkIdentical(y, UNKNOWN_TIME)
 }
 
-test.start_date_does_not_exist <- function() {
-  DEACTIVATED("FAILS: returns everything")
-  x <- "2015-02-30/2015-03-03"
-  y <- .parseISO8601(x, START_N, END_N, "UTC")
-  checkIdentical(y, UNKNOWN_TIME)
-}
-
-test.end_date_does_not_exist <- function() {
-  DEACTIVATED("FAILS: returns everything")
-  x <- "2015-02-25/2015-02-30"
-  y <- .parseISO8601(x, START_N, END_N, "UTC")
-  checkIdentical(y, UNKNOWN_TIME)
-}
+# test.start_date_does_not_exist <- function() {
+#   DEACTIVATED("FAILS: returns everything")
+#   x <- "2015-02-30/2015-03-03"
+#   y <- .parseISO8601(x, START_N, END_N, "UTC")
+#   checkIdentical(y, UNKNOWN_TIME)
+# }
+#
+# test.end_date_does_not_exist <- function() {
+#   DEACTIVATED("FAILS: returns everything")
+#   x <- "2015-02-25/2015-02-30"
+#   y <- .parseISO8601(x, START_N, END_N, "UTC")
+#   checkIdentical(y, UNKNOWN_TIME)
+# }
 
 # Fuzz tests
 test.start_end_dates_are_garbage <- function() {

inst/unitTests/runit.subset-time-of-day.R

@@ -0,0 +1,108 @@
+# Time-of-day subset
+
+test.time_of_day_start_equals_end <- function() {
+  i <- 0:47
+  x <- .xts(i, i * 3600, tz = "UTC")
+  i1 <- .index(x[c(2L, 26L)])
+  checkIdentical(.index(x["T01:00/T01:00"]), i1)
+}
+
+test.time_of_day_when_DST_starts <- function() {
+  # 2017-03-12: no 0200
+  tz <- "America/Chicago"
+  tmseq <- seq(as.POSIXct("2017-03-11", tz),
+               as.POSIXct("2017-03-14", tz), by = "1 hour")
+  x <- xts(seq_along(tmseq), tmseq)
+  i <- structure(c(1489215600, 1489219200, 1489222800, 1489302000,
+                   1489305600, 1489384800, 1489388400, 1489392000),
+       tzone = "America/Chicago", tclass = c("POSIXct", "POSIXt"))
+  checkIdentical(.index(x["T01:00:00/T03:00:00"]), i)
+}
+
+test.time_of_day_when_DST_ends <- function() {
+  # 2017-11-05: 0200 occurs twice
+  tz <- "America/Chicago"
+  tmseq <- seq(as.POSIXct("2017-11-04", tz),
+               as.POSIXct("2017-11-07", tz), by = "1 hour")
+  x <- xts(seq_along(tmseq), tmseq)
+  i <- structure(c(1509775200, 1509778800, 1509782400, 1509861600, 1509865200,
+       1509868800, 1509872400, 1509951600, 1509955200, 1509958800),
+       tzone = "America/Chicago", tclass = c("POSIXct", "POSIXt"))
+  checkIdentical(.index(x["T01:00:00/T03:00:00"]), i)
+}
+
+
+test.time_of_day_by_hour_start_equals_end <- function() {
+  i <- 0:94
+  x <- .xts(i, i * 1800, tz = "UTC")
+  i1 <- .index(x[c(3, 4, 51, 52)])
+
+  checkIdentical(.index(x["T01/T01"]), i1)
+  checkIdentical(.index(x["T1/T1"]), i1)
+}
+
+test.time_of_day_by_minute <- function() {
+  i <- 0:189
+  x <- .xts(i, i * 900, tz = "UTC")
+  i1 <- .index(x[c(5:8, 101:104)])
+
+  checkIdentical(.index(x["T01:00/T01:45"]), i1)
+  checkIdentical(.index(x["T01/T01:45"]), i1)
+}
+
+test.time_of_day_check_time_string <- function() {
+  i <- 0:10
+  x <- .xts(i, i * 1800, tz = "UTC")
+  # Should work with and without colon separator
+  checkIdentical(x["T0100/T0115"], x["T01:00/T01:15"])
+}
+
+test.time_of_day_by_second <- function() {
+  i <- 0:500
+  x <- .xts(c(i, i), c(i * 15, 86400 + i * 15), tz = "UTC")
+  i1 <- .index(x[c(474L, 475L, 476L, 477L, 478L, 479L, 480L, 481L, 482L, 483L,
+                   484L, 485L, 975L, 976L, 977L, 978L, 979L, 980L, 981L, 982L,
+                   983L, 984L, 985L, 986L)])
+
+  checkIdentical(.index(x["T01:58:05/T02:01:09"]), i1)
+  # Can only omit 0 padding for hours. Only for convenience because it does
+  # not conform to the ISO 8601 standard, which requires padding with zeros.
+  checkIdentical(.index(x["T1:58:05/T2:01:09"]), i1)
+  checkIdentical(.index(x["T1:58:05.000/T2:01:09.000"]), i1)
+}
+
+test.time_of_day_end_before_start <- function() {
+  # Yes, this actually makes sense and is useful for financial markets
+  # E.g. some futures markets open at 18:00 and close at 16:00 the next day
+  i <- 0:47
+  x <- .xts(i, i * 3600, tz = "UTC")
+  i1 <- .index(x[-c(18L, 42L)])
+
+  checkIdentical(.index(x["T18:00/T16:00"]), i1)
+}
+
+# TODO: Add tests for possible edge cases and/or errors
+# end time before start time
+# start time and/or end time missing "T" prefix
+
+test.time_of_day_on_zero_width <- function() {
+  # return relevant times and a column of NA; consistent with zoo
+  i <- 0:47
+  tz <- "America/Chicago"
+  x <- .xts(, i * 3600, tzone = tz)
+  y <- x["T18:00/T20:00"]
+  checkIdentical(y, .xts(rep(NA, 6), c(0:2, 24:26)*3600, tzone = tz))
+}
+
+test.time_of_day_zero_padding <- function() {
+  i <- 0:189
+  x <- .xts(i, i * 900, tz = "UTC")
+  i1 <- .index(x[c(5:8, 101:104)])
+
+  checkIdentical(.index(x["T01:00/T01:45"]), i1)
+  # we support un-padded hours, for convenience (it's not in the standard)
+  checkIdentical(.index(x["T1/T1:45"]), i1)
+  # minutes and seconds must be zero-padded
+  checkException(x["T01:5:5/T01:45"])
+  checkException(x["T01:05:5/T01:45"])
+}

inst/unitTests/runit.subset.R

@@ -283,61 +283,3 @@ test.duplicate_index_duplicate_i <- function() {
 
   checkIdentical(x[index(x),],  y)
 }
-
-# Time-of-day subset
-
-test.time_of_day_when_DST_starts <- function() {
-  # 2017-03-12: no 0200
-  tz <- "America/Chicago"
-  tmseq <- seq(as.POSIXct("2017-03-11", tz),
-               as.POSIXct("2017-03-14", tz), by = "1 hour")
-  x <- xts(seq_along(tmseq), tmseq)
-  i <- structure(c(1489215600, 1489219200, 1489222800, 1489302000,
-                   1489305600, 1489384800, 1489388400, 1489392000),
-       tzone = "America/Chicago", tclass = c("POSIXct", "POSIXt"))
-  checkIdentical(.index(x["T01:00:00/T03:00:00"]), i)
-}
-
-test.time_of_day_when_DST_ends <- function() {
-  # 2017-11-05: 0200 occurs twice
-  tz <- "America/Chicago"
-  tmseq <- seq(as.POSIXct("2017-11-04", tz),
-               as.POSIXct("2017-11-07", tz), by = "1 hour")
-  x <- xts(seq_along(tmseq), tmseq)
-  i <- structure(c(1509775200, 1509778800, 1509782400, 1509861600, 1509865200,
-       1509868800, 1509872400, 1509951600, 1509955200, 1509958800),
-       tzone = "America/Chicago", tclass = c("POSIXct", "POSIXt"))
-  checkIdentical(.index(x["T01:00:00/T03:00:00"]), i)
-}
-
-test.time_of_day_start_equals_end <- function() {
-  i <- 0:47
-  x <- .xts(i, i * 3600, tz = "UTC")
-  i1 <- .index(x[c(2L, 26L)])
-
-  checkIdentical(.index(x["T01:00/T01:00"]), i1)
-}
-
-test.time_of_day_end_before_start <- function() {
-  # Yes, this actually makes sense and is useful for financial markets
-  # E.g. some futures markets open at 18:00 and close at 16:00 the next day
-  i <- 0:47
-  x <- .xts(i, i * 3600, tz = "UTC")
-  i1 <- .index(x[-c(18L, 42L)])
-
-  checkIdentical(.index(x["T18:00/T16:00"]), i1)
-}
-
-# TODO: Add tests for possible edge cases and/or errors
-# end time before start time
-# start time and/or end time missing "T" prefix
-# start time and/or end time missing ":" separator
-
-test.time_of_day_on_zero_width <- function() {
-  # return relevant times and a column of NA; consistent with zoo
-  i <- 0:47
-  tz <- "America/Chicago"
-  x <- .xts(, i * 3600, tzone = tz)
-  y <- x["T18:00/T20:00"]
-  checkIdentical(y, .xts(rep(NA, 6), c(0:2, 24:26)*3600, tzone = tz))
-}

inst/unitTests/runit.xts.R

@@ -113,29 +113,23 @@ test..xts_dimnames_in_dots <- function() {
   checkEquals(x, y)
 }
 
-test..xts_ctor_does_not_return_rownames <- function() {
-  m <- matrix(1, dimnames = list("a", "b"))
-  x <- .xts(m, 1)
-  checkEquals(rownames(x), NULL)
-}
-
-test..xts_ctor_warns_if_index_tclass_not_NULL_or_POSIXct <- function() {
-  DEACTIVATED("Warning causes errors in dependencies")
-  op <- options(warn = 2)
-  on.exit(options(warn = op$warn))
-
-  idx <- 1:3
-  x <- .xts(1:3, idx)  # no error, NULL
-  idx <- .POSIXct(idx)
-  x <- .xts(1:3, idx)  # no error, POSIXct
-
-  idx <- structure(1:3, tclass = "Date", tzone = "UTC")
-  checkException(.xts(1:3, idx), msg = "tclass = Date")
-  idx <- structure(idx, tclass = "yearmon", tzone = "UTC")
-  checkException(.xts(1:3, idx), msg = "tclass = yearmon")
-  idx <- structure(idx, tclass = "timeDate", tzone = "UTC")
-  checkException(.xts(1:3, idx), msg = "tclass = timeDate")
-}
+# test..xts_ctor_warns_if_index_tclass_not_NULL_or_POSIXct <- function() {
+#   DEACTIVATED("Warning causes errors in dependencies")
+#   op <- options(warn = 2)
+#   on.exit(options(warn = op$warn))
+#
+#   idx <- 1:3
+#   x <- .xts(1:3, idx)  # no error, NULL
+#   idx <- .POSIXct(idx)
+#   x <- .xts(1:3, idx)  # no error, POSIXct
+#
+#   idx <- structure(1:3, tclass = "Date", tzone = "UTC")
+#   checkException(.xts(1:3, idx), msg = "tclass = Date")
+#   idx <- structure(idx, tclass = "yearmon", tzone = "UTC")
+#   checkException(.xts(1:3, idx), msg = "tclass = yearmon")
+#   idx <- structure(idx, tclass = "timeDate", tzone = "UTC")
+#   checkException(.xts(1:3, idx), msg = "tclass = timeDate")
+# }
 
 checkXtsFormat <- function(xts, format) {
   checkIdentical(tformat(xts), format)

inst/unitTests/runit.zoo.R

@@ -30,14 +30,14 @@ test.convert_zoo_to_xts_i1 <- function() {
 test.convert_zoo_to_xts_i1j1 <- function() {
   checkIdentical(sample.xts[1,1],as.xts(sample.zoo)[1,1])
 }
-test.zoo_reclass <- function() {
-  DEACTIVATED("rownames are not kept yet in current xts-dev")
-  checkIdentical(sample.zoo,reclass(try.xts(sample.zoo)))
-}
-test.zoo_reclass_subset_reclass_j1 <- function() {
-  DEACTIVATED("rownames are not kept yet in current xts-dev")
-  checkIdentical(sample.zoo[,1],reclass(try.xts(sample.zoo))[,1])
-}
+# test.zoo_reclass <- function() {
+#   DEACTIVATED("rownames are not kept yet in current xts-dev")
+#   checkIdentical(sample.zoo,reclass(try.xts(sample.zoo)))
+# }
+# test.zoo_reclass_subset_reclass_j1 <- function() {
+#   DEACTIVATED("rownames are not kept yet in current xts-dev")
+#   checkIdentical(sample.zoo[,1],reclass(try.xts(sample.zoo))[,1])
+# }
 test.zoo_reclass_subset_as.xts_j1 <- function() {
   checkIdentical(sample.zoo[,1],reclass(try.xts(sample.zoo)[,1]))
 }