Validate futures series contract dates

R/future_series_validation.R

@@ -0,0 +1,188 @@
+# Internal validation helpers for futures series.
+#
+# These functions intentionally preserve the package's existing storage
+# conventions. In particular, YYYY-MM expiration values remain valid and are
+# not coerced before being stored on an instrument.
+
+.parse_instrument_date <- function(x, argument) {
+  if (is.null(x)) {
+    return(NULL)
+  }
+
+  if (length(x) == 0L || any(is.na(x))) {
+    stop("'", argument, "' must not contain missing values", call. = FALSE)
+  }
+
+  if (inherits(x, "Date")) {
+    values <- format(x, "%Y-%m-%d")
+  } else if (inherits(x, "POSIXt")) {
+    values <- format(as.Date(x), "%Y-%m-%d")
+  } else if (is.character(x)) {
+    values <- x
+  } else {
+    stop(
+      "'", argument, "' must be a Date, POSIXt, or character value",
+      call. = FALSE
+    )
+  }
+
+  parse_one <- function(value) {
+    value <- gsub("^[[:space:]]+|[[:space:]]+$", "", value)
+
+    if (!nzchar(value)) {
+      stop("'", argument, "' must not contain empty values", call. = FALSE)
+    }
+
+    if (grepl("^[0-9]{4}-[0-9]{2}$", value)) {
+      year <- as.integer(substr(value, 1L, 4L))
+      month <- as.integer(substr(value, 6L, 7L))
+      precision <- "month"
+
+      if (month < 1L || month > 12L) {
+        stop(
+          "'", argument, "' contains an invalid date: ", sQuote(value),
+          call. = FALSE
+        )
+      }
+
+      date_value <- as.Date(sprintf("%04d-%02d-01", year, month))
+    } else if (grepl("^[0-9]{6}$", value)) {
+      year <- as.integer(substr(value, 1L, 4L))
+      month <- as.integer(substr(value, 5L, 6L))
+      precision <- "month"
+
+      if (month < 1L || month > 12L) {
+        stop(
+          "'", argument, "' contains an invalid date: ", sQuote(value),
+          call. = FALSE
+        )
+      }
+
+      date_value <- as.Date(sprintf("%04d-%02d-01", year, month))
+    } else if (grepl("^[0-9]{8}$", value)) {
+      date_value <- try(as.Date(value, format = "%Y%m%d"), silent = TRUE)
+
+      if (inherits(date_value, "try-error") || is.na(date_value)) {
+        stop(
+          "'", argument, "' contains an invalid date: ", sQuote(value),
+          call. = FALSE
+        )
+      }
+
+      year <- as.integer(format(date_value, "%Y"))
+      month <- as.integer(format(date_value, "%m"))
+      precision <- "day"
+    } else {
+      date_value <- try(as.Date(value), silent = TRUE)
+
+      if (inherits(date_value, "try-error") || is.na(date_value)) {
+        stop(
+          "'", argument, "' contains a value that cannot be converted to Date: ",
+          sQuote(value),
+          call. = FALSE
+        )
+      }
+
+      year <- as.integer(format(date_value, "%Y"))
+      month <- as.integer(format(date_value, "%m"))
+      precision <- "day"
+    }
+
+    if (is.na(month) || month < 1L || month > 12L || is.na(date_value)) {
+      stop(
+        "'", argument, "' contains an invalid date: ", sQuote(value),
+        call. = FALSE
+      )
+    }
+
+    data.frame(
+      original = value,
+      date = date_value,
+      year = year,
+      month = month,
+      precision = precision,
+      stringsAsFactors = FALSE
+    )
+  }
+
+  do.call(rbind, lapply(values, parse_one))
+}
+
+.parse_future_suffix <- function(suffix_id) {
+  if (!is.character(suffix_id) || length(suffix_id) != 1L ||
+      is.na(suffix_id) || !nzchar(suffix_id)) {
+    stop("'suffix_id' must be a single non-empty character value", call. = FALSE)
+  }
+
+  parsed <- try(parse_suffix(suffix_id, silent = TRUE), silent = TRUE)
+
+  if (inherits(parsed, "try-error") || is.null(parsed$format) ||
+      length(parsed$format) == 0L || is.na(parsed$format)) {
+    stop(
+      "'suffix_id' is not a recognized futures suffix: ", sQuote(suffix_id),
+      call. = FALSE
+    )
+  }
+
+  month <- match(toupper(parsed$month), toupper(month.abb))
+  year <- suppressWarnings(as.integer(parsed$year))
+  types <- parsed$type
+
+  dated_outright <-
+    "outright" %in% types &&
+    !any(c("spread", "option", "cm", "cc") %in% types) &&
+    length(month) == 1L && !is.na(month) &&
+    length(year) == 1L && !is.na(year) && year > 0L
+
+  list(
+    suffix_id = suffix_id,
+    type = types,
+    format = parsed$format,
+    month = if (dated_outright) month else NA_integer_,
+    year = if (dated_outright) year else NA_integer_,
+    dated_outright = dated_outright
+  )
+}
+
+.validate_future_series_dates <- function(suffix_id, first_traded = NULL,
+                                          expires = NULL) {
+  suffix <- .parse_future_suffix(suffix_id)
+  first_info <- .parse_instrument_date(first_traded, "first_traded")
+  expiry_info <- .parse_instrument_date(expires, "expires")
+
+  if (suffix$dated_outright && !is.null(expiry_info)) {
+    mismatch <- expiry_info$year != suffix$year |
+      expiry_info$month != suffix$month
+
+    if (any(mismatch)) {
+      supplied_months <- unique(paste(
+        month.name[expiry_info$month[mismatch]],
+        expiry_info$year[mismatch]
+      ))
+
+      warning(
+        "suffix_id ", sQuote(suffix_id), " indicates ",
+        month.name[suffix$month], " ", suffix$year,
+        ", but 'expires' indicates ",
+        paste(supplied_months, collapse = ", "),
+        call. = FALSE
+      )
+    }
+  }
+
+  if (!is.null(first_info) && !is.null(expiry_info) &&
+      nrow(first_info) == 1L && nrow(expiry_info) == 1L) {
+    first_ym <- first_info$year * 12L + first_info$month
+    expiry_ym <- expiry_info$year * 12L + expiry_info$month
+
+    if (first_ym > expiry_ym ||
+        (first_ym == expiry_ym &&
+         first_info$precision == "day" &&
+         expiry_info$precision == "day" &&
+         first_info$date > expiry_info$date)) {
+      stop("'first_traded' must not be after 'expires'", call. = FALSE)
+    }
+  }
+
+  invisible(TRUE)
+}

