diff --git a/R/instrument.R b/R/instrument.R index 277c290..9889384 100644 --- a/R/instrument.R +++ b/R/instrument.R @@ -561,24 +561,28 @@ option_series <- function(primary_id , root_id = NULL, suffix_id = NULL, } else { #if you give it only a root_id it will make the suffix_id #using expires, callput, and strike if (is.null(suffix_id)) { - sdate <- if (nchar(expires) == 8) { - try(as.Date(expires, format='%Y%m%d'), silent=TRUE) - } else try(as.Date(expires),silent=TRUE) - if (inherits(sdate,'try-error')) { - stop("expires is missing or of incorrect format") - } - sright <- try(switch(callput, C=,c=,call="C", P=,p=,put="P"), - silent=TRUE) - if (inherits(sright,'try-error')) { - stop(paste("must provide 'callput' or a 'suffix_id'", - "from which 'callput' can be inferred.")) + sdate <- .option_series_date(expires, "expires") + if (is.null(sdate)) { + stop("must provide 'expires' or a 'suffix_id'", + call. = FALSE) } + normalized_callput <- .normalize_option_callput( + callput, + allow_default = FALSE + ) + strike <- .validate_option_strike(strike) if (is.null(strike)) { stop(paste("must provide 'strike' or a 'suffix_id'", - "from which 'strike' can be inferred.")) + "from which 'strike' can be inferred."), + call. = FALSE) + } + sright <- if (identical(normalized_callput, "call")) { + "C" + } else { + "P" } - suffix_id <- paste(format(sdate,'%y%m%d'), sright, strike, - sep="") + suffix_id <- paste(format(sdate, '%y%m%d'), sright, strike, + sep = "") } primary_id <- paste(gsub("\\.","",root_id), suffix_id, sep="_") } @@ -616,29 +620,21 @@ option_series <- function(primary_id , root_id = NULL, suffix_id = NULL, pid <- parse_id(primary_id) if (is.null(root_id)) root_id <- pid$root if (is.null(suffix_id)) suffix_id <- pid$suffix - if (is.null(strike)) { - if (is.na(pid$strike)) stop('strike must be provided.') - strike <- pid$strike - } - if (is.null(expires)) { - #TODO: option_series ids contain the entire date. - # Don't have to settle for YYYY-MM - expires <- paste(pid$year, - sprintf("%02d",match(pid$month, - toupper(month.abb))),sep='-') - if (!identical(integer(0), grep("NA",expires))) { - stop(paste("must provide 'expires' formatted '%Y-%m-%d',", - "or a 'suffix_id' from which to infer 'expires'")) - } - } + validated <- .validate_option_series_fields( + suffix_id = suffix_id, + expires = expires, + first_traded = first_traded, + callput = callput, + strike = strike + ) + expires <- validated$expires + callput <- validated$callput + strike <- validated$strike + contract<-getInstrument(root_id, type='option') ## with options series we probably need to be more sophisticated, ## and find the existing series from prior periods (probably years) ## and then add the first_traded and expires to the time series - if(length(callput)==2) callput <- switch(pid$right, C='call', P='put') - if (is.null(callput)) { - stop("value of callput must be specified as 'call' or 'put'") - } if (!isTRUE(overwrite)) { temp_series<-try(getInstrument(primary_id, silent=TRUE),silent=TRUE) if(inherits(temp_series,"option_series")) { diff --git a/R/option_series_validation.R b/R/option_series_validation.R new file mode 100644 index 0000000..c480101 --- /dev/null +++ b/R/option_series_validation.R @@ -0,0 +1,205 @@ +# Internal validation helpers for option series instruments. + +.option_series_date <- function(x, argument, allow_multiple = FALSE) { + if (is.null(x)) return(NULL) + + if (inherits(x, "POSIXlt")) { + x <- as.POSIXct(x) + } + + if (!allow_multiple && length(x) != 1L) { + stop("'", argument, "' must be a single date", call. = FALSE) + } + if (length(x) < 1L || anyNA(x)) { + stop("'", argument, "' must not contain missing values", call. = FALSE) + } + parse_one <- function(value) { + if (inherits(value, "Date")) { + return(value) + } + + if (inherits(value, "POSIXt")) { + tz <- attr(value, "tzone") + + if (is.null(tz) || length(tz) == 0L || + is.na(tz[[1L]]) || !nzchar(tz[[1L]])) { + tz <- "UTC" + } else { + tz <- tz[[1L]] + } + + return(as.Date(value, tz = tz)) + } + + value <- as.character(value) + + parsed <- tryCatch( + if (grepl("^[0-9]{8}$", value)) { + as.Date(value, format = "%Y%m%d") + } else { + suppressWarnings(as.Date(value)) + }, + error = function(e) as.Date(NA) + ) + + if (is.na(parsed)) { + stop("'", argument, "' must be coercible to Date", call. = FALSE) + } + parsed + } + + as.Date(vapply(as.list(x), parse_one, as.Date("1970-01-01")), + origin = "1970-01-01") +} + +.normalize_option_callput <- function(callput, allow_default = TRUE) { + if (allow_default && length(callput) == 2L && + identical(tolower(callput), c("call", "put"))) { + return(NULL) + } + if (length(callput) != 1L || is.na(callput)) { + stop("'callput' must be a single value: 'call', 'put', 'C', or 'P'", + call. = FALSE) + } + + normalized <- switch(tolower(as.character(callput)), + c = "call", + call = "call", + p = "put", + put = "put", + NULL) + if (is.null(normalized)) { + stop("'callput' must be one of 'call', 'put', 'C', or 'P'", + call. = FALSE) + } + normalized +} + +.validate_option_strike <- function(strike) { + if (is.null(strike)) return(NULL) + if (!is.numeric(strike) || length(strike) != 1L || + is.na(strike) || !is.finite(strike) || strike <= 0) { + stop("'strike' must be a single positive number", call. = FALSE) + } + strike +} + +.parse_option_suffix <- function(suffix_id) { + if (is.null(suffix_id) || length(suffix_id) != 1L || + is.na(suffix_id) || !nzchar(suffix_id)) { + stop("'suffix_id' must identify a single option contract", + call. = FALSE) + } + + parsed <- suppressWarnings( + try(parse_suffix(suffix_id, silent = TRUE), silent = TRUE) + ) + if (inherits(parsed, "try-error") || is.null(parsed) || + !all(c("outright", "option") %in% parsed$type) || + length(parsed$format) != 1L || is.na(parsed$format) || + !parsed$format %in% c("opt2", "opt4")) { + stop("'suffix_id' must identify an outright option contract", + call. = FALSE) + } + + day <- if (identical(parsed$format, "opt2")) { + substr(suffix_id, 5L, 6L) + } else { + substr(suffix_id, 7L, 8L) + } + + expiration_text <- sprintf( + "%04d-%02d-%02d", + parsed$year, + match(parsed$month, toupper(month.abb)), + as.integer(day) + ) + expiration <- tryCatch( + suppressWarnings(as.Date(expiration_text)), + error = function(e) as.Date(NA) + ) + if (is.na(expiration)) { + stop("'suffix_id' contains an invalid option expiration date", + call. = FALSE) + } + + parsed_callput <- switch(parsed$right, C = "call", P = "put", NULL) + if (is.null(parsed_callput) || !is.numeric(parsed$strike) || + length(parsed$strike) != 1L || is.na(parsed$strike) || + !is.finite(parsed$strike) || parsed$strike <= 0) { + stop("'suffix_id' contains invalid option contract fields", + call. = FALSE) + } + + list( + expiration = expiration, + callput = parsed_callput, + strike = parsed$strike, + parsed = parsed + ) +} + +.validate_option_series_fields <- function(suffix_id, expires = NULL, + first_traded = NULL, + callput = c("call", "put"), + strike = NULL) { + suffix <- .parse_option_suffix(suffix_id) + + explicit_expiration <- .option_series_date(expires, "expires") + expiration <- if (is.null(explicit_expiration)) { + suffix$expiration + } else { + if (!identical(explicit_expiration, suffix$expiration)) { + warning( + "suffix_id '", suffix_id, "' indicates expiration ", + format(suffix$expiration), ", but expires is ", + format(explicit_expiration), + call. = FALSE + ) + } + explicit_expiration + } + + traded <- .option_series_date(first_traded, "first_traded", + allow_multiple = TRUE) + if (!is.null(traded) && any(traded > expiration)) { + stop("'first_traded' must not be later than 'expires'", + call. = FALSE) + } + + explicit_callput <- .normalize_option_callput(callput) + resolved_callput <- if (is.null(explicit_callput)) { + suffix$callput + } else { + if (!identical(explicit_callput, suffix$callput)) { + warning( + "suffix_id '", suffix_id, "' indicates a ", + suffix$callput, ", but callput is '", explicit_callput, "'", + call. = FALSE + ) + } + explicit_callput + } + + explicit_strike <- .validate_option_strike(strike) + resolved_strike <- if (is.null(explicit_strike)) { + suffix$strike + } else { + if (!isTRUE(all.equal(explicit_strike, suffix$strike, + tolerance = sqrt(.Machine$double.eps)))) { + warning( + "suffix_id '", suffix_id, "' indicates strike ", + format(suffix$strike), ", but strike is ", + format(explicit_strike), + call. = FALSE + ) + } + explicit_strike + } + + list( + expires = format(expiration), + callput = resolved_callput, + strike = resolved_strike + ) +} diff --git a/inst/tinytest/test_option_series.R b/inst/tinytest/test_option_series.R new file mode 100644 index 0000000..814d3ec --- /dev/null +++ b/inst/tinytest/test_option_series.R @@ -0,0 +1,237 @@ +# option_series() contract identity and validation + +rm_instruments(keep.currencies = FALSE) +currency("USD") +stock("SPY", "USD") +option( + ".SPY", + currency = "USD", + multiplier = 100, + tick_size = 0.01, + underlying_id = "SPY" +) + +# Constructing from fields creates an exact-date option identifier. +created <- option_series( + root_id = ".SPY", + expires = "2027-01-15", + callput = "call", + strike = 600 +) +expect_identical(created, "SPY_270115C600") + +contract <- getInstrument(created, type = "option_series") +expect_inherits(contract, "option_series") +expect_inherits(contract, "option") +expect_identical(contract$root_id, ".SPY") +expect_identical(contract$suffix_id, "270115C600") +expect_identical(contract$expires, "2027-01-15") +expect_identical(contract$callput, "call") +expect_equal(contract$strike, 600) +expect_identical(contract$currency, "USD") +expect_equal(contract$multiplier, 100) +expect_equal(contract$tick_size, 0.01) +expect_identical(contract$underlying_id, "SPY") + +# A complete option identifier supplies the exact expiration date, right, +# and strike rather than reducing expiration to year-month. +parsed <- option_series( + "SPY_270115P550", + root_id = ".SPY", + assign_i = FALSE +) +expect_inherits(parsed, "option_series") +expect_identical(parsed$expires, "2027-01-15") +expect_identical(parsed$callput, "put") +expect_equal(parsed$strike, 550) + +# Four-digit years and OSI-style fixed-width strikes are supported. +osi <- option_series( + "SPY_20270115C00600000", + root_id = ".SPY", + assign_i = FALSE +) +expect_identical(osi$expires, "2027-01-15") +expect_identical(osi$callput, "call") +expect_equal(osi$strike, 600) + +# Common call/put aliases are normalized when fields are used to construct +# the identifier. +alias_contract <- option_series( + root_id = ".SPY", + expires = "2027-02-19", + callput = "P", + strike = 500, + assign_i = FALSE +) +expect_identical(alias_contract$primary_id, "SPY_270219P500") +expect_identical(alias_contract$callput, "put") + +# Explicit fields that conflict with the identifier are retained for backward +# compatibility, but the inconsistency is reported. +expect_warning( + option_series( + "SPY_270115C600", + root_id = ".SPY", + expires = "2027-01-16", + assign_i = FALSE + ), + "indicates expiration 2027-01-15" +) +expect_warning( + option_series( + "SPY_270115C600", + root_id = ".SPY", + callput = "put", + assign_i = FALSE + ), + "indicates a call" +) +expect_warning( + option_series( + "SPY_270115C600", + root_id = ".SPY", + strike = 601, + assign_i = FALSE + ), + "indicates strike 600" +) + +# Invalid contract fields fail with domain-specific messages. +expect_error( + option_series( + root_id = ".SPY", + expires = "not-a-date", + callput = "call", + strike = 600, + assign_i = FALSE + ), + "coercible to Date" +) +expect_error( + option_series( + root_id = ".SPY", + expires = "2027-01-15", + callput = "neither", + strike = 600, + assign_i = FALSE + ), + "must be one of" +) +expect_error( + option_series( + root_id = ".SPY", + expires = "2027-01-15", + callput = "call", + strike = 0, + assign_i = FALSE + ), + "positive number" +) +expect_error( + option_series( + "SPY_270231C600", + root_id = ".SPY", + assign_i = FALSE + ), + "invalid option expiration date" +) +expect_error( + option_series( + "SPY_270115C600", + root_id = ".SPY", + first_traded = "2027-01-16", + assign_i = FALSE + ), + "must not be later" +) +expect_error( + option_series( + "SPY_BAD", + root_id = ".SPY", + assign_i = FALSE + ), + "option contract" +) + +# Listed option expirations require an exact calendar date. +expect_error( + option_series( + "SPY_270319C600", + root_id = ".SPY", + expires = "2027-03", + assign_i = FALSE + ), + "coercible to Date" +) + + +# POSIXct expiration values are accepted and normalized. +posix_expiry <- as.POSIXct( + "2027-03-19 16:00:00", + tz = "America/Chicago" +) + +posix_contract <- option_series( + "SPY_270319C600", + root_id = ".SPY", + expires = posix_expiry, + assign_i = FALSE +) + +expect_identical( + posix_contract$expires, + "2027-03-19" +) + + +# POSIXlt expiration values are accepted and normalized. +posixlt_expiry <- as.POSIXlt( + "2027-03-19 16:00:00", + tz = "America/Chicago" +) + +posixlt_contract <- option_series( + "SPY_270319C600", + root_id = ".SPY", + expires = posixlt_expiry, + assign_i = FALSE +) + +expect_identical( + posixlt_contract$expires, + "2027-03-19" +) + + +expect_silent( + option_series( + "SPY_270319C600", + root_id = ".SPY", + expires = as.Date("2027-03-19"), + first_traded = as.POSIXct( + "2027-03-01 09:30:00", + tz = "America/New_York" + ), + assign_i = FALSE + ) +) + +expect_error( + option_series( + "SPY_270319C600", + root_id = ".SPY", + expires = as.POSIXlt( + c( + "2027-03-19 16:00:00", + "2027-03-20 16:00:00" + ), + tz = "America/Chicago" + ), + assign_i = FALSE + ), + "must be a single date" +) + + +rm_instruments(keep.currencies = FALSE)