###############################################################################
# R (http://r-project.org/) Instrument Class Model
#
# Copyright (c) 2009-2012
# Peter Carl, Dirk Eddelbuettel, Jeffrey Ryan,
# Joshua Ulrich, Brian G. Peterson, and Garrett See
#
# This library is distributed under the terms of the GNU Public License (GPL)
# for full details see the file COPYING
#
# $Id$
#
###############################################################################
#.onLoad <- function(lib, pkg) {
# if(!exists('.instrument'))
# .instrument <<- new.env(hash=TRUE)
#}
.instrument <- new.env(parent=emptyenv())
#' class test for object supposedly of type 'instrument'
#' @param x object to test for type
#' @export
is.instrument <- function( x ) {
inherits( x, "instrument" )
}
#' check each element of a character vector to see if it is either the
#' primary_id or an identifier of an \code{\link{instrument}}
#' @param x character vector
#' @return logical vector
#' @export
is.instrument.name <- function(x) {
if (!is.character(x)) return(FALSE)
sapply(lapply(x, getInstrument, silent=TRUE), inherits, "instrument")
}
#' class test for object supposedly of type 'currency'
#' @param x object to test for type
#' @export
is.currency <- function( x ) {
# x<-getInstrument(x, silent=TRUE) # Please use is.currency.name if x is character
inherits( x, "currency" )
}
#' check each element of a character vector to see if it is either the
#' primary_id or an identifier of a \code{\link{currency}}
#' @param x character vector
#' @export
is.currency.name <- function( x ) {
if (!is.character(x)) return(FALSE)
sapply(lapply(x, getInstrument, type='currency', silent=TRUE), inherits,
"currency")
}
#' instrument class constructors
#'
#' All 'currency' instruments must be defined before instruments of other types
#' may be defined.
#'
#' In \dots you may pass any other arbitrary instrument fields that will be used
#' to create 'custom' fields. S3 classes in \R are basically lists with a class
#' attribute. We use this to our advantage to allow us to set arbitrary fields.
#'
#' \code{identifiers} should be a named list to specify other identifiers beyond
#' the \code{primary_id}. Please note that whenever possible, these should
#' still be unique. Perhaps Bloomberg, Reuters-X.RIC, CUSIP, etc.
#' \code{\link{getInstrument}} will return the first (and only the first) match
#' that it finds, starting with the primary_id, and then searching the
#' primary_ids of all instruments for each of the \code{identifiers}. Note that
#' when a large number of instruments are defined, it is faster to find
#' instruments by \code{primary_id} than by \code{identifiers} because it looks
#' for \code{primary_id}s first.
#'
#' The \code{primary_id} will be coerced within reason to a valid \R variable
#' name by using \code{\link{make.names}}. We also remove any leading '1' digit
#' (a simple workaround to account for issues with the Reuters API). If you are
#' defining an instrument that is not a \code{currency}, with a primary_id that
#' already belongs to a \code{currency}, a new primary_id will be create using
#' \code{make.names}. For example, \code{stock("USD", currency("USD"))}, would
#' create a stock with a primary_id of \dQuote{USD.1} instead of overwritting
#' the \code{currency}.
#'
#' Please use some care to choose your primary identifiers so that R won't
#' complain. If you have better regular expression code, we'd be happy to
#' include it.
#'
#' Identifiers will also try to be discovered as regular named arguments passed
#' in via \code{...}. We currently match any of the following:
#' \code{"CUSIP","SEDOL","ISIN","OSI","Bloomberg","Reuters","X.RIC","CQG","TT","Yahoo","Google"}
#' Others may be specified using a named list of identifiers, as described above.
#'
#' \code{assign_i} will use \code{\link{assign}} to place the constructed
#' instrument class object into the \code{.instrument} environment. Most of the
#' special type-specific constructors will use \code{assign_i=TRUE} internally.
#' Calling with \code{assign_i=FALSE}, or not specifying it, will return an
#' object and will \emph{not} store it. Use this option ether to wrap calls to
#' \code{instrument} prior to further processing (and presumably assignment) or
#' to test your parameters before assignment.
#'
#' If \code{overwrite=FALSE} is used, an error will be thrown if any
#' \code{primary_id}s are already in use.
#'
#' As of version 0.10.0, the .instrument environment is located at the top level
#' of the package. i.e. \code{.instrument}.
#'
#' \code{future} and \code{option} are used to define the contract specs of a
#' series of instruments. The \code{primary_id} for these can begin with 1 or
#' 2 dots if you need to avoid overwriting another instrument.
#' For example, if you have a \code{stock} with \sQuote{SPY} as the
#' \code{primary_id}, you could use \sQuote{.SPY} as the \code{primary_id} of
#' the \code{option} specs, and \sQuote{..SPY} as the \code{primary_id} of the
#' single stock \code{future} specs. (or vice versa)
#'
#' You can (optionally) provide a \code{src} argument in which case, it will be
#' used in a call to \code{\link[quantmod]{setSymbolLookup}}.
#' @param primary_id String describing the unique ID for the instrument. Most
#' of the wrappers allow this to be a vector.
#' @param ... Any other passthru parameters, including
#' @param underlying_id For derivatives, the identifier of the instrument that
#' this one is derived from, may be \code{NULL} for cash settled instruments
#' @param currency String describing the currency ID of an object of type
#' \code{\link{currency}}
#' @param multiplier Numeric multiplier to apply to the price in the instrument
#' to get to notional value.
#' @param tick_size The tick increment of the instrument price in it's
#' trading venue, as numeric quantity (e.g. 1/8 is .125)
#' @param identifiers Named list of any other identifiers that should also be
#' stored for this instrument
#' @param type instrument type to be appended to the class definition, typically
#' not set by user
#' @param assign_i TRUE/FALSE. Should the instrument be assigned to the
#' \code{.instrument} environment? Default is FALSE for \code{instrument},
#' TRUE for wrappers.
#' @param overwrite TRUE/FALSE. Should existing instruments with the same
#' primary_id be overwritten? Default is TRUE. If FALSE, an error will be
#' thrown and the instrument will not be created.
#' @aliases
#' stock
#' bond
#' future
#' option
#' currency
#' instrument
#' fund
#' @seealso
#' \code{\link{currency}},
#' \code{\link{exchange_rate}},
#' \code{\link{option_series}},
#' \code{\link{future_series}},
#' \code{\link{spread}},
#' \code{\link{load.instruments}}
#' @export
instrument <- function(primary_id , ..., currency , multiplier , tick_size=NULL,
identifiers = NULL, type=NULL, assign_i=FALSE,
overwrite=TRUE) {
if(is.null(primary_id)) {
stop("you must specify a primary_id for the instrument")
}
raw_id <- primary_id
#deal with leading digits or illegal characters
if(substr(primary_id,1,1)==1) {
primary_id <- substr(primary_id,2,nchar(primary_id))
}
primary_id<-make.names(primary_id)
if(missing(currency) || is.null(currency) ||
(!missing(currency) && !is.currency.name(currency))) {
stop("currency ",currency," must be defined first")
}
if(!hasArg(identifiers) || is.null(identifiers)) identifiers = list()
if(!is.list(identifiers)) {
warning("identifiers",identifiers,"do not appear to be a named list")
}
if (raw_id != primary_id) {
identifiers <- c(identifiers, raw_id=raw_id)
}
arg<-list(...)
if(is.list(arg[['...']])){
if(length(arg)==1) arg <- arg[['...']]
else {
targ<-arg[['...']]
arg[['...']]<-NULL
arg<-c(arg,targ)
}
}
if (!is.null(arg$src)) {
sarg <- list()
sarg[[primary_id]] <- arg$src
setSymbolLookup(sarg)
#arg[["src"]]<-NULL
}
#check for identifiers we recognize
ident_str<-tolower(c("X.RIC", "RIC", "CUSIP", "SEDOL", "OSI", "Bloomberg",
"Reuters", "ISIN", "CQG", "TT", "Yahoo", "Google")) #converted to lowercase for easier case-insensitive matching
lnarg <- tolower(names(arg)) #lower case names of arguments
pos_arg <- which(lnarg %in% ident_str)
identifiers <- c(identifiers, arg[pos_arg])
arg[pos_arg] <- NULL
## TODO note that multiplier could be a time series, probably add code here to check
if(!is.numeric(multiplier) || length(multiplier) > 1) {
stop("multiplier must be a single number")
}
if(!is.null(tick_size) && (!is.numeric(tick_size) | length(tick_size) > 1)) {
stop("tick_size must be NULL or a single number")
}
if(is.null(type)) {
tclass="instrument"
} else tclass = unique(c(type,"instrument"))
if (is.currency.name(primary_id) &&
!inherits(getInstrument(primary_id, type="currency"),
"exchange_rate")) {
oid <- primary_id
primary_id <- tail(make.names(c(ls_instruments(), oid), unique=TRUE), 1)
warning(paste(oid, "is the name of a currency. Using", primary_id,
"for the primary_id of this", type))
identifiers <- c(identifiers, ticker=oid)
} else if ((primary_id %in% ls_instruments()) && !overwrite &&
isTRUE(assign_i)) {
# primary_id already exists and we are not overwriting
stop(paste("an instrument with primary_id", primary_id,
"already exists in the .instrument environment.",
"Set overwrite=TRUE to overwrite."))
}
tmpinstr <- list(primary_id = primary_id,
currency = currency,
multiplier = multiplier,
tick_size=tick_size,
identifiers = identifiers,
type = type)
if(length(arg)>=1) {
tmpinstr <- c(tmpinstr,arg)
}
class(tmpinstr)<-tclass
if(assign_i) {
assign(primary_id, tmpinstr,
envir=as.environment(.instrument) )
return(primary_id)
} else return(tmpinstr)
}
#' @export
#' @rdname instrument
stock <- function(primary_id , currency=NULL , multiplier=1 , tick_size=.01,
identifiers = NULL, assign_i=TRUE, overwrite=TRUE, ...){
if (is.null(currency)) stop ("'currency' is a required argument")
if (!isTRUE(overwrite) && isTRUE(assign_i) &&
any(in.use <- primary_id %in% (li <- ls_instruments()))) {
stop(paste(paste("In stock(...) : ",
"overwrite is FALSE and primary_id",
if (sum(in.use) > 1) "s are" else " is",
" already in use:\n", sep=""),
paste(intersect(primary_id, li), collapse=", ")),
call.=FALSE)
}
if (length(primary_id) > 1) {
out <- sapply(primary_id, stock, currency=currency,
multiplier=multiplier, tick_size=tick_size,
identifiers=identifiers, assign_i=assign_i,
...=..., simplify=assign_i)
return(if (assign_i) unname(out) else out)
}
instrument(primary_id=primary_id, currency=currency, multiplier=multiplier,
tick_size=tick_size, identifiers = identifiers, ...,
type="stock", assign_i=assign_i)
}
#' @export
#' @rdname instrument
fund <- function(primary_id , currency=NULL , multiplier=1 , tick_size=.01,
identifiers = NULL, assign_i=TRUE, overwrite=TRUE, ...){
if (is.null(currency)) stop ("'currency' is a required argument")
if (!isTRUE(overwrite) && isTRUE(assign_i) &&
any(in.use <- primary_id %in% (li <- ls_instruments()))) {
stop(paste(paste("In fund(...) : ",
"overwrite is FALSE and primary_id",
if (sum(in.use) > 1) "s are" else " is",
" already in use:\n", sep=""),
paste(intersect(primary_id, li), collapse=", ")),
call.=FALSE)
}
if (length(primary_id) > 1) {
out <- sapply(primary_id, fund, currency=currency,
multiplier=multiplier, tick_size=tick_size,
identifiers=identifiers, assign_i=assign_i, ...=...,
simplify=assign_i)
return(if (assign_i) unname(out) else out)
}
instrument(primary_id=primary_id, currency=currency,
multiplier=multiplier, tick_size=tick_size,
identifiers=identifiers, ..., type="fund", assign_i=assign_i)
}
#' @export
#' @rdname instrument
future <- function(primary_id , currency , multiplier , tick_size=NULL,
identifiers = NULL, assign_i=TRUE, overwrite=TRUE, ...,
underlying_id=NULL){
if(missing(primary_id)) primary_id <- paste("..",underlying_id,sep="")
if (length(primary_id) > 1) stop('primary_id must be of length 1')
if (!isTRUE(overwrite) && assign_i==TRUE &&
primary_id %in% ls_instruments()) {
stop(sQuote(primary_id), " already in use and overwrite=FALSE")
}
if (missing(currency) && !is.null(underlying_id)) {
uinstr <- getInstrument(underlying_id,silent=TRUE)
if (is.instrument(uinstr)) {
currency <- uinstr$currency
} else stop("'currency' is a required argument")
}
if(is.null(underlying_id)) {
warning("underlying_id should only be NULL for cash-settled futures")
} else {
if(!exists(underlying_id, where=.instrument,
inherits=TRUE)) {
warning("underlying_id not found") # assumes that we know where to look
}
if (primary_id == underlying_id) {
primary_id <- paste("..",primary_id,sep="")
warning(paste('primary_id is the same as underlying_id,',
'the instrument will be given a primary_id of', primary_id))
}
}
instrument(primary_id=primary_id, currency=currency, multiplier=multiplier,
tick_size=tick_size, identifiers = identifiers, ... ,
type="future", underlying_id=underlying_id, assign_i=assign_i)
}
#' Constructors for series contracts
#'
#' Constructors for series contracts on instruments such as options and futures
#'
#' The root \code{instrument} (e.g. the \code{future} or \code{option}) must be
#' defined first.
#'
#' In custom parameters for these series contracts, we have often found it
#' useful to store attributes such as local roll-on and roll-off dates
#' (rolling not on the \code{first_listed} or \code{expires}.
#'
#' For \code{future_series} and \code{option_series} you may either provide a
#' \code{primary_id} (or vector of \code{primary_id}s),
#' OR both a \code{root_id} and \code{suffix_id}.
#'
#' Note that the code for \code{bond} and \code{bond_series} has not been
#' updated recently and may not support all the features supported for
#' \code{option_series} and \code{future_series}. Patches welcome.
#'
#' @param primary_id String describing the unique ID for the instrument. May be
#' a vector for \code{future_series} and \code{option_series}
#' @param root_id String product code or underlying_id, usually something like
#' 'ES' or 'CL' for futures, or the underlying stock symbol (maybe preceded
#' with a dot) for equity options.
#' @param suffix_id String suffix that should be associated with the series,
#' usually something like 'Z9' or 'Mar10' denoting expiration and year.
#' @param first_traded String coercible to Date for first trading day.
#' @param expires String coercible to Date for expiration date
#' @param maturity String coercible to Date for maturity date of bond series.
#' @param callput Right of option; call or put
#' @param strike Strike price of option
#' @param payment_schedule Not currently being implemented
#' @param identifiers Named list of any other identifiers that should also be
#' stored for this instrument.
#' @param assign_i TRUE/FALSE. Should the instrument be assigned in the
#' \code{.instrument} environment?
#' @param overwrite TRUE/FALSE. If FALSE, only \code{first_traded} and
#' \code{expires} will be updated.
#' @param ... any other passthru parameters
#' @aliases
#' option_series
#' future_series
#' bond_series
#' @examples
#' \dontrun{
#' currency("USD")
#' future("ES","USD",multiplier=50, tick_size=0.25)
#' future_series('ES_U1')
#' future_series(root_id='ES',suffix_id='Z11')
#' stock('SPY','USD')
#' option('.SPY','USD',multiplier=100,underlying_id='SPY')
#' #can use either .SPY or SPY for the root_id.
#' #it will find the one that is option specs.
#' option_series('SPY_110917C125', expires='2011-09-16')
#' option_series(root_id='SPY',suffix_id='111022P125')
#' option_series(root_id='.SPY',suffix_id='111119C130')
#' #multiple series instruments at once.
#' future_series(c("ES_H12","ES_M12"))
#' option_series(c("SPY_110917C115","SPY_110917P115"))
#' }
#' @export
#' @rdname series_instrument
future_series <- function(primary_id, root_id=NULL, suffix_id=NULL,
first_traded=NULL, expires=NULL, identifiers = NULL,
assign_i=TRUE, overwrite=TRUE, ...){
# if overwrite==FALSE and assign_i==TRUE, we'll need to know what instruments
# are already defined. Don't bother doing this if we're overwriting anyway
if (!isTRUE(overwrite) && isTRUE(assign_i)) li <- ls_instruments()
if (missing(primary_id)) {
if (all(is.null(c(root_id,suffix_id)))) {
stop(paste('must provide either a primary_id or',
'both a root_id and a suffix_id'))
} else {
if (is.null(suffix_id)) {
sdate <- gsub("-","",expires)
if (is.null(expires) || nchar(sdate) < 6) {
stop("must provide either 'expires' or 'suffix_id'")
}
suffix_id <- paste(M2C()[as.numeric(substr(sdate,5,6))],
substr(sdate,3,4),sep="")
}
primary_id <- paste(gsub("\\.","",root_id), suffix_id, sep="_")
}
} else if (length(primary_id) > 1) {
if (!is.null(expires) || !is.null(first_traded)) {
stop(paste("'first_traded' and 'expires' must be NULL",
"if calling with multiple primary_ids"))
}
if (!isTRUE(overwrite) && isTRUE(assign_i) &&
any(in.use <- primary_id %in% li)) {
stop(paste(paste("In future_series(...) : ",
"overwrite is FALSE and primary_id",
if (sum(in.use) > 1) "s are" else " is",
" already in use:\n", sep=""),
paste(intersect(primary_id, li), collapse=", ")),
call.=FALSE)
}
out <- sapply(primary_id, future_series, root_id=root_id,
suffix_id=suffix_id, first_traded=first_traded,
expires=expires, identifiers = identifiers,
assign_i=assign_i, ...=..., simplify=assign_i)
return(if (assign_i) unname(out) else out)
} else if (is.null(root_id) && !is.null(suffix_id) &&
parse_id(primary_id)$type == 'root') {
#if we have primary_id, but primary_id looks like a root_id, and we have
#suffix_id and don't have root_id then primary_id is really root_id and we
#need to replace primary_id
root_id <- primary_id
primary_id <- paste(root_id, suffix_id, sep="_")
}
if (!isTRUE(overwrite) && isTRUE(assign_i) && primary_id %in% li) {
stop(sQuote(primary_id), " already in use and overwrite=FALSE")
}
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(expires)) {
expires <- paste(pid$year,
sprintf("%02d", match(pid$month, toupper(month.abb))),
sep='-')
#if expires now has an NA in it, set it back to NULL
if (!identical(integer(0), grep("NA",expires))) expires <- NULL
}
contract<-getInstrument(root_id,type='future')
# TODO add check for Date equivalent in first_traded and expires
## with futures series we probably need to be more sophisticated,
## and find the existing series from prior periods (probably years or months)
## and then add the first_traded and expires to the time series bu splicing
#temp_series<-try(getInstrument(primary_id, silent=TRUE),silent=TRUE)
if (!isTRUE(overwrite)) {
temp_series<-try(getInstrument(primary_id, silent=TRUE),silent=TRUE)
if(inherits(temp_series,"future_series")) {
message("updating existing first_traded and expires for ",primary_id)
temp_series$first_traded <- unique(c(temp_series$first_traded,
first_traded))
temp_series$expires<-unique(c(temp_series$expires,expires))
assign(primary_id, temp_series,
envir=as.environment(.instrument))
return(primary_id)
} else warning("No contract found to update. A new one will be created.")
}
args <- list()
args$primary_id <- primary_id
args$root_id <- root_id
args$suffix_id=suffix_id
args$currency = contract$currency
args$multiplier = contract$multiplier
args$tick_size=contract$tick_size
args$identifiers = identifiers
args$first_traded = first_traded
args$type=c("future_series", "future")
args$expires = expires
if (!is.null(contract$exchange)) {
args$exchange <- contract$exchange
}
args$underlying_id = contract$underlying_id
if (!is.null(contract$marketName)) {
args$marketName <- contract$marketName
}
if (!is.null(contract$exchange_id)) {
args$exchange_id <- contract$exchange_id
}
if (!is.null(contract$description)) {
args$series_description <- paste(contract$description, expires)
}
args$assign_i=assign_i
dargs<-list(...)
dargs$currency=NULL
dargs$multiplier=NULL
dargs$type=NULL
if (is.null(dargs$src) && !is.null(contract$src)){
dargs$src <- contract$src
}
args <- c(args, dargs)
do.call(instrument, args)
}
#' @export
#' @rdname instrument
option <- function(primary_id , currency , multiplier , tick_size=NULL,
identifiers = NULL, assign_i=TRUE, overwrite=TRUE,
..., underlying_id=NULL){
if (missing(primary_id)) primary_id <- paste(".",underlying_id,sep="")
if (length(primary_id) > 1) stop("'primary_id' must be of length 1")
if (!isTRUE(overwrite) && assign_i==TRUE &&
primary_id %in% ls_instruments()) {
stop(sQuote(primary_id), " already in use and overwrite=FALSE")
}
if (missing(currency) && !is.null(underlying_id)) {
uinstr <- getInstrument(underlying_id,silent=TRUE)
if (is.instrument(uinstr)) {
currency <- uinstr$currency
} else stop("'currency' is a required argument")
}
if(is.null(underlying_id)) {
warning("underlying_id should only be NULL for cash-settled options")
} else {
if(!exists(underlying_id, where=.instrument,
inherits=TRUE)) {
warning("underlying_id not found") # assumes that we know where to look
}
if (primary_id == underlying_id) {
primary_id <- paste(".",primary_id,sep="")
warning(paste('primary_id is the same as underlying_id,',
'the instrument will be given a primary_id of', primary_id))
}
}
## now structure and return
instrument(primary_id=primary_id, currency=currency, multiplier=multiplier,
tick_size=tick_size, identifiers = identifiers, ..., type="option",
underlying_id=underlying_id, assign_i=assign_i )
}
#' @export
#' @rdname series_instrument
option_series <- function(primary_id , root_id = NULL, suffix_id = NULL,
first_traded=NULL, expires=NULL,
callput=c("call","put"), strike=NULL,
identifiers=NULL, assign_i=TRUE, overwrite=TRUE, ...){
if (!isTRUE(overwrite) && isTRUE(assign_i)) li <- ls_instruments()
if (missing(primary_id) ) {
if (all(is.null(c(root_id,suffix_id)))) {
stop(paste('must provide either a primary_id or',
'both a root_id and a suffix_id'))
} 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."))
}
if (is.null(strike)) {
stop(paste("must provide 'strike' or a 'suffix_id'",
"from which 'strike' can be inferred."))
}
suffix_id <- paste(format(sdate,'%y%m%d'), sright, strike,
sep="")
}
primary_id <- paste(gsub("\\.","",root_id), suffix_id, sep="_")
}
} else if (length(primary_id) > 1) {
if (!isTRUE(overwrite) && isTRUE(assign_i) &&
any(in.use <- primary_id %in% li)) {
stop(paste(paste("In option_series(...) : ",
"overwrite is FALSE and primary_id",
if (sum(in.use) > 1) "s are" else " is",
" already in use:\n", sep=""),
paste(intersect(primary_id, li), collapse=", ")),
call.=FALSE)
}
if (!is.null(expires) || !is.null(first_traded)) {
stop(paste("'first_traded' and 'expires' must be NULL",
"if calling with multiple primary_ids"))
}
out <- sapply(primary_id, option_series, root_id=root_id,
suffix_id=suffix_id, first_traded=first_traded,
expires=expires, callput=callput, strike=strike,
identifiers=identifiers, assign_i=assign_i, ...=...,
simplify=assign_i)
return(if (assign_i) unname(out) else out)
} else if (is.null(root_id) && !is.null(suffix_id) &&
parse_id(primary_id)$type == 'root') {
#if we have primary_id, but primary_id looks like a root_id, and we
#have suffix_id and don't have root_id then primary_id is really
#root_id and we need to replace primary_id
root_id <- primary_id
primary_id <- paste(root_id, suffix_id, sep="_")
}
if (!isTRUE(overwrite) && isTRUE(assign_i) && primary_id %in% li) {
stop(sQuote(primary_id), " already in use and overwrite=FALSE")
}
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'"))
}
}
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")) {
message("updating existing first_traded and expires for ",
primary_id)
temp_series$first_traded <- unique(c(temp_series$first_traded,
first_traded))
temp_series$expires<-unique(c(temp_series$expires,expires))
assign(primary_id, temp_series,
envir=as.environment(.instrument))
return(primary_id)
} else {
warning("No contract found to update. A new one will be created.")
}
} else {
dargs <- list(...)
if (is.null(dargs$src) && !is.null(contract$src)) {
dargs$src <- contract$src
}
instrument( primary_id = primary_id,
root_id = root_id,
suffix_id = suffix_id,
currency = contract$currency,
multiplier = contract$multiplier,
tick_size=contract$tick_size,
first_traded = first_traded,
expires = expires,
identifiers = identifiers,
callput = callput,
strike = strike,
underlying_id = contract$underlying_id,
...=dargs,
type=c("option_series", "option"),
assign_i=assign_i
)
}
}
#' constructor for series of options using yahoo data
#'
#' Defines a chain or several chains of options by looking up necessary info
#' from yahoo.
#'
#' If \code{Exp} is missing it will define only the nearby options.
#' If \code{Exp} is NULL it will define all options
#'
#' If \code{first_traded} and/or \code{tick_size} should not be the same for all
#' options being defined, they should be left NULL and defined outside of this
#' function.
#' @param symbol character vector of ticker symbols of the underlying
#' instruments (Currently, should only be stock tickers)
#' @param Exp Expiration date or dates to be passed to getOptionChain
#' @param currency currency of underlying and options
#' @param multiplier contract multiplier. Usually 100 for stock options
#' @param first_traded first date that contracts are tradeable. Probably not
#' applicable if defining several chains.
#' @param tick_size minimum price change of options.
#' @param overwrite if an instrument already exists, should it be overwritten?
#' @return Called for side-effect. The instrument that is created and stored
#' will inherit option_series, option, and instrument classes.
#' @references Yahoo \url{https://finance.yahoo.com}
#' @author Garrett See
#' @note Has only been tested with stock options.
#' The options' currency should be the same as the underlying's.
#' @seealso \code{\link{option_series}}, \code{\link{option}},
#' \code{\link{instrument}}, \code{\link[quantmod]{getOptionChain}}
#' @examples
#' \dontrun{
#' option_series.yahoo('SPY') #only nearby calls and puts
#' option_series.yahoo('DIA', Exp=NULL) #all chains
#' ls_instruments()
#' }
#' @export
option_series.yahoo <- function(symbol, Exp, currency="USD", multiplier=100,
first_traded=NULL, tick_size=NULL, overwrite=TRUE) {
#FIXME: identifiers?
opts <- getOptionChain(Symbols=symbol,Exp=Exp, src="yahoo")
locals <- function(x) c(grep(symbol, rownames(x$puts), value=TRUE),
grep(symbol, rownames(x$calls), value=TRUE))
if (is.null(opts$calls)) { #if is.null(Exp) we'll get back all chains
led <- (lapply(opts, locals))
optnames <- unname(do.call(c, led)) #FIXME: Is this a reasonable way to get rownames?
} else optnames <- locals(opts) #c(rownames(opts$calls),rownames(opts$puts))
CleanID <- function(x, symbol) {
si <- gsub(symbol, "", x) #suffix_id
out <- list(root_id = symbol,
expiry = substr(si, 1, 6),
right = substr(si, 7, 7),
strike = as.numeric(substr(si, 8, 15))/1000)
clean.si <- with(out, paste(expiry, right, strike, sep=""))
c(out, list(clean.si=clean.si,
primary_id = paste(symbol, "_", clean.si, sep="")))
}
id.list <- lapply(optnames, CleanID, symbol)
if (!isTRUE(overwrite)) {
new.ids <- unname((u <- unlist(id.list))[grep("primary_id", names(u))])
if (any(in.use <- new.ids %in% (li <- ls_instruments()))) {
stop(paste(paste("In option_series.yahoo(...) : ",
"overwrite is FALSE and primary_id",
if (sum(in.use) > 1) "s are" else " is",
" already in use:\n", sep=""),
paste(intersect(new.ids, li), collapse=", ")),
call.=FALSE)
}
}
idout <- NULL
for (ID in id.list) {
#create currency if it doesn't exist #?? Any reason not to ??
tmpccy <- try(getInstrument(currency, silent=TRUE), silent=TRUE)
if (!inherits(tmpccy, "currency")) {
warning(paste("Created currency", currency,
"because it did not exist."))
currency(currency) #create it
}
#create option spec if we need to.
tmpInstr <- try(getInstrument(paste('.',symbol,sep=""), silent=TRUE),
silent=TRUE)
if (!inherits(tmpInstr, "option")) {
warning(paste('Created option specs for root',
paste('.', symbol, sep="")))
option(primary_id=paste('.',symbol,sep=""), currency=currency,
multiplier=multiplier, tick_size=tick_size,
underlying_id=symbol)
}
#create specific option
tempseries = instrument(primary_id=ID[["primary_id"]],
suffix_id=ID[["clean.si"]],
first_traded=first_traded,
currency=currency,
multiplier=multiplier,
tick_size=tick_size,
expires=as.Date(paste(paste('20',
substr(ID[["expiry"]], 1, 2),
sep=""),
substr(ID[["expiry"]], 3, 4),
substr(ID[["expiry"]], 5, 6),
sep="-")),
callput=switch(ID[["right"]], C="call", P="put"), #to be consistent with the other option_series function
strike=ID[["strike"]],
underlying_id=symbol,
type = c("option_series","option"),
defined.by='yahoo', assign_i=TRUE, overwrite=overwrite
)
idout <- c(idout, ID[["primary_id"]])
}
idout
}
#' @export
#' @rdname instrument
currency <- function(primary_id, identifiers = NULL, assign_i=TRUE, ...){
if (hasArg("overwrite")) {
if (!list(...)$overwrite && isTRUE(assign_i) &&
any(in.use <- primary_id %in% (li <- ls_instruments()))) {
stop(paste(paste("In currency(...) : ",
"overwrite is FALSE and primary_id",
if (sum(in.use) > 1) "s are" else " is",
" already in use:\n", sep=""),
paste(intersect(primary_id, li), collapse=", ")),
call.=FALSE)
}
}
if (length(primary_id) > 1) {
out <- sapply(primary_id, currency, identifiers=identifiers,
assign_i=assign_i, ...=..., simplify=assign_i)
return(if (assign_i) unname(out) else out)
}
if (is.null(identifiers)) identifiers <- list()
ccy <- try(getInstrument(primary_id,type='currency',silent=TRUE))
if (is.instrument(ccy)) {
if (length(identifiers) > 0) {
if (!is.list(identifiers)) identifiers <- list(identifiers)
for (nm in names(ccy$identifiers)[names(ccy$identifiers) %in%
names(identifiers)]) {
ccy$identifiers[[nm]] <- identifiers[[nm]]
}
identifiers <- identifiers[names(identifiers)[!names(identifiers)
%in% names(ccy$identifiers)]]
ccy$identifiers <- c(identifiers, ccy$identifiers)
}
} else ccy <- list(primary_id = primary_id,
currency = primary_id,
multiplier = 1,
tick_size= .01,
identifiers = identifiers,
type = "currency")
dargs <- list(...)
if (!is.null(dargs)) {
for (nm in names(ccy)[names(ccy) %in% names(dargs)]) {
ccy[[nm]] <- dargs[[nm]]
}
dargs <- dargs[names(dargs)[!names(dargs) %in% names(ccy)]]
ccy <- c(ccy,dargs)
}
class(ccy)<-c("currency","instrument")
if (assign_i) {
assign(primary_id, ccy,
pos=as.environment(.instrument) )
return(primary_id)
}
ccy
}
#' constructor for spot exchange rate instruments
#'
#' Currency symbols (like any symbol) may be any combination of alphanumeric
#' characters, but the FX market has a convention that says that the first
#' currency in a currency pair is the 'target' and the second currency in the
#' symbol pair is the currency the rate ticks in. So 'EURUSD' can be read as
#' 'USD per 1 EUR'.
#'
#' In \code{FinancialInstrument} the \code{currency} of the instrument should
#' be the currency that the spot rate ticks in, so it will typically be the
#' second currency listed in the symbol.
#'
#' Thanks to Garrett See for helping sort out the inconsistencies in different
#' naming and calculating conventions.
#' @param primary_id string identifier, usually expressed as a currency pair
#' 'USDYEN' or 'EURGBP'
#' @param currency string identifying the currency the exchange rate ticks in
#' @param counter_currency string identifying the currency which the rate uses
#' as the base 'per 1' multiplier
#' @param tick_size minimum price change
#' @param identifiers named list of any other identifiers that should also be
#' stored for this instrument
#' @param assign_i TRUE/FALSE. Should the instrument be assigned in the
#' \code{.instrument} environment? (Default TRUE)
#' @param overwrite \code{TRUE} by default. If \code{FALSE}, an error will
#' be thrown if there is already an instrument defined with the same
#' \code{primary_id}.
#' @param ... any other passthru parameters
#' @references http://financial-dictionary.thefreedictionary.com/Base+Currency
#' @export
exchange_rate <- function (primary_id = NULL, currency = NULL,
counter_currency = NULL, tick_size=0.01,
identifiers = NULL, assign_i=TRUE, overwrite=TRUE,
...){
if (is.null(primary_id) && !is.null(currency) && !is.null(counter_currency)) {
primary_id <- c(outer(counter_currency,currency,paste,sep=""))
same.same <- function(x) substr(x,1,3) == substr(x,4,6)
primary_id <- primary_id[!same.same(primary_id)]
} else if (is.null(primary_id) && (is.null(currency) ||
is.null(counter_currency))) {
stop(paste("Must provide either 'primary_id' or both",
"'currency' and 'counter_currency'"))
}
if (!isTRUE(overwrite) && isTRUE(assign_i) &&
any(in.use <- primary_id %in% (li <- ls_instruments()))) {
stop(paste(paste("In exchange_rate(...) : ",
"overwrite is FALSE and primary_id",
if (sum(in.use) > 1) "s are" else " is",
" already in use:\n", sep=""),
paste(intersect(primary_id, li), collapse=", ")),
call.=FALSE)
}
if (length(primary_id) > 1) {
out <- sapply(primary_id, exchange_rate, identifiers=identifiers,
assign_i=assign_i, ...=..., simplify=assign_i)
return(if (assign_i) unname(out) else out)
}
if (is.null(currency)) currency <- substr(primary_id,4,6)
if (is.null(counter_currency)) counter_currency <- substr(primary_id,1,3)
if(!exists(currency, where=.instrument,inherits=TRUE)) {
warning(paste("currency",currency,"not found")) # assumes that we know where to look
}
if(!exists(counter_currency,
where=.instrument,inherits=TRUE)) {
warning(paste("counter_currency",counter_currency,"not found")) # assumes that we know where to look
}
## now structure and return
instrument(primary_id=primary_id , currency=currency , multiplier=1,
tick_size=tick_size, identifiers = identifiers, ...,
counter_currency=counter_currency,
type=c("exchange_rate","currency"), assign_i=assign_i)
}
#TODO auction dates, coupons, etc for govmt. bonds
#' @export
#' @rdname instrument
bond <- function(primary_id, currency, multiplier, tick_size=NULL,
identifiers = NULL, assign_i=TRUE, overwrite=TRUE, ...){
if (missing(currency)) stop ("'currency' is a required argument")
if (length(primary_id) > 1) stop("'primary_id' must be of length 1 for this function")
if (!isTRUE(overwrite) && isTRUE(assign_i) && primary_id %in% ls_instruments()) {
stop("overwrite is FALSE and the primary_id ", sQuote(primary_id),
" is already in use.")
}
instrument(primary_id=primary_id, currency=currency, multiplier=multiplier,
tick_size=tick_size, identifiers = identifiers, ..., type="bond",
assign_i=assign_i )
}
#' @export
#' @rdname series_instrument
bond_series <- function(primary_id , suffix_id, ..., first_traded=NULL,
maturity=NULL, identifiers = NULL,
payment_schedule=NULL, assign_i=TRUE){
contract<-try(getInstrument(primary_id))
if(!inherits(contract,"bond")) {
stop("bonds contract spec must be defined first")
}
# TODO add check for Date equivalent in first_traded and expires
## with bond series we probably need to be more sophisticated,
## and find the existing series from prior periods (probably years or months)
## and then add the first_traded and expires to the time series by splicing
id<-paste(primary_id, suffix_id,sep="_")
temp_series<-try(getInstrument(id),silent=TRUE)
if(inherits(temp_series,"bond_series")) {
message("updating existing first_traded and maturity for ",id)
temp_series$first_traded<-c(temp_series$first_traded,first_traded)
temp_series$maturity<-c(temp_series$maturity,maturity)
assign(id, temp_series,
envir=as.environment(.instrument))
} else {
dargs<-list(...)
dargs$currency=NULL
dargs$multiplier=NULL
dargs$type=NULL
temp_series = instrument( primary_id = id,
suffix_id=suffix_id,
currency = contract$currency,
multiplier = contract$multiplier,
tick_size=contract$tick_size,
first_traded = first_traded,
maturity = maturity,
identifiers = identifiers,
type=c("bond_series", "bond"),
...=dargs,
assign_i=assign_i
)
}
}
#' Create an instrument based on name alone
#'
#' Given a name, this function will attempt to create
#' an instrument of the appropriate type.
#'
#' If \code{currency} is not already defined, it will be defined (unless it is
#' not 3 uppercase characters). The default value for \code{currency} is
#' \dQuote{USD}. If you do not provide a value for \code{currency},
#' \dQuote{USD} will be defined and used to create the instrument.
#'
#' If \code{primary_id} is 6 uppercase letters and \code{default_type} is not
#' provided, it will be assumed that it is the primary_id of an
#' \code{\link{exchange_rate}}, in which case, the 1st and 2nd half of
#' \code{primary_id} will be defined as \code{\link{currency}}s if not
#' the names of already defined \code{\link{instrument}}s.
#' If the \code{primary_id} begins with a \dQuote{^} it will be assumed that it
#' is a yahoo symbol and that the instrument is an index (synthetic), and the
#' \sQuote{src} will be set to \dQuote{yahoo}.
#' (see \code{\link{setSymbolLookup}})
#'
#' If it is not clear from the \code{primary_id} what type of instrument to
#' create, an instrument of type \code{default_type} will be created (which is
#' 'NULL' by default). This will happen when \code{primary_id} is that of a
#' \code{\link{stock}}, \code{\link{future}}, \code{\link{option}}, or
#' \code{\link{bond}}. This may also happen if \code{primary_id} is that of a
#' \code{\link{future_series}} or \code{\link{option_series}} but the
#' corresponding \code{future} or \code{option} cannot be found. In this case,
#' the instrument type would be \code{default_type}, but a lot of things would
#' be filled in as if it were a valid series instrument (e.g. \sQuote{expires},
#' \sQuote{strike}, \sQuote{suffix_id}, etc.)
#' @param primary_id charater primary identifier of instrument to be created
#' @param currency character name of currency that instrument will be
#' denominated it. Default=\dQuote{USD}
#' @param multiplier numeric product multiplier
#' @param silent TRUE/FALSE. silence warnings?
#' @param default_type What type of instrument to make if it is not clear from
#' the primary_id. ("stock", "future", etc.) Default is NULL.
#' @param root character string to pass to \code{\link{parse_id}} to be used as
#' the root_id for easier/more accurate parsing.
#' @param assign_i TRUE/FALSE. Should the \code{instrument} be assigned in the
#' \code{.instrument} environment?
#' @param ... other passthrough parameters
#' @return Primarily called for its side-effect, but will return the name of the
#' instrument that was created
#' @note This is not intended to be used to create instruments of type
#' \code{stock}, \code{future}, \code{option},
#' or \code{bond} although it may be updated in the future.
#' @author Garrett See
#' @examples
#' \dontrun{
#' instrument.auto("CL_H1.U1")
#' getInstrument("CL_H1.U1") #guaranteed_spread
#'
#' instrument.auto("ES_H1.YM_H1")
#' getInstrument("ES_H1.YM_H1") #synthetic
#'
#' currency(c("USD","EUR"))
#' instrument.auto("EURUSD")
#' getInstrument("EURUSD") #made an exchange_rate
#'
#' instrument.auto("VX_H11") #no root future defined yet!
#' getInstrument("VX_H11") #couldn't find future, didnt make future_series
#' future("VX","USD",1000,underlying_id=synthetic("SPX","USD")) #make the root
#' instrument.auto("VX_H11") #and try again
#' getInstrument("VX_H11") #made a future_series
#' }
#' @export
instrument.auto <- function(primary_id, currency=NULL, multiplier=1, silent=FALSE,
default_type='unknown', root=NULL, assign_i=TRUE,
...) {
##TODO: check formals against dots and remove duplicates from dots before calling constructors to avoid
# 'formal argument "multiplier" matched by multiple actual arguments'
if (!is.null(currency) && !is.currency.name(currency)) {
if (nchar(currency) != 3 || currency != toupper(currency)) {
stop(paste(currency, "is not defined, and it will not be auto",
"defined because it does not appear to be valid."))
}
currency(currency)
if (!silent) message(paste('Created currency', currency,
'because it was not defined.\n'))
}
warned <- FALSE
dargs <- list(...)
primary_id <- make.names(primary_id)
pid <- parse_id(primary_id, root=root)
type <- NULL
if (any(pid$type == 'calendar')) {
return(guaranteed_spread(primary_id, currency=currency,
defined.by='auto', multiplier=multiplier,
assign_i=assign_i, ...))
}
if (any(pid$type == 'butterfly')) {
return(butterfly(primary_id, currency=currency, defined.by='auto',
assign_i=assign_i, ...))
}
if (any(pid$type == 'ICS')) {
root <- getInstrument(pid$root, type='ICS_root', silent=TRUE)
if (is.instrument(root)) {
return(ICS(primary_id, assign_i=assign_i, ...))
} else {
#TODO: look for members in dots
if (!silent) {
warning(paste(primary_id, " appears to be an ICS, ",
"but its ICS_root cannot be found. ",
"Creating _", default_type, "_ instrument instead.",
sep=""))
warned <- TRUE
}
dargs$root_id <- pid$root
dargs$suffix_id <- pid$suffix
dargs$expires <- paste(pid$year,
sprintf("%02d",
month_cycle2numeric(pid$month)),
sep="-")
}
}
if (any(pid$type == 'future') || any(pid$type == 'SSF')) {
root <- getInstrument(pid$root,silent=TRUE,type='future')
if (is.instrument(root) && !inherits(root, 'future_series')) {
if (is.null(currency) && is.null(root[['currency']])) {
if (!isTRUE(silent)) warning('using USD as the currency')
currency <- currency("USD")
}
return(future_series(primary_id, currency=currency,
defined.by='auto', assign_i=assign_i,...))
} else {
if (!isTRUE(silent)) {
warning(paste(primary_id," appears to be a future_series, ",
"but its root cannot be found. ",
"Creating _", default_type,
"_ instrument instead.", sep=""))
if (is.null(currency)){
warning('using USD as the currency')
currency <- currency("USD")
}
warned <- TRUE
}
dargs$root_id <- pid$root
dargs$suffix_id <- pid$suffix
dargs$expires <- paste(pid$year,
sprintf("%02d",
month_cycle2numeric(pid$month)),
sep="-")
}
}
if (any(pid$type == 'option')) {
root <- getInstrument(pid$root,silent=TRUE,type='option')
if (is.instrument(root) && !inherits(root, 'option_series')) {
if (is.null(currency) && is.null(root[['currency']])) {
if (!isTRUE(silent)) warning('using USD as the currency')
currency <- currency("USD")
}
return(option_series(primary_id, currency=currency,
defined.by='auto', assign_i=assign_i, ...))
} else {
if (!isTRUE(silent)) {
warning(paste(primary_id," appears to be an option_series, ",
"but its root cannot be found. Creating _",
default_type, "_ instrument instead.", sep=""))
if (is.null(currency)){
warning('using USD as the currency')
currency <- currency("USD")
}
warned <- TRUE
}
dargs$root_id <- pid$root
dargs$suffix_id <- pid$suffix
dargs$expires <- if(pid$format == 'opt2') {
as.Date(substr(pid$suffix,1,6),format='%y%m%d')
} else if (pid$format == 'opt4') {
as.Date(substr(pid$suffix,1,8),format='%Y%m%d')
} else paste(pid$year, sprintf("%02d",
month_cycle2numeric(pid$month)),
sep="-")
dargs$multiplier=100
dargs$callput <- switch(pid$right, C='call', P='put')
dargs$strike <- pid$strike
}
}
if (any(pid$type == 'exchange_rate'))
return(exchange_rate(primary_id, defined.by='auto', assign_i=assign_i,
...))
#if we weren't given a default_type, then if it's 6 uppercase letters, make an exchange rate
if (default_type == 'unknown' && nchar(primary_id) == 6 &&
sum(attr(gregexpr("[A-Z]",primary_id)[[1]],"match.length")) == 6) {
if (!is.instrument(getInstrument(substr(primary_id,1,3), silent=TRUE))) {
ccy.st <- currency(substr(primary_id,1,3), defined.by='auto')
if (!silent) {
message(paste("Created currency", ccy.st,
"because it was not defined."))
}
}
if (!is.instrument(getInstrument(substr(primary_id,4,6), silent=TRUE))) {
ccy.st <- currency(substr(primary_id,4,6), defined.by='auto')
if (!silent) { message(paste("Created currency", ccy.st,
"because it was not defined."))
}
}
return(exchange_rate(primary_id, defined.by='auto', assign_i=assign_i, ...))
}
if (any(pid$type == 'synthetic')) {
if (!is.na(pid$format) && pid$format == 'yahooIndex') {
if (is.null(currency)) {
if (!silent) {
warning(paste('currency will be assumed to be USD',
'because NULL is not a currency.'))
}
currency <- currency('USD')
}
return(synthetic(gsub("\\^","",primary_id), currency=currency,
multiplier=multiplier,
identifiers=list(yahoo=primary_id),
src=list(src='yahoo',name=primary_id),
defined_by='auto', assign_i=assign_i, ...))
} else {
members <- strsplit(primary_id,"\\.")[[1]]
if (!all(is.instrument.name(members))) {
# at least 1 member is not defined, so we have to assume this
# is an index (e.g. TICK-NYSE)
if (is.null(currency)) {
if (!silent) {
warning(paste('currency will be assumed to be USD',
'because NULL is not a currency.'))
}
currency <- currency('USD')
}
return(synthetic(primary_id, currency=currency,
multiplier=multiplier, defined.by='auto',
assign_i=assign_i, ...))
}
# if all members are already defined, we'll pass those to synthetic
# and let it figure out currency.
return(synthetic(members=members, currency=currency,
multiplier=multiplier, defined.by='auto',
assign_i=assign_i, ...) )
}
}
if (any(pid$type == 'root')) {
if (primary_id %in% c(paste(pid$root, "O", sep="."),
paste(pid$root, "OQ", sep="."))) {
#X.RIC for NASDAQ stock. e.g. AAPL.O, MSFT.OQ
return(stock(pid$root, currency=currency('USD'),
multiplier=multiplier,
identifiers=list(X.RIC=primary_id), defined.by='auto',
assign_i=assign_i, ...))
#update_instruments.yahoo(pid$root)
}
}
ss <- strsplit(primary_id," ")[[1]] #take out spaces (OSI uses spaces, but makenames would turn them into dots)
ss <- ss[!ss %in% ""]
if (length(ss) == 2) primary_id <- paste(ss,collapse="_")
dargs$primary_id <- primary_id
dargs$currency <- if (!is.null(currency)) {
currency
} else {
if (!silent) warning('using USD as the currency'); currency("USD")
}
dargs$multiplier <- multiplier
dargs$defined.by='auto'
dargs$assign_i <- assign_i
if(is.function(try(match.fun(default_type),silent=TRUE))) {
if (!silent && !warned)
warning('Creating a _', default_type, '_ instrument because ',
primary_id, ' is of an ambiguous format.')
return(do.call(default_type, dargs))
}
if (!silent && !warned)
warning(paste(primary_id, 'is not of an unambiguous format.',
'Creating _unknown_ instrument with multiplier 1.'))
dargs$type <- 'unknown'
do.call(instrument, dargs)
}
#' Primary accessor function for getting objects of class 'instrument'
#'
#' This function will search the \code{.instrument} environment for objects of
#' class \code{type}, using first the \code{primary_id} and then any
#' \code{identifiers} to locate the instrument. Finally, it will try adding 1
#' and then 2 dots to the beginning of the \code{primary_id} to see if an
#' instrument was stored there to avoid naming conflicts.
#'
#' \code{\link{future}} and \code{\link{option}} objects may have a primary_id
#' that begins with 1 or 2 dots (in order to avoid naming conflics). For
#' example, the root specs for options (or futures) on the stock with ticker
#' "SPY" may be stored with a primary_id of "SPY", ".SPY", or "..SPY".
#' \code{getInstrument} will try using each possible \code{primary_id}
#' until it finds an instrument of the appropriate \code{type}
#' @param x String identifier of instrument to retrieve
#' @param Dates date range to retrieve 'as of', may not currently be implemented
#' @param silent if TRUE, will not warn on failure, default FALSE
#' @param type class of object to look for. See Details
#' @examples
#' \dontrun{
#' option('..VX', multiplier=100,
#' underlying_id=future('.VX',multiplier=1000,
#' underlying_id=synthetic('VIX', currency("USD"))))
#'
#' getInstrument("VIX")
#' getInstrument('VX') #returns the future
#' getInstrument("VX",type='option')
#' getInstrument('..VX') #finds the option
#' }
#' @export
#' @rdname getInstrument
getInstrument <- function(x, Dates=NULL, silent=FALSE, type='instrument'){
tmp_instr <- try(get(x,pos=.instrument),silent=TRUE)
if(inherits(tmp_instr,"try-error") || !inherits(tmp_instr, type)){
xx <- make.names(x)
## First, look to see if x matches any identifiers.
# unlist all instruments into a big named vector
ul.instr <- unlist(as.list(.instrument,
all.names=TRUE))
# subset by names that include "identifiers"
ul.ident <- ul.instr[grep('identifiers', names(ul.instr))]
# if x (or make.names(x)) is in the identifiers subset, extract the
# primary_id from the name
tmpname <- ul.ident[ul.ident %in% unique(c(x, xx))]
# if x was not in ul.ident, tmpname will == named character(0)
if (length(tmpname) > 0) {
#primary_id is everything before .identifiers
id <- gsub("\\.identifiers.*", "", names(tmpname))
tmp_instr <- try(get(id, pos=.instrument),
silent=TRUE)
if (inherits(tmp_instr, type)) {
#&& (x %in% tmp_instr$identifiers || x %in% make.names(tmp_instr$identifiers))
return(tmp_instr)
}
}
#If not found, see if it begins with dots (future or option root)
#Remove any dots at beginning of string and add them back 1 at a time
# to the beginning of id.
char.x <- strsplit(x, "")[[1]] # split x into vector of characters
x <- substr(x, grep("[^\\.]", char.x)[1], length(char.x)) # excluding leading dots
tmp_instr<-try(get(x,pos=.instrument),silent=TRUE)
if(!inherits(tmp_instr,type)) {
tmp_instr<-try(get(paste(".",x,sep=""),
pos=.instrument),
silent=TRUE)
if(!inherits(tmp_instr,type)) {
tmp_instr<-try(get(paste("..",x,sep=""),
pos=.instrument),
silent=TRUE)
}
}
if (inherits(tmp_instr, type)) return(tmp_instr)
if(!silent) warning(paste(type,x,"not found, please create it first."))
return(FALSE)
} else{
return(tmp_instr)
}
#TODO add Date support to instrument, to get the proper value given a specific date
}
#' Add or change an attribute of an instrument
#'
#' This function will add or overwrite the data stored in the specified slot of
#' the specified instrument.
#'
#' If the \code{attr} you are trying to change is the \dQuote{primary_id,} the
#' instrument will be renamed. (A copy of the instrument will be stored by the
#' name of \code{value} and the old instrument will be removed.)
#' If the \code{attr} you are changing is \dQuote{type}, the instrument will be
#' reclassed with that type. If \code{attr} is \dQuote{src}, \code{value} will
#' be used in a call to \code{setSymbolLookup}. Other checks are in place to
#' make sure that \dQuote{currency} remains a \code{\link{currency}} object and
#' that \dQuote{multiplier} and \dQuote{tick_size} can only be changed to
#' reasonable values.
#'
#' If \code{attr} is \dQuote{identifiers} and \code{value} is \code{NULL},
#' \code{identifiers} will be set to \code{list()}. If \code{value} is not a
#' list, \code{\link{add.identifier}} will be called with \code{value}.
#' \code{add.identifier} will convert \code{value} to a list and append it to
#' the current \code{identifiers}
#' @param primary_id primary_id of the instrument that will be updated
#' @param attr Name of the slot that will be added or changed
#' @param value What to assign to the \code{attr} slot of the \code{primary_id}
#' instrument
#' @param ... arguments to pass to \code{getInstrument}. For example,
#' \code{type} could be provided to allow for \code{primary_id} to be an
#' identifier that is shared by more that one instrument (of different types)
#' @return called for side-effect
#' @note You can remove an attribute/level from an instrument by calling this
#' function with \code{value=NULL}
#' @examples
#' \dontrun{
#' currency("USD")
#' stock("SPY","USD")
#' instrument_attr("USD","description","U.S. Dollar")
#' instrument_attr("SPY", "description", "An ETF")
#' getInstrument("USD")
#' getInstrument("SPY")
#'
#' #Call with value=NULL to remove an attribute
#' instrument_attr("SPY", "description", NULL)
#' getInstrument("SPY")
#'
#' instrument_attr("SPY","primary_id","SPX") #move/rename it
#' instrument_attr("SPX","type","synthetic") #re-class
#' instrument_attr("SPX","src",list(src='yahoo',name='^GSPC')) #setSymbolLookup
#' getSymbols("SPX") #knows where to look because the last line setSymbolLookup
#' getInstrument("SPX")
#' }
#' @export
instrument_attr <- function(primary_id, attr, value, ...) {
instr <- try(getInstrument(primary_id, silent=TRUE, ...))
if (inherits(instr, 'try-error') || !is.instrument(instr))
stop(paste('instrument ',primary_id,' must be defined first.',sep=''))
if (attr == 'primary_id') {
rm(list = primary_id, pos = .instrument)
} else if (attr == 'currency') {
if (!is.currency.name(value)) {
stop("currency ", value, " must be an object of type 'currency'")
}
} else if (attr == 'multiplier') {
if (!is.numeric(value) || length(value) > 1) {
stop("multiplier must be a single number")
}
} else if (attr == 'tick_size') {
if (!is.null(value) && (!is.numeric(value) || length(value) > 1)) {
stop("tick_size must be NULL or a single number")
}
} else if (attr == 'type') {
tclass <- unique(c(value, "instrument"))
class(instr) <- tclass
} else if (attr == 'IB') {
if (inherits(value, 'twsContract')) {
class(instr) <- unique(c(class(instr)[1], 'twsInstrument',
class(instr)[-1]))
} else {
warning('non-twsContract assigned to $IB')
class(instr) <- class(instr)[!class(instr) %in% 'twsInstrument']
}
} else if (attr == 'src') {
sarg <- list()
sarg[[instr$primary_id]] <- value
setSymbolLookup(sarg)
} else if (attr == 'identifiers') {
if (length(value) == 0) {
value <- list()
} else if (!is.list(value)) {
#warning("identifiers must be a list. Appending current identifiers.")
# add.identifier will convert to list
return(add.identifier(primary_id, value))
}
}
instr[[attr]] <- value
assign(instr$primary_id, instr, pos=.instrument)
}
#' Add an identifier to an \code{instrument}
#'
#' Add an identifier to an \code{\link{instrument}} unless the instrument
#' already has that identifier.
#' @param primary_id primary_id of an \code{\link{instrument}}
#' @param ... identifiers passed as regular named arguments.
#' @return called for side-effect
#' @author Garrett See
#' @seealso \code{\link{instrument_attr}}
#' @examples
#' \dontrun{
#' stock("XXX", currency("USD"))
#' add.identifier("XXX", yahoo="^XXX")
#' getInstrument("^XXX")
#' add.identifier("^XXX", "x3")
#' all.equal(getInstrument("x3"), getInstrument("XXX")) #TRUE
#' }
#' @export
add.identifier <- function(primary_id, ...) {
new.ids <- as.list(unlist(list(...)))
instr <- getInstrument(primary_id)
if (!inherits(instr, "instrument")) {
stop(paste(primary_id, "is not a defined instrument"))
}
ids <- c(instr[["identifiers"]], new.ids)
if (all(is.null(names(ids)))) {
instrument_attr(primary_id, "identifiers", unique(ids))
} else instrument_attr(primary_id, "identifiers",
ids[!(duplicated(unlist(ids)) & duplicated(names(ids)))])
}
#' Add a source to the defined.by field of an \code{instrument}
#'
#' Concatenate a string or strings (passed through dots) to the defined.by
#' field of an instrument (separated by semi-colons). Any duplicates will be
#' removed. See Details.
#'
#' If there is already a value for the \code{defined.by} attribute of the
#' \code{primary_id} instrument, that string will be split on semi-colons and
#' converted to a character vector. That will be \code{c}ombined with any new
#' strings (in \code{...}). The unique value of this new vector will then
#' be converted into a semi-colon delimited string that will be assigned to
#' the \code{defined.by} attribute of the \code{primary_ids}' instruments
#'
#' Many functions that create or update instrument definitions will also add or
#' update the value of the defined.by attribute of that instrument. If an
#' instrument has been updated by more than one function, it's \code{defined.by}
#' attribute will likely be a semi-colon delimited string (e.g.
#' \dQuote{TTR;yahoo}).
#' @param primary_ids character vector of primary_ids of
#' \code{\link{instrument}}s
#' @param ... strings, or character vector, or semi-colon delimited string.
#' @return called for side-effect
#' @author Garrett See
#' @seealso \code{\link{add.identifier}}, \code{\link{instrument_attr}}
#' @examples
#' \dontrun{
#' update_instruments.TTR("GS")
#' getInstrument("GS")$defined.by #TTR
#' add.defined.by("GS", "gsee", "demo")
#' add.defined.by("GS", "gsee;demo") #same
#' }
#' @export
add.defined.by <- function(primary_ids, ...) {
for(id in primary_ids) {
db <- getInstrument(id)[["defined.by"]]
instrument_attr(id, "defined.by",
paste(unique(c(unlist(strsplit(db, ";")),
unlist(strsplit(unlist(list(...)), ";")))), collapse=";"))
}
}
#' instrument class print method
#'
#' @author Joshua Ulrich, Garrett See
#' @keywords internal
#' @export
print.instrument <- function(x, ...) {
str(unclass(x), comp.str="", no.list=TRUE, give.head=FALSE,
give.length=FALSE, give.attr=FALSE, nest.lev=-1, indent.str="")
invisible(x)
}
#' instrument class sort method
#'
#' @author Garrett See
#' @keywords internal
#' @export
sort.instrument <- function(x, decreasing=FALSE, na.last=NA, ...) {
anchored <- x[c("primary_id", "currency", "multiplier", "tick_size",
"identifiers", "type")]
sortable <- x[setdiff(names(x), names(anchored))]
out <- c(anchored, sortable[order(names(sortable), decreasing=decreasing,
na.last=na.last, ...)])
class(out) <- class(x)
out
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.