R/instrument.R

@@ -454,9 +454,13 @@ future_series <- function(primary_id, root_id=NULL, suffix_id=NULL,
     if (!identical(integer(0), grep("NA",expires))) expires <- NULL
   }
 
-  contract<-getInstrument(root_id,type='future')
+  .validate_future_series_dates(
+    suffix_id = suffix_id,
+    first_traded = first_traded,
+    expires = expires
+  )
 
-  # TODO add check for Date equivalent in first_traded and expires
+  contract<-getInstrument(root_id,type='future')
 
   ## with futures series we probably need to be more sophisticated,
   ## and find the existing series from prior periods (probably years or months)

inst/tinytest/test_future_series.R

@@ -0,0 +1,134 @@
+# future_series
+
+# Use a clean instrument registry so these tests are independent of other
+# tinytest files.
+rm_instruments(keep.currencies = FALSE)
+currency("USD")
+
+suppressWarnings(
+  future(
+    "ES",
+    currency = "USD",
+    multiplier = 50,
+    tick_size = 0.25,
+    underlying_id = NULL,
+    exchange = "CME",
+    description = "E-mini S&P 500 futures"
+  )
+)
+
+# A complete identifier is parsed into a futures series that inherits the root
+# contract specification.
+es_z26 <- future_series("ES_Z26", assign_i = FALSE)
+
+expect_inherits(es_z26, "future_series")
+expect_inherits(es_z26, "future")
+expect_inherits(es_z26, "instrument")
+expect_identical(es_z26$primary_id, "ES_Z26")
+expect_identical(es_z26$root_id, "ES")
+expect_identical(es_z26$suffix_id, "Z26")
+expect_identical(es_z26$currency, "USD")
+expect_identical(es_z26$multiplier, 50)
+expect_identical(es_z26$tick_size, 0.25)
+expect_identical(es_z26$exchange, "CME")
+expect_identical(es_z26$expires, "2026-12")
+expect_false(is.instrument.name("ES_Z26"))
+
+# root_id and suffix_id may be supplied separately.
+expect_identical(
+  future_series(root_id = "ES", suffix_id = "H27"),
+  "ES_H27"
+)
+expect_inherits(getInstrument("ES_H27"), "future_series")
+
+# A suffix may be derived from a full expiration date.
+expect_identical(
+  future_series(root_id = "ES", expires = "2027-06-18"),
+  "ES_M27"
+)
+expect_identical(getInstrument("ES_M27")$expires, "2027-06-18")
+
+# Month-only expiration values remain supported.
+expect_silent(
+  es_u27 <- future_series(
+    root_id = "ES",
+    suffix_id = "U27",
+    expires = "2027-09",
+    assign_i = FALSE
+  )
+)
+expect_identical(es_u27$expires, "2027-09")
+
+# A parseable mismatch warns while preserving legacy construction behavior.
+expect_warning(
+  es_bad_month <- future_series(
+    root_id = "ES",
+    suffix_id = "H27",
+    expires = "2027-12-17",
+    assign_i = FALSE
+  ),
+  "indicates March 2027"
+)
+expect_inherits(es_bad_month, "future_series")
+expect_identical(es_bad_month$expires, "2027-12-17")
+
+# Invalid dates and unrecognized suffixes fail with useful messages.
+expect_error(
+  future_series(
+    root_id = "ES",
+    suffix_id = "H27",
+    expires = "not-a-date",
+    assign_i = FALSE
+  ),
+  "cannot be converted to Date"
+)
+
+expect_error(
+  future_series(
+    root_id = "ES",
+    suffix_id = "BAD",
+    assign_i = FALSE
+  ),
+  "not a recognized futures suffix"
+)
+
+# The first trading date cannot follow expiration.
+expect_silent(
+  future_series(
+    root_id = "ES",
+    suffix_id = "H27",
+    first_traded = "2027-03-15",
+    expires = "2027-03",
+    assign_i = FALSE
+  )
+)
+
+expect_error(
+  future_series(
+    root_id = "ES",
+    suffix_id = "H27",
+    first_traded = "2027-04-01",
+    expires = "2027-03",
+    assign_i = FALSE
+  ),
+  "must not be after"
+)
+
+expect_error(
+  future_series(
+    root_id = "ES",
+    suffix_id = "H27",
+    first_traded = "2027-04-01",
+    expires = "2027-03-19",
+    assign_i = FALSE
+  ),
+  "must not be after"
+)
+
+# Multiple complete identifiers retain the existing vectorized behavior.
+series_ids <- future_series(c("ES_U28", "ES_Z28"))
+expect_identical(series_ids, c("ES_U28", "ES_Z28"))
+expect_true(all(is.instrument.name(series_ids)))
+
+# Clean up package-level state for the remaining tinytest files.
+rm_instruments(keep.currencies = FALSE)