diff --git a/R/future_series_validation.R b/R/future_series_validation.R new file mode 100644 index 0000000..fbd12b6 --- /dev/null +++ b/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) +} diff --git a/R/instrument.R b/R/instrument.R index 277c290..511066f 100644 --- a/R/instrument.R +++ b/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) diff --git a/inst/tinytest/test_future_series.R b/inst/tinytest/test_future_series.R new file mode 100644 index 0000000..c4b406c --- /dev/null +++ b/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)