Validate futures series contract dates

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)
+}

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)