diff --git a/R/future_series_validation.R b/R/future_series_validation.R new file mode 100644 index 0000000..93f7ab5 --- /dev/null +++ b/R/future_series_validation.R @@ -0,0 +1,196 @@ +# 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 || any(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) { + first_info <- .parse_instrument_date(first_traded, "first_traded") + expiry_info <- .parse_instrument_date(expires, "expires") + suffix <- .parse_future_suffix(suffix_id) + + 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)) { + # Pair vector values using R's usual recycling semantics. + n <- max(nrow(first_info), nrow(expiry_info)) + first_index <- rep(seq_len(nrow(first_info)), length.out = n) + expiry_index <- rep(seq_len(nrow(expiry_info)), length.out = n) + first_values <- first_info[first_index, , drop = FALSE] + expiry_values <- expiry_info[expiry_index, , drop = FALSE] + + first_ym <- first_values$year * 12L + first_values$month + expiry_ym <- expiry_values$year * 12L + expiry_values$month + + invalid_order <- first_ym > expiry_ym | + (first_ym == expiry_ym & + first_values$precision == "day" & + expiry_values$precision == "day" & + first_values$date > expiry_values$date) + + if (any(invalid_order)) { + stop("'first_traded' must not be after 'expires'", call. = FALSE) + } + } + + invisible(TRUE) +} diff --git a/R/instrument.R b/R/instrument.R index 277c290..6fc1b9e 100644 --- a/R/instrument.R +++ b/R/instrument.R @@ -404,12 +404,19 @@ future_series <- function(primary_id, root_id=NULL, suffix_id=NULL, 'both a root_id and a suffix_id')) } else { if (is.null(suffix_id)) { - sdate <- gsub("-","",expires) - if (is.null(expires) || nchar(sdate) < 6) { + if (is.null(expires)) { stop("must provide either 'expires' or 'suffix_id'") } - suffix_id <- paste(M2C()[as.numeric(substr(sdate,5,6))], - substr(sdate,3,4),sep="") + expiry_info <- .parse_instrument_date(expires, "expires") + if (nrow(expiry_info) != 1L) { + stop("'expires' must contain one value when 'suffix_id' is omitted", + call. = FALSE) + } + suffix_id <- paste( + M2C()[expiry_info$month], + substr(expiry_info$year, 3, 4), + sep = "" + ) } primary_id <- paste(gsub("\\.","",root_id), suffix_id, sep="_") } @@ -454,9 +461,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..3083435 --- /dev/null +++ b/inst/tinytest/test_future_series.R @@ -0,0 +1,174 @@ +# 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", + expires = "2027-13", + assign_i = FALSE + ), + "invalid 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" +) + +expect_error( + future_series( + root_id = "ES", + suffix_id = "H27", + first_traded = c("2027-03-15", "2027-04-01"), + expires = c("2027-03-19", "2027-03-31"), + assign_i = FALSE + ), + "must not be after" +) + +expect_silent( + future_series( + root_id = "ES", + suffix_id = "H27", + first_traded = "2027-03-15", + expires = c("2027-03-19", "2027-03-31"), + assign_i = FALSE + ) +) + +expect_silent( + future_series( + root_id = "ES", + suffix_id = "H27", + first_traded = as.Date("2027-03-15"), + expires = as.POSIXct("2027-03-19", tz = "UTC"), + assign_i = FALSE + ) +) + +# 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)