[Blotter-commits] r1473 - in pkg/FinancialInstrument: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon May 27 01:30:38 CEST 2013
Author: gsee
Date: 2013-05-27 01:30:38 +0200 (Mon, 27 May 2013)
New Revision: 1473
Modified:
pkg/FinancialInstrument/DESCRIPTION
pkg/FinancialInstrument/NEWS
pkg/FinancialInstrument/R/instrument.R
pkg/FinancialInstrument/R/load.instruments.R
pkg/FinancialInstrument/R/synthetic.R
pkg/FinancialInstrument/man/exchange_rate.Rd
pkg/FinancialInstrument/man/instrument.Rd
pkg/FinancialInstrument/man/load.instruments.Rd
pkg/FinancialInstrument/man/option_series.yahoo.Rd
pkg/FinancialInstrument/man/synthetic.instrument.Rd
Log:
- instrument() and most wrappers gain an overwrite argument to allow the user
to ensure that an instrument is not overwritten.
- load.instruments() gains an overwrite argument that is passed through to the
instrument() wrapper functions. Therefore, load.instruments() no longer
checks to see if an instrument already exists. Thanks to Charlie Friedemann
for the patch.
- load.instruments() gains an "identifier_cols" argument that can be used to
pass the names of columns that are to be used as identifiers instead of as
normal instrument attributes. Thanks to Charlie Friedemann for the patch
- minor code formatting; tabs to spaces, etc.
Modified: pkg/FinancialInstrument/DESCRIPTION
===================================================================
--- pkg/FinancialInstrument/DESCRIPTION 2013-05-26 14:22:55 UTC (rev 1472)
+++ pkg/FinancialInstrument/DESCRIPTION 2013-05-26 23:30:38 UTC (rev 1473)
@@ -9,9 +9,9 @@
Contributors: Dirk Eddelbuettel, Alexis Petit, Jeffrey Ryan, Joshua Ulrich
Description: Infrastructure for defining meta-data and
relationships for financial instruments.
-Version: 1.1.8
+Version: 1.1.9
URL: https://r-forge.r-project.org/projects/blotter/
-Date: 2013-03-03
+Date: 2013-05-26
Depends:
R (>= 2.12.0),
quantmod(>= 0.3-17),
Modified: pkg/FinancialInstrument/NEWS
===================================================================
--- pkg/FinancialInstrument/NEWS 2013-05-26 14:22:55 UTC (rev 1472)
+++ pkg/FinancialInstrument/NEWS 2013-05-26 23:30:38 UTC (rev 1473)
@@ -1,10 +1,29 @@
Changes in Version 1.2
======================
+
USER VISIBLE CHANGES
--------------------
+
* saveInstruments() gains a "compress" argument to allow for different
compression than the default ("gzip")
+* instrument() and most of its wrappers gain an "overwrite" argument. The
+ default is TRUE to match previous behavior -- if you try to create an
+ instrument that already exists, the old one will be replaced by
+ the new definition. If overwrite=FALSE is used, there will be an error
+ if you try to define an instrument that has a primary_id that is already
+ in use. Thanks to Charlie Friedemann for the suggestion and discussions.
+
+* load.instruments() gains an overwrite argument that is passed through to the
+ instrument() wrapper functions. Therefore, load.instruments() no longer
+ checks to see if an instrument already exists. Thanks to Charlie Friedemann
+ for the patch.
+
+* load.instruments() gains an "identifier_cols" argument that can be used to
+ pass the names of columns that are to be used as identifiers instead of as
+ normal instrument attributes. Thanks to Charlie Friedemann for the patch.
+
+
BUG FIXES
---------
Modified: pkg/FinancialInstrument/R/instrument.R
===================================================================
--- pkg/FinancialInstrument/R/instrument.R 2013-05-26 14:22:55 UTC (rev 1472)
+++ pkg/FinancialInstrument/R/instrument.R 2013-05-26 23:30:38 UTC (rev 1473)
@@ -104,6 +104,9 @@
#' \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{FinancialInstrument:::.instrument}.
#'
@@ -135,6 +138,9 @@
#' @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
@@ -151,8 +157,9 @@
#' \code{\link{spread}},
#' \code{\link{load.instruments}}
#' @export
-instrument<-function(primary_id , ..., currency , multiplier , tick_size=NULL,
- identifiers = NULL, type=NULL, assign_i=FALSE ){
+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")
}
@@ -198,7 +205,6 @@
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")
@@ -209,13 +215,21 @@
if(is.null(type)) {
tclass="instrument"
} else tclass = unique(c(type,"instrument"))
-
- if (is.currency.name(primary_id)) {
+
+ 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,
@@ -238,11 +252,22 @@
#' @export
#' @rdname instrument
stock <- function(primary_id , currency=NULL , multiplier=1 , tick_size=.01,
- identifiers = NULL, assign_i=TRUE, ...){
+ identifiers = NULL, assign_i=TRUE, overwrite=TRUE, ...){
if (is.null(currency)) stop ("'currency' is a required argument")
- if (length(primary_id) > 1) return(unname(sapply(primary_id, stock,
- currency=currency, multiplier=multiplier, tick_size=tick_size,
- identifiers=identifiers, ...=...)))
+ if (!isTRUE(overwrite) && isTRUE(assign_i) &&
+ any(in.use <- primary_id %in% (li <- ls_instruments()))) {
+ stop(paste(paste0("In stock(...) : ",
+ "overwrite is FALSE and primary_id",
+ if (sum(in.use) > 1) "s are" else " is",
+ " already in use:\n"),
+ paste(intersect(primary_id, li), collapse=", ")),
+ call.=FALSE)
+ }
+ if (length(primary_id) > 1) {
+ return(unname(sapply(primary_id, stock, currency=currency,
+ multiplier=multiplier, tick_size=tick_size,
+ identifiers=identifiers, ...=...)))
+ }
instrument(primary_id=primary_id, currency=currency, multiplier=multiplier,
tick_size=tick_size, identifiers = identifiers, ...,
type="stock", assign_i=assign_i)
@@ -251,8 +276,17 @@
#' @export
#' @rdname instrument
fund <- function(primary_id , currency=NULL , multiplier=1 , tick_size=.01,
- identifiers = NULL, assign_i=TRUE, ...){
+ 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(paste0("In fund(...) : ",
+ "overwrite is FALSE and primary_id",
+ if (sum(in.use) > 1) "s are" else " is",
+ " already in use:\n"),
+ paste(intersect(primary_id, li), collapse=", ")),
+ call.=FALSE)
+ }
if (length(primary_id) > 1) return(unname(sapply(primary_id, fund,
currency=currency, multiplier=multiplier, tick_size=tick_size,
identifiers=identifiers, ...=...)))
@@ -264,9 +298,14 @@
#' @export
#' @rdname instrument
future <- function(primary_id , currency , multiplier , tick_size=NULL,
- identifiers = NULL, assign_i=TRUE, ..., underlying_id=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)) {
@@ -358,6 +397,9 @@
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',
@@ -378,6 +420,15 @@
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)
+ }
return(unname(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,
@@ -389,8 +440,10 @@
#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
@@ -462,15 +515,20 @@
#' @export
#' @rdname instrument
option <- function(primary_id , currency , multiplier , tick_size=NULL,
- identifiers = NULL, assign_i=TRUE, ..., underlying_id=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 {
@@ -496,6 +554,7 @@
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',
@@ -525,6 +584,15 @@
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"))
@@ -540,7 +608,10 @@
#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
@@ -624,6 +695,7 @@
#' @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{http://finance.yahoo.com}
@@ -640,13 +712,8 @@
#' }
#' @export
option_series.yahoo <- function(symbol, Exp, currency="USD", multiplier=100,
- first_traded=NULL, tick_size=NULL) {
+ first_traded=NULL, tick_size=NULL, overwrite=TRUE) {
#FIXME: identifiers?
-
- if (!("package:quantmod" %in% search() ||
- require("quantmod",quietly=TRUE))) {
- stop("Please install quantmod before using this function.")
- }
opts <- getOptionChain(Symbols=symbol,Exp=Exp, src="yahoo")
@@ -657,19 +724,37 @@
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="")))
+ }
+
+ CleanID(optnames[4], "GS")
+ 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(paste0("In option_series.yahoo(...) : ",
+ "overwrite is FALSE and primary_id",
+ if (sum(in.use) > 1) "s are" else " is",
+ " already in use:\n"),
+ paste(intersect(new.ids, li), collapse=", ")),
+ call.=FALSE)
+ }
+ }
+
idout <- NULL
- for (r in optnames) {
- root_id <- symbol
- si <- gsub(symbol,"",r) #suffix_id
- expiry <- substr(si,1,6)
- right <- substr(si,7,7)
- strike <- as.numeric(substr(si,8,15))/1000
-# local <- paste(symbol, si, sep=" ")
- clean.si <- paste(expiry,right,strike,sep="")
- primary_id <- paste(symbol, "_", clean.si, sep="")
-
+ for (ID in id.list) {
#create currency if it doesn't exist #?? Any reason not to ??
- tmpccy <- try(getInstrument(currency,silent=TRUE),silent=TRUE)
+ tmpccy <- try(getInstrument(currency, silent=TRUE), silent=TRUE)
if (!inherits(tmpccy, "currency")) {
warning(paste("Created currency", currency,
"because it did not exist."))
@@ -679,34 +764,32 @@
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)
+ 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=primary_id,
- suffix_id=clean.si,
+ 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(expiry,1,2),
+ substr(ID[["expiry"]], 1, 2),
sep=""),
- substr(expiry,3,4),
- substr(expiry,5,6),
- sep="-")),
- callput=switch(right, C="call", P="put"), #to be consistent with the other option_series function
- strike=strike,
+ 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
+ defined.by='yahoo', assign_i=TRUE, overwrite=overwrite
)
-#option_series(primary_id=primary_id, suffix_id=si, exires=expiry, currency=currency,
-# callput = switch(right,C='call',P='put'))
- idout <- c(idout, primary_id)
+ idout <- c(idout, ID[["primary_id"]])
}
idout
}
@@ -714,6 +797,17 @@
#' @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(paste0("In currency(...) : ",
+ "overwrite is FALSE and primary_id",
+ if (sum(in.use) > 1) "s are" else " is",
+ " already in use:\n"),
+ paste(intersect(primary_id, li), collapse=", ")),
+ call.=FALSE)
+ }
+ }
if (length(primary_id) > 1) {
return(unname(sapply(primary_id, currency,
identifiers=identifiers, ...=...)))
@@ -779,12 +873,16 @@
#' 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, ...){
+ 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)
@@ -794,6 +892,16 @@
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(paste0("In exchange_rate(...) : ",
+ "overwrite is FALSE and primary_id",
+ if (sum(in.use) > 1) "s are" else " is",
+ " already in use:\n"),
+ paste(intersect(primary_id, li), collapse=", ")),
+ call.=FALSE)
+ }
+
if (length(primary_id) > 1) {
return(unname(sapply(primary_id, exchange_rate, identifiers=identifiers,
...=...)))
@@ -819,9 +927,13 @@
#' @export
#' @rdname instrument
bond <- function(primary_id, currency, multiplier, tick_size=NULL,
- identifiers = NULL, assign_i=TRUE, ...){
+ 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 )
@@ -938,7 +1050,8 @@
#' }
#' @export
instrument.auto <- function(primary_id, currency=NULL, multiplier=1, silent=FALSE,
- default_type='unknown', root=NULL, assign_i=TRUE, ...) {
+ 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)) {
Modified: pkg/FinancialInstrument/R/load.instruments.R
===================================================================
--- pkg/FinancialInstrument/R/load.instruments.R 2013-05-26 14:22:55 UTC (rev 1472)
+++ pkg/FinancialInstrument/R/load.instruments.R 2013-05-26 23:30:38 UTC (rev 1473)
@@ -27,6 +27,8 @@
#'
#' You will need to specify a \code{currency}, unless the instrument \code{type} is 'currency'
#'
+#' Use the \code{identifier_cols} argument to specify which fields (if any) in the CSV are to be passed to \code{\link{instrument}} as the \code{identifiers} argument
+#'
#' Typically, columns will exist for \code{multiplier} and \code{tick_size}.
#'
#' Any other columns necessary to define the specified instrument type will also be required to avoid fatal Errors.
@@ -38,6 +40,8 @@
#' @param metadata optional, data.frame containing metadata, default NULL, see Details
#' @param id_col numeric column containing id if primary_id isn't defined, default 1
#' @param default_type character string to use as instrument type fallback, see Details
+#' @param identifier_cols character vector of field names to be passed as identifiers, see Details
+#' @param overwrite TRUE/FALSE. See \code{\link{instrument}}.
#' @seealso
#' \code{\link{loadInstruments}},
#' \code{\link{instrument}},
@@ -52,7 +56,7 @@
#'
#' }
#' @export
-load.instruments <- function (file=NULL, ..., metadata=NULL, id_col=1, default_type='stock') {
+load.instruments <- function (file=NULL, ..., metadata=NULL, id_col=1, default_type='stock', identifier_cols=NULL, overwrite=TRUE) {
if(is.null(file) && is.null(metadata)) stop("You must pass either a file identifier string or a metadata object to be converted.")
if(is.null(metadata)){
@@ -87,51 +91,55 @@
#now process the data
for(rn in 1:nrow(filedata)){
- if(!isTRUE(is.instrument(try(getInstrument(as.character(filedata[rn,id_col]),silent=TRUE),silent=TRUE)))){
- type=as.character(filedata[rn,'type'])
- arg<-as.list(filedata[rn,])
- if(type=='spread' || type=='guaranteed_spread'){
- if(!is.null(arg$members)){
- arg$members<-unlist(strsplit(arg$members,','))
- }
- if(!is.null(arg$memberratio)){
- arg$memberratio<-unlist(strsplit(arg$memberratio,','))
- }
- if(!is.null(arg$ratio)){
- arg$memberratio<-unlist(strsplit(arg$ratio,','))
- }
- }
- arg$type<-NULL
- arg<-arg[!is.na(arg)]
- arg<-arg[!arg==""]
- if (set_primary) {
- arg$primary_id<-filedata[rn,id_col]
+ type <- as.character(filedata[rn,'type'])
+ arg <- as.list(filedata[rn,])
+ if(type=='spread' || type=='guaranteed_spread'){
+ if(!is.null(arg$members)){
+ arg$members<-unlist(strsplit(arg$members,','))
}
+ if(!is.null(arg$memberratio)){
+ arg$memberratio<-unlist(strsplit(arg$memberratio,','))
+ }
+ if(!is.null(arg$ratio)){
+ arg$memberratio<-unlist(strsplit(arg$ratio,','))
+ }
+ }
+ arg$type <- NULL
+ arg <- arg[!is.na(arg)]
+ arg <- arg[!arg==""]
+ if (set_primary) {
+ arg$primary_id<-filedata[rn,id_col]
+ }
+
+ #do some name cleanup to make up for Reuters silliness
+ if(substr(arg$primary_id,1,1)==1) arg$primary_id <- substr(arg$primary_id,2,nchar(arg$primary_id))
+ arg$primary_id<-make.names(arg$primary_id)
+ if(!is.null(arg$X.RIC)){
+ if(substr(arg$X.RIC,1,1)==1) arg$X.RIC <- substr(arg$X.RIC,2,nchar(arg$X.RIC))
+ }
+ if(!is.null(arg$RIC)){
+ if(substr(arg$RIC,1,1)==1) arg$RIC <- substr(arg$RIC,2,nchar(arg$RIC))
+ }
+ if(length(dotargs)) arg<-c(arg,dotargs)
+
+ if(!is.null(identifier_cols) && any(identifier_cols %in% names(arg))){
+ arg$identifiers <- arg[names(arg) %in% identifier_cols]
+ arg[identifier_cols] <- NULL
+ }
+
+ arg$overwrite <- overwrite
+ if(is.function(try(match.fun(type),silent=TRUE))){
+ out <- try(do.call(type,arg))
- #do some name cleanup to make up for Reuters silliness
- if(substr(arg$primary_id,1,1)==1) arg$primary_id <- substr(arg$primary_id,2,nchar(arg$primary_id))
- arg$primary_id<-make.names(arg$primary_id)
- if(!is.null(arg$X.RIC)){
- if(substr(arg$X.RIC,1,1)==1) arg$X.RIC <- substr(arg$X.RIC,2,nchar(arg$X.RIC))
- }
- if(!is.null(arg$RIC)){
- if(substr(arg$RIC,1,1)==1) arg$RIC <- substr(arg$RIC,2,nchar(arg$RIC))
- }
- if(length(dotargs)) arg<-c(arg,dotargs)
- if(is.function(try(match.fun(type),silent=TRUE))){
- out <- try(do.call(type,arg))
- #TODO recover gracefully?
- } else {
- # the call for a function named for type didn't work, so we'll try calling instrument as a generic
- type=c(type,"instrument")
- arg$type<-type # set the type
- arg$assign_i<-TRUE # assign to the environment
- try(do.call("instrument",arg))
- }
- } else {
- warning(filedata[rn,id_col]," already exists in the .instrument environment")
- } # end instrument check
+ #TODO recover gracefully?
+ } else {
+ # the call for a function named for type didn't work, so we'll try calling instrument as a generic
+ type=c(type,"instrument")
+ arg$type<-type # set the type
+ arg$assign_i<-TRUE # assign to the environment
+ try(do.call("instrument",arg))
+ }
} # end loop on rows
}
Modified: pkg/FinancialInstrument/R/synthetic.R
===================================================================
--- pkg/FinancialInstrument/R/synthetic.R 2013-05-26 14:22:55 UTC (rev 1472)
+++ pkg/FinancialInstrument/R/synthetic.R 2013-05-26 23:30:38 UTC (rev 1473)
@@ -14,7 +14,9 @@
#' @export
#' @rdname synthetic.instrument
-synthetic <- function(primary_id=NULL, currency=NULL, multiplier=1, identifiers = NULL, assign_i=TRUE, ..., members=NULL, type="synthetic")
+synthetic <- function(primary_id=NULL, currency=NULL, multiplier=1,
+ identifiers=NULL, assign_i=TRUE, overwrite=TRUE, ...,
+ members=NULL, type="synthetic")
{
if (missing(primary_id) || (is.null(primary_id))) primary_id <- make_spread_id(members)
if (missing(currency) || (is.null(currency))) {
@@ -25,7 +27,10 @@
if (is.instrument(instr)) currency <- instr$currency
}
}
- instrument(primary_id=primary_id , currency=currency , multiplier=multiplier , identifiers = identifiers, assign_i=assign_i, ...=..., type=type, members=members)
+ instrument(primary_id=primary_id , currency=currency ,
+ multiplier=multiplier , identifiers = identifiers,
+ assign_i=assign_i, overwrite=overwrite, ...=..., type=type,
+ members=members)
}
@@ -69,7 +74,11 @@
#' @param assign_i TRUE/FALSE. Should the instrument be assigned in the \code{.instrument} environment?
#' @param type type of instrument; wrappers do not require this.
#' @param root_id instrument identifier for the root contract, default NULL
-#' @param suffix_id identifiers for the member contract suffixes, default NULL, will be split as \code{members}, see Details
+#' @param suffix_id identifiers for the member contract suffixes, default NULL,
+#' will be split as \code{members}, see Details
+#' @param overwrite if FALSE and an instrument with the same \code{primary_id}
+#' is already defined, an error will be thrown and no instruments will be
+#' created.
#' @return called for side effect. stores an instrument in .instrument environment
#' @author Brian Peterson, Garrett See
#' @seealso instrument, future, option_series.yahoo
@@ -81,8 +90,11 @@
#' spread('SPY.DIA','USD',c('SPY','DIA'),c(1,-1))
#' }
#' @export
-synthetic.instrument <- function (primary_id, currency, members, memberratio, ..., multiplier = 1, tick_size=NULL,
- identifiers = NULL, assign_i=TRUE, type = c("synthetic.instrument", "synthetic"))
+synthetic.instrument <- function (primary_id, currency, members,
+ memberratio, ..., multiplier = 1,
+ tick_size=NULL, identifiers = NULL,
+ assign_i=TRUE,
+ type = c("synthetic.instrument", "synthetic"))
{
dargs <- list(...)
if (!is.list(members)) {
@@ -93,10 +105,10 @@
currencies = vector(), memberpositions = NULL)
for (member in members) {
tmp_instr <- try(getInstrument(member, silent=TRUE))
- if (inherits(tmp_instr, "try-error") | !is.instrument(tmp_instr)) {
+ if (inherits(tmp_instr, "try-error") | !is.instrument(tmp_instr)) {
if(missing(currency) || is.null(currency)) {
- stop("'currency' must be provided if member instruments are not defined")
- warning(paste("Instrument", member, "not found, using currency of", currency))
+ stop("'currency' must be provided if member instruments are not defined")
+ warning(paste("Instrument", member, "not found, using currency of", currency))
}
memberlist$currencies[member] <- currency
}
@@ -117,8 +129,7 @@
dargs$expires <- expires
}
}
- }
- else {
+ } else {
warning("passing in members as a list not fully tested")
if (all(do.call(c, lapply(members, is.instrument)))) { #if members is a list of instruments
instrlist <- members
@@ -143,18 +154,19 @@
primary_id <- make_spread_id(members)
if (missing(currency) || is.null(currency))
currency <- as.character(memberlist$currencies[1])
-
+
synthetic(primary_id = primary_id, currency = currency, multiplier = multiplier,
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/blotter -r 1473
More information about the Blotter-commits
mailing list