[Blotter-commits] r1474 - in pkg/FinancialInstrument: . R inst/tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon May 27 04:11:45 CEST 2013
Author: gsee
Date: 2013-05-27 04:11:44 +0200 (Mon, 27 May 2013)
New Revision: 1474
Added:
pkg/FinancialInstrument/inst/tests/test-instrument.R
Modified:
pkg/FinancialInstrument/NEWS
pkg/FinancialInstrument/R/instrument.R
Log:
- the sapply() calls in the instrument wrappers now use simplify=FALSE is
assign_i is FALSE so that a list of instruments is returned. Named lists
of instruments are easy to work with since they can be passed directly to
(re)loadInstruments(), or coerced to an environment with as.environment()
- added some tests
Modified: pkg/FinancialInstrument/NEWS
===================================================================
--- pkg/FinancialInstrument/NEWS 2013-05-26 23:30:38 UTC (rev 1473)
+++ pkg/FinancialInstrument/NEWS 2013-05-27 02:11:44 UTC (rev 1474)
@@ -43,6 +43,14 @@
uses the "%m" format in the as.Date call instead of using the month name with
the (locale-specific) "%b" format. Thanks to Alexis Petit for the patch.
+* when instrument() wrappers were called with vectors of symbols and
+ assign_i=FALSE, the symbols were being returned instead of the instrument
+ objects. Now, when `assign_i=FALSE` and `length(primary_id) > 1`, a
+ named list of instruments will be returned. Named lists of instruments are
+ easy to work with since they can be passed directly to (re)loadInstruments(),
+ or coerced to an environment with as.environment()
+
+
TESTS
-----
Modified: pkg/FinancialInstrument/R/instrument.R
===================================================================
--- pkg/FinancialInstrument/R/instrument.R 2013-05-26 23:30:38 UTC (rev 1473)
+++ pkg/FinancialInstrument/R/instrument.R 2013-05-27 02:11:44 UTC (rev 1474)
@@ -264,9 +264,11 @@
call.=FALSE)
}
if (length(primary_id) > 1) {
- return(unname(sapply(primary_id, stock, currency=currency,
- multiplier=multiplier, tick_size=tick_size,
- identifiers=identifiers, ...=...)))
+ 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, ...,
@@ -287,9 +289,13 @@
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, ...=...)))
+ 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)
@@ -429,10 +435,11 @@
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,
- ...=...)))
+ 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
@@ -597,10 +604,12 @@
stop(paste("'first_traded' and 'expires' must be NULL",
"if calling with multiple primary_ids"))
}
- return(unname(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, ...=...)))
+ 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
@@ -809,8 +818,9 @@
}
}
if (length(primary_id) > 1) {
- return(unname(sapply(primary_id, currency,
- identifiers=identifiers, ...=...)))
+ 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))
@@ -903,8 +913,9 @@
}
if (length(primary_id) > 1) {
- return(unname(sapply(primary_id, exchange_rate, identifiers=identifiers,
- ...=...)))
+ 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)
Added: pkg/FinancialInstrument/inst/tests/test-instrument.R
===================================================================
--- pkg/FinancialInstrument/inst/tests/test-instrument.R (rev 0)
+++ pkg/FinancialInstrument/inst/tests/test-instrument.R 2013-05-27 02:11:44 UTC (rev 1474)
@@ -0,0 +1,27 @@
+context("instruments")
+
+test_that("stock creates stock", {
+ # stock is created and assigned in .instrument environment and the primary_id
+ # of the stock is returned.
+ expect_is(stock("AAA", currency("USD")), "character")
+ expect_is(getInstrument("AAA", type="stock"), "stock")
+ expect_true(is.null(names(stock(c("AAA", "BBB"), "USD"))))
+})
+
+test_that("stock not assigned", {
+ # overwrite=FALSE is ignored because assign_i=FALSE
+ s <- c("BBB", "AAA")
+ ilist <- stock(s, "USD", assign_i=FALSE, overwrite=FALSE)
+ expect_is(ilist, "list")
+ expect_true(all(vapply(ilist, inherits, FUN.VALUE=TRUE, "stock")))
+ expect_identical(names(ilist), s)
+})
+
+test_that("stock overwrite throws errors", {
+ expect_error(stock("AAA", "USD", overwrite=FALSE))
+ rm_stocks("BBB")
+ expect_error(stock(c("BBB", "AAA"), "USD", overwrite=FALSE))
+ # Make sure it didn't define BBB
+ expect_true(!getInstrument("BBB", type="stock", silent=TRUE))
+})
+
More information about the Blotter-commits
mailing list