quantmod/ 0000755 0001762 0000144 00000000000 15025063626 012107 5 ustar ligges users quantmod/tests/ 0000755 0001762 0000144 00000000000 15024564471 013254 5 ustar ligges users quantmod/tests/test-Defaults.R 0000644 0001762 0000144 00000007071 15024564471 016130 0 ustar ligges users ### NOTE
# These tests are not with the rest of the test suite because setDefaults()
# only works with language symbol arguments at the top level. tinytest runs
# all tests in an environment that's different from the Global Environment.
library(quantmod)
options(useFancyQuotes = FALSE)
api.key <- "abc"
src <- "xyz"
# {{{ Unexported function
### function name as character
### --------------------------
## default argument as character
# set
setDefaults("getQuote.av", api.key = "abc")
default.key <- getDefaults("getQuote.av")[["api.key"]]
stopifnot(identical("'abc'", default.key))
# unset
unset <- unsetDefaults("getQuote.av", confirm = FALSE)
stopifnot(!is.null(unset)) # should not be NULL
default.key <- getDefaults("getQuote.av")[["api.key"]]
stopifnot(is.null(default.key))
## default argument as symbol
# set
setDefaults("getQuote.av", api.key = api.key)
default.key <- getDefaults("getQuote.av")[["api.key"]]
stopifnot(identical(sQuote(api.key), default.key))
# unset
unset <- unsetDefaults("getQuote.av", confirm = FALSE)
stopifnot(!is.null(unset)) # should not be NULL
default.key <- getDefaults("getQuote.av")[["api.key"]]
stopifnot(is.null(default.key))
### function name as symbol
### -----------------------
## default argument as character
# set
setDefaults(getQuote.av, api.key = "abc")
default.key <- getDefaults(getQuote.av)[["api.key"]]
stopifnot(identical("'abc'", default.key))
# unset
unset <- unsetDefaults(getQuote.av, confirm = FALSE)
stopifnot(!is.null(unset)) # should not be NULL
default.key <- getDefaults(getQuote.av)[["api.key"]]
stopifnot(is.null(default.key))
## default argument as symbol
fake.key <- "abc"
# set
setDefaults(getQuote.av, api.key = fake.key)
default.key <- getDefaults(getQuote.av)[["api.key"]]
stopifnot(identical(sQuote(fake.key), default.key))
# unset
unset <- unsetDefaults(getQuote.av, confirm = FALSE)
stopifnot(!is.null(unset)) # should not be NULL
default.key <- getDefaults(getQuote.av)[["api.key"]]
stopifnot(is.null(default.key))
# }}} Unexported function
# {{{ Exported function
### function name as character
### --------------------------
## default argument as character
# set
setDefaults("getSymbols", src = "xyz")
default.src <- getDefaults("getSymbols")[["src"]]
stopifnot(identical("'xyz'", default.src))
# unset
unset <- unsetDefaults("getSymbols", confirm = FALSE)
stopifnot(!is.null(unset)) # should not be NULL
default.src <- getDefaults("getSymbols")[["src"]]
stopifnot(is.null(default.src))
## default argument as symbol
# set
setDefaults("getSymbols", src = src)
default.src <- getDefaults("getSymbols")[["src"]]
stopifnot(identical("'xyz'", default.src))
# unset
unset <- unsetDefaults("getSymbols", confirm = FALSE)
stopifnot(!is.null(unset)) # should not be NULL
default.src <- getDefaults("getSymbols")[["src"]]
stopifnot(is.null(default.src))
### function name as symbol
### -----------------------
## default argument as character
# set
setDefaults(getSymbols, src = "xyz")
default.src <- getDefaults(getSymbols)[["src"]]
stopifnot(identical("'xyz'", default.src))
# unset
unset <- unsetDefaults(getSymbols, confirm = FALSE)
stopifnot(!is.null(unset)) # should not be NULL
default.src <- getDefaults(getSymbols)[["src"]]
stopifnot(is.null(default.src))
## default argument as symbol
# set
setDefaults(getSymbols, src = src)
default.src <- getDefaults(getSymbols)[["src"]]
stopifnot(identical("'xyz'", default.src))
# unset
unset <- unsetDefaults(getSymbols, confirm = FALSE)
stopifnot(!is.null(unset)) # should not be NULL
default.src <- getDefaults(getSymbols)[["src"]]
stopifnot(is.null(default.src))
# }}} Exported function
quantmod/tests/tinytest.R 0000644 0001762 0000144 00000000703 15002467345 015260 0 ustar ligges users # run package unit tests
if (requireNamespace("tinytest", quietly = TRUE)) {
suppressPackageStartupMessages(library("quantmod"))
use_color <- as.logical(Sys.getenv("_PKG_TINYTEST_COLOR_", FALSE))
verbosity <- as.integer(Sys.getenv("_PKG_TINYTEST_VERBOSE_", 1))
cat("tinytest colored output:", use_color,
"\ntinytest verbosity:", verbosity, "\n")
tinytest::test_package("quantmod", color = use_color, verbose = verbosity)
}
quantmod/tests/test-misc.R 0000644 0001762 0000144 00000004527 14774073440 015321 0 ustar ligges users av.key <- Sys.getenv("QUANTMOD_AV_API_KEY")
tiingo.key <- Sys.getenv("QUANTMOD_TIINGO_API_KEY")
test.web.endpoints <- Sys.getenv("QUANTMOD_TEST_WEB_ENDPOINTS")
# Call as.zoo before quantmod is loaded and registers its S3 method
dc <- c("2015-01-01", "2016-01-01", "2017-01-01")
dd <- as.Date(dc)
f <- data.frame(a = 1:3)
r <- f
rownames(r) <- dc
zz.f.date <- zoo::as.zoo(f, order.by = dd)
zz.f.char <- zoo::as.zoo(f, order.by = dc)
zz.f <- zoo::as.zoo(f)
zz.r.date <- zoo::as.zoo(r, order.by = dd)
zz.r.char <- zoo::as.zoo(r, order.by = dc)
zz.r <- zoo::as.zoo(r)
library(quantmod)
### quantmod:::as.zoo.data.frame
# should be the same as zoo:::as.zoo.data.frame when order.by is provided
stopifnot(identical(zz.f.char, as.zoo(f, order.by = dc)))
stopifnot(identical(zz.f.date, as.zoo(f, order.by = dd)))
stopifnot(identical(zz.r.char, as.zoo(r, order.by = dc)))
stopifnot(identical(zz.r.date, as.zoo(r, order.by = dd)))
if (nzchar(test.web.endpoints)) {
# should throw an error
errorKey <- "d116c846835e633aacedb1a31959dd2724cd67b8"
x <- try(
quantmod::getSymbols("AAPL", src = "tiingo", data.type = "csv", api.key = errorKey)
, silent = TRUE)
stopifnot(inherits(x, "try-error"))
x <- try(
quantmod::getSymbols("AAPL", src = "tiingo", data.type = "json", api.key = errorKey)
, silent = TRUE)
stopifnot(inherits(x, "try-error"))
syms <- c("SPY", "WYSIWYG")
symstr <- paste(syms, collapse = ";")
x <- try(getQuote(symstr, src = "yahoo"), silent = TRUE)
stopifnot(inherits(x, "data.frame") && all(rownames(x) == syms))
stopifnot(!is.na(x["SPY", "Last"]) && is.na(x["WYSIWYG", "Last"]))
#test batch handling
x <- getQuote(c("SPY", paste0(LETTERS, 1:199), "IWM"), src = "yahoo")
stopifnot(inherits(x, "data.frame") && nrow(x) == 201L)
if (av.key != "") {
x <- try(getQuote(symstr, src = "av", api.key = av.key), silent = TRUE)
stopifnot(inherits(x, "data.frame") && all(rownames(x) == syms))
}
if (tiingo.key != "") {
x <- try(getQuote(symstr, src = "tiingo", api.key = tiingo.key), silent = TRUE)
stopifnot(inherits(x, "data.frame") && all(rownames(x) == syms))
}
# ensure symbol order is preserved
syms <- sample(c("SPY", "TLT", "IWM", "QQQ", "WYSIWYG"))
x <- try(getQuote(syms, src = "yahoo"), silent = TRUE)
stopifnot(inherits(x, "data.frame") && all(rownames(x) == syms))
}
quantmod/MD5 0000644 0001762 0000144 00000016373 15025063626 012431 0 ustar ligges users 409c4286df5b8701a6272ddf27ece681 *DESCRIPTION
af925f02ac9f38e7251bb02eda1590d4 *NAMESPACE
a64e1ea2cba9e2df686d876b10770c99 *NEWS.md
02d0bc2c534d9628859ba7bf5a4a1357 *R/Defaults.R
00055294181660cc4b2e22a042949d60 *R/OHLC.transformations.R
309d60f2a70e2c5cf52f6a1ee0fab7b6 *R/Price.transformations.R
09a54ce40bdb58e7a9f441568ea9b22e *R/SymbolLookup.R
1544c0789a5c0c1583f489260b5db351 *R/TA.R
00ad99d89afa48a302dffa2cb3dd6435 *R/addAroon.R
825af5a63720291e1819f730769c6735 *R/addCLV.R
502442136ac6c52d9261b1aed161987b *R/addCMF.R
eb08d54848a6791222e2ac56ca249c47 *R/addCMO.R
b05bb2018824b4848142635623a6797a *R/addChaikin.R
1887312d5d0dd80fc27e4a1cf9368fb3 *R/addEMV.R
4d60b4771d54e5ea8300f2811d8419f1 *R/addKST.R
d2893f990b3be741a531bbdd2646a910 *R/addMFI.R
d06e8523237e971e6f8c5de7d7eb6830 *R/addOBV.R
f599c02f921f247bbb81a82a97617812 *R/addSMI.R
b08ce661464cde6b1a16e3c5717475cc *R/addTA.R
1924f59377e51122577e642720617c8d *R/addTDI.R
85423aaa0174beab59daddc3874af179 *R/addVo.R
dd6c35740031d9202898eea236dbd6e1 *R/addVolatility.R
ba032b32342f94c409775e032a6c8908 *R/addWPR.R
e82fc436823a3ea3bb258832af7796d7 *R/addZigZag.R
74a2d4c04fda69ec3a1a5565685b3507 *R/add_Last.R
d08f59308999c4d4d1f0cb9c2d37aa29 *R/adjustOHLC.R
dd80570b5f18aa4aeab9a3ca6c832e97 *R/attachSymbols.R
4d838787166eed631b194708bd7c2030 *R/axTicksByTime2.R
76afeb22c2c2c41bfdbc99f711329697 *R/buildModel.R
6767384c2917d19a199aa6b287581c7b *R/buildModel.methods.R
fc284e92a5bd1685aeb362bd42022e34 *R/chartSeries.R
fe375ff9c936b6a45920b4429ee175f2 *R/chartSeries.chob.R
aefda48d906e50545cc8dac74db80542 *R/chart_Series.R
22cdae299dafdc7504d77863a19f7996 *R/chob.R
0ff2ddb2c87969047fab8880c5321d58 *R/dropTA.R
cbb6427fefaa0a2579843886ac83d534 *R/gainloss.R
0f696a431bcf76bc6be9d7c69c6ae222 *R/getDividends.R
9da14edfa7993e67759d3c83a24282de *R/getFinancials.R
09922b8586e40ac67ac82271b85b6a73 *R/getModelData.R
658697ff79b4c226ddfc02f0ad376796 *R/getOptionChain.R
2a7b0e191c145ed1bfb29d33d318e4f1 *R/getOptionChain.orats.R
7c8b061624018026e007b55ed02fb5cc *R/getQuote.R
5c7a8ea96304a5c9b28dfcfe339ca036 *R/getSplits.R
299f76f2be01625a7ef7a3ee412fda02 *R/getSymbols.R
5c598fd03160fd930ce31443e7d9ee64 *R/getSymbols.skeleton.R
ce5eaff302ecf73b9767a2f8446f9ae8 *R/loadSymbols.R
d426754ea5d8c4c646efee80586f78d6 *R/modelData.R
f8a1d0187f4c836547f56ba0b5ee28e7 *R/modelReturn.R
5fb49836cdcfa0b278b824bf385af726 *R/modelSignal.R
5455b6fcb34279e20c5eeb8dbd02b6a9 *R/months.R
1123deb6bba9a3286d2b9199d53055a7 *R/newTA.R
595c883e5d16f93e1860b87c1eaf40dd *R/oanda.R
0c6223637c9f9dafd8062b0d64fab5cf *R/peak.R
e6315eccb25b274b288cf09bb3a92107 *R/periodReturn.R
6c8a2a63fdd7c9cabda17bff55276911 *R/quantmod.R
0a09bad2f3dcb6f86445cce8bb54c9e3 *R/reChart.R
84105c1e343648497fb6c4ac9ed97201 *R/replot.R
d22629cb2177d29835945d9a7c928fb3 *R/returnBy.R
365f610384311c30deb04c88043dac5a *R/saveChart.R
375a94816b114be4f994f37d1f37dc2f *R/saveModels.R
0da9c65b7fcc469ba0b84dee9dc28d18 *R/specifyModel.R
bde9f4fb4e0c592b3a4ff1c2a5a243a9 *R/symbols.R
34f044070a61777bdb7149618e2be699 *R/tools.R
d278a4eb9201362be8b7475b73cf710b *R/tradeLog.R
cbb9b0bb8eb6d7af4aebe9fb3511e6e9 *R/tradeModel.R
0c99badd6fea917d849505328953cc7d *R/updateModel.R
efea22ce21431595d7d7f76bd8dfa5ae *R/zoomChart.R
36564f3d3fbdd11c906e2d1f5d7b6b24 *R/zzz.R
512fd036a11aafe3d7e82c8b045baf63 *demo/00Index
f0f55a8e00e795c94275d57d4cd09aa1 *demo/chartSeries.R
d8dd64d91a52f8adb23dd8efc8767f70 *inst/tinytest/test-getDividends.R
7af6074062f2f9cbb5edc3abe5971107 *inst/tinytest/test-getSplits.R
d6375c170e5839b2e230eb925684fc30 *inst/tinytest/test-getSymbols.R
09c13878e6d85e02195add97ddc5b553 *inst/tinytest/test-has.R
7aaf6036f5c9a6d9892fe1a785eb13d4 *inst/tinytest/test-misc.R
45f126715a150a9cd1198721f2afd1d9 *man/Defaults.Rd
e234ab5d06debe9c1ce04fd836f9df92 *man/Delt.Rd
e4d807e1a7429aadabe5e101f9938a3f *man/Lag.Rd
c9f0ebbedb0634e5a53cb0f9a8b4803c *man/Next.Rd
18a2b63b16f130c05d5cdd7dfa8fe687 *man/OHLC.Transformations.Rd
c53d115a5189979950e21d4120c0509a *man/TA.Rd
a1d9d4bb93ba68b358aba254fdddc943 *man/addADX.Rd
434e56ba51aaf14912695d66fd900c09 *man/addBBands.Rd
fd6f5f5021ddb75a300739af985c1a6b *man/addCCI.Rd
d32851b5994699fd65cfa6c20a54811e *man/addExpiry.Rd
a34a6a46a725b87acd260f5f39f70340 *man/addMA.Rd
f06804c103a7259ac7cdffedd58681d8 *man/addMACD.Rd
6519d5fe8bd47d86b29e5c999c6d84e3 *man/addROC.Rd
5e6c856e272ba3bddf76476b0458e1c4 *man/addRSI.Rd
4cd54b4d3bf632224b85573b5dc58378 *man/addSAR.Rd
0af96ff507f76691e88b930f6219c12c *man/addSMI.Rd
714d9f2da688f5d8ae5dfef9ac14c74e *man/addVo.Rd
f717b7b281b8b6b413baf504802a0979 *man/addWPR.Rd
af0d6faa51111906f86d4f0e411ce376 *man/adjustOHLC.Rd
2cb1d30494808d42b4d1ddc1c23a719e *man/attachSymbols.Rd
208cfabf1b73107d19452c9b39fb39ab *man/buildData.Rd
e1285ed50dec7c8be5ef121ec06f9aaa *man/buildModel.Rd
b913f9649c4328c1467085917092a461 *man/chartSeries.Rd
0a61a6717495e77245c0c071069999f7 *man/chartTheme.Rd
6dd44b27ce4d5d0616b7f4b117c858be *man/chart_Series.Rd
45aa329f141b84b459e82b5a04bc419d *man/chob-class.Rd
02e34554a4a332f39d9ef26a2439b1df *man/chobTA-class.Rd
45dcdf455ab5322c9f5f49af1fd919ec *man/create.binding.Rd
40ecd8132409d573059d1ba4c807d487 *man/fittedModel.Rd
9533ffb16a6df1dca35efa526623ec45 *man/getDividends.Rd
005496a769f755adfadab4b1c05de593 *man/getFX.Rd
f3be40bbda8cc7172c9c05c951f45b5f *man/getFinancials.Rd
40e080fa80d9e34668e9aa7b4aee9894 *man/getMetals.Rd
8eba8f153dea30d9c998c2424c162fa4 *man/getModelData.Rd
f634568567e00c3416be6d2c5d430a62 *man/getOptionChain.Rd
593171b3f03107badbb6598eb4f7dd73 *man/getOptionChain.orats.Rd
cc9a058588af59a0e62402a60269e09b *man/getQuote.Rd
8b78a05483d174fe73bd61cca5408b83 *man/getSplits.Rd
61a9cf999515950bb03cff6fe60fc99f *man/getSymbols.FRED.Rd
4414a58435730a9f65d3ccdcc8e7f951 *man/getSymbols.MySQL.Rd
c1899a0a7e1e941f24ca482cb0ef2712 *man/getSymbols.Rd
bdbf6c77f13c2d0d5bcac08b5c64b402 *man/getSymbols.SQLite.Rd
9057b50d06b9aabc8b1420357a6e3229 *man/getSymbols.av.Rd
834d51a58e1d2284adc854b03025812f *man/getSymbols.csv.Rd
c10790c811d0c5fc2f7766d92f670142 *man/getSymbols.oanda.Rd
dbfd3a6b8beda5133ba2ad6edaa1100c *man/getSymbols.rda.Rd
820f511c2401f72bd91e6a37738199ce *man/getSymbols.tiingo.Rd
d22737b7a4488697912bbf5280ddb7fa *man/getSymbols.yahoo.Rd
800143de2230ef2dbeee81d6e25a2448 *man/getSymbols.yahooj.Rd
e83c8aadccd65af8c6797015d64fd0a5 *man/has.Rd
800667ddc676ca850ea3777f2bf6c7af *man/internal-quantmod.Rd
8b111538ecd1370445b8971995726bda *man/is.quantmod.Rd
7da226fb436c563fe313595b67fab75c *man/modelData.Rd
855af425d22cd54fc0898d23911ecceb *man/modelSignal.Rd
18eee46388ae1cf1e8015981cc43a9c0 *man/newTA.Rd
5c99e0232ae1934c37744ccf1d1cccad *man/options.expiry.Rd
613eafafc8dbf5efff13ea525049dd9a *man/peak.Rd
3f6edabb4659c61a1074d5dde5061952 *man/periodReturn.Rd
1bc893d43208cf1329903928d6df751f *man/quantmod-class.Rd
8d6512bb95006db54899f1a032670914 *man/quantmod-defunct.Rd
343daacb1e3bd56dd43b74f703b269f3 *man/quantmod-package.Rd
f93d01b8ea2c1ff138f675e047a382ef *man/quantmod.OHLC.Rd
b8c1ada5347961c4591f0be419ab4870 *man/saveChart.Rd
069f5eb19d32ac5a861d14cdd6301430 *man/setSymbolLookup.Rd
0228bad7cdd6f00eafc817d6dc8c2244 *man/setTA.Rd
afdfdacbf5497f767bcd09a23cb13a3e *man/specifyModel.Rd
c2bf7f480bc9059bfecbe11f136cfe1d *man/tradeModel.Rd
ba287ea419bb17e7fe24fb33de89ef92 *man/zoomChart.Rd
9617ace3b7a4ef91c7c2292c52d135df *tests/test-Defaults.R
88e57b900ffedf3ba9c644e633dc579a *tests/test-misc.R
d829677e16b5910ce626c162951bd3e2 *tests/tinytest.R
quantmod/R/ 0000755 0001762 0000144 00000000000 15024632206 012303 5 ustar ligges users quantmod/R/attachSymbols.R 0000644 0001762 0000144 00000013166 14657447467 015302 0 ustar ligges users getSymbolsDB <-
function(cache.dir=tempdir(), cacheOK=TRUE, verbose=getOption('verbose')) {
tmp <- file.path(cache.dir,'nasdaqlisted.txt')
NASDAQ <- "http://ftp.nasdaqtrader.com/dynamic/SymDir/nasdaqlisted.txt"
if(!file.exists(tmp))
download.file(NASDAQ, destfile=tmp,quiet=!verbose)
NQ <- read.delim(tmp,sep="|",stringsAsFactors=FALSE)
test_issues <- which(NQ[,4] != "N")
NQ <- NQ[-test_issues,]
if(!cacheOK)
unlink(tmp)
tmp <- file.path(cache.dir,'otherlisted.txt')
OTHER <- "http://ftp.nasdaqtrader.com/dynamic/SymDir/otherlisted.txt"
if(!file.exists(tmp))
download.file(OTHER, destfile=tmp, quiet=!verbose)
OT <- read.delim(tmp,sep="|",stringsAsFactors=FALSE)
test_issues <- which(OT[,7] != "N")
OT <- OT[-test_issues,]
if(!cacheOK)
unlink(tmp)
local.s <- gsub("\\$","_P",c(NQ[,1],OT[,1]))
local.s
}
create.binding <- function(s, lsym, rsym, gsrc,
mem.cache=TRUE,
file.cache=!mem.cache,
cache.dir=tempdir(),
envir, ...) {
#if((mem.cache + file.cache) != 1) stop("only mem or file caching supported")
# allow both to be set to FALSE, to force no caching
if(missing(rsym) || !is.function(rsym)) {
rsym <- function(x) x
}
if(missing(lsym) || !is.function(lsym)) {
lsym <- function(x) x
}
if(file.cache) {
f <- function(value) {
if(missing(value)) {
if(!file.exists(file.path(cache.dir, paste(s,"rda",sep=".")))) {
assign(lsym(s), getSymbols(rsym(s), src=gsrc, auto.assign=FALSE, ...))
save(list=lsym(s), file=file.path(cache.dir, paste(s,"rda",sep=".")))
get(lsym(s))
} else {
load(file.path(cache.dir, paste(lsym(s),"rda",sep=".")))
get(lsym(s))
}
} else {
return(message("assignment not possible with 'DDB' databases"))
}}
makeActiveBinding(lsym(s), f, as.environment(envir))
} else
if(mem.cache) {
envir <- as.environment(envir)
delayedAssign(lsym(s), {
assign(lsym(s),getSymbols(rsym(s),auto.assign=FALSE, src=gsrc, ...), envir=envir)
get(lsym(s), envir=envir) },
assign.env=envir)
} else { # no cache
f <- function(value) {
if(missing(value)) {
assign(lsym(s), getSymbols(rsym(s), src=gsrc, auto.assign=FALSE, ...))
tmp <- get(lsym(s))
rm(list=lsym(s))
tmp
} else return(message("assignment not possible with 'DDB' databases"))
}
makeActiveBinding(lsym(s), f, as.environment(envir))
}
}
attachSymbols <- function(DB=DDB_Yahoo(),pos=2,prefix=NULL,postfix=NULL,
mem.cache=TRUE, file.cache=!mem.cache, cache.dir=tempdir())
{
# this will be the function exported in quantmod
if(!inherits(DB, 'DDB'))
stop("DB must be of class 'DDB'")
do.call(paste("attachSymbols",DB$src,sep="."),
list(DB=DB,pos=pos,prefix=prefix,postfix=postfix,
mem.cache=mem.cache,
file.cache=file.cache,
cache.dir=cache.dir)
)
}
flushSymbols <- function(DB=DDB_Yahoo())
{
pos=match(DB$name, search())
detach(pos=pos)
attachSymbols(DB=DB,pos=pos)
}
attachSymbols.rds <- function(DB,pos,prefix,postfix,mem.cache,file.cache,cache.dir,...) {
attach(NULL, pos=pos, name=DB$name)
# convert underscore to hyphen for Yahoo fetch
rsym <- function(x) gsub("_","-",x,perl=TRUE)
lsym <- function(x) paste(prefix,as.character(x),postfix,sep="")
invisible(sapply(DB$db, create.binding, lsym=lsym,
rsym=rsym, gsrc="rds", mem.cache=mem.cache, file.cache=file.cache,
cache.dir=cache.dir, envir=DB$name, dir=DB$dir))
}
attachSymbols.yahoo <- function(DB,pos,prefix,postfix,mem.cache,file.cache,cache.dir,...) {
attach(NULL, pos=pos, name=DB$name)
# convert underscore to hyphen for Yahoo fetch
rsym <- function(x) gsub("_","-",x,perl=TRUE)
lsym <- function(x) paste(prefix,as.character(x),postfix,sep="")
invisible(sapply(DB$db, create.binding, lsym=lsym,
rsym=rsym, gsrc="yahoo", mem.cache=mem.cache, file.cache=file.cache,
cache.dir=cache.dir, envir=DB$name))
}
DDB_Yahoo <- function(prefix, postfix,
cache.dir=tempdir(),
cacheOK=TRUE, verbose=getOption("verbose"))
{
db <- getSymbolsDB(cache.dir, cacheOK, verbose)
db <- db[-grep("_|\\.",db)]
structure(list(name="DDB:Yahoo", src="yahoo", db=db), class="DDB")
}
# Desired use case
# package: fetch
# description: on demand data loading, caching, and management
#
# makeDB(src="yahoo") ==>> makeBD_yahoo
# attachDB(YAHOO_US_EQUITY)
# refreshDB() or refreshDB(YAHOO_US_EQUITY)
#
# These would create and attach a new environment to the search path
# that would contain the symbols and how they should be lazy loaded/cached
#
# Structure of YAHOO_US_EQUITY: (class = "fetchDB")
#
# DB name
# Symbol list (character vector)
# Symbol assignment environment
# Symbol_prefix
# Symbol_postfix
# Additional processing functions
# fetch mechanism (getSymbols in quantmod)
# fetch args
# cache mechanism (file, memory, none)
# cache directory (applicable only to 'file' cache mechanism)
# cache rule: maximum object in memory vs. load costs, FIFO, Last Access/Aging
# refresh rule: function returning T/F (only for 'file' cache data) (time-stamps?)
#
# quantmod::createSymbolsDB(src='quantmod.com/symbols/yahoo_symbols.rda')
# quantmod::attachSymbols(db=createSymbolsDB())
# quantmod::pkg/symbolDB/YAHOO_US_EQUITY
quantmod/R/reChart.R 0000644 0001762 0000144 00000011420 15002467345 014022 0 ustar ligges users `reChart` <-
function (type = c("auto", "candlesticks", "matchsticks",
"bars", "line"), subset = NULL, show.grid = TRUE, name = NULL,
time.scale = NULL, line.type = "l", bar.type = "ohlc",
theme = chartTheme("black"),
major.ticks = "auto", minor.ticks = TRUE,
yrange=NULL,
up.col, dn.col, color.vol = TRUE, multi.col = FALSE, ...)
{
chob <- get.current.chob()
#sys.TZ <- Sys.getenv('TZ')
#Sys.setenv(TZ='GMT')
#on.exit(Sys.setenv(TZ=sys.TZ))
x <- chob@xdata
########### name ###########
if(!missing(name)) chob@name <- name
########### end name ###########
########### type ###########
if(!missing(type)) {
chart.options <- c("auto","candlesticks","matchsticks","line","bars")
chart <- chart.options[pmatch(type,chart.options)]
if(chart[1]=="auto") {
chart <- ifelse(NROW(x) > 300,"matchsticks","candlesticks")
}
if(chart[1]=="candlesticks") {
spacing <- 3
width <- 3
} else
if(chart[1]=="matchsticks" || chart[1]=='line') {
spacing <- 1
width <- 1
} else
if(chart[1]=="bars") {
spacing <- 4
width <- 3
if(NROW(x) > 60) width <- 1
}
chob@spacing <- spacing
chob@width <- width
chob@type <- chart[1]
}
########### end type ###########
########### subset ##########
if(!missing(subset)) {
if (!is.null(subset) && is.character(subset)) {
if (strsplit(subset, " ")[[1]][1] %in% c("first", "last")) {
subsetvec <- strsplit(subset, " ")[[1]]
if (length(subsetvec) < 3) {
subset.n <- ifelse(length(subsetvec) == 1, 1L,
as.numeric(subsetvec[2]))
}
else {
subset.n <- paste(subsetvec[2:3], collapse = " ")
}
sub.index <- index(do.call(subsetvec[1], list(x,
subset.n)))
xsubset <- which(index(x) %in% sub.index)
}
else xsubset <- which(index(x) %in% index(x[subset]))
}
else xsubset <- 1:NROW(x)
if(!is.null(subset)) {
chob@xsubset <- xsubset
x <- x[xsubset,]
chob@xrange <- c(1, NROW(x))
if (is.OHLC(x)) {
chob@yrange <- c(min(Lo(x), na.rm = TRUE), max(Hi(x),
na.rm = TRUE))
}
else chob@yrange <- range(x[, 1], na.rm = TRUE)
if(!is.null(yrange) && length(yrange)==2) chob@yrange <- yrange
}
chob@xsubset <- xsubset
if(missing(major.ticks)) {
majorticks <- chob@major.ticks
} else majorticks <- major.ticks
chob@bp <- axTicksByTime(x,majorticks)
chob@x.labels <- names(chob@bp)
chob@length <- NROW(x)
}
########### end subset ##########
if(!missing(major.ticks)) {
chob@bp <- axTicksByTime(x[chob@xsubset],major.ticks)
chob@x.labels <- names(chob@bp)
chob@major.ticks <- major.ticks
}
if(!missing(minor.ticks))
chob@minor.ticks = minor.ticks
########### chartTheme ##########
if(!missing(theme)) {
if(inherits(theme,'chart.theme')) {
chob@colors <- theme
} else chob@colors <- chartTheme(theme)
}
########### end chartTheme ##########
########### multi.col ##########
if(missing(theme) && !missing(multi.col) )
stop(paste(sQuote('theme'),'must be specified in conjunction with',
sQuote('multi.col')))
theme <- chob@colors
if(missing(multi.col)) multi.col <- chob@multi.col
if(is.OHLC(x)) {
Opens <- as.numeric(Op(x))
Highs <- as.numeric(Hi(x))
Lows <- as.numeric(Lo(x))
Closes <- as.numeric(Cl(x))
} else {
Lows <- min(x[,1])
Highs <- max(x[,1])
Closes <- as.numeric(x[,1])
type <- "line"
color.vol <- FALSE
}
if(has.Vo(x)) {
Volumes <- as.numeric(Vo(x))
show.vol <- TRUE
} else show.vol <- FALSE
if(missing(time.scale)) {
time.scale <- chob@time.scale
}
if(!missing(up.col)) theme$up.col <- up.col
if(!missing(dn.col)) theme$dn.col <- dn.col
if(!multi.col) { # interpret as FALSE
theme$dn.up.col <- theme$up.col
theme$up.up.col <- theme$up.col
theme$dn.dn.col <- theme$dn.col
theme$up.dn.col <- theme$dn.col
} else {
if(is.character(multi.col)) {
# add some check for length 4 colors
theme$dn.up.col <- multi.col[1]
theme$up.up.col <- multi.col[2]
theme$dn.dn.col <- multi.col[3]
theme$up.dn.col <- multi.col[4]
}
theme$up.col <- theme$up.up.col
theme$dn.col <- theme$dn.dn.col
multi.col <- TRUE
}
chob@colors <- theme
chob@multi.col <- multi.col
chob@color.vol <- color.vol
########### end multi.col ##########
chob@passed.args$TA <- sapply(chob@passed.args$TA,
function(x) eval(x@call)
)
chartSeries.chob(chob)
chob@device <- as.numeric(dev.cur())
write.chob(chob,chob@device)
invisible(chob)
}
quantmod/R/add_Last.R 0000644 0001762 0000144 00000011017 15002467345 014147 0 ustar ligges users add_Last <-
function(name=TRUE,last=TRUE) {
lenv <- new.env()
lenv$plot_axis <- function(x,show.last,show.name) {
xdata <- x$Env$xdata
nr <- NROW(x$Env$xdata[x$Env$xsubset])
last_values <- last(xdata[x$Env$xsubset])
offset <- offset_names <- NULL
offsets <- NULL
offset <- max(strwidth(pretty(as.numeric(last_values))))
if(!x$Env$theme$rylab)
offset <- 0
offset_names <- max(strwidth(colnames(last_values))) # only relevant to names & last
for(i in 1:NCOL(last_values)) {
if(!name) {
text(nr+offset, as.numeric(last_values[,i]),
sprintf("%+.2f",last_values[,i]), col=x$Env$theme$line.col[i],
cex=.9,font=2,pos=4,xpd=TRUE)
} else if(!last) {
text(nr+offset, as.numeric(last_values[,i]),
colnames(last_values)[i], col=x$Env$theme$line.col[i],
cex=.9,font=2,pos=4,xpd=TRUE)
} else {
text((nr+offset)+c(0,offset_names), as.numeric(last_values[,i]),
c(colnames(last_values)[i],sprintf("%+.2f",last_values[,i])),
col=c(x$Env$theme$line.col[i],'black'),
cex=.9,font=c(2,1),pos=4,xpd=TRUE)
}
}
}
#exp <- expression(plot_axis(x=current.chob(),show.last=last,show.name=name))
exp <- parse(text = gsub("list", "plot_axis", as.expression(substitute(list(x = current.chob(),
show.last=last, show.name=name,...)))), srcfile = NULL)
plot_object <- current.chob()
plot_object$Env$mar <- c(3,1,0,if(name && last) if(plot_object$Env$theme$rylab) 5 else 4 else 3)
lenv$xdata <- plot_object$Env$xdata
plot_object$set_frame(2,clip=FALSE)
plot_object$add(exp, env=c(lenv,plot_object$Env), expr=TRUE, clip=FALSE)
plot_object
}
add_axis <-
function(side, at=NULL, labels=TRUE, tick=TRUE, line=NA, pos=NA, font=NA, col=NULL) {
lenv <- new.env()
lenv$plot_axis <- function(x,side,at,labels,tick,font,pos,col) {
xdata <- x$Env$xdata
if(is.OHLC(xdata))
xdata <- OHLC(xdata)
xsubset <- x$Env$xsubset
nr <- NROW(x$Env$xdata[x$Env$xsubset])
if(is.logical(labels) && labels==TRUE) {
labels <- pretty(xdata[xsubset])
dropped_label <- which(labels < min(xdata[xsubset],na.rm=TRUE))
labels <- labels[-dropped_label]
}
if(is.null(at))
at <- labels
if(side==2) {
nr <- 0
}
text(nr, at, labels, col=col,
cex=.9,font=font,pos=pos,xpd=TRUE)
if(tick)
segments(nr-(1/8 * max(strwidth(labels))),at,
nr+(1/8 * max(strwidth(labels))),at)
}
if(missing(pos))
pos <- side
mapply(function(name, value) {
assign(name, value, envir = lenv)
}, names(list(side=side,at=at,labels=labels,font=font,tick=tick,pos=pos,col=col)),
list(side=side,at=at,labels=labels,font=font,tick=tick,pos=pos,col=col))
exp <- parse(text = gsub("list", "plot_axis", as.expression(substitute(list(x = current.chob(),
side=side, at=get("at"), labels=get("labels"), tick=tick,
font=font,pos=pos, col=col)))), srcfile = NULL)
plot_object <- current.chob()
lenv$xdata <- plot_object$Env$xdata
plot_object$set_frame(2)
plot_object$add(exp, env=c(lenv,plot_object$Env), expr=TRUE)
plot_object
}
add_title <-
function(main=NULL, sub=NULL, xlab=NULL, ylab=NULL, line=NA, ...) {
lenv <- new.env()
lenv$plot_title <- function(x,main,sub,xlab,ylab,line,side,font,pos) {
xdata <- x$Env$xdata
if(is.OHLC(xdata))
xdata <- OHLC(xdata)
xsubset <- x$Env$xsubset
nr <- NROW(x$Env$xdata[x$Env$xsubset])
if(is.logical(labels) && labels==TRUE) {
labels <- pretty(xdata[xsubset])
dropped_label <- which(labels < min(xdata[xsubset],na.rm=TRUE))
labels <- labels[-dropped_label]
}
if(is.null(at))
at <- labels
if(side==2) {
nr <- 0
}
text(nr, at, labels, col=col,
cex=.9,font=font,pos=pos,xpd=TRUE)
segments(nr-(1/8 * max(strwidth(labels))),at,
nr+(1/8 * max(strwidth(labels))),at)
}
#if(missing(pos))
# pos <- side
mapply(function(name, value) {
assign(name, value, envir = lenv)
}, names(list(main=main,sub=sub,xlab=xlab,ylab=ylab,line=line)),
list(main=main,sub=sub,xlab=xlab,ylab=ylab,line=line))
exp <- parse(text = gsub("list", "plot_title", as.expression(substitute(list(x = current.chob(),
side=side, at=get("at"), labels=get("labels"), font=font,pos=pos, col=col)))), srcfile = NULL)
plot_object <- current.chob()
lenv$xdata <- plot_object$Env$xdata
plot_object$set_frame(2)
plot_object$add(exp, env=c(lenv,plot_object$Env), expr=TRUE)
plot_object
}
quantmod/R/chartSeries.R 0000644 0001762 0000144 00000050437 15002467345 014721 0 ustar ligges users # chartSeries0 {{{
`chartSeries0` <-
function(x,
type=c("auto","candlesticks","matchsticks","bars","line"),
subset=NULL,
show.grid=TRUE,name=NULL,
time.scale=NULL,
TA=c(addVo()),
line.type="l",
bar.type="ohlc",
theme=chartTheme("black"),
major.ticks='auto',minor.ticks=TRUE,
up.col,dn.col,color.vol=TRUE,multi.col=FALSE,...
) {
sys.TZ <- Sys.getenv('TZ')
Sys.setenv(TZ='GMT')
on.exit(Sys.setenv(TZ=sys.TZ))
if(!is.xts(x)) x <- as.xts(x)
tclass(x) <- "POSIXct"
if(!is.null(subset) && is.character(subset)) {
if(strsplit(subset,' ')[[1]][1] %in% c('first','last')) {
subsetvec <- strsplit(subset,' ')[[1]]
if(length(subsetvec) < 3) {
subset.n <- ifelse(length(subsetvec)==1,1L,as.numeric(subsetvec[2]))
} else {
subset.n <- paste(subsetvec[2:3],collapse=' ')
}
sub.index <- index(do.call(subsetvec[1],list(x,subset.n)))
xsubset <- which(index(x) %in% sub.index)
} else xsubset <- which(index(x) %in% index(x[subset]))
} else xsubset <- 1:NROW(x)
xdata <- x
x <- x[xsubset]
if(is.OHLC(x)) {
Opens <- as.numeric(Op(x))
Highs <- as.numeric(Hi(x))
Lows <- as.numeric(Lo(x))
Closes <- as.numeric(Cl(x))
} else {
Lows <- min(x[,1])
Highs <- max(x[,1])
Closes <- as.numeric(x[,1])
type <- "line"
color.vol <- FALSE
}
if(has.Vo(x)) {
Volumes <- as.numeric(Vo(x))
show.vol <- TRUE
} else show.vol <- FALSE
if(is.null(time.scale)) {
time.scale <- periodicity(x)$scale
}
if(is.character(theme)) theme <- chartTheme(theme)
if(!missing(up.col)) theme$up.col <- up.col
if(!missing(dn.col)) theme$dn.col <- dn.col
if(missing(multi.col) || !multi.col) { # interpret as FALSE
multi.col <- FALSE
theme$dn.up.col <- theme$up.col
theme$up.up.col <- theme$up.col
theme$dn.dn.col <- theme$dn.col
theme$up.dn.col <- theme$dn.col
} else {
if(is.character(multi.col)) {
# add some check for length 4 colors
theme$dn.up.col <- multi.col[1]
theme$up.up.col <- multi.col[2]
theme$dn.dn.col <- multi.col[3]
theme$up.dn.col <- multi.col[4]
}
theme$up.col <- theme$up.up.col
theme$dn.col <- theme$dn.dn.col
multi.col <- TRUE
}
# spacing requirements for chart type
chart.options <- c("auto","candlesticks","matchsticks","line","bars")
chart <- chart.options[pmatch(type,chart.options)]
if(chart[1]=="auto") {
chart <- ifelse(NROW(x) > 300,"matchsticks","candlesticks")
}
if(chart[1]=="candlesticks") {
spacing <- 3
width <- 3
} else
if(chart[1]=="matchsticks" || chart[1]=='line') {
spacing <- 1
width <- 1
} else
if(chart[1]=="bars") {
spacing <- 4
width <- 3
if(NROW(x) > 60) width <- 1
}
ep <- axTicksByTime(x, major.ticks)
ep <- c(rev(rev(ep)[-1]),rev(ep)[1]-1)
x.labels <- format(index(x)[ep + 1], "%n%b%n%Y")
if (time.scale == "weekly" || time.scale == "daily")
x.labels <- format(index(x)[ep + 1], "%b %d%n%Y")
if (time.scale == "minute" || time.scale == "hourly")
x.labels <- format(index(x)[ep + 1], "%b %d%n%H:%M")
chob <- new("chob")
chob@call <- match.call(expand.dots=TRUE)
if(is.null(name)) name <- as.character(match.call()$x)
chob@xdata <- xdata
chob@xsubset <- xsubset
chob@name <- name
chob@type <- chart[1]
chob@xrange <- c(1,NROW(x))
if(is.OHLC(x)) {
chob@yrange <- c(min(Lo(x),na.rm=TRUE),max(Hi(x),na.rm=TRUE))
} else chob@yrange <- range(x[,1],na.rm=TRUE)
chob@color.vol <- color.vol
chob@multi.col <- multi.col
chob@show.vol <- show.vol
chob@bar.type <- bar.type
chob@line.type <- line.type
chob@spacing <- spacing
chob@width <- width
chob@bp <- ep
chob@x.labels <- x.labels
chob@colors <- theme
chob@time.scale <- time.scale
chob@minor.ticks <- minor.ticks
chob@show.grid <- show.grid
chob@length <- NROW(x)
chob@passed.args <- as.list(match.call(expand.dots=TRUE)[-1])
if(!is.null(TA)) {
# important to force eval of _current_ chob, not saved chob
thisEnv <- environment()
if(is.character(TA)) TA <- as.list(TA)
chob@passed.args$TA <- list()
for(ta in 1:length(TA)) {
if(is.character(TA[[ta]])) {
chob@passed.args$TA[[ta]] <- eval(parse(text=TA[[ta]]),envir=thisEnv)
} else chob@passed.args$TA[[ta]] <- eval(TA[[ta]],envir=thisEnv)
}
chob@windows <- length(which(sapply(chob@passed.args$TA,function(x) x@new)))+1
chob@passed.args$show.vol <- any(sapply(chob@passed.args$TA,function(x) x@name=="chartVo"))
} else chob@windows <- 1
#if(debug) return(str(chob))
# re-evaluate the TA list, as it will be using stale data,
chob@passed.args$TA <- sapply(chob@passed.args$TA, function(x) { eval(x@call) } )
# draw the chart
do.call('chartSeries.chob',list(chob))
chob@device <- as.numeric(dev.cur())
write.chob(chob,chob@device)
invisible(chob)
} #}}}
# candleChart {{{
`candleChart` <-
function(x,
subset = NULL,
type="candlesticks",
show.grid=TRUE,name=deparse(substitute(x)),
time.scale=NULL,log.scale=FALSE,
TA="addVo()",
theme=chartTheme("black"),
major.ticks='auto', minor.ticks = TRUE,
color.vol=TRUE,multi.col=FALSE,...
) {
do.call('chartSeries',list(x,subset=subset,
name=name,type='candlesticks',show.grid=show.grid,
time.scale=time.scale,log.scale=log.scale,TA=substitute(TA),
theme=theme,major.ticks=major.ticks,minor.ticks=minor.ticks,
color.vol=color.vol,
multi.col=multi.col,...))
} #}}}
# matchChart {{{
`matchChart` <-
function(x,
subset = NULL,
type="matchsticks",
show.grid=TRUE,name=deparse(substitute(x)),
time.scale=NULL,log.scale=FALSE,
TA="addVo()",
theme=chartTheme("black"),
major.ticks='auto', minor.ticks = TRUE,
color.vol=TRUE,multi.col=FALSE,...
) {
do.call('chartSeries',list(x,subset=subset,
name=name,type='matchsticks',show.grid=show.grid,
time.scale=time.scale,log.scale=log.scale,TA=substitute(TA),
theme=theme,major.ticks=major.ticks,minor.ticks=minor.ticks,
color.vol=color.vol,
multi.col=multi.col,...))
} #}}}
# barChart {{{
`barChart` <-
function(x,
subset = NULL,
type="bars",
show.grid=TRUE,name=deparse(substitute(x)),
time.scale=NULL,log.scale=FALSE,
TA="addVo()",
bar.type="ohlc",
theme=chartTheme("black"),
major.ticks='auto', minor.ticks = TRUE,
color.vol=TRUE,multi.col=FALSE,...
) {
do.call('chartSeries',list(x,subset=subset,
name=name,type='bars',show.grid=show.grid,
time.scale=time.scale,log.scale=log.scale,TA=substitute(TA),bar.type=bar.type,
theme=theme,major.ticks=major.ticks,minor.ticks=minor.ticks,
color.vol=color.vol,
multi.col=multi.col,...))
} #}}}
# lineChart {{{
`lineChart` <-
function(x,subset = NULL,
type="line",
show.grid=TRUE,name=deparse(substitute(x)),
time.scale=NULL,log.scale=FALSE,
TA="addVo()",
line.type="l",
theme=chartTheme("black"),
major.ticks='auto', minor.ticks = TRUE,
color.vol=TRUE,multi.col=FALSE,...
) {
do.call('chartSeries',list(x,subset=subset,
name=name,type='line',show.grid=show.grid,
time.scale=time.scale,log.scale=log.scale,TA=substitute(TA),line.type=line.type,
theme=theme,major.ticks=major.ticks,minor.ticks=minor.ticks,
color.vol=color.vol,
multi.col=multi.col,...))
} #}}}
# .chart.theme {{{
`.chart.theme` <- structure(list(
'white'=
list(fg.col="#000000",bg.col="#F0F0F0",
grid.col="#CCCCCC",border="#444444",
minor.tick="#888888",major.tick="#000000",
up.col="#00CC00",dn.col="#FF7700",
dn.up.col="#888888",up.up.col="#FFFFFF",
dn.dn.col="#FF0000",up.dn.col="#000000",
up.border="#444444",dn.border="#444444",
dn.up.border="#444444",up.up.border="#444444",
dn.dn.border="#444444",up.dn.border="#444444",
main.col="#555555",sub.col="#555555",
area="#FFFFFF",
fill="#F7F7F7",
Expiry='#C9C9C9',
theme.name='white'
),
'white.mono'=
list(fg.col="#666666",bg.col="#FFFFFF",
grid.col="#CCCCCC",border="#666666",
minor.tick="#CCCCCC",major.tick="#888888",
up.col="#000000",dn.col="#000000",
dn.up.col="#888888",up.up.col="#FFFFFF",
dn.dn.col="#4D4D4D",up.dn.col="#000000",
up.border="#666666",dn.border="#666666",
dn.up.border="#666666",up.up.border="#666666",
dn.dn.border="#666666",up.dn.border="#666666",
main.col="#555555",sub.col="#555555",
fill="#F7F7F7",
Expiry='#C9C9C9',
BBands.col='#666666',BBands.fill="#F7F7F7",
BBands=list(col='#666666',fill='#F7F7F7'),
theme.name='white.mono'
),
'black'=
list(fg.col="#666666",bg.col="#222222",
grid.col="#303030",border="#666666",
minor.tick="#303030",major.tick="#AAAAAA",
up.col="#00FF00",dn.col="#FF9900",
dn.up.col="#888888",up.up.col="#FFFFFF",
dn.dn.col="#FF0000",up.dn.col="#000000",
up.border="#666666",dn.border="#666666",
dn.up.border="#666666",up.up.border="#666666",
dn.dn.border="#666666",up.dn.border="#666666",
main.col="#999999",sub.col="#999999",
area="#252525",
fill="#282828",
Expiry='#383838',
BBands.col='red',BBands.fill="#282828",
BBands=list(col='red',fill='#282828'),
theme.name='black'
),
'black.mono'=
list(fg.col="#666666",bg.col="#222222",
grid.col="#303030",border="#666666",
minor.tick="#303030",major.tick="#AAAAAA",
up.col="#FFFFFF",dn.col="#FFFFFF",
dn.up.col="#888888",up.up.col="#FFFFFF",
dn.dn.col="#4D4D4D",up.dn.col="#000000",
up.border="#666666",dn.border="#666666",
dn.up.border="#666666",up.up.border="#666666",
dn.dn.border="#666666",up.dn.border="#666666",
main.col="#999999",sub.col="#999999",
fill="#777777",
Expiry='#383838',
BBands=list(col='#DDDDDD',fill='#777777'),
BBands.col='#DDDDDD',BBands.fill="#777777",
theme.name='black.mono'
),
'beige'=
list(fg.col="#888888",bg.col="#F5F5D0",
grid.col="#CCCCCC",border="#666666",
minor.tick="#CCCCCC",major.tick="#AAAAAA",
up.col="#00FF00",dn.col="#AA0000",
dn.up.col="#888888",up.up.col="#FFFFFF",
dn.dn.col="#FF0000",up.dn.col="#000000",
up.border="#666666",dn.border="#666666",
dn.up.border="#666666",up.up.border="#666666",
dn.dn.border="#666666",up.dn.border="#666666",
main.col="#555555",sub.col="#555555",
fill="#F5F5F5",
Expiry='#C9C9C9',
BBands.col='orange',BBands.fill='#F5F5DF',
BBands=list(col='orange',fill='#F5F5DF'),
theme.name='beige'
),
'wsj'=
list(fg.col="#000000",bg.col="#F0F0F0",
grid.col="#ffffff",border="#444444",
minor.tick="#888888",major.tick="#000000",
up.col="#FFFFFF",dn.col="#666666",
dn.up.col="#888888",up.up.col="#FFFFFF",
dn.dn.col="#FF0000",up.dn.col="#000000",
up.border="#444444",dn.border="#666666",
dn.up.border="#444444",up.up.border="#444444",
dn.dn.border="#444444",up.dn.border="#444444",
main.col = "#555555", sub.col = "#555555", area = "#d3d0af",
fill = "#F7F7F7", Expiry = "#C9C9C9",
theme.name = "wsj")
), class='chart.theme')
# }}}
`print.chart.theme` <- function(x,...) {
str(x)
}
# chartTheme {{{
`chartTheme` <- function(theme='black',...) {
ctheme <- .chart.theme
attr(ctheme,".Environment") <- NULL
current.theme <- ctheme[[theme]]
ll <- list(...)
for(i in names(ll)) {
current.theme[[i]] <- ll[[i]]
}
return(structure(current.theme,class='chart.theme'))
}#}}}
# chartSeries {{{
`chartSeries` <-
function(x,
type=c("auto","candlesticks","matchsticks","bars","line"),
subset=NULL,
show.grid=TRUE,name=NULL,
time.scale=NULL,log.scale=FALSE,
TA='addVo()',TAsep=';',
line.type="l",
bar.type="ohlc",
theme=chartTheme("black"),
layout=NA,
major.ticks='auto',minor.ticks=TRUE,
yrange=NULL,
plot=TRUE,
up.col,dn.col,color.vol=TRUE,multi.col=FALSE,...
) {
#sys.TZ <- Sys.getenv('TZ')
#Sys.setenv(TZ='GMT')
#on.exit(Sys.setenv(TZ=sys.TZ))
#if(!is.xts(x)) x <- as.xts(x)
x <- try.xts(x, error='chartSeries requires an xtsible object')
x <- na.omit(x)
tclass(x) <- "POSIXct"
if(!is.null(subset) && is.character(subset)) {
if(strsplit(subset,' ')[[1]][1] %in% c('first','last')) {
subsetvec <- strsplit(subset,' ')[[1]]
if(length(subsetvec) < 3) {
subset.n <- ifelse(length(subsetvec)==1,1L,as.numeric(subsetvec[2]))
} else {
subset.n <- paste(subsetvec[2:3],collapse=' ')
}
sub.index <- index(do.call(subsetvec[1],list(x,subset.n)))
xsubset <- which(index(x) %in% sub.index)
} else xsubset <- which(index(x) %in% index(x[subset]))
} else xsubset <- 1:NROW(x)
xdata <- x
x <- x[xsubset]
if(is.OHLC(x)) {
Opens <- as.numeric(Op(x))
Highs <- as.numeric(Hi(x))
Lows <- as.numeric(Lo(x))
Closes <- as.numeric(Cl(x))
} else {
Lows <- min(x[,1])
Highs <- max(x[,1])
Closes <- as.numeric(x[,1])
type <- "line"
color.vol <- FALSE
}
if(has.Vo(x)) {
Volumes <- as.numeric(Vo(x))
show.vol <- TRUE
} else show.vol <- FALSE
if(is.null(time.scale)) {
time.scale <- periodicity(x)$scale
}
if(is.character(theme)) theme <- chartTheme(theme)
if(!missing(up.col)) theme$up.col <- up.col
if(!missing(dn.col)) theme$dn.col <- dn.col
if(missing(multi.col) || !multi.col) { # interpret as FALSE
multi.col <- FALSE
theme$dn.up.col <- theme$up.col
theme$up.up.col <- theme$up.col
theme$dn.dn.col <- theme$dn.col
theme$up.dn.col <- theme$dn.col
} else {
if(is.character(multi.col)) {
# add some check for length 4 colors
theme$dn.up.col <- multi.col[1]
theme$up.up.col <- multi.col[2]
theme$dn.dn.col <- multi.col[3]
theme$up.dn.col <- multi.col[4]
}
theme$up.col <- theme$up.up.col
theme$dn.col <- theme$dn.dn.col
multi.col <- TRUE
}
# spacing requirements for chart type
chart.options <- c("auto","candlesticks","matchsticks","line","bars")
chart <- chart.options[pmatch(type,chart.options)]
if(chart[1]=="auto") {
chart <- ifelse(NROW(x) > 300,"matchsticks","candlesticks")
}
if(chart[1]=="candlesticks") {
spacing <- 3
width <- 3
} else
if(chart[1]=="matchsticks" || chart[1]=='line') {
spacing <- 1
width <- 1
} else
if(chart[1]=="bars") {
spacing <- 4
width <- 3
if(NROW(x) > 60) width <- 1
}
ep <- axTicksByTime(x,major.ticks)
x.labels <- names(ep)
chob <- new("chob")
chob@call <- match.call(expand.dots=TRUE)
if(is.null(name)) name <- as.character(match.call()$x)
chob@xdata <- xdata
chob@xsubset <- xsubset
chob@name <- name
chob@type <- chart[1]
chob@xrange <- c(1,NROW(x))
if(is.OHLC(x)) {
chob@yrange <- c(min(Lo(x),na.rm=TRUE),max(Hi(x),na.rm=TRUE))
} else chob@yrange <- range(x[,1],na.rm=TRUE)
if(!is.null(yrange) && length(yrange)==2)
chob@yrange <- yrange
chob@log.scale <- log.scale
chob@color.vol <- color.vol
chob@multi.col <- multi.col
chob@show.vol <- show.vol
chob@bar.type <- bar.type
chob@line.type <- line.type
chob@spacing <- spacing
chob@width <- width
chob@bp <- ep
chob@x.labels <- x.labels
chob@colors <- theme
chob@layout <- layout
chob@time.scale <- time.scale
chob@minor.ticks <- minor.ticks
chob@major.ticks <- major.ticks
chob@show.grid <- show.grid
chob@length <- NROW(x)
chob@passed.args <- as.list(match.call(expand.dots=TRUE)[-1])
if(!is.null(TA)) {
# important to force eval of _current_ chob, not saved chob
thisEnv <- environment()
if(is.character(TA)) TA <- as.list(strsplit(TA,TAsep)[[1]])
#if(!has.Vo(x)) TA <- TA[-which(TA=='addVo()')] # remove addVo if no volume
chob@passed.args$TA <- list()
#if(length(TA) > 0) {
for(ta in 1:length(TA)) {
if(is.character(TA[[ta]])) {
chob@passed.args$TA[[ta]] <- eval(parse(text=TA[[ta]]),envir=thisEnv)
} else chob@passed.args$TA[[ta]] <- eval(TA[[ta]],envir=thisEnv)
}
# check if all args are indeed chobTA
poss.new <- sapply(chob@passed.args$TA, function(x)
{
if(isS4(x) && is(x, 'chobTA'))
return(x@new)
stop('improper TA argument/call in chartSeries', call.=FALSE)
} )
if(length(poss.new) > 0)
poss.new <- which(poss.new)
chob@windows <- length(poss.new) + 1
#chob@windows <- length(which(sapply(chob@passed.args$TA,
# function(x) ifelse(is.null(x),FALSE,x@new))))+1
chob@passed.args$show.vol <- any(sapply(chob@passed.args$TA,
function(x) x@name=="chartVo"))
#} else {
# chob@windows <- 1
# chob@passed.args$TA <- NULL
#}
} else chob@windows <- 1
#if(debug) return(str(chob))
# re-evaluate the TA list, as it will be using stale data,
chob@passed.args$TA <- sapply(chob@passed.args$TA, function(x) { eval(x@call) } )
if(plot) # draw the chart
do.call('chartSeries.chob',list(chob))
chob@device <- as.numeric(dev.cur())
write.chob(chob,chob@device)
invisible(chob)
} #}}}
quantmod/R/months.R 0000644 0001762 0000144 00000002212 15002467345 013741 0 ustar ligges users `options.expiry` <-
function(x) {
# the 3rd friday of month
which(format(index(x),"%d") > 14 &
format(index(x),"%d") < 22 &
format(index(x),"%w")==5)
}
`futures.expiry` <-
function(x) {
# the last 3rd friday of quarter
which(format(index(x),"%d") > 14 &
format(index(x),"%d") < 22 &
format(index(x),"%w")==5 &
(.indexmon(x)+1) %in% c(3,6,9,12))
}
`nmicroseconds` <-
function(x) {
length(endpoints(x,"microseconds"))-1
}
`nmilliseconds` <-
function(x) {
length(endpoints(x,"milliseconds"))-1
}
`nseconds` <-
function(x) {
length(endpoints(x,"seconds"))-1
}
`nminutes` <-
function(x) {
length(endpoints(x,"minutes"))-1
}
`nhours` <-
function(x) {
length(endpoints(x,"hours"))-1
}
`ndays` <-
function(x) {
length(endpoints(x,"days"))-1
}
`nmonths` <-
function(x) {
length(endpoints(x,"months"))-1
}
`nquarters` <-
function(x) {
length(endpoints(x,"quarters"))-1
}
`nweekdays` <-
function(x) {
stop('weekdays are currently unimplemented')
length(endpoints(x,"weekdays"))-1
}
`nweeks` <-
function(x) {
length(endpoints(x,"weeks"))-1
}
`nyears` <-
function(x) {
length(endpoints(x,"years"))-1
}
quantmod/R/addAroon.R 0000644 0001762 0000144 00000005207 14657447467 014211 0 ustar ligges users # aroon from TTR
#
# chartSeries interface by Jeffrey A. Ryan 2008
#
# addAroon
# addAroonOsc
`addAroon` <-
function (n = 20, ..., on = NA, legend = "auto")
{
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
x <- cbind(Hi(x),Lo(x))
x <- aroon(HL = x, n = n)[,-3]
yrange <- NULL
chobTA <- new("chobTA")
if (NCOL(x) == 1) {
chobTA@TA.values <- x[lchob@xsubset]
}
else chobTA@TA.values <- x[lchob@xsubset, ]
chobTA@name <- "chartTA"
if (any(is.na(on))) {
chobTA@new <- TRUE
}
else {
chobTA@new <- FALSE
chobTA@on <- on
}
chobTA@call <- match.call()
legend.name <- gsub("^add", "", deparse(match.call()))
gpars <- c(list(...), list(col = 3:4))[unique(names(c(list(col = 3:4),
list(...))))]
chobTA@params <- list(xrange = lchob@xrange, yrange = yrange,
colors = lchob@colors, color.vol = lchob@color.vol,
multi.col = lchob@multi.col,
spacing = lchob@spacing, width = lchob@width, bp = lchob@bp,
x.labels = lchob@x.labels, time.scale = lchob@time.scale,
isLogical = is.logical(x), legend = legend, legend.name = legend.name,
pars = list(gpars))
return(chobTA)
}
`addAroonOsc` <-
function (n = 20, ..., on = NA, legend = "auto")
{
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
x <- cbind(Hi(x),Lo(x))
x <- aroon(HL = x, n = n)[,3]
yrange <- NULL
chobTA <- new("chobTA")
if (NCOL(x) == 1) {
chobTA@TA.values <- x[lchob@xsubset]
}
else chobTA@TA.values <- x[lchob@xsubset, ]
chobTA@name <- "chartTA"
if (any(is.na(on))) {
chobTA@new <- TRUE
}
else {
chobTA@new <- FALSE
chobTA@on <- on
}
chobTA@call <- match.call()
legend.name <- gsub("^addAroonOsc", "Aroon Oscillator ", deparse(match.call()))
gpars <- c(list(...), list(col = 3:4))[unique(names(c(list(col = 3:4),
list(...))))]
chobTA@params <- list(xrange = lchob@xrange, yrange = yrange,
colors = lchob@colors, color.vol = lchob@color.vol, multi.col = lchob@multi.col,
spacing = lchob@spacing, width = lchob@width, bp = lchob@bp,
x.labels = lchob@x.labels, time.scale = lchob@time.scale,
isLogical = is.logical(x), legend = legend, legend.name = legend.name,
pars = list(gpars))
if (is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA, chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new, 1,
0)
do.call("chartSeries.chob", list(lchob))
invisible(chobTA)
}
else {
return(chobTA)
}
}
quantmod/R/addCMF.R 0000644 0001762 0000144 00000004643 14654457715 013535 0 ustar ligges users
# addCMF {{{
`addCMF` <- function(n=20) {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- TRUE
xx <- if(is.OHLC(x)) {
cbind(Hi(x),Lo(x),Cl(x))
} else stop("CMF only applicaple to HLC series")
cmf <- CMF(xx,Vo(x),n=n)
chobTA@TA.values <- cmf[lchob@xsubset]
chobTA@name <- "chartCMF"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} #}}}
# chartCMF {{{
`chartCMF` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
n <- x@params$n
cmf <- x@TA.values
y.range <- seq(-max(abs(cmf), na.rm = TRUE), max(abs(cmf),
na.rm = TRUE), length.out = length(x.range)) * 1.05
plot(x.range,y.range,
type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
xx <- seq(1,length(x.range),by=spacing)
cmf.positive <- ifelse(cmf >= 0,cmf,0)
cmf.negative <- ifelse(cmf < 0,cmf,0)
polygon(c(xx,rev(xx)),c(cmf.positive,rep(0,length(cmf))),col=x@params$colors$up.col)
polygon(c(xx,rev(xx)),c(cmf.negative,rep(0,length(cmf))),col=x@params$colors$dn.col)
abline(h=0,col="#999999")
text(0, last(y.range)*.9,
paste("Chaikin Money Flow (", x@params$n,"):", sep = ""),
pos = 4)
text(0, last(y.range)*.9,
paste("\n\n\n",sprintf("%.3f",last(cmf)), sep = ""),
col = ifelse(last(cmf) > 0,x@params$colors$up.col,x@params$colors$dn.col),
pos = 4)
axis(2)
box(col=x@params$colors$fg.col)
} # }}}
quantmod/R/addMFI.R 0000644 0001762 0000144 00000003037 14654457715 013537 0 ustar ligges users # Money Flow Index from TTR by Josh Ulrich
#
# chartSeries interface by Jeffrey A. Ryan 2008
#
# addMFI
`addMFI` <-
function (n = 14, ..., on = NA, legend = "auto")
{
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
volume <- Vo(x)
x <- HLC(x)
x <- MFI(HLC = x, volume = volume, n = n)
yrange <- NULL
chobTA <- new("chobTA")
if (NCOL(x) == 1) {
chobTA@TA.values <- x[lchob@xsubset]
}
else chobTA@TA.values <- x[lchob@xsubset, ]
chobTA@name <- "chartTA"
if (any(is.na(on))) {
chobTA@new <- TRUE
}
else {
chobTA@new <- FALSE
chobTA@on <- on
}
chobTA@call <- match.call()
legend.name <- gsub("^addMFI", "Money Flow Index ", deparse(match.call()))
gpars <- c(list(...), list(col = 8))[unique(names(c(list(col = 8),
list(...))))]
chobTA@params <- list(xrange = lchob@xrange, yrange = yrange,
colors = lchob@colors, color.vol = lchob@color.vol, multi.col = lchob@multi.col,
spacing = lchob@spacing, width = lchob@width, bp = lchob@bp,
x.labels = lchob@x.labels, time.scale = lchob@time.scale,
isLogical = is.logical(x), legend = legend, legend.name = legend.name,
pars = list(gpars))
if (is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA, chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new, 1,
0)
do.call("chartSeries.chob", list(lchob))
invisible(chobTA)
}
else {
return(chobTA)
}
}
quantmod/R/periodReturn.R 0000644 0001762 0000144 00000006225 15002467345 015123 0 ustar ligges users cumReturn <- function(x, ...) {
first.value <- as.numeric(x[1])
(x - first.value)/first.value
}
`periodReturn` <-
function(x,period='monthly',subset=NULL,type='arithmetic',leading=TRUE,...) {
xx <- try.xts(x)
# currently there is a bug in ts conversions, just use 'xts'
if(inherits(x,'ts')) {
x <- na.omit(try.xts(x))
xtsAttributes(x) <- CLASS(x) <- NULL
xx <- x
TS <- TRUE
} else TS <- FALSE
if(has.Op(xx) && has.Cl(xx)) {
getFirst <- function(X) Op(X)
getLast <- function(X) Cl(X)
} else getFirst <- getLast <- function(X) X[,1]
#FUN = eval(parse(text=paste('xts::to',period,sep='.')))
on.opts <- list(daily='days',
weekly='weeks',
monthly='months',
quarterly='quarters',
yearly='years',
annually='years')
ep <- endpoints(xx, on=on.opts[[period]])
#ret <- Delt_(Cl(FUN(x,...)),type=type)
ret <- Delt_(Cl(to_period(xx, period=on.opts[[period]],...)),type=type)
if(leading) {
firstval <- as.numeric(Delt_(getFirst(xx[1]),getLast(xx[ep[2]]),type=type))
ret[1,] <- firstval
}
colnames(ret) <- paste(period,'returns',sep='.')
if(TS) xx <- 1 # make sure reclass doesn't do anything!
tmp.ret <- reclass(ret,xx[ep[-1]])
if(is.null(subset)) subset <- '/'
reclass(as.xts(tmp.ret)[subset])
}
`periodReturn0` <-
function(x,period='monthly',subset=NULL,type='arithmetic',...) {
xx <- x
if(is.null(subset)) subset <- '::'
FUN = eval(parse(text=paste('xts::to',period,sep='.')))
x <- FUN(x, ...)
# get key attributes for later rebuilding
x <- as.xts(x)
.originalCLASS <- CLASS(x)
.originalAttr <- xtsAttributes(x)
.originalIndexClass <- tclass(x)
x <- Delt(Cl(x),type=type)
colnames(x) <- paste(period,'returns',sep='.')
x <- as.xts(x)[subset]
# replace attributes lost to Delt fun and reclass
CLASS(x) <- .originalCLASS
xtsAttributes(x) <- .originalAttr
tclass(x) <- .originalIndexClass
reclass(x)
}
`dailyReturn` <-
function(x,subset=NULL,type='arithmetic',leading=TRUE,...) {
periodReturn(x,'daily',subset,type,leading,...)
}
`monthlyReturn` <-
function(x,subset=NULL,type='arithmetic',leading=TRUE,...) {
periodReturn(x,'monthly',subset,type,leading,...)
}
`weeklyReturn` <-
function(x,subset=NULL,type='arithmetic',leading=TRUE,...) {
periodReturn(x,'weekly',subset,type,leading,...)
}
`quarterlyReturn` <-
function(x,subset=NULL,type='arithmetic',leading=TRUE,...) {
periodReturn(x,'quarterly',subset,type,leading,...)
}
`yearlyReturn` <-
function(x,subset=NULL,type='arithmetic',leading=TRUE,...) {
periodReturn(x,'yearly',subset,type,leading,...)
}
`annualReturn` <- yearlyReturn
`allReturns` <-
function(x,subset=NULL,type='arithmetic',leading=TRUE) {
x.orig <- x
x <- try.xts(x)
all.ret <- cbind(
periodReturn(x,'daily',subset,type=type,leading=FALSE),
periodReturn(x,'weekly',subset,type=type),
periodReturn(x,'monthly',subset,type=type,indexAt='endof'),
periodReturn(x,'quarterly',subset,type=type,indexAt='endof'),
periodReturn(x,'yearly',subset,type=type)
)
colnames(all.ret) <- c('daily','weekly','monthly','quarterly','yearly')
reclass(all.ret, x.orig)
}
quantmod/R/getOptionChain.orats.R 0000644 0001762 0000144 00000012074 15002467345 016502 0 ustar ligges users #
# quantmod: Quantitative Financial Modelling Framework
#
# Copyright (C) 2021 Joshua M. Ulrich, Steve Bronder
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see .
#
.make_orats_option_df <- function(option_df, call_cols, put_cols, extra_cols) {
call <- data.frame(
Ticker = option_df$ticker,
Strike = option_df$strike,
Bid = option_df$callBidPrice,
Ask = option_df$callAskPrice,
Vol = option_df$callVolume,
OI = option_df$callOpenInterest)
put <- data.frame(
Ticker = option_df$ticker,
Strike = option_df$strike,
Bid = option_df$putBidPrice,
Ask = option_df$putAskPrice,
Vol = option_df$putVolume,
OI = option_df$putOpenInterest)
call_extra <- option_df[, c("ticker", "strike", call_cols)]
colnames(call_extra) <- gsub("call|Call", "", colnames(call_extra))
put_extra <- option_df[, c("ticker", "strike", put_cols)]
colnames(put_extra) <- gsub("put|Put", "", colnames(put_extra))
extra <- option_df[, extra_cols]
return(list(call = call, put = put, call_extra = call_extra, put_extra = put_extra, extra = extra))
}
getOptionChain.orats <- function(Symbols, Exp, api.key, dte, delta) {
if (missing(api.key)) {
# Check if they have ORATS_API_KEY defined
orats_key <- Sys.getenv("ORATS_API_KEY")
if (orats_key == "") {
stop(paste0("For the orats API an API key must be provided either",
" as a function argument or via an environment variable ORATS_API_KEY"))
} else {
api.key <- orats_key
}
}
# Construct URL
base_url <- "https://api.orats.io/datav2/strikes.json"
urlExp <- paste0(base_url, "?token=", api.key,
"&ticker=", paste0(Symbols, collapse=","))
if (!missing(dte)) {
if (length(dte) > 2) {
stop(paste0("Date to Expiry (dte) must be of size 2, but is size (", length(dte), ")"))
}
urlExp <- paste0(urlExp, "&dte=", paste0(dte, collapse = ","))
}
if (!missing(delta)) {
if (length(delta) > 2) {
stop(paste0("Date to Expiry (dte) must be of size 2, but is size (", length(delta), ")"))
}
urlExp <- paste0(urlExp, "&delta=", paste0(delta, collapse = ","))
}
# Fetch data (jsonlite::fromJSON will handle connection)
tbl <- jsonlite::fromJSON(urlExp)[["data"]]
tbl[, "expirDate"] <- as.POSIXct(tbl[, "expirDate"], format = "%Y-%m-%d")
tbl[, "tradeDate"] <- as.POSIXct(tbl[, "tradeDate"], format = "%Y-%m-%d")
tbl[, "updatedAt"] <- as.POSIXct(tbl[, "updatedAt"], format = "%Y-%m-%dT%H:%M:%SZ")
tbl[, "snapShotDate"] <- as.POSIXct(tbl[, "snapShotDate"], format = "%Y-%m-%dT%H:%M:%SZ")
tbl[, "quoteDate"] <- as.POSIXct(tbl[, "quoteDate"], format = "%Y-%m-%dT%H:%M:%SZ")
tbl_cols <- colnames(tbl)
call_cols <- tbl_cols[grep("call|Call", tolower(tbl_cols))]
put_cols <- tbl_cols[grep("put|Put", tolower(tbl_cols))]
extra_cols <- colnames(tbl)[!(colnames(tbl) %in% c(call_cols, put_cols))]
if(!missing(Exp)) {
if (is.null(Exp)) {
date_expr <- format(tbl[, "expirDate"], format = "%b.%d.%Y")
tbl2 <- split(tbl, factor(date_expr, levels = unique(date_expr)))
tbl3 <- lapply(tbl2, .make_orats_option_df, call_cols, put_cols, extra_cols)
return(tbl3)
} else {
all.expiries <- tbl$expirDate
all.expiries.posix <- .POSIXct(as.numeric(all.expiries), tz="UTC")
if(inherits(Exp, "Date")) {
valid.expiries <- as.Date(all.expiries.posix) %in% Exp
} else if(inherits(Exp, "POSIXt")) {
valid.expiries <- all.expiries.posix %in% Exp
} else if(is.character(Exp)) {
expiry.range <- range(unlist(lapply(Exp, .parseISO8601, tz="UTC")))
valid.expiries <- all.expiries.posix >= expiry.range[1] &
all.expiries.posix <= expiry.range[2]
}
if(all(!valid.expiries)) {
stop("Provided expiry date(s) [", paste0(Exp, collapse = ","), "] not found. Available dates are: ",
paste(as.Date(all.expiries.posix), collapse=", "))
}
exp_posixct <- as.POSIXct(Exp)
tbl_exp <- tbl[tbl$expirDate %in% exp_posixct,]
if (length(Exp) == 1) {
return(.make_orats_option_df(tbl_exp, call_cols, put_cols, extra_cols))
} else {
date_expr <- format(tbl_exp[, "expirDate"], format = "%b.%d.%Y")
tbl2 <- split(tbl_exp, factor(date_expr, levels = unique(date_expr)))
tbl3 <- lapply(tbl2, .make_orats_option_df, call_cols, put_cols, extra_cols)
return(tbl3)
}
}
} else {
tbl_exp <- tbl[tbl$expirDate == tbl$expirDate[1],]
return(.make_orats_option_df(tbl_exp, call_cols, put_cols, extra_cols))
}
}
quantmod/R/peak.R 0000644 0001762 0000144 00000001235 14772047315 013361 0 ustar ligges users findPeaks <-
function(x, thresh=0) {
pks <- which(diff(sign(diff(x, na.pad=FALSE)),na.pad=FALSE) < 0) + 2
if( !missing(thresh) ) {
if(sign(thresh) < 0)
thresh <- -thresh
pks[x[pks-1]-coredata(x[pks]) > thresh]
} else pks
}
peak <- function(x) {
.Deprecated("findPeaks", package="quantmod")
findPeaks(x)
}
findValleys <-
function(x, thresh=0) {
pks <- which(diff(sign(diff(x, na.pad=FALSE)),na.pad=FALSE) > 0) + 2
if( !missing(thresh) ) {
if(sign(thresh) > 0)
thresh <- -thresh
pks[x[pks-1]-coredata(x[pks]) < thresh]
} else pks
}
valley <- function(x) {
.Deprecated("findValleys", package="quantmod")
findValleys(x)
}
quantmod/R/Defaults.R 0000644 0001762 0000144 00000020631 15002467345 014205 0 ustar ligges users "importDefaults" <-
function(calling.fun=NULL) {
sc <- sys.call(-1)
if(is.null(calling.fun)) calling.fun <- as.character(sc[[1]])
if(is.function(calling.fun)) calling.fun <- deparse(substitute(calling.fun))
if(is.null(sc))
stop("importDefaults is only valid inside a function call")
funcall <- as.character(sc[[1]])
funcall <- if(funcall[1] %in% c("::", ":::")) funcall[3] else funcall[1]
if(funcall != calling.fun) return()
all.defaults <- getDefaults(calling.fun)
if(is.null(all.defaults)) return()
envir <- as.environment(-1)
passed.args <- names(as.list(match.call(
definition=eval(parse(text=calling.fun)),
call=sc)))[-1]
formal.args <- names(formals(calling.fun))
default.args <- names(which(sapply(all.defaults,function(x) !is.null(x))==TRUE))
for(arg in formal.args) {
if(!arg %in% passed.args) {
if(arg %in% default.args) {
this.default <- all.defaults[arg][[1]]
if(typeof(this.default)=='list') {
assign(arg, as.vector(this.default),envir=envir)
}
else if(typeof(this.default) %in% c('symbol','language')) {
assign(arg, this.default,envir=envir)
}
else if(typeof(this.default)=="character") {
if(length(this.default)==1) {
assign(arg, eval(parse(text=this.default)),envir=envir)
} else {
assign(arg, as.character(parse(text=this.default)),envir=envir)
}
}
else {
assign(arg, as.vector(unlist(this.default)),envir=envir)
}
}
}
}
}
`setDefaults` <-
function (name, ...)
{
# 'name' can be a character string or a symbol.
# We need the character string representation of the function name so
# we can use it to create the option name. Then we can look it up via
# importDefaults() when the function is called.
# Should also document that 'name' can be a symbol, but only at the top
# level. Calls to setDefaults() (etc.) within functions must use character
# strings to identify functions.
is.func <-
try({
is.function(name)
eval(parse(text=name))
}, silent=TRUE)
# 'name' can be a function name, expression, or character
# the try() catches instances where name is an unexported symbol
if(inherits(is.func, "try-error")) {
# get the character representation of the symbol
name.str <- deparse(substitute(name))
# remove quotes in the case 'name' is already character
name.str <- gsub("['\"]", "", name.str)
ga.func <- getAnywhere(name.str)
ga.objs <- ga.func[["objs"]]
if (length(ga.objs) < 1) {
stop("no function named '", ga.func$name, "' was found")
}
# check that the function body has a call to importDefaults()
has.importDefaults <- function(fn) {
out <- FALSE
if (is.function(fn)) {
chr <- as.character(body(fn))
has <- grepl("importDefaults", chr, fixed = TRUE)
out <- any(has)
} else {
out <- FALSE
}
out
}
is.valid <- sapply(ga.objs, has.importDefaults)
is.visible <- ga.func[["visible"]]
first.choice <- which(is.valid & is.visible)
if(length(first.choice) < 1) {
# first non-visible function
first.choice <- which(is.valid)
if(length(first.choice) < 1) {
# nothing visible and valid
stop("argument 'name' must be a function that contains a ",
"call to 'importDefaults()'")
}
} else {
first.choice <- first.choice[1]
}
name <- ga.func[["name"]]
avail.defaults <- formals(ga.objs[[first.choice]])
} else {
if (is.function(name)) {
name <- deparse(substitute(name))
}
func <- eval(parse(text=name))
if (!is.function(func)) {
stop("argument 'name' must be a function", call. = FALSE)
}
avail.defaults <- formals(func)
}
default.name <- paste(name, "Default", sep = ".")
old.defaults <- getDefaults(name)
new.defaults <- list(...)
matched.defaults <- list()
for(arg in names(new.defaults)) {
if(!is.na(pmatch(arg,names(avail.defaults)))) {
# if partial match is made:
arg.name <- match.arg(arg,names(avail.defaults))
mc <- match.call()[[arg]]
if(is.language(mc)) mc <- eval(mc)
if(is.character(mc))
new.defaults[[arg]] <- paste("'", mc, "'", sep = "")
if(is.name(mc))
new.defaults[[arg]] <- as.character(mc)
matched.defaults[[arg.name]] <- new.defaults[[arg]]
if(is.null(new.defaults[[arg]])) old.defaults[[arg.name]]<-NULL
} else {
warning(paste(
sQuote(arg),"was not set, possibly not a formal arg for",
sQuote(name)))
}
}
# merge original and new, then take first value only
all.and.matched <- c(matched.defaults,old.defaults)
all.and.matched <- all.and.matched[unique(names(all.and.matched))]
if (length(all.and.matched) == 0) {
if(!is.null(getDefaults(name))) unsetDefaults(name, confirm = FALSE)
}
else {
env <- as.environment(-1)
default.deparse <- function(x) {
if (is.character(x))
# paste into single string (deparse may return length > 1)
paste(deparse(x), sep="", collapse="")
else
x
}
default.values <- lapply(all.and.matched, default.deparse)
default.list <- paste(names(all.and.matched), "=", default.values)
eval(parse(text = paste("options(", default.name, "=list(",
paste(default.list, collapse = ","), "))", sep = "")), envir = env)
}
}
`unsetDefaults` <-
function(name,confirm=TRUE) {
importDefaults(calling.fun='unsetDefaults')
# 'name' can be a function name, expression, or character
# the try() catches instances where name is an unexported symbol
name.is.function <- try(is.function(name), silent = TRUE)
if(inherits(name.is.function, "try-error") || isTRUE(name.is.function)) {
name <- deparse(substitute(name))
}
if(is.null(getDefaults(name)))
invisible(return())
#stop(paste("no Defaults set for",sQuote(name)))
remove.yes <- TRUE
if(confirm) {
CONFIRMATION <- readline(prompt=
paste("Are you sure you want to remove",
sQuote(name),"defaults? (N): "))
if(toupper(substr(CONFIRMATION,1,1))!="Y") {
remove.yes <- FALSE
cat(paste(sQuote(name),"Defaults NOT removed\n"))
} else {
if(confirm)
cat(paste(sQuote(name),"Defaults removed!\n"))
}
}
if(remove.yes) {
default.name <- paste(name,"Default",sep=".")
env <- as.environment(-1)
eval(parse(text=paste('options(',default.name,'=NULL)',sep='')),envir=env)
}
}
"getDefaults" <-
function(name=NULL,arg=NULL) {
# 'name' can be a function name, expression, or character
# the try() catches instances where name is an unexported symbol
name.is.function <- try(is.function(name), silent = TRUE)
if(inherits(name.is.function, "try-error") || isTRUE(name.is.function)) {
name <- deparse(substitute(name))
}
if(!is.null(name)) {
if(!is.character(name)) {
fcall <- match.call()
name <- as.character(fcall[['name']])
}
if(length(name) > 1) {
if(!is.character(name))
stop(paste(sQuote('name'),"must be a character vector",
"or visible function"))
all.names=list()
}
for(each.name in name) {
default.name <- paste(each.name,"Default",sep=".")
if(is.null(arg)) {
if(exists('all.names',inherits=FALSE)) {
all.names[[each.name]] <- options(default.name)[[1]]
} else {
return(options(default.name)[[1]])
}
} else {
default.list <- list()
for(each.arg in arg) {
default.list[[each.arg]] <- options(default.name)[[1]][[each.arg]]
}
if(exists('all.names',inherits=FALSE)) {
all.names[[each.name]] <- default.list
} else {
return(default.list)
}
}
}
return(all.names)
} else {
all.options <- names(options())
all.Defaults <-as.character(
sapply(all.options[grep('.Default$',all.options)],
FUN=function(x) {
gsub('.Default$','',x)
})
)
if(identical(all.Defaults,character(0))) return(NULL)
return(all.Defaults)
}
}
quantmod/R/tradeModel.R 0000644 0001762 0000144 00000005145 15002467345 014521 0 ustar ligges users "tradeModel" <- function(x,
signal.threshold=c(0,0),
leverage=1,
return.model=TRUE,
plot.model=FALSE,
trade.dates=NULL,
exclude.training=TRUE,
ret.type=c('weeks','months','quarters','years'),...)
{
trade.offset = 0;
quantmod <- getModelData(x);
if(!inherits(quantmod, "quantmod")) stop("model must be of class quantmod");
if(!is.null(trade.dates) && length(trade.dates) < 2) stop("trade.dates must be of length 2");
model.data <- modelData(quantmod,trade.dates,exclude.training=exclude.training);
fitted.zoo <- predictModel(quantmod@fitted.model,model.data,...)
if(inherits(fitted.zoo, "zoo", which = TRUE) != 1) {
fitted.zoo <- zoo(as.vector(fitted.zoo),index(model.data));
}
# trade Rule section
#on open
signal.zoo <- ifelse(fitted.zoo < signal.threshold[1] |
fitted.zoo > signal.threshold[2],
ifelse(fitted.zoo > 0,1,-1), 0);
tmp.index <- index(signal.zoo)[-(1+trade.offset)];
market.zoo <- model.data[-(NROW(model.data)+trade.offset),1]
signal.zoo <- signal.zoo[-c(length(index(signal.zoo))-trade.offset,length(index(signal.zoo)))];
signal.zoo = merge(market.zoo,signal.zoo)
index(signal.zoo) <- tmp.index;
#quantmodResults <- new("quantmodResults", model=quantmod, signal=signal.zoo);
quantmodResults <- list(model=quantmod, signal=signal.zoo)
model.returns <- modelReturn(quantmodResults,trade.dates=trade.dates,leverage=leverage,ret.type=ret.type);
quantmodResults$return <- model.returns;
# strip data to minimize memory consumption
quantmodResults$model <- stripModelData(quantmodResults$model);
return(structure(quantmodResults, class="quantmodResults"));
}
print.quantmodResults <- function(x, ...) {
cat("\n Model: ",x$model@model.id,"\n")
cat("\n C.A.G.R.: ",sprintf("%04.2f%%",x$return@CAGR*100),"\tH.P.R.: ",
sprintf("%04.2f%%",x$return@HPR*100),"\n");
to.date.ret <- sprintf("%04.2f%%",x$return@returnsBy[NROW(x$return@returnsBy),-1]*100)
to.date.ret <- as.data.frame(t(to.date.ret),row.names=" ")
colnames(to.date.ret) <- colnames(x$return@returnsBy[,-1])
cat("\n Returns by period summary:\n\n")
print(as.data.frame(lapply(as.data.frame(x$return@returnsBy[,-1]),
function(x) sprintf("%04.2f%%",(rev(as.numeric(summary(x))[1:6]*100)))),
row.names=c(' Max.',' 3rd Qu.',' Mean',' Median',' 2rd Qu.',' Min.')))
cat("\n Period to date returns:\n\n")
print(to.date.ret)
}
quantmod/R/getSymbols.R 0000644 0001762 0000144 00000164152 15024564542 014576 0 ustar ligges users # getSymbols {{{
"getSymbols" <-
function(Symbols=NULL,
env=parent.frame(), ### 0.4-0
#env=NULL, ### 0.5-0
reload.Symbols=FALSE,
verbose=FALSE,
warnings=TRUE,
src="yahoo",
symbol.lookup=TRUE,
auto.assign=getOption('getSymbols.auto.assign',TRUE),
...) {
importDefaults("getSymbols")
# to enable as-it-was behavior, set this:
# options(getSymbols=list(env=substitute(parent.frame(3))))
#if(missing(env))
# env <- eval(getOption("getSymbols")$env) ### 0.5-0
if(missing(env) && !is.null(getOption("getSymbols.env")) )
env <- getOption("getSymbols.env") ### 0.4-0
#env_ <- getSymbols_options_("env")
#if(missing(env) && !is.null(env_))
# env <- env_
if(is.null(env)) # default as of 0.5-0
auto.assign <- FALSE
if(!auto.assign && length(Symbols)>1)
stop("must use auto.assign=TRUE for multiple Symbols requests")
force(Symbols) # need to check if symbol lookup defined _within_ call
if(symbol.lookup && missing(src)) {
# if src is specified - override symbol.lookup
symbols.src <- getOption('getSymbols.sources')
} else {
symbols.src <- src[1]
}
#src <- src[1]
if(is.character(Symbols)) {
# at least one Symbol has been specified
Symbols <- unlist(strsplit(Symbols,';'))
tmp.Symbols <- vector("list")
for(each.symbol in Symbols) {
if(each.symbol %in% names(symbols.src)) {
tmp.src <- symbols.src[[each.symbol]]$src[1]
#tmp.src <- symbols.src[[each.symbol]]
if(is.null(tmp.src)) {
tmp.Symbols[[each.symbol]] <- src[1]
} else {
tmp.Symbols[[each.symbol]] <- tmp.src
}
} else {
tmp.Symbols[[each.symbol]] <- src[1]
}
}
Symbols <- tmp.Symbols
}
old.Symbols <- NULL
if(auto.assign && exists('.getSymbols',env,inherits=FALSE)) {
old.Symbols <- get('.getSymbols',env)
}
if(reload.Symbols) {
Symbols <- c(Symbols, old.Symbols)[unique(names(c(Symbols,old.Symbols)))]
}
if(!auto.assign && length(Symbols) > 1)
stop("must use auto.assign=TRUE when reloading multiple Symbols")
if(!is.null(Symbols)) {
#group all Symbols by source
Symbols <- as.list(unlist(lapply(unique(as.character(Symbols)),
FUN=function(x) {
Symbols[Symbols==x]
}
)))
# are any symbols reserved words?
if(getOption("quantmod.warn.ticker.reserved.word", TRUE)) {
reserved.tickers <- c("NA", "TRUE")
is.reserved <- reserved.tickers %in% names(Symbols)
if(any(is.reserved)) {
rtk <- paste(reserved.tickers[is.reserved], collapse = ", ")
if (sum(is.reserved) > 1) {
msg <- paste("tickers", rtk, "are reserved words")
} else {
msg <- paste("ticker", rtk, "is a reserved word")
}
warning(msg, " and must be back-quoted to be used (e.g. `NA`).")
}
}
# was getSymbols() called with more than 1 symbol?
.has1sym. <- length(Symbols) < 2L
#Symbols <- as.list(Symbols)
all.symbols <- list()
for(symbol.source in unique(as.character(Symbols))) {
current.symbols <- names(Symbols[Symbols==symbol.source])
symbols.returned <- do.call(paste('getSymbols.',symbol.source,sep=''),
list(Symbols=current.symbols,env=env,
#return.class=return.class,
#reload.Symbols=reload.Symbols,
verbose=verbose,warnings=warnings,
auto.assign=auto.assign,
...,
.has1sym.=.has1sym.))
if(!auto.assign)
return(symbols.returned)
for(each.symbol in symbols.returned) all.symbols[[each.symbol]] <- symbol.source
}
req.symbols <- names(all.symbols)
all.symbols <- c(all.symbols,old.Symbols)[unique(names(c(all.symbols,old.Symbols)))]
if(auto.assign) {
assign('.getSymbols',all.symbols,env);
return(req.symbols)
#return(env)
}
} else {
warning('no Symbols specified')
}
}
#}}}
loadSymbols <- getSymbols
loadSymbols.formals <- c(formals(getSymbols)[-(8:9)], alist(auto.assign=getOption("loadSymbols.auto.assign",TRUE),...=))
formals(loadSymbols) <- loadSymbols.formals
# getSymbols.Bloomberg {{{
#"getSymbols.Bloomberg" <- function(Symbols,env,return.class='xts',
# from=as.POSIXlt(Sys.time()-60*60,"GMT"),
# to=as.POSIXlt(Sys.time(),"GMT"),
# bb.suffix="Equity",
# bb.interval="5",
# ...) {
# importDefaults("getSymbols.Bloomberg")
# this.env <- environment()
# for(var in names(list(...))) {
# # import all named elements that are NON formals
# assign(var, list(...)[[var]], this.env)
# }
# if ((inherits(from, "Date") && inherits(to, "Date")) ||
# (is.character(from) && length(from)<=8 &&
# is.character(to) && length(to)<=8 )) {
# bb.intraday <- FALSE
# bb.call <- bdh
# bb.fields <- c("OPEN", "HIGH", "LOW", "PX_LAST", "VOLUME")
# } else {
# bb.intraday <- TRUE
# bb.call <- bar
# bb.fields <- "TRADE"
# }
# if(missing(verbose)) verbose <- FALSE
# if(missing(auto.assign)) auto.assign <- TRUE
# if('package:RBloomberg' %in% search() ||
#require('RBloomberg',quietly=TRUE)) {
# {}
# } else {
# stop(paste("package:",dQuote('RBloomberg'),"cannot be loaded."))
# }
# bbconn <- blpConnect()
# for(i in 1:length(Symbols)) {
# bbsym <- paste(Symbols[[i]],bb.suffix)
#
# if(verbose) {
# cat(paste('Loading ',bbsym, ' from BB ', from,' to ',to,
# paste(rep('.',18-nchar(Symbols[[i]])),collapse=''),
# sep=''))
#
# }
# tryCatch (
# {
# if (bb.intraday) {
# fromStr <- paste(as.character(from),".000",sep="")
# toStr <- paste(as.character(to),".000",sep="")
# b <- bb.call(bbconn, bbsym, bb.fields,
# fromStr, toStr, bb.interval)
# b$datetime <- as.POSIXct(strptime(b$time,
#format="%Y-%m-%dT%H:%M:%S"))
# bxo <- as.xts(b$open, order.by=b$datetime)
# fr <- merge(bxo, b$high, b$low, b$close, b$volume)
# } else {
# if (is.character(from)) {
# fromStr <- from
# } else {
# fromStr <- strftime(from,format="%Y%m%d")
# }
# if (is.character(to)) {
# toStr <- to
# } else {
# toStr <- strftime(to,format="%Y%m%d")
# }
# b <- bb.call(bbconn, bbsym, bb.fields,
# fromStr, toStr)
# b$datetime <- as.POSIXct(strptime(b$date,
#format="%Y-%m-%d"))
# bxo <- as.xts(b$OPEN, order.by=b$datetime)
# fr <- merge(bxo, b$HIGH, b$LOW, b$PX_LAST, b$VOLUME)
# }
#
#
#
# if(verbose) {
# cat(paste(length(fr),'points '))
# }
# colnames(fr) <- paste(Symbols[[i]],
# c('Open','High','Low','Close','Volume'),
# sep='.')
# fr <- convert.time.series(fr=fr,return.class=return.class)
# if(auto.assign)
# assign(Symbols[[i]],fr,env)
# },
# error=function(e) {print(e);fr <- data.frame()},
# finally=function () {if(verbose) {cat('done\n')}}
# )
# }
# blpDisconnect(bbconn)
# if(auto.assign)
# return(Symbols)
# return(fr)
#}
#"getSymbols.Bloomberg" <- getSymbols.Bloomberg
# }}}
.getHandle <- function(curl.options = list(), force.new = FALSE)
{
h <- get0("_handle_", .quantmodEnv)
if (is.null(h) || force.new) {
# create 'h' if it doesn't exist yet
h <- curl::new_handle()
curl::handle_setopt(h, .list = curl.options)
assign("_handle_", h, .quantmodEnv)
}
return(h)
}
.yahooJsonURL <-
function(symbol, from, to, interval)
{
u <- paste0("https://query2.finance.yahoo.com/v8/finance/chart/",
symbol,
sprintf("?period1=%.0f&period2=%.0f&interval=%s", from, to, interval))
return(u)
}
.dateToUNIX <- function(Date) {
posixct <- as.POSIXct(as.Date(Date, origin = "1970-01-01"))
trunc(as.numeric(posixct))
}
# getSymbols.yahoo {{{
"getSymbols.yahoo" <-
function(Symbols,env,return.class='xts',index.class="Date",
from='2007-01-01',
to=Sys.Date(),
...,
periodicity="daily",
curl.options=list())
{
importDefaults("getSymbols.yahoo")
this.env <- environment()
for(var in names(list(...))) {
# import all named elements that are NON formals
assign(var, list(...)[[var]], this.env)
}
if(!hasArg("adjust"))
adjust <- FALSE
default.return.class <- return.class
default.from <- from
default.to <- to
mins <- c(1, 2, 5, 15, 30, 60, 90)
min_vals <- paste0(rep(mins, 2), "m")
names(min_vals) <- c(paste0(mins, "minutes"), paste0(mins, " minutes"))
intervals <- c(daily = "1d", weekly = "1wk", monthly = "1mo", hourly = "1h", min_vals)
default.periodicity <- match.arg(periodicity, names(intervals))
if(!hasArg("verbose")) verbose <- FALSE
if(!hasArg("auto.assign")) auto.assign <- TRUE
if(!hasArg("warnings")) warnings <- TRUE
handle <- .getHandle(curl.options)
returnSym <- Symbols
noDataSym <- NULL
for(i in seq_along(Symbols)) {
test <- try({
return.class <- getSymbolLookup()[[Symbols[[i]]]]$return.class
return.class <- ifelse(is.null(return.class),default.return.class,
return.class)
periodicity <- getSymbolLookup()[[Symbols[[i]]]]$periodicity
periodicity <- if(is.null(periodicity)) default.periodicity else periodicity
# ensure valid periodicity
p <- pmatch(periodicity, names(intervals))
if(is.na(p))
stop("periodicity must be one of: ", paste(intervals, collapse=", "))
interval <- intervals[p]
is.intraday <- !(interval %in% c("1d", "1wk", "1mo"))
from <- getSymbolLookup()[[Symbols[[i]]]]$from
from <- if(is.null(from)) default.from else from
to <- getSymbolLookup()[[Symbols[[i]]]]$to
to <- if(is.null(to)) default.to else to
if(is.intraday) {
from.date <- as.Date(from)
to.date <- as.Date(to)
n.days <- difftime(time1 = to.date, time2 = from.date, units = "days")
if(n.days > 7) {
from <- to.date - 7
if(warnings) {
warning(paste0(
"Only a maximum of 7 days is allowed for querying intraday data",
"data from 'yahoo'. Setting `from` to '", from, "'."
), call. = FALSE)
}
}
}
from.posix <- .dateToUNIX(from)
to.posix <- .dateToUNIX(to)
Symbols.name <- getSymbolLookup()[[Symbols[[i]]]]$name
Symbols.name <- ifelse(is.null(Symbols.name),Symbols[[i]],Symbols.name)
if(verbose) cat("downloading ",Symbols.name,".....\n\n")
yahoo.URL <- .yahooJsonURL(Symbols.name, from.posix, to.posix, interval)
conn <- curl::curl(yahoo.URL, handle = handle)
y <- jsonlite::fromJSON(conn)
if (is.null(y$chart) || is.null(y$chart$result)) {
stop("no data for", Symbols.name)
}
y <- y$chart$result
ohlcv <- unlist(y$indicators$quote[[1]], recursive = FALSE)
tz <- y$meta$exchangeTimezoneName
idx <- .POSIXct(y$timestamp[[1]], tz = tz)
if (!is.intraday) {
idx <- as.Date(idx)
}
x <- xts(do.call(cbind, ohlcv), idx,
src='yahoo', updated=Sys.time())
fr <- OHLCV(x)
cnames <- c("Open", "High", "Low", "Close", "Volume")
if (!is.intraday) {
fr <- merge(fr, adjusted = unlist(y$indicators$adjclose))
cnames <- c(cnames, "Adjusted")
}
# convert column names to Initial Capitalization
cn <- colnames(fr)
substring(cn, 1, 1) <- toupper(substring(cn, 1, 1))
colnames(fr) <- cn
# warn about missing values
if (any(is.na(fr)) && isTRUE(warnings)) {
warning(Symbols.name, " contains missing values. Some functions will",
" not work if objects contain missing values in the middle",
" of the series. Consider using na.omit(), na.approx(),",
" na.fill(), etc to remove or replace them.", call. = FALSE)
}
# re-order column names and prefix with symbol
corder <- pmatch(substr(cnames, 1, 3), colnames(fr))
fr <- fr[,corder]
colnames(fr) <- paste(toupper(gsub("\\^","",Symbols.name)), cnames, sep=".")
if(adjust) {
# Adjustment algorithm by Joshua Ulrich
fr <- adjustOHLC(fr, symbol.name=Symbols.name)
}
fr <- convert.time.series(fr=fr,return.class=return.class)
if(is.xts(fr)) {
if(!is.intraday) {
tclass(fr) <- index.class
}
}
Symbols[[i]] <- toupper(gsub('\\^','',Symbols[[i]]))
returnSym[[i]] <- gsub('\\^', '', returnSym[[i]])
if(auto.assign)
assign(Symbols[[i]],fr,env)
}, silent = TRUE)
if (inherits(test, "try-error")) {
msg <- paste0("Unable to import ", dQuote(returnSym[[i]]),
".\n", attr(test, "condition")$message)
if (hasArg(".has1sym.") && match.call(expand.dots=TRUE)$.has1sym.) {
stop(msg)
}
if (isTRUE(warnings)) {
warning(msg, call. = FALSE, immediate. = TRUE)
}
noDataSym <- c(noDataSym, returnSym[[i]])
}
}
if(auto.assign)
return(setdiff(returnSym, noDataSym))
return(fr)
}
# }}}
# getSymbols.yahooj {{{
"getSymbols.yahooj" <-
function(Symbols, env=parent.frame(), return.class='xts', index.class="Date",
from='2007-01-01',
to=Sys.Date(),
...)
{
importDefaults("getSymbols.yahooj")
this.env <- environment()
for(var in names(list(...))) {
# import all named elements that are NON formals
assign(var, list(...)[[var]], this.env)
}
if(!hasArg("adjust"))
adjust <- FALSE
default.return.class <- return.class
default.from <- from
default.to <- to
if(!hasArg("verbose")) verbose <- FALSE
if(!hasArg("auto.assign")) auto.assign <- TRUE
if(!hasArg("warnings")) warnings <- TRUE
if(!requireNamespace("xml2", quietly=TRUE))
stop("package:",dQuote("xml2"),"cannot be loaded.")
yahoo.URL <- "https://finance.yahoo.co.jp/quote/"
returnSym <- Symbols
noDataSym <- NULL
for(i in seq_along(Symbols)) {
test <- try({
# The name of the symbol, which will actually be used as the
# variable name. It needs to start with YJ, and it will be appended
# if it does not.
symname <- toupper(Symbols[[i]])
# The symbol actually sent to Yahoo Japan. This is without the
# starting YJ bit.
symbol <- symname
# If it starts with YJ, try looking up defaults
if (grepl("^YJ", symname)) {
return.class <- getSymbolLookup()[[symname]]$return.class
return.class <- ifelse(is.null(return.class),default.return.class,
return.class)
from <- getSymbolLookup()[[symname]]$from
from <- if(is.null(from)) default.from else from
to <- getSymbolLookup()[[symname]]$to
to <- if(is.null(to)) default.to else to
# Extract the actual symbol to be sent to Yahoo Japan
symbol <- substring(symname, 3)
} else {
return.class <- default.return.class
from <- default.from
to <- default.to
# Prepend 'YJ' to the symbol and store it in symname
symname <- paste('YJ', symbol, sep="")
}
from.str <- format(as.Date(from), "%Y%m%d")
to.str <- format(as.Date(to), "%Y%m%d")
Symbols.name <- getSymbolLookup()[[symname]]$name
Symbols.name <- ifelse(is.null(Symbols.name),symbol,Symbols.name)
if(verbose) cat("downloading ",Symbols.name,".....\n\n")
page <- 1
totalrows <- c()
while (TRUE) {
URL <- paste0(yahoo.URL, Symbols.name, "/history?")
URL <- paste0(URL, "from=", from.str, "&to=", to.str, "&timeFrame=d&page=", page)
fdoc <- xml2::read_html(URL)
rows <- xml2::xml_find_all(fdoc, "//table/tbody/tr")
rows <- lapply(rows, function(r) { xml2::xml_text(xml2::xml_children(r)) })
rows <- rows[sapply(rows, length) >= 5]
if (length(rows) == 0) break
totalrows <- c(totalrows, rows)
page <- page + 1
}
if(verbose) cat("done.\n")
if (is.null(rows)) {
stop("No historical data for ", dQuote(Symbols[[i]]), ".")
}
# Available columns
cols <- c('Open','High','Low','Close','Volume','Adjusted')
# Handle date + OHLC, when date + OHLCVA isn't returned
if (length(totalrows[[1]]) == 5) {
cols <- cols[-(5:6)]
}
# Process from the start, for easier stocksplit management
totalrows <- rev(totalrows)
mat <- do.call(rbind, totalrows)
dates <- as.Date(mat[,1], format="%Y\u5e74%m\u6708%d\u65e5")
ohlc <- gsub(",", "", mat[,-1], fixed = TRUE)
storage.mode(ohlc) <- "numeric" # convert from character to number
fr <- xts(ohlc, dates, src="yahooj", updated=Sys.time())
colnames(fr) <- paste(symname, cols, sep='.')
fr <- convert.time.series(fr=fr,return.class=return.class)
if(is.xts(fr))
tclass(fr) <- index.class
Symbols[[i]] <- symname
if(auto.assign)
assign(Symbols[[i]],fr,env)
if(i >= 5 && length(Symbols) > 5) {
message("pausing 1 second between requests for more than 5 symbols")
Sys.sleep(1)
}
}, silent = TRUE)
if (inherits(test, "try-error")) {
msg <- paste0("Unable to import ", dQuote(returnSym[[i]]),
".\n", attr(test, "condition")$message)
if (hasArg(".has1sym.") && match.call(expand.dots=TRUE)$.has1sym.) {
stop(msg)
}
if (isTRUE(warnings)) {
warning(msg, call. = FALSE, immediate. = TRUE)
}
noDataSym <- c(noDataSym, returnSym[[i]])
}
}
if(auto.assign)
return(setdiff(returnSym, noDataSym))
return(fr)
}
# }}}
# getSymbols.google {{{
"getSymbols.google" <-
function(Symbols,env,return.class='xts',
from='2007-01-01',
to=Sys.Date(),
...)
{
msg <- paste0(sQuote("getSymbols.google"), " is defunct.",
"\nGoogle Finance stopped providing data in March, 2018.",
"\nYou could try setting src = \"yahoo\" instead.",
"\nSee help(\"Defunct\") and help(\"quantmod-defunct\")")
.Defunct("getSymbols", "quantmod", msg = msg)
}
# }}}
# getSymbols.SQLite {{{
"getSymbols.SQLite" <- function(Symbols,env,return.class='xts',
db.fields=c('row_names','Open','High',
'Low','Close','Volume','Adjusted'),
field.names = NULL,
dbname=NULL,
POSIX = TRUE,
...) {
importDefaults("getSymbols.SQLite")
this.env <- environment()
for(var in names(list(...))) {
# import all named elements that are NON formals
assign(var, list(...)[[var]], this.env)
}
if(!hasArg("verbose")) verbose <- FALSE
if(!hasArg("auto.assign")) auto.assign <- TRUE
if(!hasArg("warnings")) warnings <- TRUE
if(!requireNamespace("DBI", quietly=TRUE))
stop("package:",dQuote("DBI"),"cannot be loaded.")
if(!requireNamespace("RSQLite", quietly=TRUE))
stop("package:",dQuote("RSQLite"),"cannot be loaded.")
drv <- DBI::dbDriver("SQLite")
con <- DBI::dbConnect(drv,dbname=dbname)
db.Symbols <- DBI::dbListTables(con)
if(length(Symbols) != sum(Symbols %in% db.Symbols)) {
missing.db.symbol <- Symbols[!Symbols %in% db.Symbols]
warning(paste('could not load symbol(s): ',paste(missing.db.symbol,collapse=', ')))
Symbols <- Symbols[Symbols %in% db.Symbols]
}
returnSym <- Symbols
noDataSym <- NULL
for(i in seq_along(Symbols)) {
test <- try({
if(verbose) {
cat(paste('Loading ',Symbols[[i]],
paste(rep('.',10-nchar(Symbols[[i]])),collapse=''),
sep=''))
}
query <- paste("SELECT ",
paste(db.fields,collapse=','),
" FROM ",Symbols[[i]],
" ORDER BY row_names")
rs <- DBI::dbSendQuery(con, query)
fr <- DBI::fetch(rs, n=-1)
#fr <- data.frame(fr[,-1],row.names=fr[,1])
if(POSIX) {
d <- as.numeric(fr[,1])
class(d) <- c("POSIXt","POSIXct")
fr <- xts(fr[,-1],order.by=d)
} else {
fr <- xts(fr[,-1],order.by=as.Date(as.numeric(fr[,1]),origin='1970-01-01'))
}
colnames(fr) <- paste(Symbols[[i]],
c('Open','High','Low','Close','Volume','Adjusted'),
sep='.')
fr <- convert.time.series(fr=fr,return.class=return.class)
if(auto.assign)
assign(Symbols[[i]],fr,env)
if(verbose) cat('done\n')
}, silent = TRUE)
if (inherits(test, "try-error")) {
msg <- paste0("Unable to import ", dQuote(returnSym[[i]]),
".\n", attr(test, "condition")$message)
if (hasArg(".has1sym.") && match.call(expand.dots=TRUE)$.has1sym.) {
stop(msg)
}
if (isTRUE(warnings)) {
warning(msg, call. = FALSE, immediate. = TRUE)
}
}
}
DBI::dbDisconnect(con)
if(auto.assign)
return(setdiff(returnSym, noDataSym))
return(fr)
}
"getSymbols.sqlite" <- getSymbols.SQLite
# }}}
# getSymbols.MySQL {{{
"getSymbols.MySQL" <- function(Symbols,env,return.class='xts',
db.fields=c('date','o','h','l','c','v','a'),
field.names = NULL,
user=NULL,password=NULL,dbname=NULL,host='localhost',port=3306,
...) {
importDefaults("getSymbols.MySQL")
this.env <- environment()
for(var in names(list(...))) {
# import all named elements that are NON formals
assign(var, list(...)[[var]], this.env)
}
if(!hasArg("verbose")) verbose <- FALSE
if(!hasArg("auto.assign")) auto.assign <- TRUE
if(!hasArg("warnings")) warnings <- TRUE
if(!requireNamespace("DBI", quietly=TRUE))
stop("package:",dQuote("DBI"),"cannot be loaded.")
if(!requireNamespace("RMySQL", quietly=TRUE))
stop("package:",dQuote("RMySQL"),"cannot be loaded.")
if(is.null(user) || is.null(password) || is.null(dbname)) {
stop(paste(
'At least one connection argument (',sQuote('user'),
sQuote('password'),sQuote('dbname'),
") is not set"))
}
con <- DBI::dbConnect(RMySQL::MySQL(),user=user,password=password,dbname=dbname,host=host,port=port)
db.Symbols <- DBI::dbListTables(con)
if(length(Symbols) != sum(Symbols %in% db.Symbols)) {
missing.db.symbol <- Symbols[!Symbols %in% db.Symbols]
warning(paste('could not load symbol(s): ',paste(missing.db.symbol,collapse=', ')))
Symbols <- Symbols[Symbols %in% db.Symbols]
}
returnSym <- Symbols
noDataSym <- NULL
for(i in seq_along(Symbols)) {
test <- try({
if(verbose) {
cat(paste('Loading ',Symbols[[i]],paste(rep('.',10-nchar(Symbols[[i]])),collapse=''),sep=''))
}
query <- paste("SELECT ",paste(db.fields,collapse=',')," FROM ",Symbols[[i]]," ORDER BY date")
rs <- DBI::dbSendQuery(con, query)
fr <- DBI::fetch(rs, n=-1)
#fr <- data.frame(fr[,-1],row.names=fr[,1])
fr <- xts(as.matrix(fr[,-1]),
order.by=as.Date(fr[,1],origin='1970-01-01'),
src=dbname,updated=Sys.time())
colnames(fr) <- paste(Symbols[[i]],
c('Open','High','Low','Close','Volume','Adjusted'),
sep='.')
fr <- convert.time.series(fr=fr,return.class=return.class)
if(auto.assign)
assign(Symbols[[i]],fr,env)
if(verbose) cat('done\n')
}, silent = TRUE)
if (inherits(test, "try-error")) {
msg <- paste0("Unable to import ", dQuote(returnSym[[i]]),
".\n", attr(test, "condition")$message)
if (hasArg(".has1sym.") && match.call(expand.dots=TRUE)$.has1sym.) {
stop(msg)
}
if (isTRUE(warnings)) {
warning(msg, call. = FALSE, immediate. = TRUE)
}
noDataSym <- c(noDataSym, returnSym[[i]])
}
}
DBI::dbDisconnect(con)
if(auto.assign)
return(setdiff(returnSym, noDataSym))
return(fr)
}
"getSymbols.mysql" <- getSymbols.MySQL
# }}}
# getSymbols.FRED {{{
`getSymbols.FRED` <- function(Symbols,env,
return.class="xts", ...) {
importDefaults("getSymbols.FRED")
this.env <- environment()
for(var in names(list(...))) {
# import all named elements that are NON formals
assign(var, list(...)[[var]], this.env)
}
if(!hasArg("verbose")) verbose <- FALSE
if(!hasArg("auto.assign")) auto.assign <- TRUE
if(!hasArg("warnings")) warnings <- TRUE
if(!hasArg("from")) from <- ""
if(!hasArg("to")) to <- ""
FRED.URL <- "https://fred.stlouisfed.org/graph/fredgraph.csv?id="
returnSym <- Symbols
noDataSym <- NULL
for(i in seq_along(Symbols)) {
if(verbose) cat("downloading ",Symbols[[i]],".....\n\n")
test <- try({
URL <- paste0(FRED.URL, Symbols[[i]])
fr <- read.csv(curl::curl(URL),na.strings=".")
if(verbose) cat("done.\n")
fr <- xts(as.matrix(fr[,-1]),
as.Date(fr[,1],origin='1970-01-01'),
src='FRED',updated=Sys.time())
dim(fr) <- c(NROW(fr),1)
colnames(fr) <- as.character(toupper(Symbols[[i]]))
# subset between from/to dates before we convert from xts
fr <- fr[paste(from, to, sep = "/")]
fr <- convert.time.series(fr=fr,return.class=return.class)
Symbols[[i]] <-toupper(gsub('\\^','',Symbols[[i]]))
if(auto.assign)
assign(Symbols[[i]],fr,env)
}, silent = TRUE)
if (inherits(test, "try-error")) {
msg <- paste0("Unable to import ", dQuote(returnSym[[i]]),
".\n", attr(test, "condition")$message)
if (hasArg(".has1sym.") && match.call(expand.dots=TRUE)$.has1sym.) {
stop(msg)
}
if (isTRUE(warnings)) {
warning(msg, call. = FALSE, immediate. = TRUE)
}
noDataSym <- c(noDataSym, returnSym[[i]])
}
}
if(auto.assign)
return(setdiff(returnSym, noDataSym))
return(fr)
} #}}}
"getSymbols.cache" <- function() {}
# getFX {{{
`getFX` <-
function(Currencies,from=Sys.Date()-179,to=Sys.Date(),
env=parent.frame(),
verbose=FALSE,warning=TRUE,
auto.assign=TRUE,...) {
importDefaults("getFX")
if(missing(env))
env <- parent.frame(1)
if(is.null(env))
auto.assign <- FALSE
if(!auto.assign && length(Currencies) > 1)
stop("must use auto.assign=TRUE for multiple currency requests")
#src <- c('oanda','FRED')[pmatch(src,c('oanda','FRED'))[1]]
# parse Symbols
# make symbols conform to service naming conventions
# e.g. USD/JPY for oanda
#
# DEXUSJP for FRED
#
#if(src[1]=="oanda") {
getSymbols.oanda(Symbols=Currencies,from=from,to=to,
env=env,verbose=verbose,warning=warning,
auto.assign=auto.assign,...)
#} else {
# getSymbols.FRED(Symbols=Currencies,env=env,verbose=verbose,warning=warning,...)
#}
}
#}}}
# getMetals {{{
`getMetals` <-
function(Metals,from=Sys.Date()-179,to=Sys.Date(),
base.currency="USD",env=parent.frame(),
verbose=FALSE,warning=TRUE,
auto.assign=TRUE,...) {
importDefaults("getMetals")
if(missing(env))
env <- parent.frame(1)
if(is.null(env))
auto.assign <- FALSE
metals <- c("XAU-GOLD","XPD-PALLADIUM","XPT-PLATINUM","XAG-SILVER")
metals <- metals[sapply(Metals, function(x) grep(x,metals,ignore.case=TRUE))]
metals <- as.character(sapply(metals,
function(x) {
paste(strsplit(x,'-')[[1]][1],base.currency,sep="/")
}))
getSymbols.oanda(Symbols=metals,from=from,to=to,auto.assign=auto.assign,
env=env,verbose=verbose,warning=warning,...)
}
#}}}
# getRates {{{
`getRates` <-
function() {
}
#}}}
# getSymbols.csv {{{
"getSymbols.csv" <-
function(Symbols,env,
dir="",
return.class="xts",
extension="csv",
col.names=c('Open','High','Low','Close','Volume','Adjusted'),
...) {
importDefaults("getSymbols.csv")
this.env <- environment()
for(var in names(list(...))) {
assign(var,list(...)[[var]], this.env)
}
default.return.class <- return.class
default.dir <- dir
default.extension <- extension
if(!hasArg("verbose")) verbose <- FALSE
if(!hasArg("auto.assign")) auto.assign <- TRUE
if(!hasArg("warnings")) warnings <- TRUE
returnSym <- Symbols
noDataSym <- NULL
for(i in seq_along(Symbols)) {
test <- try({
return.class <- getSymbolLookup()[[Symbols[[i]]]]$return.class
return.class <- ifelse(is.null(return.class),default.return.class,
return.class)
dir <- getSymbolLookup()[[Symbols[[i]]]]$dir
dir <- ifelse(is.null(dir),default.dir,
dir)
extension <- getSymbolLookup()[[Symbols[[i]]]]$extension
extension <- ifelse(is.null(extension),default.extension,
extension)
if(verbose) cat("loading ",Symbols[[i]],".....")
if(dir=="") {
sym.file <- paste(Symbols[[i]],extension,sep=".")
} else {
sym.file <- file.path(dir,paste(Symbols[[i]],extension,sep="."))
}
if(!file.exists(sym.file)) {
cat("\nfile ",paste(Symbols[[i]],"csv",sep='.')," does not exist ",
"in ",dir,"....skipping\n")
next
}
fr <- read.csv(sym.file)
if(verbose)
cat("done.\n")
# ensure date column is character before calling as.Date
asDateArgs <- list(x=as.character(fr[,1]))
# use format passed via '...', if specified
if(hasArg("format"))
asDateArgs$format <- format
# allow format from setSymbolLookup to override
if(!is.null(getSymbolLookup()[[Symbols[[i]]]]$format))
asDateArgs$format <- getSymbolLookup()[[Symbols[[i]]]]$format
fr <- xts(fr[,-1],do.call("as.Date", asDateArgs),src='csv',updated=Sys.time())
colnames(fr) <- paste(toupper(gsub('\\^','',Symbols[[i]])),col.names,sep='.')
fr <- convert.time.series(fr=fr,return.class=return.class)
Symbols[[i]] <-toupper(gsub('\\^','',Symbols[[i]]))
if(auto.assign)
assign(Symbols[[i]],fr,env)
}, silent = TRUE)
if (inherits(test, "try-error")) {
msg <- paste0("Unable to import ", dQuote(returnSym[[i]]),
".\n", attr(test, "condition")$message)
if (hasArg(".has1sym.") && match.call(expand.dots=TRUE)$.has1sym.) {
stop(msg)
}
if (isTRUE(warnings)) {
warning(msg, call. = FALSE, immediate. = TRUE)
}
noDataSym <- c(noDataSym, returnSym[[i]])
}
}
if(auto.assign)
return(setdiff(returnSym, noDataSym))
return(fr)
}
#}}}
# getSymbols.rds {{{
"getSymbols.rds" <-
function(Symbols,env,
dir="",
return.class="xts",
extension="rds",
col.names=c('Open','High','Low','Close','Volume','Adjusted'),
...) {
importDefaults("getSymbols.rds")
this.env <- environment()
for(var in names(list(...))) {
assign(var,list(...)[[var]], this.env)
}
default.return.class <- return.class
default.dir <- dir
default.extension <- extension
if(!hasArg("verbose")) verbose <- FALSE
if(!hasArg("auto.assign")) auto.assign <- TRUE
if(!hasArg("warnings")) warnings <- TRUE
returnSym <- Symbols
noDataSym <- NULL
for(i in seq_along(Symbols)) {
test <- try({
return.class <- getSymbolLookup()[[Symbols[[i]]]]$return.class
return.class <- ifelse(is.null(return.class),default.return.class,
return.class)
dir <- getSymbolLookup()[[Symbols[[i]]]]$dir
dir <- ifelse(is.null(dir),default.dir,
dir)
extension <- getSymbolLookup()[[Symbols[[i]]]]$extension
extension <- ifelse(is.null(extension),default.extension,
extension)
if(verbose) cat("loading ",Symbols[[i]],".....")
if(dir=="") {
sym.file <- paste(Symbols[[i]],extension,sep=".")
} else {
sym.file <- file.path(dir,paste(Symbols[[i]],extension,sep="."))
}
if(!file.exists(sym.file)) {
cat("\nfile ",paste(Symbols[[i]],extension,sep='.')," does not exist ",
"in ",dir,"....skipping\n")
next
}
#fr <- read.csv(sym.file)
fr <- readRDS(sym.file)
if(verbose)
cat("done.\n")
if(!is.xts(fr)) fr <- xts(fr[,-1],as.Date(fr[,1],origin='1970-01-01'),src='rda',updated=Sys.time())
colnames(fr) <- paste(toupper(gsub('\\^','',Symbols[[i]])),col.names,sep='.')
fr <- convert.time.series(fr=fr,return.class=return.class)
Symbols[[i]] <-toupper(gsub('\\^','',Symbols[[i]]))
if(auto.assign)
assign(Symbols[[i]],fr,env)
}, silent = TRUE)
if (inherits(test, "try-error")) {
msg <- paste0("Unable to import ", dQuote(returnSym[[i]]),
".\n", attr(test, "condition")$message)
if (hasArg(".has1sym.") && match.call(expand.dots=TRUE)$.has1sym.) {
stop(msg)
}
if (isTRUE(warnings)) {
warning(msg, call. = FALSE, immediate. = TRUE)
}
noDataSym <- c(noDataSym, returnSym[[i]])
}
}
if(auto.assign)
return(setdiff(returnSym, noDataSym))
return(fr)
}
#}}}
# getSymbols.rda {{{
"getSymbols.rda" <-
function(Symbols,env,
dir="",
return.class="xts",
extension="rda",
col.names=c('Open','High','Low','Close','Volume','Adjusted'),
...) {
importDefaults("getSymbols.rda")
this.env <- environment()
for(var in names(list(...))) {
assign(var,list(...)[[var]], this.env)
}
default.return.class <- return.class
default.dir <- dir
default.extension <- extension
if(!hasArg("verbose")) verbose <- FALSE
if(!hasArg("auto.assign")) auto.assign <- TRUE
if(!hasArg("warnings")) warnings <- TRUE
returnSym <- Symbols
noDataSym <- NULL
for(i in seq_along(Symbols)) {
test <- try({
return.class <- getSymbolLookup()[[Symbols[[i]]]]$return.class
return.class <- ifelse(is.null(return.class),default.return.class,
return.class)
dir <- getSymbolLookup()[[Symbols[[i]]]]$dir
dir <- ifelse(is.null(dir),default.dir,
dir)
extension <- getSymbolLookup()[[Symbols[[i]]]]$extension
extension <- ifelse(is.null(extension),default.extension,
extension)
if(verbose) cat("loading ",Symbols[[i]],".....")
if(dir=="") {
sym.file <- paste(Symbols[[i]],extension,sep=".")
} else {
sym.file <- file.path(dir,paste(Symbols[[i]],extension,sep="."))
}
if(!file.exists(sym.file)) {
cat("\nfile ",paste(Symbols[[i]],extension,sep='.')," does not exist ",
"in ",dir,"....skipping\n")
next
}
#fr <- read.csv(sym.file)
local.name <- load(sym.file)
assign('fr',get(local.name))
if(verbose)
cat("done.\n")
if(!is.xts(fr)) fr <- xts(fr[,-1],as.Date(fr[,1],origin='1970-01-01'),src='rda',updated=Sys.time())
colnames(fr) <- paste(toupper(gsub('\\^','',Symbols[[i]])),col.names,sep='.')
fr <- convert.time.series(fr=fr,return.class=return.class)
Symbols[[i]] <-toupper(gsub('\\^','',Symbols[[i]]))
if(auto.assign)
assign(Symbols[[i]],fr,env)
}, silent = TRUE)
if (inherits(test, "try-error")) {
msg <- paste0("Unable to import ", dQuote(returnSym[[i]]),
".\n", attr(test, "condition")$message)
if (hasArg(".has1sym.") && match.call(expand.dots=TRUE)$.has1sym.) {
stop(msg)
}
if (isTRUE(warnings)) {
warning(msg, call. = FALSE, immediate. = TRUE)
}
noDataSym <- c(noDataSym, returnSym[[i]])
}
}
if(auto.assign)
return(setdiff(returnSym, noDataSym))
return(fr)
}
#}}}
# getSymbols.RData {{{
`getSymbols.RData` <- getSymbols.rda
# }}}
# getSymbols.IBrokers {{{
"getSymbols.IBrokers" <- function(Symbols, env, return.class='xts',
endDateTime, barSize='1 day', duration='1 M',
useRTH = '1', whatToShow = 'TRADES', time.format = '1', ...)
{
importDefaults('getSymbols.IBrokers')
this.env <- environment()
for(var in names(list(...))) {
assign(var, list(...)[[var]], this.env)
}
if(!hasArg("verbose")) verbose <- FALSE
if(!hasArg("auto.assign")) auto.assign <- TRUE
if(!hasArg("warnings")) warnings <- TRUE
if(is.method.available("twsConnect","IBrokers")) {
tws <- do.call('twsConnect',list(clientId=1001))
on.exit(do.call('twsDisconnect',list(tws)))
if(missing(endDateTime)) endDateTime <- NULL
returnSym <- Symbols
noDataSym <- NULL
for(i in seq_along(Symbols)) {
test <- try({
Contract <- getSymbolLookup()[[Symbols[i]]]$Contract
if(inherits(Contract,'twsContract')) {
fr <- do.call('reqHistoricalData',list(tws, Contract, endDateTime=endDateTime,
barSize=barSize, duration=duration,
useRTH=useRTH, whatToShow=whatToShow,
timeFormat=time.format, verbose=verbose))
fr <- convert.time.series(fr=fr, return.class=return.class)
if(auto.assign)
assign(Symbols[[i]], fr, env)
if(i < length(Symbols)) {
if(verbose) cat('waiting for TWS to accept next request')
for(pacing in 1:6) {
if(verbose) cat('.',sep='')
Sys.sleep(1)
}
if(verbose) cat('done\n')
}
} else if (isTRUE(warnings)) {
warning(paste('unable to load',Symbols[i],': missing twsContract definition'))
}
}, silent = TRUE)
if (inherits(test, "try-error")) {
msg <- paste0("Unable to import ", dQuote(returnSym[[i]]),
".\n", attr(test, "condition")$message)
if (hasArg(".has1sym.") && match.call(expand.dots=TRUE)$.has1sym.) {
stop(msg)
}
if (isTRUE(warnings)) {
warning(msg, call. = FALSE, immediate. = TRUE)
}
noDataSym <- c(noDataSym, returnSym[[i]])
}
}
if(auto.assign)
return(setdiff(returnSym, noDataSym))
return(fr)
}
}
# }}}
# getSymbols.RBloomberg {{{
"getSymbols.RBloomberg" <- function() {}
# }}}
# getSymbols.url {{{
"getSymbols.url" <- function() {}
# }}}
# getSymbols.freelunch {{{
"getSymbols.freelunch" <- function() {}
# }}}
# getSymbols.RODBC {{{
"getSymbols.RODBC" <- function() {}
# }}}
# getSymbols.RSQLite {{{
"getSymbols.RSQLite" <- function() {}
# }}}
# getSymbols.ROracle {{{
"getSymbols.ROracle" <- function() {}
# }}}
# getSymbols.oanda {{{
`getSymbols.oanda` <-
function(Symbols,env,return.class='xts',
from=Sys.Date()-179,
to=Sys.Date(),
...) {
importDefaults("getSymbols.oanda")
this.env <- environment()
for(var in names(list(...))) {
# import all named elements that are NON formals
assign(var, list(...)[[var]], this.env)
}
if(!auto.assign && length(Symbols) > 1)
stop("must use auto.assign=TRUE for multiple Symbols requests")
default.return.class <- return.class
default.from <- from
default.to <- to
if(!hasArg("verbose")) verbose <- FALSE
if(!hasArg("auto.assign")) auto.assign <- TRUE
if(!hasArg("warnings")) warnings <- TRUE
returnSym <- Symbols
noDataSym <- NULL
for(i in seq_along(Symbols)) {
test <- try({
return.class <- getSymbolLookup()[[Symbols[[i]]]]$return.class
return.class <- ifelse(is.null(return.class),default.return.class,
return.class)
from <- getSymbolLookup()[[Symbols[[i]]]]$from
from <- ifelse(is.null(from),default.from,from)
from <- as.Date(from, origin='1970-01-01')
to <- getSymbolLookup()[[Symbols[[i]]]]$to
to <- ifelse(is.null(to),default.to,to)
to <- as.Date(to, origin='1970-01-01')
Symbols.name <- getSymbolLookup()[[Symbols[[i]]]]$name
Symbols.name <- ifelse(is.null(Symbols.name),Symbols[[i]],Symbols.name)
currency.pair <- strsplit(toupper(Symbols.name),"/")[[1]]
if(length(currency.pair) != 2) {
if(isTRUE(warnings)) {
warning(paste("incorrectly specified currency pair",Symbols.name))
}
next
}
if(verbose) cat("downloading ",Symbols.name,".....")
# throw warning, but return as much data as possible
if(from < Sys.Date() - 180) {
if(isTRUE(warnings)) {
warning("Oanda only provides historical data for the past 180 days.",
" Symbol: ", Symbols[[i]])
}
}
oanda.URL <- paste0("https://fxds-hcc.oanda.com/api/data/update",
"?&source=OANDA&adjustment=0",
"&base_currency=", currency.pair[1],
"&start_date=", from,
"&end_date=", to,
"&period=daily",
"&price=mid",
"&view=table",
""e_currency_0=", currency.pair[2])
# Fetch data (jsonlite::fromJSON will handle connection)
tbl <- jsonlite::fromJSON(oanda.URL, simplifyVector = FALSE)
Data <- tbl[[1]][[1]]$data
# timestamps are ms since midnight 1970-01-01
secs <- as.numeric(sapply(Data, `[[`, 1L)) / 1000
dates <- as.Date(.POSIXct(secs, tz = "UTC"))
# remove thousands separator and convert to numeric
rates <- sapply(Data, `[[`, 2L)
if(is.character(rates))
rates <- as.numeric(gsub(",", "", rates))
if(verbose) cat("done.\n")
fr <- xts(rates, dates, src="oanda", updated=Sys.time())
fr <- fr[paste(from, to, sep="/")] # subset to requested timespan
colnames(fr) <- gsub("/",".",Symbols[[i]])
fr <- convert.time.series(fr=fr,return.class=return.class)
Symbols[[i]] <-toupper(gsub('\\^|/','',Symbols[[i]]))
if(auto.assign)
assign(Symbols[[i]],fr,env)
}, silent = TRUE)
if (inherits(test, "try-error")) {
msg <- paste0("Unable to import ", dQuote(returnSym[[i]]),
".\n", attr(test, "condition")$message)
if (hasArg(".has1sym.") && match.call(expand.dots=TRUE)$.has1sym.) {
stop(msg)
}
if (isTRUE(warnings)) {
warning(msg, call. = FALSE, immediate. = TRUE)
}
noDataSym <- c(noDataSym, returnSym[[i]])
}
}
if(auto.assign)
return(setdiff(returnSym, noDataSym))
return(fr)
}#}}}
#
# Download OHLC Data From Alpha Vantage
#
# Meant to be called internally by getSymbols().
#
getSymbols.av <- function(Symbols, env, api.key,
return.class="xts",
periodicity="daily",
adjusted=FALSE,
interval="1min",
output.size="compact",
data.type="json",
...)
{
importDefaults("getSymbols.av")
this.env <- environment()
for (var in names(list(...))) {
assign(var, list(...)[[var]], this.env)
}
if (!hasArg("api.key")) {
stop("getSymbols.av: An API key is required (api.key). Free registration",
" at https://www.alphavantage.co/.", call.=FALSE)
}
if (!hasArg("auto.assign")) auto.assign <- TRUE
if (!hasArg("verbose")) verbose <- FALSE
if (!hasArg("warnings")) warnings <- TRUE
valid.periodicity <- c("daily", "weekly", "monthly", "intraday")
periodicity <- match.arg(periodicity, valid.periodicity)
interval <- match.arg(interval, c("1min", "5min", "15min", "30min", "60min"))
output.size <- match.arg(output.size, c("compact", "full"))
default.return.class <- return.class
default.periodicity <- periodicity
#
# For daily, weekly, and monthly data, timestamps are "yyyy-mm-dd".
# For intraday data, timestamps are "yyyy-mm-dd HH:MM:SS".
#
convertTimestamps <- function(ts, periodicity, tz) {
if (periodicity == "intraday")
as.POSIXct(ts, tz=tz)
else
as.Date(ts)
}
downloadOne <- function(sym, default.return.class, default.periodicity) {
return.class <- getSymbolLookup()[[sym]]$return.class
return.class <- if (is.null(return.class)) default.return.class else return.class
periodicity <- getSymbolLookup()[[sym]]$periodicity
periodicity <- if (is.null(periodicity)) default.periodicity else periodicity
periodicity <- match.arg(periodicity, valid.periodicity)
if (adjusted && periodicity == "intraday")
stop("getSymbols.av: Intraday data cannot be adjusted.", call.=FALSE)
sym.name <- getSymbolLookup()[[sym]]$name
sym.name <- if (is.null(sym.name)) sym else sym.name
FUNCTION <- paste0("TIME_SERIES_",
switch(periodicity,
daily = if (adjusted) "DAILY_ADJUSTED" else "DAILY",
weekly = if (adjusted) "WEEKLY_ADJUSTED" else "WEEKLY",
monthly = if (adjusted) "MONTHLY_ADJUSTED" else "MONTHLY",
intraday = "INTRADAY" ))
if (verbose) cat("loading", sym.name, ".....")
URL <- paste0("https://www.alphavantage.co/query",
"?function=", FUNCTION,
"&symbol=", sym.name,
"&interval=", interval,
"&outputsize=", output.size,
"&datatype=", data.type,
"&apikey=", api.key)
if (data.type == "json") {
lst <- jsonlite::fromJSON(URL)
#
# Errors return a list with one element: An error message
#
if (length(lst) == 1)
stop("getSymbols.av: ", lst[[1]], call.=FALSE)
if (verbose) cat("done.\n")
#
# The first element of 'lst' is the metadata.
# Typical metadata (in JSON format):
#
# "Meta Data": {
# "1. Information": "Intraday (1min) prices and volumes",
# "2. Symbol": "MSFT",
# "3. Last Refreshed": "2017-05-23 16:00:00",
# "4. Interval": "1min",
# "5. Output Size": "Compact",
# "6. Time Zone": "US/Eastern"
# }
#
meta <- lst[[1]]
tz <- meta[["6. Time Zone"]]
updated <- convertTimestamps(meta[["3. Last Refreshed"]], periodicity, tz=tz)
#
# The second element of 'lst' is the data: a list.
# The names of the list elements are the timestamps.
# Typical list element, non-adjusted data (in JSON format):
#
# "2017-05-23": {
# "1. open": "68.6750",
# "2. high": "68.7100",
# "3. low": "68.6400",
# "4. close": "68.6800",
# "5. volume": "1591941"
# }
#
# Typical list element, adjusted data (again, JSON format):
#
# "2017-06-30": {
# "1. open": "68.7800",
# "2. high": "69.3800",
# "3. low": "68.7400",
# "4. close": "68.9300",
# "5. adjusted close": "68.9300",
# "6. volume": "23039328",
# "7. dividend amount": "0.00",
# "8. split coefficient": "1.0000"
# },
#
elems <- lst[[2]]
tm.stamps <- convertTimestamps(names(elems), periodicity, tz=tz)
if (adjusted) {
av_names <- c("1. open", "2. high", "3. low", "4. close", "6. volume", "5. adjusted close")
qm_names <- paste(sym, c("Open", "High", "Low", "Close", "Volume", "Adjusted"), sep=".")
} else {
av_names <- c("1. open", "2. high", "3. low", "4. close", "5. volume")
qm_names <- paste(sym, c("Open", "High", "Low", "Close", "Volume"), sep=".")
}
# extract columns from each element (row) and unlist to a vector
rows <- lapply(elems, function(x) unlist(x[av_names], use.names=FALSE))
rows <- do.call(rbind, rows)
colnames(rows) <- qm_names
storage.mode(rows) <- "numeric"
# convert matrix to xts
mat <- xts(rows, tm.stamps, src="alphavantage", updated=updated)
mat <- convert.time.series(mat, return.class=return.class)
} else {
mat <- as.xts(read.zoo(curl::curl(URL), header=TRUE, sep=","),
src="alphavantage", updated=Sys.time())
# convert column names to symbol.series
cn <- colnames(mat)
cn <- paste0(toupper(substring(cn, 1, 1)), substring(cn, 2))
colnames(mat) <- paste(sym, cn, sep=".")
mat <- convert.time.series(mat, return.class=return.class)
}
if (auto.assign)
assign(sym, mat, env)
return(mat)
}
returnSym <- Symbols
noDataSym <- NULL
matrices <- list()
for(i in seq_along(Symbols)) {
test <- try({
matrices[[i]] <- downloadOne(Symbols[[i]],
default.return.class = default.return.class,
default.periodicity = default.periodicity)
}, silent = TRUE)
if (inherits(test, "try-error")) {
msg <- paste0("Unable to import ", dQuote(returnSym[[i]]),
".\n", attr(test, "condition")$message)
if (hasArg(".has1sym.") && match.call(expand.dots=TRUE)$.has1sym.) {
stop(msg)
}
if (isTRUE(warnings)) {
warning(msg, call. = FALSE, immediate. = TRUE)
}
noDataSym <- c(noDataSym, returnSym[[i]])
}
}
if (auto.assign) {
return(setdiff(returnSym, noDataSym))
} else {
return(matrices[[1]])
}
}
# Mnemonic alias, letting callers use getSymbols("IBM", src="alphavantage")
getSymbols.alphavantage <- getSymbols.av
#
# Download OHLC Data From Tiingo
#
# Meant to be called internally by getSymbols().
#
getSymbols.tiingo <- function(Symbols, env, api.key,
return.class="xts",
periodicity="daily",
adjust=FALSE,
from='2007-01-01',
to=Sys.Date(),
...) {
importDefaults("getSymbols.tiingo")
this.env <- environment()
for (var in names(list(...))) {
assign(var, list(...)[[var]], this.env)
}
if (!hasArg("api.key")) {
stop("getSymbols.tiingo: An API key is required (api.key). Register",
" at https://api.tiingo.com.", call.=FALSE)
}
if (!hasArg("auto.assign")) auto.assign <- TRUE
if (!hasArg("verbose")) verbose <- FALSE
if (!hasArg("warnings")) warnings <- TRUE
valid.periodicity <- c("daily", "weekly", "monthly", "annually")
periodicity <- match.arg(periodicity, valid.periodicity)
default.return.class <- return.class
default.periodicity <- periodicity
downloadOne <- function(sym, default.return.class, default.periodicity) {
return.class <- getSymbolLookup()[[sym]]$return.class
return.class <- if (is.null(return.class)) default.return.class else return.class
periodicity <- getSymbolLookup()[[sym]]$periodicity
periodicity <- if (is.null(periodicity)) default.periodicity else periodicity
periodicity <- match.arg(periodicity, valid.periodicity)
sym.name <- getSymbolLookup()[[sym]]$name
sym.name <- if (is.null(sym.name)) sym else sym.name
if (verbose) cat("loading", sym.name, ".....")
from.strftime <- strftime(from, format = "%Y-%m-%d")
to.strftime <- strftime(to, format = "%Y-%m-%d")
URL <- paste0("https://api.tiingo.com/tiingo/daily/",
sym.name, "/prices",
"?startDate=", from.strftime,
"&endDate=", to.strftime,
"&resampleFreq=", periodicity,
"&format=csv",
"&token=", api.key)
#tiingo will return a text error for ticker not found, which read.csv converts
#to a zero row, 1 column data.frame, with a warning
stock.data <- suppressWarnings(read.csv(URL, as.is=TRUE))
# check for error
if (NCOL(stock.data) == 1) {
msg <- sub("Error: ", "", colnames(stock.data))
stop(msg, call. = FALSE)
}
tm.stamps <- as.Date(stock.data[, "date"])
if (adjust) {
stock.data <- stock.data[, c("adjOpen", "adjHigh", "adjLow", "adjClose", "adjVolume")]
colnames(stock.data) <- paste(sym, c("Open", "High", "Low", "Close", "Volume"), sep=".")
} else {
stock.data <- stock.data[, c("open", "high", "low", "close", "volume", "adjClose")]
colnames(stock.data) <- paste(sym, c("Open", "High", "Low", "Close", "Volume", "Adjusted"), sep=".")
}
# convert data to xts
xts.data <- xts(stock.data, tm.stamps, src="tiingo", updated=Sys.time())
xts.data <- convert.time.series(xts.data, return.class=return.class)
if (auto.assign)
assign(sym, xts.data, env)
return(xts.data)
}
returnSym <- Symbols
noDataSym <- NULL
matrices <- list()
for(i in seq_along(Symbols)) {
test <- try({
matrices[[i]] <- downloadOne(Symbols[[i]],
default.return.class = default.return.class,
default.periodicity = default.periodicity)
}, silent = TRUE)
if (inherits(test, "try-error")) {
msg <- paste0("Unable to import ", dQuote(returnSym[[i]]),
".\n", attr(test, "condition")$message)
if (hasArg(".has1sym.") && match.call(expand.dots=TRUE)$.has1sym.) {
stop(msg)
}
if (isTRUE(warnings)) {
warning(msg, call. = FALSE, immediate. = TRUE)
}
noDataSym <- c(noDataSym, returnSym[[i]])
}
}
if (auto.assign) {
return(setdiff(returnSym, noDataSym))
} else {
return(matrices[[1]])
}
}
# convert.time.series {{{
`convert.time.series` <- function(fr,return.class) {
if('quantmod.OHLC' %in% return.class) {
class(fr) <- c('quantmod.OHLC','zoo')
return(fr)
} else
if('xts' %in% return.class) {
return(fr)
}
if('zoo' %in% return.class) {
return(as.zoo(fr))
} else
if('ts' %in% return.class) {
fr <- as.ts(fr)
return(fr)
} else
if('data.frame' %in% return.class) {
fr <- as.data.frame(fr)
return(fr)
} else
if('matrix' %in% return.class) {
fr <- as.data.frame(fr)
return(fr)
} else
if('timeSeries' %in% return.class) {
if(requireNamespace("timeSeries", quietly=TRUE)) {
fr <- timeSeries::timeSeries(coredata(fr), charvec=as.character(index(fr)))
return(fr)
} else {
warning(paste("'timeSeries' from package 'timeSeries' could not be loaded:",
" 'xts' class returned"))
}
}
}#}}}
# removeSymbols {{{
"removeSymbols" <-
function(Symbols=NULL,env=parent.frame()) {
if(exists('.getSymbols',env,inherits=FALSE)) {
getSymbols <- get('.getSymbols',env,inherits=FALSE)
if(is.null(Symbols)) {
#Symbols <- paste(getSymbols)
Symbols <- names(getSymbols)
} else {
#Symbols now has ONLY existing Symbols in it
#Symbols <- Symbols[Symbols %in% unlist(getSymbols)]
Symbols <- Symbols[Symbols %in% names(getSymbols)]
}
remove(list=as.character(Symbols),envir=env)
Symbols.remaining <- getSymbols[!names(getSymbols) %in% Symbols]
if(length(Symbols.remaining) == 0) {
remove(list=c('.getSymbols'),envir=env)
} else {
assign('.getSymbols',Symbols.remaining,env)
}
}
}
# }}}
# showSymbols {{{
"showSymbols" <-
function(env=parent.frame()) {
if(exists('.getSymbols',env,inherits=FALSE)) {
return(unlist(get('.getSymbols',env)))
} else { return(NULL) }
}
# }}}
# saveSymbols {{{
"saveSymbols"<-
function(Symbols=NULL,file.path=stop("must specify 'file.path'"),env=parent.frame()) {
if(exists('.getSymbols',env,inherits=FALSE)) {
getSymbols <- get('.getSymbols',env,inherits=FALSE)
if(is.null(Symbols)) {
Symbols <- names(getSymbols)
} else {
#Symbols now has ONLY existing Symbols in it
Symbols <- Symbols[Symbols %in% names(getSymbols)]
}
for(each.symbol in Symbols) {
save(list=each.symbol,
file=paste(file.path,'/',each.symbol,".RData",sep=''),
envir=env)
}
}
}
# }}}
# buildData {{{
"buildData" <- function(formula,na.rm=TRUE,return.class="zoo") {
if(is.quantmod(formula)) {
fr <- modelData(formula)
} else {
fr <- modelData(specifyModel(formula,na.rm=na.rm))
}
fr <- convert.time.series(fr=fr,return.class=return.class)
}
#}}}
quantmod/R/TA.R 0000644 0001762 0000144 00000025202 15002467345 012741 0 ustar ligges users # core addTA base functions
#
# written by Jeffrey A. Ryan
# Copyright 2008
# Distributed under the GPL 3 or later
`funToTA` <-
function(x,drop.arg=1) {
drop.arg <- if(any(drop.arg < 1)) {
1:length(formals(x))
} else -drop.arg
fun.args <- paste(names(formals(x))[drop.arg],'=',sapply(formals(x), deparse)[drop.arg],sep='')
fun.args <- paste(gsub('=$','',fun.args),collapse=',')
paste('add',deparse(substitute(x)),'(',fun.args,') {',collapse='',sep='')
}
shading <- function(x)
{
# to be used from addTA when passed a logical object or vector
# also from new addEvents function
#
# ex. rect(shading$start-spacing, par('usr')[3],
# shading$end-spacing, par('usr')[3])
if( !is.logical(x) )
warning('need logical object')
runs <- rle(as.logical(x))
list(
start=cumsum(runs$lengths)[which(runs$values)] - runs$lengths[which(runs$values)]+1,
end=cumsum(runs$lengths)[which(runs$values)]
)
}
# addTA {{{
`addTA` <-
function(ta, order=NULL, on=NA, legend='auto', yrange=NULL, ...) {
if(is.character(ta)) {
if(exists(ta)) {
plot(do.call(paste('add',ta,sep=''),list(...)))
} else stop(paste('no TA method found for',paste('add',ta,sep='')))
} else {
lchob <- get.current.chob()
chobTA <- new("chobTA")
if(any(is.na(on))) {
chobTA@new <- TRUE
} else {
chobTA@new <- FALSE
chobTA@on <- on
}
nrc <- NROW(lchob@xdata)
ta <- try.xts(ta, error=FALSE)
if(is.xts(ta)) {
x <- merge(lchob@xdata, ta, fill=ifelse(is.logical(ta),0,NA),join='left', retside=c(FALSE,TRUE))
} else {
if(NROW(ta) != nrc)
stop('non-xtsible data must match the length of the underlying series')
x <- merge(lchob@xdata, ta, join='left', retside=c(FALSE,TRUE))
}
if(is.logical(ta))
x <- as.logical(x, drop=FALSE) #identical to storage.mode(x)<-"logical"
chobTA@TA.values <- coredata(x)[lchob@xsubset,]
chobTA@name <- "chartTA"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
yrange=yrange,
colors=lchob@colors,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
isLogical=is.logical(ta),
x.labels=lchob@x.labels,
order=order,legend=legend,
pars=list(list(...)),
time.scale=lchob@time.scale)
# if(is.null(sys.call(-1))) {
# TA <- lchob@passed.args$TA
# lchob@passed.args$TA <- c(TA,chobTA)
# lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
# do.call('chartSeries.chob',list(lchob))
# #quantmod:::chartSeries.chob(lchob)
# invisible(chobTA)
# } else {
return(chobTA)
# }
}
}#}}}
# chartTA {{{
`chartTA` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
tav <- x@TA.values
if(x@new) {
# draw new sub-window
y.range <- if(is.null(x@params$yrange) || length(x@params$yrange) != 2) {
seq(min(tav * 0.975, na.rm = TRUE), max(tav * 1.05, na.rm = TRUE),
length.out=length(x.range))
} else seq(x@params$yrange[1],x@params$yrange[2],length.out=length(x.range))
plot(x.range,y.range,type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
}
pars <- x@params$pars[[1]]
pars <- lapply(pars,
function(x) {
len <- NCOL(tav)
if(length(x) < len) {
rep(list(x), length.out=len)
} else rep(list(x),length.out=len)
})
# pars <- x@params$pars#[[1]]
# pars <- lapply(pars, function(x) rep(x, length.out=NCOL(tav)))
col.order <- if(is.null(x@params$order)) {
1:NCOL(tav)
} else x@params$order
if(is.null(x@params$legend)) legend <- function(legend,text.col,...) {}
if(is.character(x@params$legend) && x@params$legend != "auto") {
legend("topleft", legend=x@params$legend, bty='n', y.intersp=0.95)
legend <- function(legend,text.col,...) { }
}
if(!x@new) {
legend <- function(legend,text.col,...) { list(legend=legend,text.col=text.col) }
}
#formals(legend) <- alist(legend=,text.col=,...=) #formals(graphics::legend) # all have the same formals now
legend.text <- list()
# possibly able to handle newTA functionality
if(is.null(x@params$legend.name)) x@params$legend.name <- deparse(x@call[-1][[1]])
x.pos <- 1 + spacing * (1:length(x.range))
if(NCOL(tav) == 1) {
tmp.pars <- lapply(pars,function(x) x[[1]][[1]])
if(x@params$isLogical) {
do.call('rect',c(list(x.pos[shading(tav)$start-1] - spacing/3), list(par('usr')[3]),
list(x.pos[shading(tav)$end-1] + spacing/3), list(par('usr')[4]), tmp.pars))
# do not add a legend name for background shading. probably better to have
# the labels in another routine
} else {
do.call('lines',c(list(seq(1,length(x.range),by=spacing)), list(tav), tmp.pars))
legend.text[[1]] <- legend('topleft',
legend=c(paste(x@params$legend.name,":"),sprintf("%.3f",last(na.omit(tav)))),
text.col=c(x@params$colors$fg.col,last(pars$col[[1]])),bty='n',y.intersp=0.95)
}
} else {
for(cols in col.order) {
tmp.pars <- lapply(pars,function(x) {
p <- try(x[[cols]][[cols]],silent=TRUE)
if(inherits(p, 'try-error')) {
stop("TA parameter length must equal number of columns", call.=FALSE)
} else p
}
)
do.call('lines',c(list(seq(1,length(x.range),by=spacing)), list(tav[,cols]), tmp.pars))
if(cols==1) {
legend.text[[cols]] <- legend('topleft',
legend=c(paste(x@params$legend.name,":")),
text.col=c(x@params$colors$fg.col,last(pars$col[[cols]])),bty='n',y.intersp=0.95)
}
# for each column, add colname: value
Col.title <- colnames(tav)[cols]
legend.text[[cols]] <- legend('topleft',
legend=c(rep('',cols),paste(Col.title,":",
sprintf("%.3f",last(na.omit(tav[,cols]))))),
text.col=pars$col[[cols]][cols],bty='n',y.intersp=0.95)
}
}
axis(2)
box(col=x@params$colors$fg.col)
invisible(legend.text)
} # }}}
# chartSetUp {{{
`chartSetUp` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
tav <- x@TA.values
if(x@new) {
y.range <- if(is.null(x@params$yrange) || length(x@params$yrange) != 2) {
seq(min(tav * 0.975, na.rm = TRUE), max(tav * 1.05, na.rm = TRUE),
length.out=length(x.range))
} else seq(x@params$yrange[1],x@params$yrange[2],length.out=length(x.range))
plot(x.range,y.range,type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
}
pars <- x@params$pars[[1]]
pars <- lapply(pars,
function(x) {
len <- NCOL(tav)
if(length(x) < len) {
rep(list(x), length.out=len)
} else rep(list(x),length.out=len)
})
# pars <- x@params$pars#[[1]]
# pars <- lapply(pars, function(x) rep(x, length.out=NCOL(tav)))
col.order <- if(is.null(x@params$order)) {
1:NCOL(tav)
} else x@params$order
if(is.null(x@params$legend)) legend <- function(legend,text.col,...) {}
if(is.character(x@params$legend) && x@params$legend != "auto") {
legend("topleft", legend=x@params$legend, bty='n', y.intersp=0.95)
legend <- function(legend,text.col,...) { }
}
if(!x@new) {
legend <- function(legend,text.col,...) { list(legend=legend,text.col=text.col) }
}
legend.text <- list()
# possibly able to handle newTA functionality
if(is.null(x@params$legend.name)) x@params$legend.name <- deparse(x@call[-1][[1]])
if(NCOL(tav) == 1) {
tmp.pars <- lapply(pars,function(x) x[[1]][[1]])
# if(x@params$isLogical) {
# do.call('rect',c(list(shading(tav)$start*spacing), list(par('usr')[3]),
# list(shading(tav)$end*spacing), list(par('usr')[4]), tmp.pars))
# } else
# do.call('lines',c(list(seq(1,length(x.range),by=spacing)), list(tav), tmp.pars))
legend.text[[1]] <- legend('topleft',
legend=c(paste(x@params$legend.name,":"),sprintf("%.3f",last(na.omit(tav)))),
text.col=c(x@params$colors$fg.col,last(pars$col[[1]])),bty='n',y.intersp=0.95)
} else {
for(cols in col.order) {
tmp.pars <- lapply(pars,function(x) x[[cols]][[cols]])
# do.call('lines',c(list(seq(1,length(x.range),by=spacing)), list(tav[,cols]), tmp.pars))
if(cols==1) {
legend.text[[cols]] <- legend('topleft',
legend=c(paste(x@params$legend.name,":")),
text.col=c(x@params$colors$fg.col,last(pars$col[[cols]])),bty='n',y.intersp=0.95)
}
# for each column, add colname: value
Col.title <- colnames(tav)[cols]
legend.text[[cols]] <- legend('topleft',
legend=c(rep('',cols),paste(Col.title,":",
sprintf("%.3f",last(na.omit(tav[,cols]))))),
text.col=pars$col[[cols]][cols],bty='n',y.intersp=0.95)
}
}
axis(2)
box(col=x@params$colors$fg.col)
invisible(legend.text)
} # }}}
# setTA {{{
`setTA` <-
function(type=c('chartSeries','barChart','candleChart')) {
if('chartSeries' %in% type) setDefaults(chartSeries,TA=listTA())
if('barChart' %in% type) setDefaults(barChart,TA=listTA())
if('candleChart' %in% type) setDefaults(candleChart,TA=listTA())
}# }}}
# unsetTA {{{
`unsetTA` <-
function(type=c('chartSeries','barChart','candleChart')) {
if('chartSeries' %in% type) setDefaults(chartSeries,TA=NULL)
if('barChart' %in% type) setDefaults(barChart,TA=NULL)
if('candleChart' %in% type) setDefaults(candleChart,TA=NULL)
}# }}}
# listTA {{{
`listTA` <-
function(dev) {
if(missing(dev)) dev <- dev.cur()
sapply(get.chob()[[dev]]@passed.args$TA,function(x) x@call)
} # }}}
chartNULL <- function(...) return(invisible(NULL))
quantmod/R/addZigZag.R 0000644 0001762 0000144 00000003225 14654457715 014316 0 ustar ligges users # ZigZag from TTR by Josh Ulrich
#
# chartSeries interface by Jeffrey A. Ryan 2008
#
# addZigZag
`addZigZag` <-
function (change = 10, percent = TRUE, retrace = FALSE, lastExtreme = TRUE,
..., on = -1, legend = "auto")
{
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
x <- cbind(Hi(x),Lo(x))
x <- ZigZag(HL = x, change = change, percent = percent, retrace = retrace,
lastExtreme = lastExtreme)
yrange <- NULL
chobTA <- new("chobTA")
if (NCOL(x) == 1) {
chobTA@TA.values <- x[lchob@xsubset]
}
else chobTA@TA.values <- x[lchob@xsubset, ]
chobTA@name <- "chartTA"
if (any(is.na(on))) {
chobTA@new <- TRUE
}
else {
chobTA@new <- FALSE
chobTA@on <- on
}
chobTA@call <- match.call()
legend.name <- gsub("^add", "", deparse(match.call()))
gpars <- c(list(...), list(col = 4, lwd = 3))[unique(names(c(list(col = 4,
lwd = 3), list(...))))]
chobTA@params <- list(xrange = lchob@xrange, yrange = yrange,
colors = lchob@colors, color.vol = lchob@color.vol, multi.col = lchob@multi.col,
spacing = lchob@spacing, width = lchob@width, bp = lchob@bp,
x.labels = lchob@x.labels, time.scale = lchob@time.scale,
isLogical = is.logical(x), legend = legend, legend.name = legend.name,
pars = list(gpars))
if (is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA, chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new, 1,
0)
do.call("chartSeries.chob", list(lchob))
invisible(chobTA)
}
else {
return(chobTA)
}
}
quantmod/R/specifyModel.R 0000644 0001762 0000144 00000005735 15002467345 015071 0 ustar ligges users `sM` <-
function(formula, na.rm = TRUE) {
nq <- new('quantmod')
formula <- as.formula(formula)
if(length(formula) < 3) stop('formula must have a lhs')
nq@model.spec <- formula #original specification on the cli
nq@model.formula <- model.formula(formula) #parsed formula to remove illegal chars
nq@model.target <- as.character(nq@model.formula[[2]])
nq@build.inputs <- as.character(attr(terms(nq@model.formula), 'term.labels'))
nq@symbols <- all.vars(formula)
nq@product <- all.vars(formula)[1]
nq@model.data <- structure(as.xts(model.data(formula)),.CLASS=NULL)
return(nq)
}
`model.data` <- function(x) {
# create a data.frame for use in statistical function calls
# this creates the data.frame that will be passable
# as a 'data' argument to most function calls
dat <- sapply(attr(terms(x), 'variables')[-1], eval)
colnames(dat) <- make.names(attr(terms(x), 'variables'))[-1]
rownames(dat) <- rownames(get(all.vars(x)[1]))
as.data.frame(dat)
}
`model.formula` <- function(x) {
Terms <- rownames(attr(terms(x), 'factors'))
escape <- function(ff) {
ff <- gsub('(\\()','\\\\(',ff)
ff <- gsub('(\\))','\\\\)',ff)
ff <- gsub('(\\[)','\\\\[',ff)
gsub('(\\])','\\\\]',ff)
}
for(i in 1:length(Terms)) {
x <- eval(parse(text=gsub(escape(Terms[i]), make.names(Terms[i]), deparse(x))))
}
x
}
"specifyModel" <-
function(formula,na.rm=TRUE) {
new.quantmod <- new("quantmod");
formula <- as.formula(formula);
dot.vars <- all.vars(formula);
convert.vars <- function(vars) {
v <- unlist(strsplit(vars,'[.]'));
v <- paste(v[1],'(',v[2], if(length(v)>2) paste(',',v[3],sep=''),')',sep='');
return(v);
}
# model.vars <- unlist(lapply(dot.vars,convert.vars));
# model.formula <- paste(model.vars[1],paste(model.vars[-1],collapse=' + '),sep=' ~ ');
new.quantmod@model.spec <- formula
new.quantmod@model.formula <- as.formula(gsub("[) ]","",gsub("[(,=:^'\"]",".",deparse(formula))));
new.quantmod@model.target <- as.character(new.quantmod@model.formula[[2]])
new.quantmod@build.inputs <- as.character(attr(terms(new.quantmod@model.formula),"term.labels"));
vars <- all.vars(formula);
new.quantmod@symbols <- vars;
new.quantmod@product <- vars[1];
new.quantmod <- getModelData(new.quantmod,na.rm=na.rm);
return(new.quantmod);
}
"specifyModel.original" <-
function(formula,na.rm=TRUE) {
new.quantmod <- new("quantmod");
formula <- as.formula(formula);
new.quantmod@model.spec <- formula
new.quantmod@model.formula <- as.formula(gsub("\\)","",gsub("\\(",".",deparse(formula))));
new.quantmod@model.target <- deparse(formula[[2]]);
new.quantmod@build.inputs <- as.character(attr(terms(formula),"term.labels"));
vars <- all.vars(formula);
new.quantmod@symbols <- vars;
new.quantmod@product <- vars[1];
new.quantmod <- getModelData(new.quantmod,na.rm=na.rm);
return(new.quantmod);
}
`make.short.names` <-
function(x) {
gsub('\\.+','.',make.names(colnames(model.frame(x))))
}
quantmod/R/modelSignal.R 0000644 0001762 0000144 00000000262 14657447467 014714 0 ustar ligges users "modelSignal" <-
function(x)
{
if(!is.quantmodResults(x)) stop(paste(dQuote("x"),"must be of class",
dQuote("quantmodResults")))
x@signal
}
quantmod/R/getSplits.R 0000644 0001762 0000144 00000003714 15002467345 014417 0 ustar ligges users `getSplits` <-
function(Symbol,from='1970-01-01',to=Sys.Date(),env=parent.frame(),src='yahoo',
auto.assign=FALSE,auto.update=FALSE,verbose=FALSE,...,
curl.options=list()) {
# Function written by Joshua Ulrich, using
# getSymbols.yahoo as a guide.
tmp.symbol <- Symbol
if(missing(env)) {
env <- parent.frame(1)
} else {
if(exists(Symbol, envir = env, inherits = FALSE)) {
tmp.symbol <- get(Symbol, envir = env)
}
if(!missing(auto.assign) && !isTRUE(auto.assign) && !is.null(env)) {
warning("ignoring 'auto.assign = FALSE' because 'env' is specified")
}
auto.assign <- TRUE
}
if(is.null(env))
auto.assign <- FALSE
Symbol.name <- ifelse(!is.character(Symbol),
deparse(substitute(Symbol)),
as.character(Symbol))
from.posix <- .dateToUNIX(from)
to.posix <- .dateToUNIX(to)
handle <- .getHandle()
yahoo.URL <- .yahooJsonURL(Symbol.name, from.posix, to.posix, "1d")
yahoo.URL <- paste0(yahoo.URL, "&events=splits")
conn <- curl::curl(yahoo.URL,handle=handle)
json <- try(jsonlite::fromJSON(conn, simplifyVector = FALSE)$chart$result, silent = TRUE)
if(inherits(json, "try-error")) {
msg <- paste0("Unable to import splits for ", Symbol.name,
".\n", attr(json, "condition")$message)
stop(msg)
}
split.events <- json[[1]][["events"]][["splits"]]
if(!is.null(split.events)) {
to.xts <- function(x) {
ratio <- x$numerator/x$denominator
xts(ratio, as.Date(.POSIXct(x$date, "UTC")))
}
fr <- 1 / do.call(rbind, lapply(split.events, to.xts))
colnames(fr) <- paste(Symbol.name,'spl',sep='.')
} else {
fr <- xts(numeric(0), .Date(integer(0)))
}
if(is.xts(tmp.symbol)) {
if(auto.update) {
xtsAttributes(tmp.symbol) <- list(splits=fr)
assign(Symbol.name,tmp.symbol,envir=env)
}
} else if(auto.assign) {
assign(paste(Symbol.name,'spl',sep='.'),fr,envir=env)
} else fr
}
quantmod/R/addChaikin.R 0000644 0001762 0000144 00000006036 14654457715 014474 0 ustar ligges users # Chaikin Functions
# chaikinAD and chaikinVolatility by Josh Ulrich from TTR
#
# chartSeries implementation by Jeffrey A. Ryan 2008
#
# addChAD
# addChVol
`addChAD` <-
function (..., on = NA, legend = "auto")
{
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
x <- chaikinAD(HLC = HLC(x), volume = Vo(x))
yrange <- NULL
chobTA <- new("chobTA")
if (NCOL(x) == 1) {
chobTA@TA.values <- x[lchob@xsubset]
}
else chobTA@TA.values <- x[lchob@xsubset, ]
chobTA@name <- "chartTA"
if (any(is.na(on))) {
chobTA@new <- TRUE
}
else {
chobTA@new <- FALSE
chobTA@on <- on
}
chobTA@call <- match.call()
legend.name <- gsub("^.*[(]", " Chaikin Acc/Dist (", deparse(match.call()))
#extended = TRUE)
gpars <- c(list(...), list(col = 11))[unique(names(c(list(col = 11),
list(...))))]
chobTA@params <- list(xrange = lchob@xrange, yrange = yrange,
colors = lchob@colors, color.vol = lchob@color.vol, multi.col = lchob@multi.col,
spacing = lchob@spacing, width = lchob@width, bp = lchob@bp,
x.labels = lchob@x.labels, time.scale = lchob@time.scale,
isLogical = is.logical(x), legend = legend, legend.name = legend.name,
pars = list(gpars))
if (is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA, chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new, 1,
0)
do.call("chartSeries.chob", list(lchob))
invisible(chobTA)
}
else {
return(chobTA)
}
}
`addChVol` <-
function (n = 10, maType, ..., on = NA, legend = "auto")
{
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
x <- chaikinVolatility(HL = HLC(x)[,-3], n = n, maType = maType)
yrange <- NULL
chobTA <- new("chobTA")
if (NCOL(x) == 1) {
chobTA@TA.values <- x[lchob@xsubset]
}
else chobTA@TA.values <- x[lchob@xsubset, ]
chobTA@name <- "chartTA"
if (any(is.na(on))) {
chobTA@new <- TRUE
}
else {
chobTA@new <- FALSE
chobTA@on <- on
}
chobTA@call <- match.call()
legend.name <- gsub("^.*[(]", " Chaikin Volatility (", deparse(match.call()))#,
#extended = TRUE)
gpars <- c(list(...), list(col = 8))[unique(names(c(list(col = 8),
list(...))))]
chobTA@params <- list(xrange = lchob@xrange, yrange = yrange,
colors = lchob@colors, color.vol = lchob@color.vol, multi.col = lchob@multi.col,
spacing = lchob@spacing, width = lchob@width, bp = lchob@bp,
x.labels = lchob@x.labels, time.scale = lchob@time.scale,
isLogical = is.logical(x), legend = legend, legend.name = legend.name,
pars = list(gpars))
if (is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA, chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new, 1,
0)
do.call("chartSeries.chob", list(lchob))
invisible(chobTA)
}
else {
return(chobTA)
}
}
quantmod/R/saveModels.R 0000644 0001762 0000144 00000002645 14654457715 014561 0 ustar ligges users "saveModels" <-
function(...,list=character(0),dir=NULL)
{
if(is.null(dir)) {
dir <- getOption('tR.dir');
}
if(is.null(dir)) stop('please specify model directory: via dir arg or options("tR.dir")');
models.list <- as.character(substitute(list(...)))[-1];
models <- c(list,models.list);
if(length(models)==0) {
for(i in ls(1)) {
if(class(eval(parse(text=i)))[1]=='quantmod') models <- c(models,i);
}
}
if(length(models) > 0) {
for(obj in models) {
model.obj <- eval(parse(text=obj));
model.obj <- stripModelData(model.obj);
if(class(model.obj)[1]=='quantmod')
save(model.obj,file=paste(dir,model.obj@model.id,sep=''),envir=sys.frame(1));
}
}
}
"loadModels" <-
function(...,dir=NULL)
{
if(is.null(dir)) {
dir <- getOption('tR.dir');
}
if(is.null(dir)) stop('please specify model directory: via dir arg or options("tR.dir")');
models <- as.character(list(...));
if(length(models)==0) {
stop('no file(s) specified');
}
if(length(models) > 0) {
for(obj in models) {
thisName <- load(file=paste(dir,obj,sep=''))
this <- eval(parse(text=thisName));
this <- stripModelData(this);
thisName <- this@model.id;
assign(thisName,this,.quantmodEnv);
}
}
}
quantmod/R/quantmod.R 0000644 0001762 0000144 00000005022 15002467345 014263 0 ustar ligges users "is.quantmod" <-
function(x)
{
inherits(x, 'quantmod')
}
"is.quantmodResults" <-
function(x)
{
inherits(x, 'quantmodResults')
}
`as.zoo.data.frame`<-
function(x,row.date=TRUE,...)
{
# ignore row.date if order.by is specified
if(hasArg("order.by")) {
# Don't warn because behavior won't change when this method is removed
zoo(x,...)
} else {
warning("quantmod::as.zoo.data.frame() is deprecated and will be removed in a future version",
"\n Use zoo(x, order.by = as.Date(rownames(x))) instead.")
#really need to test order - ???how?
if(row.date) {
zoo(x,as.Date(rownames(x),origin='1970-01-01'),...)
}
else {
zoo(x,rownames(x),...)
}
}
}
`as.zoo.quantmod.OHLC` <-
function(x,...)
{
class(x) <- 'zoo'
x
}
`as.quantmod.OHLC`<-
function(x,
col.names=c('Open','High','Low','Close','Volume','Adjusted'),
name=NULL,
...)
{
if(ncol(x) != length(col.names))
stop("'col.names' must match number of columns of 'x'")
UseMethod("as.quantmod.OHLC")
}
`as.quantmod.OHLC.data.frame`<-
function(x,
col.names=c('Open','High','Low','Close','Volume','Adjusted'),
name=NULL,
...)
{
if(is.null(name)) name <- deparse(substitute(x))
x <- as.zoo(x)
colnames(x) <- paste(name,'.',col.names,sep='')
class(x) <- c('quantmod.OHLC','zoo')
x
}
`as.quantmod.OHLC.quantmod.OHLC` <-
function(x,
col.names=c('Open','High','Low','Close','Volume','Adjusted'),
name=NULL,
...)
{
if(is.null(name)) name <- deparse(substitute(x))
x <- as.zoo(x)
colnames(x) <- paste(name,'.',col.names,sep='')
class(x) <- c('quantmod.OHLC','zoo')
x
}
`as.quantmod.OHLC.zoo` <-
function(x,
col.names=c('Open','High','Low','Close','Volume','Adjusted'),
name=NULL,
...)
{
if(is.null(name)) name <- deparse(substitute(x))
x <- as.zoo(x)
colnames(x) <- paste(name,'.',col.names,sep='')
class(x) <- c('quantmod.OHLC','zoo')
x
}
`[.quantmod.OHLC`<-
function(x,i,j,drop=TRUE,...)
{
original.cols <- ncol(x)
original.names <- colnames(x)
class(x) <- "zoo"
if(missing(i)) i <- 1:NROW(x)
if(missing(j)) {
x <- x[i=i,drop=drop,...]
class(x) <- c("quantmod.OHLC","zoo")
j <- 1:original.cols
} else {
x <- x[i=i,j=j,drop=drop,...]
if(is.null(dim(x)))
dim(x) <- c(NROW(x),NCOL(x))
if(NCOL(x)==original.cols)
class(x) <- c("quantmod.OHLC","zoo")
}
if(!is.null(dim(x)))
colnames(x) <- original.names[j]
x
}
quantmod/R/OHLC.transformations.R 0000644 0001762 0000144 00000031345 15002467345 016417 0 ustar ligges users seriesAccel <- function(x)
{
diff(x, diff=2L, na.pad=TRUE) > 0
}
seriesDecel <- function(x)
{
diff(x, diff=2L, na.pad=TRUE) < 0
}
seriesIncr <- function(x, thresh=0, diff.=1L)
{
diff(x, diff=diff., na.pad=TRUE) > thresh
}
seriesDecr <- function(x, thresh=0, diff.=1L)
{
diff(x, diff=diff., na.pad=TRUE) < thresh
}
`seriesHi` <-
function(x) {
UseMethod("seriesHi")
}
`seriesHi.default` <-
function(x) {
if(!is.null(dim(x)[2])) {
if(dim(x)[2]==1) {
# a univariate series - non-numeric
return(x[which(max(x)==as.numeric(x))])
} else {
# a multivariate series
return(x[which(max(Hi(x))==as.numeric(Hi(x)))])
}
}
# a numeric vector
max(x,na.rm=TRUE)
}
`seriesHi.timeSeries` <-
function(x) {
x.Data <- x@Data
if(!is.null(dim(x)[2])) {
if(dim(x)[2]==1) {
#univariate timeSeries
return(x[which(max(as.numeric(x.Data))==as.numeric(x.Data))])
} else {
#multivariate timeSeries
return(x[which(max(as.numeric(Hi(x)@Data))==as.numeric(Hi(x)@Data))])
}
}
}
`seriesHi.ts` <-
function(x) {
if(!is.null(dim(x)[2])) {
return(x[which(max(Hi(x),na.rm=TRUE)==Hi(x)),])
}
# a numeric vector
max(x,na.rm=TRUE)
}
`seriesLo` <-
function(x) {
UseMethod("seriesLo")
}
`seriesLo.default` <-
function(x) {
if(!is.null(dim(x)[2])) {
if(dim(x)[2]==1) {
# a univariate series - non-numeric
return(x[which(min(x)==as.numeric(x))])
} else {
# a multivariate series
return(x[which(min(Lo(x))==as.numeric(Lo(x)))])
}
}
# a numeric vector
min(x,na.rm=TRUE)
}
`seriesLo.timeSeries` <-
function(x) {
x.Data <- x@Data
if(!is.null(dim(x)[2])) {
if(dim(x)[2]==1) {
#univariate timeSeries
return(x[which(min(as.numeric(x.Data))==as.numeric(x.Data))])
} else {
#multivariate timeSeries
return(x[which(min(as.numeric(Lo(x)@Data))==as.numeric(Lo(x)@Data))])
}
}
}
`seriesLo.ts` <-
function(x) {
if(!is.null(dim(x)[2])) {
return(x[which(min(Lo(x),na.rm=TRUE)==Lo(x)),])
}
# a numeric vector
min(x,na.rm=TRUE)
}
`is.OHLC` <-
function (x) #, check=FALSE)
{
if(all(has.Op(x), has.Hi(x), has.Lo(x), has.Cl(x))) # &&
# has.OHLC(x,TRUE) == seq(has.Op(x,1), length,out=4))
{
# if(check) {
# if(!all(x[,2] > x[,3] &&
# x[,2] >= x[,1] &&
# x[,2] >= x[,4] &&
# x[,3] <= x[,1] &&
# x[,3] <= x[,4])) {
# warning('OHLC data is inconsistent')
# return(FALSE)
# }
# }
TRUE
} else FALSE
}
`is.HLC` <-
function(x)
{
all(has.Hi(x),has.Lo(x),has.Cl(x))# && has.HLC(x,TRUE) == seq(has.Hi(x,1),length.out=3)
}
is.OHLCV <- function(x)
{
# test for OHLCV columns
all(has.Op(x),has.Hi(x),has.Lo(x),has.Cl(x),has.Vo(x))
}
`has.OHLC` <-
function(x,which=FALSE)
{
if(which) {
c(has.Op(x,1),has.Hi(x,1),has.Lo(x,1),has.Cl(x,1))
} else {
c(has.Op(x),has.Hi(x),has.Lo(x),has.Cl(x))
}
}
has.OHLCV <- function(x,which=FALSE)
{
if(which) {
c(has.Op(x,1),has.Hi(x,1),has.Lo(x,1),has.Cl(x,1),has.Vo(x,1))
} else {
c(has.Op(x),has.Hi(x),has.Lo(x),has.Cl(x),has.Vo(x))
}
}
`has.HLC` <-
function(x,which=FALSE)
{
if(which) {
c(has.Hi(x,1),has.Lo(x,1),has.Cl(x,1))
} else {
c(has.Hi(x),has.Lo(x),has.Cl(x))
}
}
`HLC` <-
function(x)
{
if(is.HLC(x))
return(x[,has.HLC(x,1)])
NULL
}
`OHLC` <-
function(x)
{
if(is.OHLC(x))
return(x[,has.OHLC(x,1)])
NULL
}
OHLCV <- function(x)
{
if(is.OHLCV(x))
return(x[,has.OHLCV(x,1)])
NULL
}
# High-Low
`has.HL` <-
function(x,which=FALSE)
{
if(which) {
c(has.Hi(x,1),has.Lo(x,1))
} else {
c(has.Hi(x),has.Lo(x))
}
}
`is.HL` <-
function(x)
{
all(has.Hi(x),has.Lo(x))
}
`HL` <-
function(x)
{
if(is.HL(x))
return(x[,has.HL(x,1)])
NULL
}
`Op` <-
function(x)
{
loc <- has.Op(x,which = TRUE)
if ((length(loc) == 1) && (is.numeric(loc)))
return(x[,loc])
stop('subscript out of bounds: no or multiple column name containing "Open"')
}
`has.Op` <-
function(x,which=FALSE)
{
colAttr <- attr(x, "Op")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
loc <- grep('\\bOpen\\b',colnames(x),ignore.case=TRUE)
if (length(loc) > 1) loc <- grep('\\.Open$',colnames(x),ignore.case=TRUE)
if(!identical(loc,integer(0))) {
return(if(which) loc else TRUE)
} else FALSE
}
`Hi` <-
function(x)
{
loc <- has.Hi(x,which = TRUE)
if ((length(loc) == 1) && (is.numeric(loc)))
return(x[,loc])
stop('subscript out of bounds: no or multiple column name containing "High"')
}
`has.Hi` <-
function(x,which=FALSE)
{
colAttr <- attr(x, "Hi")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
loc <- grep('\\bHigh\\b',colnames(x),ignore.case=TRUE)
if (length(loc) > 1) loc <- grep('\\.High$',colnames(x),ignore.case=TRUE)
if(!identical(loc,integer(0))) {
return(if(which) loc else TRUE)
} else FALSE
}
`Lo` <-
function(x)
{
loc <- has.Lo(x,which = TRUE)
if ((length(loc) == 1) && (is.numeric(loc)))
return(x[,loc])
stop('subscript out of bounds: no or multiple column name containing "Low"')
}
`has.Lo` <-
function(x,which=FALSE)
{
colAttr <- attr(x, "Lo")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
loc <- grep('\\bLow\\b',colnames(x),ignore.case=TRUE)
if (length(loc) > 1) loc <- grep('\\.Low$',colnames(x),ignore.case=TRUE)
if(!identical(loc,integer(0))) {
return(if(which) loc else TRUE)
} else FALSE
}
`Cl` <-
function(x)
{
loc <- has.Cl(x,which = TRUE)
if ((length(loc) == 1) && (is.numeric(loc)))
return(x[,loc])
stop('subscript out of bounds: no or multiple column name containing "Close"')
}
`has.Cl` <-
function(x,which=FALSE)
{
colAttr <- attr(x, "Cl")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
loc <- grep('\\bClose\\b',colnames(x),ignore.case=TRUE)
if (length(loc) > 1) loc <- grep('\\.Close$',colnames(x),ignore.case=TRUE)
if(!identical(loc,integer(0))) {
return(if(which) loc else TRUE)
} else FALSE
}
`Vo` <-
function(x)
{
loc <- has.Vo(x,which = TRUE)
if ((length(loc) == 1) && (is.numeric(loc)))
return(x[,loc])
stop('subscript out of bounds: no or multiple column name containing "Volume"')
}
`has.Vo` <-
function(x,which=FALSE)
{
colAttr <- attr(x, "Vo")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
loc <- grep('\\bVolume\\b',colnames(x),ignore.case=TRUE)
if (length(loc) > 1) loc <- grep('\\.Volume\\b',colnames(x),ignore.case=TRUE)
if(!identical(loc,integer(0))) {
return(if(which) loc else TRUE)
} else FALSE
}
`Ad` <-
function(x)
{
loc <- has.Ad(x,which = TRUE)
if ((length(loc) == 1) && (is.numeric(loc)))
return(x[,loc])
stop('subscript out of bounds: no or multiple column name containing "Adjusted"')
}
`has.Ad` <-
function(x,which=FALSE)
{
colAttr <- attr(x, "Ad")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
loc <- grep('\\bAdjusted\\b',colnames(x),ignore.case=TRUE)
if (length(loc) > 1) loc <- grep('\\.Adjusted\\b',colnames(x),ignore.case=TRUE)
if(!identical(loc,integer(0))) {
return(if(which) loc else TRUE)
} else FALSE
}
`OpCl` <-
function(x)
{
xx <- Delt(Op(x),Cl(x))
colnames(xx) <- paste("OpCl",deparse(substitute(x)),sep='.')
xx
}
`ClOp` <-
function(x)
{
xx <- Delt(lag(Cl(x)), Op(x))
colnames(xx) <- paste("ClOp",deparse(substitute(x)),sep='.')
xx
}
`OpOp` <-
function(x)
{
xx <- Delt(Op(x))
colnames(xx) <- paste("OpOp",deparse(substitute(x)),sep='.')
xx
}
`ClCl` <-
function(x)
{
xx <- Delt(Cl(x))
colnames(xx) <- paste("ClCl",deparse(substitute(x)),sep='.')
xx
}
`OpLo` <-
function(x)
{
xx <- Delt(Op(x),Lo(x))
colnames(xx) <- paste("OpLo",deparse(substitute(x)),sep='.')
xx
}
`OpHi` <-
function(x)
{
xx <- Delt(Op(x),Hi(x))
colnames(xx) <- paste("OpHi",deparse(substitute(x)),sep='.')
xx
}
`LoHi` <-
function(x)
{
xx <- Delt(Lo(x),Hi(x))
colnames(xx) <- paste("LoHi",deparse(substitute(x)),sep='.')
xx
}
`LoCl` <-
function(x)
{
xx <- Delt(Lo(x),Cl(x))
colnames(xx) <- paste("LoCl",deparse(substitute(x)),sep='.')
xx
}
`HiCl` <-
function(x)
{
xx <- Delt(Hi(x),Cl(x))
colnames(xx) <- paste("HiCl",deparse(substitute(x)),sep='.')
xx
}
`Next` <-
function(x,k=1)
{
UseMethod("Next")
}
`Next.data.frame` <-
function(x,k=1)
{
if(k<0||k!=as.integer(k)||length(k)>1) stop("k must be a non-negative integer")
if(k==0) return(x);
new.x <- as.data.frame(c(x[-(0:k),],rep(NA,k)))
rownames(new.x) <- rownames(x)
colnames(new.x) <- "Next"
return(new.x)
}
`Next.quantmod.OHLC` <-
function(x,k=1)
{
if(k<0||k!=as.integer(k)||length(k)>1) stop("k must be a non-negative integer")
if(k==0) return(x);
new.x <- as.matrix(c(as.numeric(x[-(0:k),]),rep(NA,k)))
x.index <- index(x)
new.x <- zoo(new.x,x.index)
colnames(new.x) <- "Next"
return(new.x)
}
`Next.zoo` <- Next.quantmod.OHLC
`Next.numeric` <-
function(x,k=1)
{
if(k<0||k!=as.integer(k)||length(k)>1) stop("k must be a non-negative integer")
if(k==0) return(x);
new.x <- as.matrix(c(as.numeric(x[-(0:k)]),rep(NA,k)))
colnames(new.x) <- "Next"
return(new.x)
}
`Lag` <-
function(x,k=1)
{
UseMethod("Lag")
}
`Lag.data.frame`<-
function(x,k=1)
{
new.x <- sapply(as.list(k), function(k.e) {
if(k.e<0||k.e!=as.integer(k.e)) stop("k must be a non-negative integer")
if(k.e==0) return(x);
c(rep(NA,k.e),x[-((nrow(x)-k.e+1):nrow(x)),])
}
)
rownames(new.x) <- rownames(x)
colnames(new.x) <- paste("Lag.",k,sep="")
return(new.x)
}
`Lag.quantmod.OHLC` <-
function(x,k=1)
{
new.x <- sapply(as.list(k), function(k.e) {
if(k.e<0||k.e!=as.integer(k.e)) stop("k must be a non-negative integer")
if(k.e==0) return(coredata(x));
c(rep(NA,k.e),x[-((length(x)-k.e+1):length(x))])
}
)
x.index <- index(x)
if(inherits(x,'xts')) {
new.x <- xts(new.x,x.index)
} else {
new.x <- zoo(new.x,x.index)
}
dim(new.x) <- c(NROW(new.x),length(k)) #max(k,1))
colnames(new.x) <- paste("Lag.",k,sep="")
return(new.x)
}
`Lag.zoo` <- `Lag.xts` <- Lag.quantmod.OHLC
`Lag.numeric` <-
function(x,k=1)
{
new.x <- sapply(as.list(k), function(k.e) {
if(k.e<0||k.e!=as.integer(k.e)) stop("k must be a non-negative integer")
if(k.e==0) return(x);
c(rep(NA,k.e),x[-((length(x)-k.e+1):length(x))])
}
)
dim(new.x) <- c(NROW(new.x),length(k)) #max(k,1))
colnames(new.x) <- paste("Lag.",k,sep="")
return(new.x)
}
`Lag.default`<-
function(x,k=1)
{
if(is.character(x)) stop("x must be a time series or numeric vector")
lag(x,k)
}
Delt_ <-
function(x1,x2=NULL,k=0,type=c('arithmetic','log'))
{
x1 <- try.xts(x1, error=FALSE)
type <- match.arg(type[1],c('log','arithmetic'))
if(length(x2)!=length(x1) && !is.null(x2)) stop('x1 and x2 must be of same length');
if(is.null(x2)){
x2 <- x1 #copy for same symbol deltas
if(length(k) < 2) {
k <- max(1,k)
}
}
dim(x2) <- NULL # allow for multiple k matrix math to happen
if(type=='log') {
xx <- lapply(k, function(K.) {
log(unclass(x2)/lag(x1,K.))
})
} else {
xx <- lapply(k, function(K.) {
unclass(x2)/lag(x1,K.)-1
})
}
xx <- do.call("cbind", xx)
colnames(xx) <- paste("Delt",k,type,sep=".")
reclass(xx,x1)
}
`Delt` <-
function(x1,x2=NULL,k=0,type=c('arithmetic','log'))
{
x1 <- try.xts(x1, error=FALSE)
type <- match.arg(type[1],c('log','arithmetic'))
if(length(x2)!=length(x1) && !is.null(x2)) stop('x1 and x2 must be of same length');
if(is.null(x2)){
x2 <- x1 #copy for same symbol deltas
if(length(k) < 2) {
k <- max(1,k)
}
}
dim(x2) <- NULL # allow for multiple k matrix math to happen
if(type=='log') {
xx <- lapply(k, function(K.) {
log(unclass(x2)/Lag(x1,K.))
})
} else {
xx <- lapply(k, function(K.) {
unclass(x2)/Lag(x1,K.)-1
})
}
xx <- do.call("cbind", xx)
colnames(xx) <- paste("Delt",k,type,sep=".")
reclass(xx,x1)
}
.Delt <- function(x1, x2 = NULL, k = 0, type=c("arithmetic","log")) {
x1 <- try.xts(x1, error=FALSE)
type <- match.arg(type[1], c("arithmetic","log"))
if(length(x2) != length(x1) && !is.null(x2))
stop("x1 and x2 must be of the same length")
if(is.null(x2)) {
x2 <- x1
if(length(k) < 2) {
k <- max(1,k)
}
}
if(type=="log") {
#xx <- lapply(k, function(K) diff(log(x1), K))
xx <- lapply(k, function(K) log(x2/lag(x1, K)))
}
else {
#xx <- lapply(k, function(K) diff(x1,K) / lag(x1,K))
xx <- lapply(k, function(K) (x2 - lag(x1,K)) / lag(x1,K))
}
xx <- do.call(cbind,xx)
colnames(xx) <- paste("Delt",k,type,sep=".")
reclass(xx,x1)
}
quantmod/R/gainloss.R 0000644 0001762 0000144 00000001340 14654457715 014265 0 ustar ligges users "plotGainLoss" <- function(x,last.n.days=60) {
if(is.quantmodResults(x)) x <- modelSignal(x)
ms <- x[(NROW(x)-last.n.days):NROW(x),]
plwd <- 3
val.range <- sd(ms[,1])*3
ylim <- c(-val.range,val.range)
oldbg <- par('bg')
par(bg='#333333')
par(new=FALSE)
# plot all returns in bar style
plot(ms[,1],type='h',ylim=ylim,col='#dddddd',lwd=plwd,ylab='', xlab='',bty='n')
merged.d.f <- merge(abs(subset(ms,ms[,1]*ms[,2]<0)[,1])*-1,abs(subset(ms,ms[,1]*ms[,2]>0)[,1]))
par(new=TRUE)
plot(merged.d.f[,1],type='h',ylim=ylim,col='#ff0000',lwd=plwd,ylab='', xlab='')
par(new=TRUE)
plot(merged.d.f[,2],type='h',ylim=ylim,col='#00ff00',lwd=plwd,ylab='', xlab='')
grid(NA,5,lwd=1,col="#aaaaaa",lty=3)
par(bg=oldbg)
}
quantmod/R/newTA.R 0000644 0001762 0000144 00000011322 14657447467 013473 0 ustar ligges users `newTA` <- function(FUN, preFUN, postFUN, on=NA, yrange=NULL,
legend.name, fdots=TRUE, cdots=TRUE, data.at=1, ...) {
if(is.character(FUN)) {
if(exists(FUN) && is.function(get(FUN))) {
FUN.name <- FUN
FUN <- get(FUN)
}
} else
if(is.function(FUN)) {
FUN.name <- deparse(substitute(FUN))
} else stop('FUN required to be a function object')
# create a text string of the function for inclusion in .body
funToFun <- function (x, fun.name, drop.arg = 1, dots=TRUE)
{
drop.arg <- if (any(drop.arg < 1)) {
1:length(formals(x))
}
else -drop.arg
fnames <- names(formals(x))
if( !dots && ('...' %in% fnames) )
fnames <- fnames[-which('...' == fnames)]
fun.args <- paste(fnames, "=",
c('x',fnames[drop.arg]), sep = "")
fun.args <- paste(gsub("=\\.\\.\\.", "", fun.args), collapse = ",")
paste(fun.name, "(", fun.args, ")",
collapse = "", sep = "")
}
.formals <- formals(FUN)[-data.at]
.body <- deparse(body(skeleton.TA))
gpars <- list(...)
# add ability to customize legend.name, still retaining legend color/last value
if(!missing(legend.name) && is.character(legend.name)) {
.body[22] <- paste("legend.name <- gsub('^.*[(]',",paste('\'',legend.name,'(\''),
#",deparse(match.call()),extended=TRUE)")
",deparse(match.call()))")
}
# cdots: should the newTA object have a ... arg?
# if the function uses, the call must too
if(missing(fdots) && !('...' %in% .formals))
fdots <- FALSE
if(fdots) cdots <- TRUE
if(!cdots) {
.formals <- .formals[-which('...' == names(.formals))]
.body[23] <- paste("gpars <-",list(gpars))
} else {
if(!'...' %in% names(.formals)) {
.formals <- c(.formals,alist(...=))
}
.body[23] <- paste('gpars <- c(list(...),', list(gpars),
')[unique(names(c(',list(gpars),',list(...))))]')
}
.formals <- eval(parse(text=paste('c(.formals,alist(on=',on,', legend="auto"))')))
if(!missing(preFUN)) {
if(is.character(preFUN)) {
if(exists(preFUN) && is.function(get(preFUN))) {
preFUN <- preFUN
}
} else
if(is.function(preFUN)) {
preFUN <- deparse(substitute(preFUN))
} else stop('preFUN required to be a function object')
# add tranform Function to .body
.body[4] <- paste("x <-",preFUN,"(x)",sep="")
# if missing, assume no transform need to be done
} else .body[4] <- 'preFUN <- ""'
if(!missing(postFUN)) {
if(is.character(postFUN)) {
if(exists(postFUN) && is.function(get(postFUN))) {
postFUN <- postFUN
}
} else
if(is.function(postFUN)) {
postFUN <- deparse(substitute(postFUN))
} else stop('postFUN required to be a function object')
# add tranform Function to .body
.body[6] <- paste("x <-",postFUN,"(x)",sep="")
# if missing, assume no transform need to be done
} else .body[6] <- 'postFUN <- ""'
# allow for yrange to be set
if(!is.null(yrange)) {
.body[7] <- paste('yrange <-',deparse(yrange))
}
# fdots: should the underlying function call use ...
.body[5] <- paste("x <-",funToFun(FUN,FUN.name,data.at, dots=fdots))
if(.body[6] == 'postFUN <- ""') .body[6] <- ''
if(.body[4] == 'preFUN <- ""' ) .body[4] <- ''
as.function(c(.formals,as.call(parse(text=.body))[[1]]),
envir = asNamespace('quantmod'))
}
## Do not edit! Some line numbers are referred to in newTA.
`skeleton.TA` <- function(on)
{
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
preFUN <- ""
FUN <- ""
postFUN <- ""
yrange <- NULL
chobTA <- new("chobTA")
if(NCOL(x) == 1) {
chobTA@TA.values <- x[lchob@xsubset]
} else chobTA@TA.values <- x[lchob@xsubset,]
chobTA@name <- "chartTA"
if(any(is.na(on))) {
chobTA@new <- TRUE
}
else {
chobTA@new <- FALSE
chobTA@on <- on
}
chobTA@call <- match.call()
legend.name <- gsub('^add','',deparse(match.call()))
gpars <- list()
## safe to edit from here down
chobTA@params <- list(xrange = lchob@xrange, yrange=yrange, colors = lchob@colors,
color.vol = lchob@color.vol, multi.col = lchob@multi.col,
spacing = lchob@spacing, width = lchob@width, bp = lchob@bp,
x.labels = lchob@x.labels, time.scale = lchob@time.scale,
isLogical=is.logical(x),legend = legend, legend.name = legend.name, pars = list(gpars))
if (is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA, chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new, 1,
0)
do.call(chartSeries.chob,list(lchob))
invisible(chobTA)
}
else {
return(chobTA)
}
}
quantmod/R/addCMO.R 0000644 0001762 0000144 00000004315 14654457715 013542 0 ustar ligges users
# addCMO {{{
`addCMO` <- function(n=14) {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- TRUE
# needs to accept any arguments for x, not just close
xx <- if(has.Cl(x)) {
Cl(x)
} else if(is.null(dim(x))) {
x
} else {
x[,1]
}
cmo <- CMO(xx,n=n)
chobTA@TA.values <- cmo[lchob@xsubset]
chobTA@name <- "chartCMO"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} #}}}
# chartCMO {{{
`chartCMO` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
n <- x@params$n
cmo <- x@TA.values
y.range <- seq(-max(abs(cmo), na.rm = TRUE), max(abs(cmo),
na.rm = TRUE), length.out = length(x.range)) * 1.05
plot(x.range,y.range,
type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
COLOR="#0033CC"
abline(h=0,col="#666666",lwd=1,lty='dotted')
lines(seq(1,length(x.range),by=spacing),cmo,col=COLOR,lwd=1,type='l')
text(0, last(y.range)*.9,
paste("Chande Momentum Oscillator (", x@params$n,"):", sep = ""),
pos = 4)
text(0, last(y.range)*.9,
paste("\n\n\n",sprintf("%.3f",last(cmo)), sep = ""), col = COLOR,
pos = 4)
axis(2)
box(col=x@params$colors$fg.col)
} # }}}
quantmod/R/SymbolLookup.R 0000644 0001762 0000144 00000003300 15002467345 015067 0 ustar ligges users setSymbolLookup <- function(...)
{
new.symbols <- list(...)
if(length(new.symbols)==1 && is.null(names(new.symbols)) && is.list(new.symbols[[1]])) new.symbols<-new.symbols[[1]]
all.symbols <- getOption("getSymbols.sources")
for(each.symbol in names(new.symbols)) {
if(length(new.symbols[[each.symbol]])==1 &
!is.list(new.symbols[[each.symbol]])) {
# if a single value is passed then it
# is interpreted as 'src', unless
# it is part of a list, then it is the
# appropriately named element.
all.symbols[[each.symbol]] <- list(src=new.symbols[[each.symbol]])
} else {
all.symbols[[each.symbol]] <- new.symbols[[each.symbol]]
}
}
options(getSymbols.sources=all.symbols)
}
"setSymbolLookup.bak" <-
function(...)
{
new.symbols <- list(...)
all.symbols <- getOption("getSymbols.sources")
for(each.symbol in names(new.symbols)) {
all.symbols[[each.symbol]] <- new.symbols[[each.symbol]]
}
options(getSymbols.sources=all.symbols)
}
"loadSymbolLookup" <-
function(file,dir="")
{
if(missing(file)) file <- ".quantmod.SymbolLookup.rda"
if(dir!="") {
file <- file.path(dir,file)
}
if(file.exists(file)) {
load(file)
options(getSymbols.sources=get('lookup.list'))
} else {
stop("no SymbolLookup file exists in this directory")
}
}
"saveSymbolLookup" <-
function(file,dir="")
{
if(missing(file)) file <- ".quantmod.SymbolLookup.rda"
if(dir!="") {
file <- file.path(dir,file)
}
lookup.list <- getSymbolLookup()
save(lookup.list,file=file)
}
"getSymbolLookup" <-
function(Symbols=NULL)
{
all.symbols <- getOption("getSymbols.sources")
if(is.null(Symbols)) Symbols <- names(all.symbols)
all.symbols[Symbols]
}
quantmod/R/zoomChart.R 0000644 0001762 0000144 00000002637 14657447467 014434 0 ustar ligges users `zoomChart` <-
function(subset, yrange=NULL) {
if(missing(subset) || is.null(subset)) #{
subset <- '::'
# } else {
# if (!is.character(subset))
# subset <- deparse(match.call()$subset)
# subset <- gsub("::", "/", subset, perl = TRUE)
# subset <- gsub("[-:]", "", subset, perl = TRUE)
# subset <- gsub("[ ]", "", subset, perl = TRUE)
# }
reChart(subset=subset, yrange=yrange)
}
`zooom` <-
function (n = 1, eps = 2)
{
for (i in 1:n) {
cat("select left and right extremes by clicking the chart\n")
points <- locator(2)
if (abs(diff(points$x)) < eps) {
zoomChart()
}
else {
usr <- par("usr")
xdata <- get.chob()[[2]]@xdata
xsubset <- get.chob()[[2]]@xsubset
sq <- floor(seq(usr[1], usr[2], 1))
st <- which(floor(points$x[1]) == sq)/length(sq) *
NROW(xdata[xsubset])
en <- which(floor(points$x[2]) == sq)/length(sq) *
NROW(xdata[xsubset])
sorted <- sort(c(st, en))
st <- sorted[1]
en <- sorted[2] * 1.05
zoomChart(paste(index(xdata[xsubset])[max(1, floor(st),
na.rm = TRUE)], index(xdata[xsubset])[min(ceiling(en),
NROW(xdata[xsubset]), na.rm = TRUE)], sep = "::"))
}
}
cat("done\n")
}
quantmod/R/addCLV.R 0000644 0001762 0000144 00000003150 14654457715 013544 0 ustar ligges users # Close Location Value from TTR by Josh Ulrich
#
# chartSeries implementation by Jeffrey A. Ryan 2008
#
# addCLV
`addCLV` <-
function (..., on = NA, legend = "auto")
{
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
x <- HLC(x)
x <- CLV(HLC = x)
yrange <- NULL
chobTA <- new("chobTA")
if (NCOL(x) == 1) {
chobTA@TA.values <- x[lchob@xsubset]
}
else chobTA@TA.values <- x[lchob@xsubset, ]
chobTA@name <- "chartTA"
if (any(is.na(on))) {
chobTA@new <- TRUE
}
else {
chobTA@new <- FALSE
chobTA@on <- on
}
chobTA@call <- match.call()
legend.name <- gsub("^.*[(]", " Close Location Value (",
deparse(match.call()))#, extended = TRUE)
gpars <- c(list(...), list(col=5, type = "h"))[unique(names(c(list(col=5, type = "h"),
list(...))))]
chobTA@params <- list(xrange = lchob@xrange, yrange = yrange,
colors = lchob@colors, color.vol = lchob@color.vol, multi.col = lchob@multi.col,
spacing = lchob@spacing, width = lchob@width, bp = lchob@bp,
x.labels = lchob@x.labels, time.scale = lchob@time.scale,
isLogical = is.logical(x), legend = legend, legend.name = legend.name,
pars = list(gpars))
# if (is.null(sys.call(-1))) {
# TA <- lchob@passed.args$TA
# lchob@passed.args$TA <- c(TA, chobTA)
# lchob@windows <- lchob@windows + ifelse(chobTA@new, 1,
# 0)
# chartSeries.chob <- quantmod:::chartSeries.chob
# do.call("chartSeries.chob", list(lchob))
# invisible(chobTA)
# }
# else {
return(chobTA)
# }
}
quantmod/R/getQuote.R 0000644 0001762 0000144 00000043237 15013723375 014242 0 ustar ligges users # getQuote should function like getSymbols
# getQuote.yahoo
# getQuote.IBrokers
# getQuote.RBloomberg
# getQuote.OpenTick
`getQuote` <-
function(Symbols,src='yahoo',what, ...) {
importDefaults("getQuote")
Symbols <- unique(unlist(strsplit(Symbols,";")))
args <- list(Symbols=Symbols,...)
if(!missing(what))
args$what <- what
df <- do.call(paste('getQuote',src,sep='.'), args)
if(NROW(df) != length(Symbols)) {
# merge to generate empty rows for missing results from underlying source
allSymbols <- data.frame(Symbol = Symbols, stringsAsFactors = FALSE)
df <- merge(allSymbols, df, by = "Symbol", all.x = TRUE)
}
rownames(df) <- df$Symbol
df$Symbol <- NULL
# order result the same as Symbols input
df[Symbols,]
}
.yahooSession <- function(is.retry = FALSE) {
cache.name <- "_yahoo_curl_session_"
ses <- get0(cache.name, .quantmodEnv) # get cached session
if (is.null(ses) || is.retry) {
ses <- list()
ses$h <- curl::new_handle()
# yahoo finance doesn't seem to set cookies without these headers
# and the cookies are needed to get the crumb
curl::handle_setheaders(ses$h,
accept = "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,image/apng,*/*;q=0.8,application/signed-exchange;v=b3;q=0.7",
"User-Agent" = "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/115.0.0.0 Safari/537.36 Edg/115.0.1901.183")
URL <- "https://finance.yahoo.com/"
r <- curl::curl_fetch_memory(URL, handle = ses$h)
# yahoo redirects to a consent form w/ a single cookie for GDPR:
# detecting the redirect seems very brittle as its sensitive to the trailing "/"
ses$can.crumb <- ((r$status_code == 200) && (URL == r$url) && (NROW(curl::handle_cookies(ses$h)) > 1))
assign(cache.name, ses, .quantmodEnv) # cache session
}
if (ses$can.crumb) {
# get a crumb so that downstream callers don't have to handle invalid sessions.
# this is a network hop, but very lightweight payload
n <- if (unclass(Sys.time()) %% 1L >= 0.5) 1L else 2L
query.srv <- paste0("https://query", n, ".finance.yahoo.com/v1/test/getcrumb")
r <- curl::curl_fetch_memory(query.srv, handle = ses$h)
if ((r$status_code == 200) && (length(r$content) > 0)) {
ses$crumb <- rawToChar(r$content)
} else {
# we were unable to get a crumb
if (is.retry) {
# we already did a retry and still couldn't get a crumb with a new session
stop("unable to get yahoo crumb")
} else {
# we tried to re-use a session but couldn't get a crumb
# try to get a crumb using a new session
ses <- .yahooSession(TRUE)
}
}
}
return(ses)
}
`getQuote.yahoo` <-
function(Symbols,what=standardQuote(),session=NULL,...) {
importDefaults("getQuote.yahoo")
length.of.symbols <- length(Symbols)
if (is.null(session)) session <- .yahooSession()
if (!session$can.crumb) {
stop("Unable to obtain yahoo crumb. If this is being called from a GDPR country, Yahoo requires GDPR consent, which cannot be scripted")
}
if(length.of.symbols > 99) {
# yahoo only works with 99 symbols or less per call
# we will recursively call getQuote.yahoo to handle each block of 200
all.symbols <- lapply(seq(1,length.of.symbols,99),
function(x) na.omit(Symbols[x:(x+98)]))
df <- NULL
cat("downloading set: ")
for(i in 1:length(all.symbols)) {
Sys.sleep(0.5)
cat(i,", ")
df <- rbind(df, getQuote.yahoo(all.symbols[[i]],what,session=session))
}
cat("...done\n")
return(df)
}
# escape symbols that have special characters
escapedSymbols <- sapply(Symbols, URLencode, reserved = TRUE)
SymbolsString <- paste(escapedSymbols, collapse = ',')
if(inherits(what, 'quoteFormat')) {
QF <- what[[1]]
QF.names <- what[[2]]
} else {
QF <- what
QF.names <- NULL
}
# JSON API currently returns the following fields with every request:
# language, quoteType, marketState, exchangeDataDelayedBy,
# exchange, fullExchangeName, market, sourceInterval, exchangeTimezoneName,
# exchangeTimezoneShortName, gmtOffSetMilliseconds, tradeable, symbol
QFc <- paste0(QF,collapse=',')
URL <- paste0("https://query1.finance.yahoo.com/v7/finance/quote?crumb=", session$crumb,
"&symbols=", SymbolsString,
"&fields=", QFc)
# The 'response' data.frame has fields in columns and symbols in rows
response <- jsonlite::fromJSON(curl::curl(URL, handle = session$h))
if (is.null(response$quoteResponse$error)) {
sq <- response$quoteResponse$result
} else {
stop(response$quoteResponse$error)
}
# milliseconds to seconds
milliFields <- c("firstTradeDateMilliseconds", "gmtOffSetMilliseconds")
for (field in milliFields) {
if (!is.null(sq[[field]])) {
sq[[field]] <- sq[[field]] / 1000
}
}
# Use exchange TZ, if possible. POSIXct must have only one TZ, so times
# from different timezones will be converted to a common TZ
tz <- sq[["exchangeTimezoneName"]]
if (length(unique(tz)) == 1L) {
tz <- tz[1]
} else {
warning("symbols have different timezones; converting to local time")
tz <- NULL
}
# timestamps to POSIXct
timeFields <-
c("regularMarketTime", "postMarketTime", "exDividendDate", "dividendDate",
"earningsTimestamp", "earningsTimestampStart", "earningsTimestampEnd",
"firstTradeDateMilliseconds")
for (field in timeFields) {
if (!is.null(sq[[field]])) {
sq[[field]] <- .POSIXct(sq[[field]], tz = tz)
}
}
if (is.null(sq$regularMarketTime)) {
sq$regularMarketTime <- .POSIXct(NA)
}
# Extract user-requested columns. Convert to list to avoid
# 'undefined column' error with data.frame.
qflist <- setNames(as.list(sq)[QF], QF)
# Fill any missing columns with NA
pad <- rep(NA, NROW(sq))
qflist <- lapply(qflist, function(e) if (is.null(e)) pad else e)
# Add the symbols and trade time, and setNames() on other elements
# Always return symbol and time
qflist <- c(list(Symbol = sq$symbol, regularMarketTime = sq$regularMarketTime),
setNames(qflist, QF))
df <- data.frame(qflist, stringsAsFactors = FALSE, check.names = FALSE)
if(!is.null(QF.names)) {
colnames(df) <- c('Symbol','Trade Time',QF.names)
}
df
}
# integrate this into the main getQuote.yahoo, after branching that
#
`getAllQuotes` <-
function() {
st <- seq(1,3000,200)
en <- seq(200,3000,200)
aq <- NULL
for(i in 1:length(st)) {
cc <- getQuote(paste(read.csv(options()$symbolNamesFile.NASDAQ, sep='|')$Sym[seq(st[i],en[i])],collapse=';'))
cat('finished first',en[i],'\n')
Sys.sleep(.1)
aq <- rbind(aq,cc)
}
aq
}
`standardQuote` <- function(src='yahoo') {
do.call(paste('standardQuote',src,sep='.'),list())
}
`standardQuote.yahoo` <- function() {
yahooQF(names=c("Last Trade (Price Only)",
"Change","Change in Percent",
"Open", "Days High", "Days Low", "Volume"))
}
yahooQuote.EOD <- structure(list("ohgl1v", c("Open", "High",
"Low", "Close",
"Volume")), class="quoteFormat")
`yahooQF` <- function(names) {
optnames <- .yahooQuoteFields[,"name"]
optshort <- .yahooQuoteFields[,"shortname"]
optcodes <- .yahooQuoteFields[,"field"]
w <- NULL
if(!missing(names)) {
names <- unlist(strsplit(names,';'))
for(n in names) {
w <- c(w,which(optnames %in% n))
}
} else {
names <- select.list(optnames, multiple=TRUE)
for(n in names) {
w <- c(w,which(optnames %in% n))
}
}
return(structure(list(optcodes[w], optshort[w]), class='quoteFormat'))
}
# name, shortname, field
.yahooQuoteFields <-
matrix(c(
# quote / symbol
"Symbol", "Symbol", "symbol",
"Name", "Name", "shortName",
"Name (Long)", "NameLong", "longName",
"Display Name", "Display Name", "displayName",
"Quote Type", "Quote Type", "quoteType",
"Quote Source Name", "Quote Source", "quoteSourceName",
"Source Interval", "Source Interval", "sourceInterval",
"Currency", "Currency", "currency",
"Financial Currency", "Financial Currency", "financialCurrency",
"First Trade Date", "First Trade Date", "firstTradeDateMilliseconds",
"Region", "Region", "region",
"Triggerable", "Triggerable", "triggerable",
# market / exchange
"Market", "Market", "market",
"Market State", "Market State", "marketState",
"Exchange", "Exchange", "exchange",
"Exchange Full Name", "Exchange Full Name", "fullExchangeName",
"Exchange Timezone", "Exchange Timezone", "exchangeTimezoneName",
"Exchange TZ", "Exchange TZ", "exchangeTimezoneShortName",
"Exchange Data Delay", "Exchange Data Delay", "exchangeDataDelayedBy",
"GMT Offset Millis", "GMT Offset", "gmtOffSetMilliseconds",
"Tradeable", "Tradeable", "tradeable",
# market data
"Ask", "Ask", "ask",
"Bid", "Bid", "bid",
"Ask Size", "Ask Size", "askSize",
"Bid Size", "Bid Size", "bidSize",
"Last Trade (Price Only)", "Last", "regularMarketPrice",
"Last Trade Time", "Last Trade Time", "regularMarketTime",
"Change", "Change", "regularMarketChange",
"Open", "Open", "regularMarketOpen",
"Days High", "High", "regularMarketDayHigh",
"Days Low", "Low", "regularMarketDayLow",
"Volume", "Volume", "regularMarketVolume",
"Change in Percent", "% Change", "regularMarketChangePercent",
"Previous Close", "P. Close", "regularMarketPreviousClose",
"Regular Hours Range", "Regular Hours Range", "regularMarketDayRange",
"Post Market Change", "Post Market Change", "postMarketChange",
"Post Market Percent Change", "Post Market % Change", "postMarketChangePercent",
"Post Market Time", "Post Market Time", "postMarketTime",
"Post Market Price", "Post Market Price", "postMarketPrice",
# trading stats
"Change From 52-week Low", "Change From 52-week Low", "fiftyTwoWeekLowChange",
"Percent Change From 52-week Low", "% Change From 52-week Low", "fiftyTwoWeekLowChangePercent",
"Change From 52-week High", "Change From 52-week High", "fiftyTwoWeekHighChange",
"Percent Change From 52-week High", "% Change From 52-week High", "fiftyTwoWeekHighChangePercent",
"52-week Low", "52-week Low", "fiftyTwoWeekLow",
"52-week High", "52-week High", "fiftyTwoWeekHigh",
"52-week Range", "52-week Range", "fiftyTwoWeekRange",
"52-week Percent Change", "52-week % Change", "fiftyTwoWeekChangePercent",
"50-day Moving Average", "50-day MA", "fiftyDayAverage",
"Change From 50-day Moving Average", "Change From 50-day MA", "fiftyDayAverageChange",
"Percent Change From 50-day Moving Average", "% Change From 50-day MA", "fiftyDayAverageChangePercent",
"200-day Moving Average", "200-day MA", "twoHundredDayAverage",
"Change From 200-day Moving Average", "Change From 200-day MA", "twoHundredDayAverageChange",
"Percent Change From 200-day Moving Average", "% Change From 200-day MA", "twoHundredDayAverageChangePercent",
"Year-to-Date Return", "YTD Return", "ytdReturn",
"Trailing 3 Month Return", "Trailing 3mo Return", "trailingThreeMonthReturns",
"Trailing 3 Month NAV Return", "Trailing 3mo NAV Return", "trailingThreeMonthNavReturns",
# valuation stats
"Market Capitalization", "Market Capitalization", "marketCap",
"P/E Ratio", "P/E Ratio", "trailingPE",
"Price/EPS Estimate Current Year", "Price/EPS Estimate Current Year", "priceEpsCurrentYear",
"Price/EPS Estimate Next Year", "Price/EPS Estimate Next Year", "forwardPE",
"Price/Book", "Price/Book", "priceToBook",
"Book Value", "Book Value", "bookValue",
# share stats
"Average Daily Volume", "Ave. Daily Volume", "averageDailyVolume3Month",
"Average Daily Volume", "Ave. Daily Volume", "averageDailyVolume10Day",
"Shares Outstanding", "Shares Outstanding", "sharesOutstanding",
# dividends / splits
"Ex-Dividend Date", "Ex-Dividend Date", "exDividendDate",
"Dividend Pay Date", "Dividend Pay Date", "dividendDate",
"Dividend/Share", "Dividend/Share", "trailingAnnualDividendRate",
"Dividend Yield", "Dividend Yield", "trailingAnnualDividendYield",
"Dividend Rate", "Dividend Rate", "dividendRate",
"Div Yield", "Div Yield", "dividendYield",
# earnings
"Earnings Timestamp", "Earnings Timestamp", "earningsTimestamp",
"Earnings Start Time", "Earnings Start Time", "earningsTimestampStart",
"Earnings End Time", "Earnings End Time", "earningsTimestampEnd",
"Earnings/Share", "Earnings/Share", "epsTrailingTwelveMonths",
"EPS Forward", "EPS Forward", "epsForward",
"EPS Current Year", "EPS Current Year", "epsCurrentYear",
# yahoo / meta
"Language", "Language", "language",
"Message Board ID", "Message Board ID", "messageBoardId",
"Price Hint", "Price Hint", "priceHint",
# other
"Average Analyst Rating", "Ave. Analyst Rating", "averageAnalystRating",
"Custom Price Alert Confidence", "Custom Price Alert Confidence", "customPriceAlertConfidence",
"ESG Populated", "ESG Populated", "esgPopulated",
"Crypto Tradeable", "Crypto Tradeable", "cryptoTradeable",
"Net Assets", "Net Assets", "netAssets",
"Net Expense Ratio", "Net Expense Ratio", "netExpenseRatio"),
ncol = 3, byrow = TRUE, dimnames = list(NULL, c("name", "shortname", "field")))
getQuote.av <- function(Symbols, api.key, ...) {
importDefaults("getQuote.av")
if(!hasArg("api.key")) {
stop("getQuote.av: An API key is required (api.key). Free registration,",
" at https://www.alphavantage.co/.", call.=FALSE)
}
URL <- paste0("https://www.alphavantage.co/query",
"?function=GLOBAL_QUOTE",
"&apikey=", api.key,
"&symbol=")
# column metadata
map <- data.frame(
qm.names = c("Symbol", "Open", "High", "Low", "Last", "Volume",
"Trade Time", "P. Close", "Change", "% Change"),
av.names = c("symbol", "open", "high", "low", "price", "volume",
"latest trading day", "previous close", "change", "change percent"),
is.number = c(FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, TRUE),
stringsAsFactors = FALSE
)
prefix <- sprintf("%02d.", seq_len(NROW(map)))
map[["av.names"]] <- paste(prefix, map[["av.names"]])
# Function to process each quote response
quote2df <-
function(response, map, symbol)
{
# Expected response structure
qres <- setNames(vector("list", NROW(map)), map[["av.names"]])
elem <- function(el, isnum)
{
res <- NA_real_
if (!is.null(el)) {
if (isnum) {
# process numeric columns
haspct <- grepl("%", el, fixed = TRUE)
if (haspct) {
el <- sub("%", "", el, fixed = TRUE)
res <- as.numeric(el) / 100
} else {
res <- as.numeric(el)
}
} else {
res <- el
}
}
res
}
tmp <- modifyList(qres, response)
tmp <- Map(elem, el = tmp, isnum = map[["is.number"]])
# populate Symbol column for symbols missing quotes
if (is.na(tmp[["01. symbol"]])) {
tmp[["01. symbol"]] <- symbol
}
data.frame(tmp, stringsAsFactors = FALSE)
}
# get latest daily quotes from AV
# they don't have batch quotes anymore as of Feb 2020
Symbols <- toupper(Symbols)
qlist <- list()
for (Symbol in Symbols) {
# Alpha Vantage's standard API is limited 5 calls/minute (~0.0833/sec)
Sys.sleep(0.1)
resp <- jsonlite::fromJSON(paste0(URL, Symbol))
if (names(resp)[1] != "Global Quote") {
msg <- paste(names(resp)[1], resp[[1]], sep = ": ")
warning(paste0("getQuote.av didn't return a quote for ", Symbol, "\n",
"\tMessage: \"", msg, "\""),
call. = FALSE, immediate. = TRUE)
} else {
resp <- resp[[1]] # resp$`Global Quote`
qlist[[Symbol]] <- quote2df(resp, map, Symbol)
}
}
qdf <- do.call(rbind, qlist)
if (NROW(qdf) < 1) {
syms <- paste(Symbols, collapse = ", ")
stop("Error in getQuote.av; no data for symbols: ",
syms, call. = FALSE)
}
names(qdf) <- map[["qm.names"]]
qdf[["Trade Time"]] <- as.Date(qdf[["Trade Time"]])
return(qdf)
}
`getQuote.tiingo` <- function(Symbols, api.key, ...) {
# docs: https://api.tiingo.com/docs/iex/realtime
# NULL Symbols will retrieve quotes for all symbols
importDefaults("getQuote.tiingo")
if(!hasArg("api.key")) {
stop("getQuote.tiingo: An API key is required (api.key). ",
"Registration at https://api.tiingo.com/.", call. = FALSE)
}
Symbols <- unlist(strsplit(Symbols,';'))
base.url <- paste0("https://api.tiingo.com/iex/?token=", api.key)
r <- NULL
if(is.null(Symbols)) {
batch.size <- 1L
batch.length <- 1L
} else {
batch.size <- 100L
batch.length <- length(Symbols)
}
for(i in seq(1L, batch.length, batch.size)) {
batch.end <- min(batch.length, i + batch.size - 1L)
if(i > 1L) {
Sys.sleep(0.25)
cat("getQuote.tiingo downloading batch", i, ":", batch.end, "\n")
}
if(is.null(Symbols)) {
batch.url <- base.url
} else {
batch.url <- paste0(base.url, "&tickers=", paste(Symbols[i:batch.end], collapse = ","))
}
batch.result <- jsonlite::fromJSON(curl::curl(batch.url))
if(NROW(batch.result) < 1) {
syms <- paste(Symbols[i:batch.end], collapse = ", ")
stop("Error in getQuote.tiingo; no data for symbols: ",
syms, call. = FALSE)
}
# do type conversions for each batch so we don't get issues with rbind
for(cn in colnames(batch.result)) {
if(grepl("timestamp", cn, ignore.case = TRUE)) {
batch.result[, cn] <- as.POSIXct(batch.result[, cn])
}
else if(cn != "ticker") {
batch.result[, cn] <- as.numeric(batch.result[, cn])
}
}
r <- rbind(r, batch.result)
}
# Normalize column names and output
r <- r[, c("ticker", "lastSaleTimestamp", "open", "high", "low", "last", "volume")]
colnames(r) <- c("Symbol", "Trade Time", "Open", "High", "Low", "Last", "Volume")
return(r)
}
quantmod/R/addKST.R 0000644 0001762 0000144 00000003307 14654457715 013565 0 ustar ligges users # Know Sure Thing from TTR by Josh Ulrich
#
# chartSeries interface by Jeffrey A. Ryan 2008
#
# addKST
#
`addKST` <-
function (n = c(10, 10, 10, 15), nROC = c(10, 15, 20, 30), nSig = 9,
maType, wts = 1:NROW(n), ..., on = NA, legend = "auto")
{
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
x <- coredata(Cl(x))
x <- KST(price = x, n = n, nROC = nROC, nSig = nSig, maType = maType,
wts = wts)
yrange <- NULL
chobTA <- new("chobTA")
if (NCOL(x) == 1) {
chobTA@TA.values <- x[lchob@xsubset]
}
else chobTA@TA.values <- x[lchob@xsubset, ]
chobTA@name <- "chartTA"
if (any(is.na(on))) {
chobTA@new <- TRUE
}
else {
chobTA@new <- FALSE
chobTA@on <- on
}
chobTA@call <- match.call()
legend.name <- gsub("^addKST", "Know Sure Thing ", deparse(match.call()))
gpars <- c(list(...), list(col = 6:7))[unique(names(c(list(col = 6:7),
list(...))))]
chobTA@params <- list(xrange = lchob@xrange, yrange = yrange,
colors = lchob@colors, color.vol = lchob@color.vol, multi.col = lchob@multi.col,
spacing = lchob@spacing, width = lchob@width, bp = lchob@bp,
x.labels = lchob@x.labels, time.scale = lchob@time.scale,
isLogical = is.logical(x), legend = legend, legend.name = legend.name,
pars = list(gpars))
if (is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA, chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new, 1,
0)
chartSeries.chob <- chartSeries.chob
do.call("chartSeries.chob", list(lchob))
invisible(chobTA)
}
else {
return(chobTA)
}
}
quantmod/R/zzz.R 0000644 0001762 0000144 00000017215 15002467345 013277 0 ustar ligges users #".onLoad" <- function(lib,pkg) {
# cat("quantmod: Quantitative Financial Modelling Framework\n\n")
# cat("Version 0.3-7, Revision 461\n")
# cat("http://www.quantmod.com\n\n")
#}
.plotEnv <- new.env()
.quantmodEnv <- new.env()
quantmodenv <- function() as.environment(".quantmodEnv")
print.quantmodEnv <- function(x, ...) {
print("")
}
.onAttach <- function(libname,pkgname) {
#msg <- "Version 0.4-0 included new data defaults. See ?getSymbols."
#packageStartupMessage(msg)
# --as-cran check is complaining of this, as a NOTE
#attach(NULL, name='.quantmodEnv')
}
setOldClass("zoo");
setOldClass("xts");
setOldClass("Date");
setClassUnion("xtsORzoo", c("xts","zoo"))
setClass("quantmod",representation(
model.id="character",
model.spec="formula",
model.formula="formula",
model.target="character",
model.inputs="character",
build.inputs="character",
symbols="character",
product="character",
price.levels="ANY",
training.data="ANY",
build.date="character",
fitted.model="ANY",
model.data="ANY",
quantmod.version="numeric"
)
);
setClass("quantmodReturn",representation(
results="xtsORzoo",
returns="xtsORzoo",
CAGR="numeric",
HPR="numeric",
accuracy="xtsORzoo",
directional.accuracy="list",
dist.of.returns="list",
returnsBy="ANY"
)
);
#setClass("quantmodResults",representation(
# model="quantmod",
# signal="zoo",
# return="quantmodReturn"
# )
# );
#setClass("tradeLog",representation(
# action="character",
# quantity="numeric",
# underlying="character",
# price="numeric",
# currency="character",
# date="Date",
# trade.id="numeric"),
# prototype = list(action='',
# quantity=0,
# underlying='',
# price=0,
# currency='USD',
# date=as.Date('2007-01-01'),
# trade.id=1)
# )
#setMethod("show","tradeLog",
# function(object)
# {
# tradeLog <- cbind(object@date,object@trade.id,object@price,object@quantity)
# print(zoo(tradeLog,order.by=object@date))
# })
setMethod("show", "chobTA",
function(object) {
plot.chobTA(object)
}
)
setMethod("show","quantmod", function(object) {
cat("\nquantmod object: ",
object@model.id,"\tBuild date: ",
paste(object@build.date),"\n");
cat("\nModel Specified: \n ",
gsub("[ ]+"," ",deparse(object@model.spec)),"\n");
cat("\nModel Target: ",object@model.target,"\t\t",
"Product: ",object@product,"\n");
cat("Model Inputs: ",
paste(object@model.inputs,collapse=", "),"\n\n");
cat("Fitted Model: \n\n");
if(class(object@fitted.model)[1]=="NULL") {
cat("\tNone Fitted\n");
} else {
cat("\tModelling procedure: ",
class(object@fitted.model),"\n");
cat("\tTraining window: ",
length(object@training.data)," observations from ",
paste(object@training.data[c(1,length(object@training.data))],
collapse=" to "));
cat("\n")
print(object@fitted.model)
}
}
)
setMethod("summary","quantmod", function(object) {
cat("\nquantmod object: ",
object@model.id,"\tBuild date: ",
paste(object@build.date),"\n");
cat("\nModel Specified: \n ",
gsub("[ ]+"," ",deparse(object@model.spec)),"\n");
cat("\nModel Target: ",object@model.target,"\t\t",
"Product: ",object@product,"\n");
cat("Model Inputs: ",
paste(object@model.inputs,collapse=", "),"\n\n");
cat("Fitted Model: \n\n");
if(class(object@fitted.model)[1]=="NULL") {
cat("\tNone Fitted\n");
} else {
cat("\tModelling procedure: ",
class(object@fitted.model),"\n");
cat("\tTraining window: ",
length(object@training.data)," observations from ",
paste(object@training.data[c(1,length(object@training.data))],
collapse=" to "));
cat("\n")
summary(object@fitted.model)
}
})
#setMethod("show","quantmodResults", function(object) {
# cat("\n Model: ",object@model@model.id,"\n")
# cat("\n C.A.G.R.: ",sprintf("%04.2f%%",object@return@CAGR*100),"\tH.P.R.: ",
# sprintf("%04.2f%%",object@return@HPR*100),"\n");
# to.date.ret <- sprintf("%04.2f%%",object@return@returnsBy[NROW(object@return@returnsBy),-1]*100)
# to.date.ret <- as.data.frame(t(to.date.ret),row.names=" ")
#
# colnames(to.date.ret) <- colnames(object@return@returnsBy[,-1])
# cat("\n Returns by period summary:\n\n")
# print(as.data.frame(lapply(as.data.frame(object@return@returnsBy[,-1]),
# function(x) sprintf("%04.2f%%",(rev(as.numeric(summary(x))[1:6]*100)))),
# row.names=c(' Max.',' 3rd Qu.',' Mean',' Median',' 2rd Qu.',' Min.')))
# cat("\n Period to date returns:\n\n")
# print(to.date.ret)
#}
#)
"fittedModel"<-function(object) {object@fitted.model}
#setGeneric("fittedModel<-", function(x,...,value) standardGeneric("fittedModel<-"))
setGeneric("fittedModel<-", function(object,value) standardGeneric("fittedModel<-"))
#setReplaceMethod("fittedModel","quantmod", function(x,...,value)
setReplaceMethod("fittedModel","quantmod", function(object,value)
{
object@fitted.model <- value
}
)
## setGeneric('plot', function(x,y,...) standardGeneric('plot'));
## setMethod("plot","tR.results", function(x,y,...) {
## object <- x
## ret.by <- object@return@returnsBy
## plot(ret.by,type=c('l',rep('h',ncol(ret.by)-1)))
## }
## )
## setMethod("plot",signature("ANY","ANY"),function(x,y,...) { UseMethod('plot') } )
#####################################################
###
### Default S3 method and definition for predictModel
###
#####################################################
"predictModel" <-
function(object,data,...)
{
UseMethod("predictModel");
}
"predictModel.default" <-
function(object,data,...)
{
predict(object,data,...);
}
'plot.quantmodResults' <-
function(x,...)
{
ret.by <- x@return@returnsBy
plot(ret.by,type=c('l',rep('h',ncol(ret.by)-1)),...)
}
'formula.quantmod' <-
function(x,...)
{
x@model.formula
}
'coef.quantmod' <-
function(object,...)
{
if(!is.null(fittedModel(object)))
coef(fittedModel(object),...)
}
'coefficients.quantmod' <- coef.quantmod
'fitted.quantmod' <-
function(object,...)
{
if(!is.null(fittedModel(object)))
fitted(fittedModel(object),...)
}
'fitted.values.quantmod' <- fitted.quantmod
'residuals.quantmod' <-
function(object,...)
{
if(!is.null(fittedModel(object)))
residuals(fittedModel(object,...))
}
'resid.quantmod' <- residuals.quantmod
'vcov.quantmod' <-
function(object,...)
{
if(!is.null(fittedModel(object)))
vcov(fittedModel(object,...))
}
'logLik.quantmod' <-
function(object, ...)
{
if(!is.null(fittedModel(object)))
logLik(fittedModel(object),...)
}
'anova.quantmod' <-
function(object,...)
{
if(!is.null(fittedModel(object)))
anova(fittedModel(object),...)
}
'plot.quantmod' <-
function(x,...)
{
if(!is.null(fittedModel(x)))
plot(fittedModel(x),...)
}
quantmod/R/tools.R 0000644 0001762 0000144 00000003570 15002467345 013601 0 ustar ligges users `quantmodVersion` <- function() {
return(list(Version='0.3-7', Revision=433))
}
`quantmodNews` <- function() {
}
`quantmodChanges` <- function() {
}
`quantmodBugs` <- function() {
}
`quantmodComment` <- function() {
}
`quantmod.com` <- function() {
browseURL('http://www.quantmod.com')
}
`try.download.file` <-
function(url, destfile, method, quiet = FALSE, mode = "w", cacheOK = TRUE,
extra = getOption("download.file.extra"), ...)
{
# no longer used
# appears to have only been callled by getSymbols.FRED() to handle https
# downloads that are now handled by curl
# leaving in place in case needed for some other scenario
if (missing(method))
method <- getOption("download.file.method", default="auto")
# capture download.file errors (e.g. https not supported)
try.download <- try({
download.file(url, destfile, method, quiet, mode, cacheOK, extra)
}, silent=TRUE)
if (inherits(try.download, "try-error")) {
if (requireNamespace("downloader", quietly=TRUE)) {
# use downloader::download, if available
# everything except 'url' is passed via '...', so name them; and
# download automatically determines 'method' and errors if supplied
# as an argument, so omit it
downloader::download(url, destfile=destfile, quiet=quiet,
mode=mode, cacheOK=cacheOK, extra=extra)
} else {
# report original error, and provide recommendations
errcond <- attr(try.download, "condition")
stop("Failed to download file. Error message:\n", errcond$message, "\n",
"If this is related to https, possible solutions are:\n",
"1. Explicitly pass method= via the getSymbols call (or via setDefaults)\n",
"2. Install downloader, which may be able to automagically determine a method\n",
"3. Set the download.file.method global option", call.=FALSE)
}
}
}
quantmod/R/adjustOHLC.R 0000644 0001762 0000144 00000002755 15002467345 014405 0 ustar ligges users adjustOHLC <-
function(x,
adjust=c("split","dividend"),
use.Adjusted=FALSE,
ratio=NULL, symbol.name=deparse(substitute(x)))
{
if(is.null(ratio)) {
if(use.Adjusted) {
# infer from Yahoo! Adjusted column
if(!has.Ad(x))
stop("no Adjusted column in 'x'")
ratio <- Ad(x)/Cl(x)
} else {
# use actual split and/or dividend data
div <- getDividends(symbol.name, from="1900-01-01")
splits <- getSplits(symbol.name, from="1900-01-01")
# un-adjust dividends for splits (Yahoo already adjusts div for splits)
# do not use split.adjust=FALSE in getDividends call, which would
# download the split data twice.
if(is.xts(splits) && is.xts(div) && NROW(splits) > 0 && NROW(div) > 0)
div <- div * 1/adjRatios(splits=merge(splits, index(div)))[,1]
# calculate adjustment ratios using unadjusted dividends
ratios <- adjRatios(splits, div, Cl(x))
if(length(adjust)==1 && adjust == "split") {
ratio <- ratios[,1]
} else if(length(adjust)==1 && adjust == "dividend") {
ratio <- ratios[,2]
} else ratio <- ratios[,1] * ratios[,2]
}
}
Adjusted <- Cl(x) * ratio
structure(
cbind((ratio * (Op(x)-Cl(x)) + Adjusted),
(ratio * (Hi(x)-Cl(x)) + Adjusted),
(ratio * (Lo(x)-Cl(x)) + Adjusted),
Adjusted,
if(has.Vo(x)) Vo(x) else NULL,
if(has.Ad(x)) Ad(x) else NULL
),
.Dimnames=list(NULL, colnames(x)))
}
quantmod/R/getFinancials.R 0000644 0001762 0000144 00000004027 15002467345 015206 0 ustar ligges users `getFinancials` <-
getFin <- function(Symbol, env=parent.frame(), src="google", auto.assign=TRUE, ...) {
src <- match.arg(src, "google")
if (src != "google") {
stop("src = ", sQuote(src), " is not implemented")
}
getFinancials.google(Symbol, env, auto.assign = auto.assign, ...)
}
getFinancials.google <-
function(Symbol, env=parent.frame(), src="google", auto.assign=TRUE, ...) {
msg <- paste0(sQuote("getFinancials.google"), " is defunct.",
"\nGoogle Finance stopped providing data in March, 2018.",
"\nYou could try some of the data sources via Quandl instead.",
"\nSee help(\"Defunct\") and help(\"quantmod-defunct\")")
.Defunct("Quandl", "quantmod", msg = msg)
}
`print.financials` <- function(x, ...) {
cat('Financial Statement for',attr(x,'symbol'),'\n')
cat('Retrieved from',attr(x,'src'),'at',format(attr(x,'updated')),'\n')
cat('Use "viewFinancials" or "viewFin" to view\n')
}
`viewFin` <-
`viewFinancials` <- function(x, type=c('BS','IS','CF'), period=c('A','Q'),
subset = NULL) {
if(!inherits(x,'financials')) stop(paste(sQuote('x'),'must be of type',sQuote('financials')))
type <- match.arg(toupper(type[1]),c('BS','IS','CF'))
period <- match.arg(toupper(period[1]),c('A','Q'))
statements <- list(BS='Balance Sheet',
IS='Income Statement',
CF='Cash Flow Statement',
A='Annual',
Q='Quarterly')
if(is.null(subset)) {
message(paste(statements[[period]],statements[[type]],'for',attr(x,'symbol')))
return(x[[type]][[period]])
} else {
tmp.table <- as.matrix(as.xts(t(x[[type]][[period]]),dateFormat='Date')[subset])
dn1 <- rownames(tmp.table)
dn2 <- colnames(tmp.table)
tmp.table <- t(tmp.table)[, NROW(tmp.table):1]
if(is.null(dim(tmp.table))) {
dim(tmp.table) <- c(NROW(tmp.table),1)
dimnames(tmp.table) <- list(dn2,dn1)
}
message(paste(statements[[period]],statements[[type]],'for',attr(x,'symbol')))
return(tmp.table)
}
}
quantmod/R/saveChart.R 0000644 0001762 0000144 00000001310 14657447467 014371 0 ustar ligges users `saveChart` <-
function(.type='pdf', ..., dev=dev.cur()) {
dev <- as.numeric(dev)
gchob <- get.chob()[[dev]]
dim.inches <- par('din')
resolution <- 1
if(.type %in% c('png', 'jpeg')) resolution <- 72
width <- dim.inches[1] * resolution
height <- dim.inches[2] * resolution
export.pars <- c(list(...), list(file=paste(gchob@name,.type,sep='.'),width=width,height=height))[unique(names(c(list(file=1,width=width, height=height),
list(...))))]
do.call(.type, export.pars) # set up new device
chartSeries.chob(gchob)
invisible(dev.off()) # turn off device
release.chob(length(get.chob())) # remove from internal chob list
message(paste("chart saved to",export.pars$file))
}
quantmod/R/chartSeries.chob.R 0000644 0001762 0000144 00000024471 15002467345 015632 0 ustar ligges users # chartSeries.chob {{{
`chartSeries.chob` <-
function(x)
{
old.par <- par(c('pty','mar','xpd','bg','xaxs','las','col.axis','fg'))
on.exit(par(old.par))
LAYOUT <- ifelse(is.null(x@layout),FALSE,TRUE)
par.list <- list(list(mar=c( 0,3.5,2,3)),
list(mar=c( 0,3.5,0,3)),
list(mar=c(3.5,3.5,0,3)))
# layout page
if(LAYOUT) {
if(!inherits(x@layout,'chart.layout')) {
cl <- chart.layout(x@windows)
} else cl <- x@layout
layout(cl$mat, cl$width, cl$height, respect=FALSE)
}
if(x@windows > 1) {
do.call('par',par.list[[1]])
} else par(mar=c(3.5,3.5,2,3))
x.range <- 1:(x@xrange[2]*x@spacing)
y.range <- seq(x@yrange[1],x@yrange[2],length.out=length(x.range))
log.scale <- ifelse(x@log.scale, 'y', '')
# get current values of series to be charted
xx <- x@xdata
xx <- xx[x@xsubset]
if(is.OHLC(xx)) {
Opens <- as.numeric(Op(xx))
Highs <- as.numeric(Hi(xx))
Lows <- as.numeric(Lo(xx))
Closes <- as.numeric(Cl(xx))
} else {
# if not OHLC, assume univariate series
Lows <- min(xx[,1],na.rm=TRUE)
Highs <- max(xx[,1],na.rm=TRUE)
Closes <- as.numeric(xx[,1])
}
if(x@type=="Heikin-Ashi") {
xCloses <- (Opens+Highs+Lows+Closes)/4
xOpens <- (Opens + lag(Closes)) / 2
xHighs <- max(c(Highs, xOpens, xCloses),na=TRUE)
xLows <- min(c(Lows, xOpens, xCloses),na=TRUE)
Closes <- xCloses
Opens <- xOpens
Highs <- xHighs
Lows <- xLows
x@type <- "candlesticks"
}
par(bg=x@colors$bg.col,col.axis=x@colors$fg.col,
xaxs='r',las=2,fg=x@colors$fg.col)
# create scale of main plot window
plot.new()
plot.window(xlim=c(1,x@xrange[2]*x@spacing),
ylim=c(x@yrange[1],x@yrange[2]),
log=log.scale)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@colors$area)
# check for any underlay TA indicators that need to be drawn here:
main.key <- list() # main.key stores text to be added after all drawing by text()
if (length(x@passed.args$TA) > 0) {
underlay.TA <- which(sapply(x@passed.args$TA,
function(x) {
on <- (-1 %in% x@on)
ifelse(!identical(on, logical(0)), on, F)
}))
for (j in underlay.TA) {
tmp.x <- x@passed.args$TA[[j]]
main.key <- c(main.key,do.call(x@passed.args$TA[[j]]@name, list(tmp.x)))
}
}
# add gridlines _under_ main series
#grid(NA,NULL,col=x@colors$grid.col)
if(x@show.grid) abline(h=axTicks(2), col=x@colors$grid.col)
# a vector of x positions
x.pos <- 1+x@spacing*(1:x@length-1)
if(x@type=='line') {
lines(x.pos,Closes,col=x@colors$up.col,type=x@line.type)
main.key <- c(list(list(legend=
paste('Last',last(Closes)),
text.col=x@colors$up.col)),main.key)
} else {
# create a vector of colors
if(x@multi.col) {
last.Closes <- as.numeric(quantmod::Lag(Closes))
last.Closes[1] <- Closes[1]
# create vector of appropriate bar colors
bar.col <- ifelse(Opens < Closes,
ifelse(Opens < last.Closes,
x@colors$dn.up.col,
x@colors$up.up.col),
ifelse(Opens < last.Closes,
x@colors$dn.dn.col,
x@colors$up.dn.col))
# create vector of appropriate border colors
bar.border <- ifelse(Opens < Closes,
ifelse(Opens < last.Closes,
x@colors$dn.up.border,
x@colors$up.up.border),
ifelse(Opens < last.Closes,
x@colors$dn.dn.border,
x@colors$up.dn.border))
} else {
bar.col <- ifelse(Opens < Closes,x@colors$up.col,x@colors$dn.col)
bar.border <- ifelse(Opens < Closes,x@colors$up.border,x@colors$dn.border)
}
if(x@type %in% c('candlesticks','matchsticks')) {
# draw HL lines
#segments(x.pos,Lows,x.pos,Highs,col=bar.border)
# draw bottom wick
segments(x.pos,Lows,x.pos,apply(cbind(Opens,Closes),1,min),col=bar.border)
# draw top wick
segments(x.pos,Highs,x.pos,apply(cbind(Opens,Closes),1,max),col=bar.border)
# draw OC candles
if(x@type=='candlesticks') {
rect(x.pos-x@spacing/3,Opens,x.pos+x@spacing/3,Closes,
col=bar.col,border=bar.border)
} else segments(x.pos,Opens,x.pos,Closes,col=bar.col)
} else { # draw HLC or OHLC bars
# draw vertical HL
segments(x.pos,Lows,x.pos,Highs,col=bar.col)
# draw CLOSE notch
segments(x.pos,Closes,x.pos+x@spacing/6,Closes,col=bar.col)
# extend CLOSE to left side if HLC, else draw OPEN notch
if(x@bar.type=='hlc') {
segments(x.pos-x@spacing/6,Closes,x.pos,Closes,col=bar.col)
} else segments(x.pos-x@spacing/6,Opens,x.pos,Opens,col=bar.col)
}
main.key <- c(list(list(legend=
paste('Last',last(Closes)),
text.col=last(bar.col))),main.key)
}
axis(4)
box(col=x@colors$fg.col)
old.adj <- par('adj')
par('adj'=0)
do.call('title',list(x@name, col.main=x@colors$fg.col))
par('adj'=1)
do.call('title',list(paste('[',start(xx),'/',end(xx),']', sep='')
,col.main=x@colors$main.col))
par('adj'=old.adj)
# TA calculation and drawing loops
if(x@windows > 1 || length(x@passed.args$TA) > 0) {
for(i in 1:x@windows) {
# draw all overlays needed for figure 'i' on plot
overlay.TA <- which(sapply(x@passed.args$TA,
function(x) {
on <- i %in% x@on
ifelse(!identical(on,logical(0)),on,FALSE)
}))
for(j in overlay.TA) {
# call draws TA and returns the text to add to the chart
overlay.text <- do.call(x@passed.args$TA[[j]]@name,list(x@passed.args$TA[[j]]))
main.key <- c(main.key,overlay.text)
}
if(1) { #i == 1) {
# add indicator key to main chart
if(length(main.key) > 0) {
for(indicator in 1:length(main.key)) {
legend("topleft",
legend=c(rep('',indicator-1), paste(main.key[[indicator]][["legend"]],collapse="")),
text.col=rev(main.key[[indicator]][["text.col"]])[1], bty='n', y.intersp=0.95)
}
}
main.key <- list()
}
if(x@windows >= i+1) {
# if there are more windows to draw...draw the next one
next.new.TA <- which(sapply(x@passed.args$TA,function(x) x@new))[i]
do.call('par',par.list[[2]]) #par(mar=c(0,4,0,3))
if(x@windows == i+1) do.call('par',par.list[[3]]) #par(mar=c(4,4,0,3))
# draw all underlays needed for next figure 'i' on plot
underlay.TA <- which(sapply(x@passed.args$TA,
function(x) {
on <- (-(i+1) %in% x@on)
ifelse(!identical(on,logical(0)),on,FALSE)
}))
if(length(underlay.TA) > 0) {
# if underlays are to be drawn, first set up plot window
#main.key <- list(list("")) # need to position underlay text _under_ original text
do.call("chartSetUp",list(x@passed.args$TA[[next.new.TA]]))
for (j in underlay.TA) {
tmp.x <- x@passed.args$TA[[j]]
underlay.text <- c(main.key,do.call(x@passed.args$TA[[j]]@name, list(tmp.x)))
#main.key <- c(main.key,do.call(x@passed.args$TA[[j]]@name, list(tmp.x)))
}
x@passed.args$TA[[next.new.TA]]@new <- FALSE # make sure plot is not redrawn
main.key <- c(do.call(x@passed.args$TA[[next.new.TA]]@name,list(x@passed.args$TA[[next.new.TA]])),underlay.text)
x@passed.args$TA[[next.new.TA]]@new <- TRUE # make sure plot is redrawn
if(length(main.key) > 0) {
for(indicator in (length(main.key)-length(underlay.text)):length(main.key)) {
legend("topleft",
legend=c(rep('',indicator-1), paste(main.key[[indicator]][["legend"]],collapse="")),
text.col=rev(main.key[[indicator]][["text.col"]])[1], bty='n', y.intersp=0.95)
}
}
} else
main.key <- do.call(x@passed.args$TA[[next.new.TA]]@name,list(x@passed.args$TA[[next.new.TA]]))
}
}
}
# draw the final x labels
if(x@minor.ticks)
axis(1,at=x.pos,labels=FALSE,col=x@colors$minor.tick)
axis(1,at=1+x@bp*x@spacing-x@spacing,labels=x@x.labels,las=1,lwd=1,mgp=c(3,2,0),
col=x@colors$major.tick)
# resave new chob object - just in case of any changes
write.chob(x,dev.cur())
# reset layout of page
if(LAYOUT) layout(matrix(1))
}#}}}
# chart.layout {{{
`chart.layout` <-
function(x) {
if(x==1) {
lyt <- 'layout(matrix(1))'
mat <- matrix(1)
wd <- 1
ht <- 1
} else {
lyt <- paste('layout(matrix(c(1,1:',x,'),',x+1,',1,byrow=TRUE),',
'1,1,respect=FALSE)',sep='')
mat <- matrix(1:x,x,1,byrow=TRUE)
wd <- 1
ht <- c(3,rep(1,x-2),1.60)
}
par.list <- list(list(mar=c( 0,3.5,2,3)),
list(mar=c( 0,3.5,0,3)),
list(mar=c(3.5,3.5,0,3)))
structure(list(text=lyt,mat=mat,width=wd,height=ht,par.list=par.list), class='chart.layout')
}
#}}}
# experimental {{{
#`doCharts` <- function(W, TA, nc) {
# chartLayout(W,TA,nc)
# for(i in 1:x) barChart(GS, subset='2008', layout=NULL)
#}
#
#`chartLayout` <- function(W=1, TA=1, nc=1) {
# x <- matrix(rep(c(1,1,seq(2,length.out=TA)),W) +
# rep(seq(0,by=TA+1, length.out=W), each=TA+2),
# nc=nc, byrow=FALSE)
# layout(x,1,1,respect=FALSE)
#}
#
#`dozenCharts` <- function(W,TA , nc) {
# getSymbols("GS")
# chartLayout(W,TA,nc)
# TAs <- paste('addVo();addMACD();addRSI();addSMI();addROC();addDPO()',
# 'addADX();addATR();addCMF();addCCI();addCMO();addWPR()',sep=';')
# TAs <- unlist(strsplit(TAs,';'))
# Overlays <- paste('addEMA();addBBands();addEnvelope()',
# 'addExpiry();addSAR();addSMA()',sep=';')
# Overlays <- rep(unlist(strsplit(Overlays,';')),2)
#
# for(i in 1:W) {
# TA <- paste(TAs[i],Overlays[i],sep=';')
# candleChart(GS, theme='white', subset='2008', type='b', layout=NULL, TA=TA)
# }
#} #}}}
quantmod/R/replot.R 0000644 0001762 0000144 00000021543 15002467345 013746 0 ustar ligges users # replot {{{
new.replot <- function(frame=1,asp=1,xlim=c(1,10),ylim=list(structure(c(1,10),fixed=FALSE))) {
# global variables
Env <- new.env()
Env$frame <- frame
Env$asp <- asp
#Env$usr <- par("usr")
Env$xlim <- xlim
Env$ylim <- ylim
Env$pad1 <- -0 # bottom padding per frame
Env$pad3 <- 0 # top padding per frame
if(length(asp) != length(ylim))
stop("'ylim' and 'asp' must be the same length")
# setters
set_frame <- function(frame,clip=TRUE) {
Env$frame <<- frame;
set_window(clip); # change actual window
}
set_asp <- function(asp) { Env$asp <<- asp }
set_xlim <- function(xlim) { Env$xlim <<- xlim }
set_ylim <- function(ylim) { Env$ylim <<- ylim }
set_pad <- function(pad) { Env$pad1 <<- pad[1]; Env$pad3 <<- pad[2] }
reset_ylim <- function() {
ylim <- get_ylim()
ylim <- rep(list(c(Inf,-Inf)),length(ylim))
#ylim[[1]] <- range(OHLC(Env$xdata)[x]) # main data
lapply(Env$actions,
function(x) {
frame <- attr(x, "frame")
if(frame > 0) {
lenv <- attr(x,"env")
if(is.list(lenv)) lenv <- lenv[[1]]
ylim[[frame]][1] <<- min(ylim[[frame]][1],range(na.omit(lenv$xdata[Env$xsubset]))[1],na.rm=TRUE)
ylim[[frame]][2] <<- max(ylim[[frame]][2],range(na.omit(lenv$xdata[Env$xsubset]))[2],na.rm=TRUE)
}
})
# reset all ylim values, by looking for range(env[[1]]$xdata)
# xdata should be either coming from Env or if lenv lenv
set_ylim(ylim)
}
# getters
get_frame <- function(frame) { Env$frame }
get_asp <- function(asp) { Env$asp }
get_xlim <- function(xlim) { Env$xlim }
get_ylim <- function(ylim) { Env$ylim }
get_pad <- function() c(Env$pad1,Env$pad3)
# scale ylim based on current frame, and asp values
scale_ranges <- function(frame, asp, ranges)
{
asp/asp[frame] * abs(diff(ranges[[frame]]))
}
# set_window prepares window for drawing
set_window <- function(clip=TRUE,set=TRUE)
{
frame <- Env$frame
frame <- abs(frame)
asp <- Env$asp
xlim <- Env$xlim
ylim <- lapply(Env$ylim, function(x) structure(x + (diff(x) * c(Env$pad1, Env$pad3)),fixed=attr(x,"fixed")))
sr <- scale_ranges(frame, asp, ylim)
if(frame == 1) {
win <- list(xlim, c((ylim[[frame]][1] - sum(sr[-1])), ylim[[frame]][2]))
} else
if(frame == length(ylim)) {
win <- list(xlim, c(ylim[[frame]][1], ylim[[frame]][2] + sum(sr[-length(sr)])))
} else {
win <- list(xlim, c(ylim[[frame]][1] - sum(sr[-(1:frame)]),
ylim[[frame]][2] + sum(sr[-(frame:length(sr))])))
}
if(!set) return(win)
do.call("plot.window",win)
if(clip) clip(par("usr")[1],par("usr")[2],ylim[[frame]][1],ylim[[frame]][2])
}
get_actions <- function(frame) {
actions <- NULL
for(i in 1:length(Env$actions)) {
if(abs(attr(Env$actions[[i]],"frame"))==frame)
actions <- c(actions, Env$actions[i])
}
actions
}
# add_frame:
# append a plot frame to the plot window
add_frame <- function(after, ylim=c(0,0), asp=0, fixed=FALSE) {
if(missing(after))
after <- max(abs(sapply(Env$actions, function(x) attr(x,"frame"))))
for(i in 1:length(Env$actions)) {
cframe <- attr(Env$actions[[i]],"frame")
if(cframe > 0 && cframe > after)
attr(Env$actions[[i]], "frame") <- cframe+1L
if(cframe < 0 && cframe < -after)
attr(Env$actions[[i]], "frame") <- cframe-1L
}
Env$ylim <- append(Env$ylim,list(structure(ylim,fixed=fixed)),after)
Env$asp <- append(Env$asp,asp,after)
}
update_frames <- function(headers=TRUE) {
# use subset code here, without the subset part.
from_by <- ifelse(headers,2,1)
ylim <- get_ylim()
for(y in seq(from_by,length(ylim),by=from_by)) {
if(!attr(ylim[[y]],'fixed'))
ylim[[y]] <- structure(c(Inf,-Inf),fixed=FALSE)
}
lapply(Env$actions,
function(x) {
if(!is.null(attr(x,"no.update")) && attr(x, "no.update"))
return(NULL)
frame <- abs(attr(x, "frame"))
fixed <- attr(ylim[[frame]],'fixed')
#fixed <- attr(x, "fixed")
if(frame %% from_by == 0 && !fixed) {
lenv <- attr(x,"env")
if(is.list(lenv)) lenv <- lenv[[1]]
dat.range <- range(na.omit(lenv$xdata[Env$xsubset]))
min.tmp <- min(ylim[[frame]][1],dat.range,na.rm=TRUE)
max.tmp <- max(ylim[[frame]][2],dat.range,na.rm=TRUE)
ylim[[frame]] <<- structure(c(min.tmp,max.tmp),fixed=fixed)
}
})
# reset all ylim values, by looking for range(env[[1]]$xdata)
# xdata should be either coming from Env or if lenv, lenv
set_ylim(ylim)
}
remove_frame <- function(frame) {
rm.frames <- NULL
max.frame <- max(abs(sapply(Env$actions, function(x) attr(x,"frame"))))
for(i in 1:length(Env$actions)) {
cframe <- attr(Env$actions[[i]],"frame")
if(abs(attr(Env$actions[[i]],"frame"))==frame)
rm.frames <- c(rm.frames, i)
if(cframe > 0 && cframe > frame) {
attr(Env$actions[[i]], "frame") <- cframe-1L
}
if(cframe < 0 && cframe < -frame) {
attr(Env$actions[[i]], "frame") <- cframe+1L
}
}
if(frame > max.frame) {
Env$frame <- max.frame
} else Env$frame <- max.frame-1
Env$ylim <- Env$ylim[-frame]
Env$asp <- Env$asp[-frame]
if(!is.null(rm.frames))
Env$actions <- Env$actions[-rm.frames]
}
next_frame <- function() {
set_frame(max(abs(sapply(Env$actions,function(x) attr(x,"frame"))))+1L)
}
move_frame <- function() {}
# actions
Env$actions <- list()
# aplot
add <- replot <- function(x,env=Env,expr=FALSE,clip=TRUE,...) {
if(!expr) {
x <- match.call()$x
}
a <- structure(x,frame=Env$frame,clip=clip,env=env,...)
Env$actions[[length(Env$actions)+1]] <<- a
}
# prepare window to draw
#set_window()
# return
replot_env <- new.env()
class(replot_env) <- c("replot","environment")
replot_env$Env <- Env
replot_env$set_window <- set_window
replot_env$add <- add
replot_env$replot <- replot
replot_env$get_actions <- get_actions
replot_env$subset <- subset
replot_env$update_frames <- update_frames
replot_env$set_frame <- set_frame
replot_env$get_frame <- get_frame
replot_env$next_frame <- next_frame
replot_env$add_frame <- add_frame
replot_env$remove_frame <- remove_frame
replot_env$set_asp <- set_asp
replot_env$get_asp <- get_asp
replot_env$set_xlim <- set_xlim
replot_env$get_xlim <- get_xlim
replot_env$reset_ylim <- reset_ylim
replot_env$set_ylim <- set_ylim
replot_env$get_ylim <- get_ylim
replot_env$set_pad <- set_pad
return(replot_env)
} # }}}
str.replot <- function(object, ...) {
print(str(unclass(object)))
}
# print/plot replot methods {{{
print.replot <- function(x, ...) plot(x,...)
plot.replot <- function(x, ...) {
plot.new()
#assign(".chob",x,.GlobalEnv)
assign(".chob",x,.plotEnv)
cex <- par(cex=x$Env$cex)
mar <- par(mar=x$Env$mar)
if(.Device=="X11") # only reasonable way to fix X11/quartz issue
par(cex=x$Env$cex * 1.5)
oxpd <- par(xpd=FALSE)
usr <- par("usr")
# plot negative (underlay) actions
last.frame <- x$get_frame()
x$update_frames()
lapply(x$Env$actions,
function(aob) {
if(attr(aob,"frame") < 0) {
x$set_frame(attr(aob,"frame"),attr(aob,"clip"))
env <- attr(aob,"env")
if(is.list(env)) {
# if env is c(env, Env), convert to list
env <- unlist(lapply(env, function(x) eapply(x, eval)),recursive=FALSE)
}
eval(aob, env)
}
}
)
# plot positive (overlay) actions
lapply(x$Env$actions,
function(aob) {
if(attr(aob,"frame") > 0) {
x$set_frame(attr(aob,"frame"),attr(aob,"clip"))
env <- attr(aob,"env")
if(is.list(env)) {
env <- unlist(lapply(env, function(x) eapply(x, eval)),recursive=FALSE)
}
eval(aob, env)
}
}
)
#for(frames in 1:length(x$get_ylim())) {
#x$set_frame(frames)
#abline(h=x$get_ylim()[[frames]][1], col=x$Env$theme$grid, lwd=1)
#}
x$set_frame(abs(last.frame),clip=FALSE)
do.call("clip",as.list(usr))
par(xpd=oxpd,cex=cex$cex,mar=mar$mar)#,usr=usr)
invisible(x$Env$actions)
} # }}}
# scale.ranges {{{
scale.ranges <- function(frame, asp, ranges)
{
asp/asp[frame] * abs(diff(ranges[[frame]]))
} # }}}
`+.replot` <- function(e1, e2) {
e2 <- match.call()$e2
e2$plot_object <- (substitute(e1))
eval(e2)
}
`+.replot` <- function(e1, e2) {
assign(".chob",e1,.plotEnv)
e2 <- eval(e2)
e2
}
##### accessor functions
re_Chart <- function() current.chob()
chart_asp <- function() current.chob()$get_asp()
chart_ylim <- function() current.chob()$get_ylim()
chart_xlim <- function() current.chob()$get_xlim()
actions <- function(obj) obj$Env$actions
chart_actions <- function() actions(current.chob())
quantmod/R/chart_Series.R 0000644 0001762 0000144 00000144466 15002467345 015066 0 ustar ligges users findOHLC <- function() {
chob <- current.chob()
loc <- round(locator(1)$x)
ohlc <- current.chob()$Env$xdata[current.chob()$Env$xsubset][loc]
actions <- chob$Env$actions
envs <- lapply(actions[which(!sapply(actions,attr,'frame')%%2)],attr,'env')
values <- lapply(lapply(envs[sapply(envs,is.list)],`[[`,1),
function(x) x$xdata[chob$Env$xsubset][loc])
do.call('cbind',c(list(ohlc),values))
}
getSubset <- function() {
chob <- current.chob()
from <- round(locator(1)$x)
to <- round(locator(1)$x)
ohlc <- current.chob()$Env$xdata[current.chob()$Env$xsubset][from:to]
actions <- chob$Env$actions
envs <- lapply(actions[which(!sapply(actions,attr,'frame')%%2)],attr,'env')
values <- lapply(lapply(envs[sapply(envs,is.list)],`[[`,1),
function(x) x$xdata[chob$Env$xsubset][from:to])
c(list(ohlc),values)
}
# axTicksByValue {{{
axTicksByValue <-
function(x,
match.to=c(1e8,1e7,1e6,1e5,1e4,1e3,
500,300,200,150,100,
50,20,10,
5,2,1,
0.50,0.25,0.20,0.10,
0.05,0.02,0.01),
lt=20,gt=3, secondary=FALSE) {
x <- na.omit(x)
diff_range <- diff(range(x))
if(diff_range > 1)
diff_range <- diff(range(x %/% 1))
by <- match.to[which(diff_range %/% match.to > gt & diff_range %/% match.to < lt)[1]]
if(is.na(by)) {
by <- 1L
}
ticks1 <- do.call('seq.int', as.list(c(range(x)[1]%/%by*by,range(x)[2]%/%by*by,by)))
# if(length(ticks1) > 5) ticks1 <- ticks1[-c(1,length(ticks1))]
ticks1
} # }}}
#axTicksByValue <- function(x, ...) pretty(x)
# UNUSED heikin.ashi.bars {{{
heikin.ashi.bars <-
function(x, type="", spacing=1, up.col="green",dn.col="red",up.border="grey",dn.border=up.border) {
if(is.OHLC(x)) {
haCloses <- as.xts(apply(OHLC(x),1,sum))/4
haOpens <- Op(x)
haOpens <- (lag(haOpens) + lag(haCloses))/2
haHighs <- as.numeric(as.xts(apply(cbind(Hi(x),haOpens,haCloses),1,max)))
haLows <- as.numeric(as.xts(apply(cbind(Lo(x),haOpens,haCloses),1,min)))
haOpens <- as.numeric(haOpens)
haCloses <- as.numeric(haCloses)
}
bar.col <- ifelse(haOpens < haCloses, up.col, dn.col)
bar.border <- ifelse(haOpens < haCloses, up.border, dn.border)
x.pos <- spacing*(1:NROW(x))
segments(x.pos, haLows, x.pos, apply(cbind(haOpens,haCloses),1,min),col=bar.border)
segments(x.pos, haHighs, x.pos, apply(cbind(haOpens,haCloses),1,max),col=bar.border)
if (type == "candlesticks") {
rect(x.pos - spacing/3, haOpens, x.pos + spacing/3,
haCloses, col = bar.col, border = bar.border)
} else segments(x.pos, haOpens, x.pos, haCloses, col='blue')
} # }}}
# rangeBars {{{
rangeBars <-
function(x, type="", spacing=1, line.col="darkorange",
up.col="green",dn.col="red",up.border="grey",dn.border=up.border) {
if(is.OHLC(x) && type != "line") {
Opens <- as.numeric(Op(x))
Highs <- as.numeric(Hi(x))
Lows <- as.numeric(Lo(x))
Closes <- as.numeric(Cl(x))
if(type=="heikin.ashi") {
Closes <- as.xts(apply(OHLC(x),1,sum))/4
Opens <- Op(x)
Opens <- (lag(Opens) + lag(Closes))/2
Highs <- as.numeric(as.xts(apply(cbind(Hi(x),Opens,Closes),1,max)))
Lows <- as.numeric(as.xts(apply(cbind(Lo(x),Opens,Closes),1,min)))
Opens <- as.numeric(Opens)
Closes <- as.numeric(Closes)
type <- "candlesticks"
}
} else {
line.col <- rep(line.col, length.out=NCOL(x))
for(i in 1:NCOL(x))
lines(1:NROW(x),x[,i],lwd=2,col=line.col[i],lend=3,lty=1)
return(NULL)
}
bar.col <- ifelse(Opens < Closes, up.col, dn.col)
bar.border <- ifelse(Opens < Closes, up.border, dn.border)
x.pos <- spacing*(1:NROW(x))
if( type %in% c("ohlc", "hlc")) {
bar.border <- bar.col
bar.border[is.na(bar.border)] <- up.border
}
segments(x.pos, Lows, x.pos, apply(cbind(Opens,Closes),1,min),col=bar.border,lwd=1.2,lend=3)
segments(x.pos, Highs, x.pos, apply(cbind(Opens,Closes),1,max),col=bar.border,lwd=1.2,lend=3)
if (type == "candlesticks") {
rect(x.pos - spacing/3, Opens, x.pos + spacing/3,
Closes, col = bar.col, border = bar.border, lwd=0.2)
} else
if (type == "matchsticks") {
bar.col[is.na(bar.col)] <- up.col
segments(x.pos, Opens, x.pos, Closes, col=bar.col,lwd=1.2,lend=3)
} else
if (type == "ohlc") {
segments(x.pos, Opens, x.pos, Closes, col=bar.border,lwd=1.2,lend=3)
segments(x.pos-1/3, Opens, x.pos, Opens, col=bar.border,lwd=1.2,lend=3)
segments(x.pos, Closes, x.pos+1/3, Closes, col=bar.border,lwd=1.2,lend=3)
} else
if (type == "hlc") {
segments(x.pos, Opens, x.pos, Closes, col=bar.border,lwd=1.2,lend=3)
segments(x.pos, Closes, x.pos+1/3, Closes, col=bar.border,lwd=1.2,lend=3)
}
} # }}}
# {{{ chart_theme
chart_theme <- chart_theme_white <- function() {
theme <-list(col=list(bg="#FFFFFF",
label.bg="#F0F0F0",
grid="#F0F0F0",
grid2="#F5F5F5",
ticks="#999999",
labels="#333333",
line.col="darkorange",
dn.col="red",
up.col=NA,
dn.border="#333333",
up.border="#333333"),
shading=1,
format.labels=TRUE,
coarse.time=TRUE,
rylab=TRUE,
lylab=TRUE,
grid.ticks.lwd=1,
grid.ticks.on="months")
theme$bbands <- list(col=list(fill="whitesmoke",upper="#D5D5D5",
lower="#D5D5D5",ma="#D5D5D5"),
lty=list(upper="dashed",lower="dashed",ma="dotted")
)
theme
} # }}}
# chart_pars {{{
chart_pars <- function() {
list(cex=0.6, mar=c(3,1,0,1))
} # }}}
# chart_Series {{{
# Updated: 2010-01-15
#
# chart_Series now uses a new graphical extension
# called 'replot'. This enables the accumulation
# of 'actions', in the form of (unevaluated) R
# expressions, to be stored within a replot object.
# This object is an R closure, which contains
# all the methods which are needed to perform
# graphical operations.
#
# Ideally all behavior is consistent with the
# original quantmod:::chartSeries, except the
# undesireable ones.
chart_Series <- function(x,
name=NULL,
type="candlesticks",
subset="",
TA="",
pars=chart_pars(), theme=chart_theme(),
clev=0,
...) {
cs <- new.replot()
#cex <- pars$cex
#mar <- pars$mar
line.col <- theme$col$line.col
up.col <- theme$col$up.col
dn.col <- theme$col$dn.col
up.border <- theme$col$up.border
dn.border <- theme$col$dn.border
format.labels <- theme$format.labels
if(is.null(theme$grid.ticks.on)) {
xs <- x[subset]
major.grid <- c(years=nyears(xs),
months=nmonths(xs),
days=ndays(xs))
grid.ticks.on <- names(major.grid)[rev(which(major.grid < 30))[1]]
} else grid.ticks.on <- theme$grid.ticks.on
label.bg <- theme$col$label.bg
cs$subset <- function(x) {
if(FALSE) {set_ylim <- get_ylim <- set_xlim <- Env<-function(){} } # appease R parser?
if(missing(x)) {
x <- "" #1:NROW(Env$xdata)
}
Env$xsubset <<- x
set_xlim(c(1,NROW(Env$xdata[Env$xsubset])))
ylim <- get_ylim()
for(y in seq(2,length(ylim),by=2)) {
if(!attr(ylim[[y]],'fixed'))
ylim[[y]] <- structure(c(Inf,-Inf),fixed=FALSE)
}
lapply(Env$actions,
function(x) {
frame <- abs(attr(x, "frame"))
fixed <- attr(ylim[[frame]],'fixed')
#fixed <- attr(x, "fixed")
if(frame %% 2 == 0 && !fixed) {
lenv <- attr(x,"env")
if(is.list(lenv)) lenv <- lenv[[1]]
min.tmp <- min(ylim[[frame]][1],range(na.omit(lenv$xdata[Env$xsubset]))[1],na.rm=TRUE)
max.tmp <- max(ylim[[frame]][2],range(na.omit(lenv$xdata[Env$xsubset]))[2],na.rm=TRUE)
ylim[[frame]] <<- structure(c(min.tmp,max.tmp),fixed=fixed)
}
})
# reset all ylim values, by looking for range(env[[1]]$xdata)
# xdata should be either coming from Env or if lenv, lenv
set_ylim(ylim)
}
environment(cs$subset) <- environment(cs$get_asp)
if(is.character(x))
stop("'x' must be a time-series object")
if(is.OHLC(x)) {
cs$Env$xdata <- OHLC(x)
if(has.Vo(x))
cs$Env$vo <- Vo(x)
} else cs$Env$xdata <- x
#subset <- match(.index(x[subset]), .index(x))
cs$Env$xsubset <- subset
cs$Env$cex <- pars$cex
cs$Env$mar <- pars$mar
cs$set_asp(3)
cs$set_xlim(c(1,NROW(cs$Env$xdata[subset])))
cs$set_ylim(list(structure(range(na.omit(cs$Env$xdata[subset])),fixed=FALSE)))
cs$set_frame(1,FALSE)
cs$Env$clev = min(clev+0.01,1) # (0,1]
cs$Env$theme$bbands <- theme$bbands
cs$Env$theme$shading <- theme$shading
cs$Env$theme$line.col <- theme$col$line.col
cs$Env$theme$up.col <- up.col
cs$Env$theme$dn.col <- dn.col
cs$Env$theme$up.border <- up.border
cs$Env$theme$dn.border <- dn.border
cs$Env$theme$rylab <- theme$rylab
cs$Env$theme$lylab <- theme$lylab
cs$Env$theme$bg <- theme$col$bg
cs$Env$theme$grid <- theme$col$grid
cs$Env$theme$grid2 <- theme$col$grid2
cs$Env$theme$labels <- "#333333"
cs$Env$theme$label.bg <- label.bg
cs$Env$format.labels <- format.labels
cs$Env$ticks.on <- grid.ticks.on
cs$Env$grid.ticks.lwd <- theme$grid.ticks.lwd
cs$Env$type <- type
# axis_ticks function to label lower frequency ranges/grid lines
cs$Env$axis_ticks <- function(xdata,xsubset) {
ticks <- diff(axTicksByTime2(xdata[xsubset],labels=FALSE))/2 +
last(axTicksByTime2(xdata[xsubset],labels=TRUE),-1)
if(!theme$coarse.time || length(ticks) == 1)
return(unname(ticks))
if(min(diff(ticks)) < max(strwidth(names(ticks)))) {
ticks <- unname(ticks)
}
ticks
}
# need to add if(upper.x.label) to allow for finer control
cs$add(expression(atbt <- axTicksByTime2(xdata[xsubset]),
segments(atbt, #axTicksByTime2(xdata[xsubset]),
get_ylim()[[2]][1],
atbt, #axTicksByTime2(xdata[xsubset]),
get_ylim()[[2]][2], col=theme$grid, lwd=grid.ticks.lwd),
axt <- axis_ticks(xdata,xsubset),
text(as.numeric(axt),
par('usr')[3]-0.2*min(strheight(axt)),
names(axt),xpd=TRUE,cex=0.9,pos=3)),
clip=FALSE,expr=TRUE)
cs$set_frame(-1)
# background of main window
#cs$add(expression(rect(par("usr")[1],
# par("usr")[3],
# par("usr")[2],
# par("usr")[4],border=NA,col=theme$bg)),expr=TRUE)
cs$add_frame(0,ylim=c(0,1),asp=0.2)
cs$set_frame(1)
# add observation level ticks on x-axis if < 400 obs.
cs$add(expression(if(NROW(xdata[xsubset])<400)
{axis(1,at=1:NROW(xdata[xsubset]),labels=FALSE,col=theme$grid2,tcl=0.3)}),expr=TRUE)
# add "month" or "month.abb"
cs$add(expression(axt <- axTicksByTime(xdata[xsubset],format.labels=format.labels),
axis(1,at=axt, #axTicksByTime(xdata[xsubset]),
labels=names(axt), #axTicksByTime(xdata[xsubset],format.labels=format.labels)),
las=1,lwd.ticks=1,mgp=c(3,1.5,0),tcl=-0.4,cex.axis=.9)),
expr=TRUE)
if(is.null(name)) {
name <- deparse(substitute(x))
}
cs$Env$name <- name
text.exp <- c(expression(text(1-1/3,0.5,name,font=2,col='#444444',offset=0,cex=1.1,pos=4)),
expression(text(NROW(xdata[xsubset]),0.5,
paste(start(xdata[xsubset]),end(xdata[xsubset]),sep=" / "),
col=1,adj=c(0,0),pos=2)))
cs$add(text.exp, env=cs$Env, expr=TRUE)
cs$set_frame(2)
cs$Env$axis_labels <- function(xdata,xsubset,scale=5) {
axTicksByValue(na.omit(xdata[xsubset]))
}
cs$Env$make_pretty_labels <- function(ylim) {
p <- pretty(ylim,10)
p[p > ylim[1] & p < ylim[2]]
}
#cs$add(assign("five",rnorm(10))) # this gets re-evaled each update, though only to test
#cs$add(expression(assign("alabels", axTicksByValue(na.omit(xdata[xsubset])))),expr=TRUE)
#cs$add(expression(assign("alabels", pretty(range(xdata[xsubset],na.rm=TRUE)))),expr=TRUE)
#cs$add(expression(assign("alabels", pretty(get_ylim(get_frame())[[2]],10))),expr=TRUE)
cs$add(expression(assign("alabels", make_pretty_labels(get_ylim(get_frame())[[2]]))),expr=TRUE)
# add $1 grid lines if appropriate
cs$set_frame(-2)
# add minor y-grid lines
cs$add(expression(if(diff(range(xdata[xsubset],na.rm=TRUE)) < 50)
segments(1,seq(min(xdata[xsubset]%/%1,na.rm=TRUE),
max(xdata[xsubset]%/%1,na.rm=TRUE),1),
length(xsubset),
seq(min(xdata[xsubset]%/%1,na.rm=TRUE),
max(xdata[xsubset]%/%1,na.rm=TRUE),1),
col=theme$grid2, lty="dotted")), expr=TRUE)
cs$set_frame(2)
# add main y-grid lines
cs$add(expression(segments(1,alabels,NROW(xdata[xsubset]),alabels, col=theme$grid)),expr=TRUE)
# left axis labels
if(theme$lylab) {
cs$add(expression(text(1-1/3-max(strwidth(alabels)),
alabels, #axis_labels(xdata,xsubset),
noquote(format(alabels,justify="right")),
col=theme$labels,offset=0,cex=0.9,pos=4,xpd=TRUE)),expr=TRUE)
}
# right axis labels
if(theme$rylab) {
cs$add(expression(text(NROW(xdata[xsubset])+1/3,
alabels,
noquote(format(alabels,justify="right")),
col=theme$labels,offset=0,cex=0.9,pos=4,xpd=TRUE)),expr=TRUE)
}
# add main series
cs$set_frame(2)
# need to rename rangeBars to something more generic, and allow type= to handle:
# ohlc, hlc, candles, ha-candles, line, area
# chart_Perf will be the call to handle relative performace plots
cs$add(expression(rangeBars(xdata[xsubset],
type, 1,
fade(theme$line.col,clev),
fade(theme$up.col,clev),
fade(theme$dn.col,clev),
fade(theme$up.border,clev),
fade(theme$dn.border,clev))),expr=TRUE)
assign(".chob", cs, .plotEnv)
# handle TA="add_Vo()" as we would interactively FIXME: allow TA=NULL to work
if(!is.null(TA)){
for(i in seq_along(TA)) {
# evaluate TA in environment from which chart_Series was called
if(nchar(TA[i]) > 0) {
ta <- parse(text=TA[i], srcfile=NULL)
cs <- eval(ta, envir = parent.frame())
}
}
}
assign(".chob", cs, .plotEnv)
cs
} #}}}
# zoom_Chart {{{
zoom_Chart <- function(subset) {
chob <- current.chob()
chob$subset(subset)
chob
}
# }}}
fade <- function(col, level) {
# adjust col toward white, (?background) by 0-1 range
cols <- character(length(col))
for(i in 1:length(col))
cols[i] <- colorRampPalette(c(col[i], "white"))(99)[level*100]
cols
}
current.chob <- function() invisible(get(".chob",.plotEnv))
use.chob <- function(use=TRUE) {
options('global.chob'=use)
}
new_ta <- function(FUN, preFUN, postFUN, on=NA, ...) {}
# add_Series {{{
add_Series <-
function(x,
type = "candlesticks",
order = NULL,
on = NA,
name = NULL,
theme = NULL,
...)
{
lenv <- new.env()
if(is.null(name) || isTRUE(name == "auto")) {
# Checking for `name == "auto"` handles the case where the user explicitly
# provided "auto" for the 5th argument. The 5th argument used to be
# `legend = "auto"`, but only "auto" was supported.
name <- deparse(substitute(x))
}
lenv$name <- name
lenv$plot_series <- function(x, series, type, ..., legend = NULL) {
# The 'legend = NULL` argument was added to remove `legend` from `...` to
# suppress this warning:
## Warning message:
## In plot.xy(xy.coords(x, y), type = type, ...) :
## "legend" is not a graphical parameter
# vertical grid lines
if(FALSE) theme <- NULL
segments(axTicksByTime2(xdata[xsubset]),
par("usr")[3], #min(-10,range(na.omit(macd))[1]),
axTicksByTime2(xdata[xsubset]),
par("usr")[4], #max(10,range(na.omit(macd))[2]), col=x$Env$theme$grid)
col=theme$grid)
#col=x$Env$theme$grid)
series <- merge(series, x$Env$xdata, join="outer",retside=c(TRUE,FALSE))[x$Env$xsubset]
rangeBars(series, type=type)
}
lenv$xdata <- x
# map all passed args (if any) to 'lenv' environment
mapply(function(name,value) { assign(name,value,envir=lenv) },
names(list(x=x,type=type,order=order,on=on,...)),
list(x=x,type=type,order=order,on=on,...))
exp <- parse(text=gsub("list","plot_series",
as.expression(substitute(list(x=current.chob(),type=type,series=get("x"), ...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$theme <- if(is.null(theme)) plot_object$Env$theme else theme
xdata <- plot_object$Env$xdata
xsubset <- plot_object$Env$xsubset
tav <- merge(x, xdata, join="left",retside=c(TRUE,FALSE))
lenv$upper.env <- plot_object$Env
lenv$xdata <- x
x <- x[xsubset]
if(is.na(on)) {
plot_object$add_frame(ylim=c(0,1),asp=0.15)
plot_object$next_frame()
text.exp <- expression(text(x=c(1),y=0.3, name, col=c(1),adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
plot_object$add_frame(ylim=range(na.omit(OHLC(x))),asp=1) # need to have a value set for ylim
plot_object$next_frame()
plot_object$add(expression(assign("alabels", axTicksByValue(na.omit(xdata[xsubset])))),expr=TRUE)
# add main y-grid lines
plot_object$add(expression(segments(1,alabels,NROW(xdata[xsubset]),alabels, col=theme$grid)),expr=TRUE)
# left axis labels
exp <- c(expression(text(1-1/3-max(strwidth(alabels)),
alabels, #axis_labels(xdata,xsubset),
noquote(format(alabels,justify="right")),
col=theme$labels,offset=0,cex=0.9,pos=4)),
expression(text(NROW(upper.env$xdata[xsubset])+1/3,
alabels,
noquote(format(alabels,justify="right")),
col=theme$labels,offset=0,cex=0.9,pos=4)),exp)
# lenv$grid_lines <- function(xdata,x) { seq(-1,1) }
# # add grid lines
# exp <- c(expression(abline(h=grid_lines(xdata,xsubset),col=theme$grid)),
# # add axis labels/boxes
# expression(text(0,grid_lines(xdata,xsubset),
# sprintf("%+d",grid_lines(xdata,xsubset)),
# col=theme$labels,pos=2)),
# expression(text(NROW(xdata[xsubset]),grid_lines(xdata,xsubset),
# sprintf("%+d",grid_lines(xdata,xsubset)),
# col=theme$labels,pos=4)),exp)
} else { plot_object$set_frame(sign(on)*(abs(on)+1L)) }
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} #}}}
# add_TA {{{
add_TA <-
function(x,
order = NULL,
on = NA,
name = NULL,
yaxis = list(NULL, NULL),
col = 1,
taType = NULL,
...)
{
lenv <- new.env()
if(is.null(name) || isTRUE(name == "auto")) {
# Checking for `name == "auto"` handles the case where the user explicitly
# provided "auto" for the 4th argument. The 4th argument used to be
# `legend = "auto"`, but only "auto" was supported.
name <- deparse(substitute(x))
}
lenv$name <- name
lenv$plot_ta <- function(x, ta, on, taType, col=col, ..., legend=NULL) {
# The 'legend = NULL` argument was added to remove `legend` from `...` to
# suppress this warning:
## Warning message:
## In plot.xy(xy.coords(x, y), type = type, ...) :
## "legend" is not a graphical parameter
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
if(all(is.na(on))) {
segments(axTicksByTime2(xdata[xsubset]),
par("usr")[3],
axTicksByTime2(xdata[xsubset]),
par("usr")[4],
col=x$Env$theme$grid)
}
if(is.logical(ta)) {
ta <- merge(ta, xdata, join="right",retside=c(TRUE,FALSE))[xsubset]
shade <- shading(as.logical(ta,drop=FALSE))
if(length(shade$start) > 0) # all FALSE cause zero-length results
rect(shade$start-1/3, par("usr")[3] ,shade$end+1/3, par("usr")[4], col=col,...)
} else {
# we can add points that are not necessarily at the points
# on the main series
subset.range <- paste(start(x$Env$xdata[x$Env$xsubset]),
end(x$Env$xdata[x$Env$xsubset]),sep="/")
ta.adj <- merge(n=.xts(1:NROW(x$Env$xdata[x$Env$xsubset]),
.index(x$Env$xdata[x$Env$xsubset]), tzone=tzone(x$Env$xdata)),ta)[subset.range]
ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) )
ta.y <- ta.adj[,-1]
for(i in 1:NCOL(ta.y))
lines(ta.x, as.numeric(ta.y[,i]), col=col,...)
}
}
lenv$xdata <- x
# map all passed args (if any) to 'lenv' environment
mapply(function(name,value) { assign(name,value,envir=lenv) },
names(list(x=x,order=order,on=on,
taType=taType,col=col,...)),
list(x=x,order=order,on=on,
taType=taType,col=col,...))
exp <- parse(text=gsub("list","plot_ta",
as.expression(substitute(list(x=current.chob(),
ta=get("x"),on=on,
taType=taType,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
xdata <- plot_object$Env$xdata
xsubset <- plot_object$Env$xsubset
if(is.logical(x)) no.update <- TRUE else no.update <- FALSE
# this merge isn't going to work if x isn't in xdata range. Something like:
# na.approx(merge(n=.xts(1:NROW(xdata),.index(xdata)),ta)[,1])
# should allow for any time not in the original to be merged in.
# probably need to subset xdata _before_ merging, else subset will be wrong
#
#tav <- merge(x, xdata, join="right",retside=c(TRUE,FALSE))
#lenv$xdata <- tav
#tav <- tav[xsubset]
lenv$col <- col
lenv$xdata <- merge(x,xdata,retside=c(TRUE,FALSE))
if(is.na(on)) {
plot_object$add_frame(ylim=c(0,1),asp=0.15)
plot_object$next_frame()
text.exp <- expression(text(x=c(1,1+strwidth(name)),
y=0.3,
labels=c(name,round(last(xdata[xsubset]),5)),
col=c(1,col),adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
plot_object$add_frame(ylim=range(na.omit(xdata)),asp=1) # need to have a value set for ylim
plot_object$next_frame()
# add grid lines, using custom function for MACD gridlines
lenv$grid_lines <- function(xdata,xsubset) {
pretty(xdata[xsubset])
}
exp <- c(expression(segments(1,grid_lines(xdata,xsubset),NROW(xdata[xsubset]),grid_lines(xdata,xsubset),
col=theme$grid)), exp, # NOTE 'exp' was defined earlier to be plot_macd
# add axis labels/boxes
expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)),
expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update)
} else {
for(i in 1:length(on)) {
plot_object$set_frame(2*on[i]) # this is defaulting to using headers, should it be optionable?
lenv$grid_lines <- function(xdata,xsubset) {
pretty(xdata[xsubset])
}
exp <- c(exp,
# LHS
#expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
# noquote(format(grid_lines(xdata,xsubset),justify="right")),
# col=theme$labels,offset=0,pos=4,cex=0.9)),
# RHS
expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)))
#}
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE,no.update=no.update)
}
}
plot_object
} #}}}
# add_SMA {{{
add_SMA <- function(n=10, on=1, col='brown',...) {
lenv <- new.env()
lenv$add_sma <- function(x, n, col,...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
ema <- SMA(Cl(xdata), n=n)[xsubset]
lines(1:NROW(xdata[xsubset]), ema, col=col,...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(n=n,...)), list(n=n,col=col,...))
exp <- parse(text=gsub("list","add_sma",as.expression(substitute(list(x=current.chob(),n=n,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- SMA(Cl(plot_object$Env$xdata),n=n)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_EMA {{{
add_EMA <- function(n=10, on=1, col='blue',...) {
lenv <- new.env()
lenv$add_ema <- function(x, n, col,...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
ema <- EMA(Cl(xdata), n=n)[xsubset]
lines(1:NROW(xdata[xsubset]), ema, col=col, ...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(n=n,...)), list(n=n,col=col,...))
exp <- parse(text=gsub("list","add_ema",as.expression(substitute(list(x=current.chob(),n=n,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- EMA(Cl(plot_object$Env$xdata),n=n)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_WMA {{{
add_WMA <- function(n=10, wts=1:n, on=1, col='green',...) {
lenv <- new.env()
lenv$add_wma <- function(x, n, wts, col, ...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
ema <- WMA(Cl(xdata), n=n, wts=wts)[xsubset]
lines(1:NROW(xdata[xsubset]), ema, col=col, ...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(n=n,wts=wts,col=col,...)), list(n=n,wts=wts,col=col,...))
exp <- parse(text=gsub("list","add_wma",as.expression(substitute(list(x=current.chob(),n=n,wts=wts,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- WMA(Cl(plot_object$Env$xdata),n=n,wts=wts)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_DEMA {{{
add_DEMA <- function(n=10, on=1, col='pink', ...) {
lenv <- new.env()
lenv$add_dema <- function(x, n, col, ...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
dema <- DEMA(Cl(xdata), n=n)[xsubset]
lines(1:NROW(xdata[xsubset]), dema, col=col, ...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(n=n,col=col,...)), list(n=n,col=col,...))
exp <- parse(text=gsub("list","add_dema",as.expression(substitute(list(x=current.chob(),n=n,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- DEMA(Cl(plot_object$Env$xdata),n=n)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_VWAP {{{
add_VWAP <- function(n=10, on=1, col='darkgrey', ...) {
lenv <- new.env()
lenv$add_vwap <- function(x, n, col, ...) {
xdata <- x$Env$xdata
xvo <- x$Env$vo
xsubset <- x$Env$xsubset
vwap <- VWAP(Cl(xdata),xvo, n=n)[xsubset]
lines(1:NROW(xdata[xsubset]), vwap, col=col, ...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(n=n,col=col,...)), list(n=n,col=col,...))
exp <- parse(text=gsub("list","add_vwap",as.expression(substitute(list(x=current.chob(),n=n,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- VWAP(Cl(plot_object$Env$xdata),plot_object$Env$vo,n=n)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_EVWMA {{{
add_EVWMA <- function(n=10, on=1, col='darkgrey', ...) {
lenv <- new.env()
lenv$add_evwma <- function(x, n, col, ...) {
xdata <- x$Env$xdata
xvo <- x$Env$vo
xsubset <- x$Env$xsubset
evwma <- EVWMA(Cl(xdata),xvo, n=n)[xsubset]
lines(1:NROW(xdata[xsubset]), evwma, col=col, ...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(n=n,col=col,...)), list(n=n,col=col,...))
exp <- parse(text=gsub("list","add_evwma",as.expression(substitute(list(x=current.chob(),n=n,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- EVWMA(Cl(plot_object$Env$xdata),plot_object$Env$vo,n=n)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_GMMA {{{
add_GMMA <- function(short=c(3,5,8,10,12,15),long=c(30,35,40,45,50,60), on=1, col=c('yellow','brown'),...) {
#x, short = c(3, 5, 8, 10, 12, 15), long = c(30, 35,
# 40, 45, 50, 60), maType
lenv <- new.env()
lenv$add_gmma <- function(x, short, long, col,...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
gmma <- GMMA(Cl(xdata), short, long, maType="EMA")[xsubset]
col <- colorRampPalette(col)(length(short)+length(long))
for(i in 1:(length(short)+length(long)))
lines(1:NROW(xdata[xsubset]), gmma[,i], col=col[i],...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(short=short,long=long,col=col,...)), list(short=short,long=long,col=col,...))
exp <- parse(text=gsub("list","add_gmma",as.expression(substitute(list(x=current.chob(),short=short,long=long,col=col,...)))),
srcfile=NULL)
plot_object <- current.chob()
lenv$xdata <- GMMA(Cl(plot_object$Env$xdata), short=short, long=long)
plot_object$set_frame(sign(on)*(abs(on)+1L))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_SMI {{{
add_SMI <- function (n=13, nFast=25, nSlow=2, nSig=9, maType="EMA", bounded=TRUE,...) {
lenv <- new.env()
lenv$plot_smi <- function(x, n, nFast, nSlow, nSig, maType, bounded, ...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
smi <- SMI(HLC(xdata),n=n,nFast=nFast,nSlow=nSlow,nSig=nSig,
maType=maType,bounded=bounded)
x.pos <- 1:NROW(xdata[xsubset])
segments(axTicksByTime2(xdata[xsubset]),
range(na.omit(smi))[1],
axTicksByTime2(xdata[xsubset]),
range(na.omit(smi))[2], col=x$Env$theme$grid)
lines(x.pos, smi[xsubset,1], col=x$Env$theme$smi$col$smi, lwd=2,...)
lines(x.pos, smi[xsubset,2], col=x$Env$theme$smi$col$signal, ...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) },
names(list(n=n,nFast=nFast,nSlow=nSlow,nSig=nSig,maType=maType,bounded=bounded,...)),
list(n=n,nFast=nFast,nSlow=nSlow,nSig=nSig,maType=maType,bounded=bounded,...))
exp <- parse(text=gsub("list","plot_smi",
as.expression(substitute(list(x=current.chob(),
n=n,nFast=nFast,
nSlow=nSlow,nSig=nSig,
maType=maType,bounded=bounded,...)))),
srcfile=NULL)
plot_object <- current.chob()
if(is.null(plot_object$Env$theme$smi)) {
plot_object$Env$theme$smi$col$smi <- "orange"
plot_object$Env$theme$smi$col$signal <- "darkgrey"
}
xsubset <- plot_object$Env$xsubset
smi <- SMI(HLC(plot_object$Env$xdata),n=n,nFast=nFast,nSlow=nSlow,nSig=nSig,
maType=maType,bounded=bounded)
plot_object$add_frame(ylim=c(0,1),asp=0.2)
plot_object$next_frame()
lenv$xdata <- structure(smi,.Dimnames=list(NULL, c("smi","signal")))
text.exp <- expression(text(c(1,
1+strwidth(paste("SMI(",paste(n,nFast,nSlow,nSig,sep=","),"):",sep="")),
1+strwidth(paste("SMI(",paste(n,nFast,nSlow,nSig,sep=","),"):",sep=""))+strwidth("-22.22222")),
0.3,
c(paste("SMI(",paste(n,nFast,nSlow,nSig,sep=","),"):",sep=""),
round(last(xdata[xsubset,1]),5),
round(last(xdata[xsubset,2]),5)),
col=c(1,theme$smi$col$smi,theme$smi$col$signal),adj=c(0,0),cex=0.9,offset=0,pos=4))
#plot_object$add(expression(rect(par("usr")[1],0,par("usr")[2],1,col=theme$grid,border=NA)),expr=TRUE)
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
plot_object$add_frame(ylim=range(na.omit(smi)),fixed=TRUE ,asp=1)
plot_object$next_frame()
# add grid lines
lenv$grid_lines <- function(xdata,x) { seq(-50,50,50) }
exp <- c(expression(abline(h=grid_lines(xdata,xsubset),col=theme$grid)), exp,
# add axis labels/boxes
expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)),
expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)))
# exp <- c(expression(abline(h=grid_lines(xdata,xsubset),col=theme$grid)),
# # add axis labels/boxes
# expression(text(0,grid_lines(xdata,xsubset),
# sprintf("%+d",grid_lines(xdata,xsubset)),
# col=theme$labels,offset=0,pos=2)),
# expression(text(length(xsubset),grid_lines(xdata,xsubset),
# sprintf("%+d",grid_lines(xdata,xsubset)),
# col=theme$labels,offset=0,pos=4)),exp)
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
# add_RSI {{{
add_RSI <- function (n=14, maType="EMA", wilder=TRUE, ..., RSIup=70, RSIdn=30) {
# added in wilder=TRUE to handle missingness behavior in original TTR::RSI call
lenv <- new.env()
lenv$plot_rsi <- function(x, n, maType, wilder, ...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
rsi <- RSI(Cl(xdata),n=n,maType=maType,wilder=wilder)[xsubset]
x.pos <- 1:NROW(rsi)
theme <- x$Env$theme$rsi
# vertical grid lines
segments(axTicksByTime2(xdata[xsubset]),
par("usr")[3], #min(-10,range(na.omit(macd))[1]),
axTicksByTime2(xdata[xsubset]),
par("usr")[4], #max(10,range(na.omit(macd))[2]), col=x$Env$theme$grid)
col=x$Env$theme$grid)
lines(x.pos, rep(RSIdn,length(x.pos)), col=theme$col$lines, lwd=1,lty=2,lend=2,...)
lines(x.pos, rep(RSIup,length(x.pos)), col=theme$col$lines, lwd=1,lty=2,lend=2,...)
lines(x.pos, rsi[,1], col=x$Env$theme$rsi$col$rsi, lwd=1.5,...)
}
mapply(function(name,value) { assign(name,value,envir=lenv) },
names(list(n=n,maType=maType,wilder=wilder,...)),
list(n=n,maType=maType,wilder=wilder,...))
exp <- parse(text=gsub("list","plot_rsi",
as.expression(substitute(list(x=current.chob(),
n=n,maType=maType,wilder=wilder,...)))),
srcfile=NULL)
plot_object <- current.chob()
if(is.null(plot_object$Env$theme$rsi)) {
plot_object$Env$theme$rsi$col$rsi <- "saddlebrown"
plot_object$Env$theme$rsi$col$lines <- "orange2"
}
xsubset <- plot_object$Env$xsubset
rsi <- RSI(Cl(plot_object$Env$xdata),n=n,maType=maType,wilder=wilder)
plot_object$add_frame(ylim=c(0,1),asp=0.2)
plot_object$next_frame()
lenv$xdata <- structure(rsi,.Dimnames=list(NULL, "rsi"))
text.exp <- expression(text(c(1,
1+strwidth(paste("RSI(",n,"):",sep=""))),
0.3,
c(paste("RSI(",n,"):",sep=""),
round(last(xdata[xsubset]),5)),
col=c(1,theme$rsi$col$rsi),adj=c(0,0),cex=0.9,offset=0,pos=4))
#plot_object$add(expression(rect(par("usr")[1],0,par("usr")[2],1,col=theme$grid,border="black")),expr=TRUE)
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
plot_object$add_frame(ylim=c(0,100),asp=1,fixed=TRUE)
plot_object$next_frame()
# add grid lines
lenv$grid_lines <- function(xdata,x) { c(RSIdn,RSIup) }
# add grid lines
exp <- c(expression(segments(1, grid_lines(xdata,xsubset),
NROW(xdata[xsubset]), grid_lines(xdata,xsubset), col=theme$grid)),exp,
# add axis labels/boxes
expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)),
expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)))
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
skeleton_TA <- function(on, arg, ...) {
# NON-FUNCTIONING
lenv <- new.env()
lenv$plot_ta <- function(x, arg, ...) {
# fill in body of low level plot calls here
# use a switch based on type of TA to draw: bands, bars, lines, dots...
}
mapply(function(name, value) {assign(name,value,envir=lenv)},
names(list(arg=arg,...)),
list(arg=arg,...))
exp <- parse(text=gsub("list","plot_ta",
as.expression(substitute(list(x=current.chob(),
arg=arg,
...)))), srcfile=NULL)
chob <- current.chob()
xsubset <- chob$Env$xsubset
preFUN <- ""
FUN <- ""
postFUN <- ""
chob$add_frame(ylin=c(0,1),asp=0.15)
chob$next_frame()
}
# add_MACD {{{
add_MACD <- function(fast=12,slow=26,signal=9,maType="EMA",histogram=TRUE,...) {
lenv <- new.env() # local environment for add_MACD call
# plot_macd draws the indicator using the data from the first(only) call to
# add_MACD. This is a bit analogous to chartMACD in the first quantmod versions
lenv$plot_macd <- function(x, fast, slow, signal, maType, histogram,...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
macd <- macd[xsubset]
# vertical grid lines
segments(axTicksByTime2(xdata[xsubset]),
par("usr")[3], #min(-10,range(na.omit(macd))[1]),
axTicksByTime2(xdata[xsubset]),
par("usr")[4], #max(10,range(na.omit(macd))[2]), col=x$Env$theme$grid)
col=x$Env$theme$grid)
# histogram
x.pos <- 1:NROW(macd)
if(histogram) {
macd.hist <- macd[,1] - macd[,2]
bar.col <- ifelse(macd.hist > 0, x$Env$theme$macd$up.col, x$Env$theme$macd$dn.col)
rect(x.pos-1/3, 0, x.pos+1/3, macd.hist, col=bar.col, border="grey", lwd=0.2, ...) # base graphics call
}
# macd line
lines(x.pos, macd[,1], col=x$Env$theme$macd$macd, lwd=2,,lty=1,...)
# signal line
lines(x.pos, macd[,2], col=x$Env$theme$macd$signal, lty=3,...)
}
# map all passed args (if any) to 'lenv' environment
mapply(function(name,value) { assign(name,value,envir=lenv) },
names(list(fast=fast,slow=slow,signal=signal,maType=maType,histogram=histogram,...)),
list(fast=fast,slow=slow,signal=signal,maType=maType,histogram=histogram,...))
# exp will be what is re-evaluated during redrawing (subset, new TA, etc)
# we need to build this piece by piece
exp <- parse(text=gsub("list","plot_macd",
as.expression(substitute(list(x=current.chob(),fast=fast,slow=slow,signal=signal,maType=maType,
histogram=histogram,...)))),
srcfile=NULL)
# plot_object is the current list of actions, and chart 'state'
plot_object <- current.chob()
# now we can evaluate plot_object, as the parse/substitute is behind us
# check if the theme has a macd component, if not set defaults here
if(is.null(plot_object$Env$theme$macd)) {
plot_object$Env$theme$macd$macd <- "#555555"
plot_object$Env$theme$macd$signal <- "black"
plot_object$Env$theme$macd$up.col <- "green"
plot_object$Env$theme$macd$dn.col <- "red"
}
# copy some Env data to local, make it cleaner to read
xdata <- plot_object$Env$xdata # original (OHLC) series
xsubset <- plot_object$Env$xsubset # current subset
# calculate our indicator here
macd <- MACD(Cl(xdata),fast,slow,signal,maType)
lenv$xdata <- structure(cbind(macd,macd[,1]-macd[,2]),.Dimnames=list(NULL,c("macd","signal","histogram")))
lenv$macd <- cbind(macd,macd[,1]-macd[,2])
# text annotation
plot_object$add_frame(ylim=c(0,1),asp=0.15) # add the header frame
plot_object$next_frame() # move to header frame
text.exp <- expression(text(x=c(1,
1+strwidth(paste("MACD(",paste(fast,slow,signal,sep=","),"):",sep="")),
1+strwidth(paste("MACD(",paste(fast,slow,signal,sep=","),"):",sep=""))+strwidth("5")*7),
y=0.3,
labels=c(paste("MACD(",paste(fast,slow,signal,sep=","),"):",sep=""),round(last(xdata[xsubset,1]),5),
round(last(xdata[xsubset,2]),5)),
col=c(1,theme$macd$macd,theme$macd$signal),adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
# main MACD plot from expression above
plot_object$add_frame(ylim=range(na.omit(lenv$macd[xsubset])),fixed=FALSE,asp=1)
plot_object$next_frame()
# add grid lines, using custom function for MACD gridlines
lenv$grid_lines <- function(xdata,xsubset) {
axTicksByValue(xdata[xsubset],c(5,4,3,2,1),gt=3)
}
exp <- c(expression(segments(1,grid_lines(xdata,xsubset),length(xsubset),grid_lines(xdata,xsubset),
col=theme$grid)), exp, # NOTE 'exp' was defined earlier to be plot_macd
# add axis labels/boxes
expression(text(1-1/3-max(strwidth(grid_lines(xdata,xsubset))),grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)),
expression(text(NROW(xdata[xsubset])+1/3,grid_lines(xdata,xsubset),
noquote(format(grid_lines(xdata,xsubset),justify="right")),
col=theme$labels,offset=0,pos=4,cex=0.9)))
# add 'exp' to actions list of plot_object
plot_object$add(exp,env=c(lenv, plot_object$Env),expr=TRUE)
# return plot_object to allow for auto-printing
plot_object
} # }}}
# add_BBands {{{
add_BBands <- function(n=20, maType="SMA", sd=2, on=-1, ...) {
lenv <- new.env()
lenv$plot_bbands <- function(x, n, maType, sd, on, ...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
col <- x$Env$theme$bbands$col
lty <- x$Env$theme$bbands$lty
bbands <- coredata(BBands(Cl(xdata),n=n, maType,sd)[xsubset])
if(on < 0) {
xx <- do.call("seq",as.list(x$get_xlim()))
polygon(c(xx,rev(xx)), c(bbands[,1],rev(bbands[,3])),col=col$fill,border=NA)
lines(1:NROW(xdata[xsubset]), bbands[,1], lty=lty$upper, col=col$upper,...)
lines(1:NROW(xdata[xsubset]), bbands[,3], lty=lty$lower, col=col$lower,...)
lines(1:NROW(xdata[xsubset]), bbands[,2], lty=lty$ma, col=col$ma,...)
} else {
lines(1:NROW(xdata[xsubset]), bbands[,1], lty=lty$upper, ...)
lines(1:NROW(xdata[xsubset]), bbands[,3], lty=lty$lower, ...)
lines(1:NROW(xdata[xsubset]), bbands[,2], lty=lty$ma, ...)
}
}
mapply(function(name,value) { assign(name,value,envir=lenv) },
names(list(n=n,maType=maType,sd=sd,on=on,...)), list(n=n,maType=maType,sd=sd,on=on,...))
exp <- parse(text=gsub("list","plot_bbands",as.expression(substitute(list(x=current.chob(),n=n,maType=maType,
sd=sd,on=on,...)))),srcfile=NULL)
# save data that is drawn on charts
chob <- current.chob()
xdata <- chob$Env$xdata
lenv$xdata <- BBands(Cl(xdata),n=n, maType,sd)[,-4] # pctB is bad for ylim calculation on subset
chob$set_frame(sign(on)*(abs(on)+1L)) # need to adjust for header offset
chob$add(exp,env=c(lenv, chob$Env),expr=TRUE)
chob
} # }}}
# add_ADX {{{
add_ADX <- function(n = 14, maType = "EMA", on = NA, ...) {
lenv <- new.env()
lenv$add_adx <- function(x, n, col, ...) {
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
adx <- ADX(HLC(xdata), n = n, ...)[xsubset]
x_axis <- seq_len(NROW(xdata[xsubset]))
lines(x_axis, adx$DIp, col = "green", ...)
lines(x_axis, adx$DIn, col = "red", ...)
lines(x_axis, adx$DX, col = "black", ...)
lines(x_axis, adx$ADX, col = "blue", lty = 2, ...)
}
mapply(function(name, value) {
assign(name, value, envir = lenv)
}, names(list(n = n, ...)), list(n = n, ...))
exp <- parse(text = gsub("list",
"add_adx",
as.expression(substitute(list(x = current.chob(),
n = n, ...)))),
srcfile = NULL)
plot_object <- current.chob()
adx <- ADX(HLC(plot_object$Env$xdata), n = n, ...)
lenv$xdata <- adx
# panel header
plot_object$add_frame(ylim = c(0, 1), asp = 0.2)
plot_object$next_frame()
header_expr <- expression({
header <- paste0("ADX(", n, "): ")
header_width <- strwidth(header)
pad <- strwidth("5")
last_values <- round(last(xdata[xsubset]), 2)
text(x = c(1,
1 + header_width,
1 + header_width + pad * 6,
1 + header_width + pad * 12,
1 + header_width + pad * 19),
y = 0.3,
labels = c(header,
last_values[, 1],
last_values[, 2],
last_values[, 3],
last_values[, 4]),
col = c("black", "green", "red", "black", "blue"),
adj = c(0, 0),
cex = 0.9,
offset = 0,
pos = 4)
})
plot_object$add(header_expr, env = c(lenv, plot_object$Env), expr = TRUE)
# y-axis grid lines and labels
lenv$grid_lines <- function(xdata, xsubset) {
axTicksByValue(xdata[xsubset], 10, gt = 3)
}
y_axis_expr <- expression({
segments(1,
grid_lines(xdata, xsubset),
NROW(xdata[xsubset]),
grid_lines(xdata, xsubset),
col = theme$grid)
})
y_label_expr <- expression({
text(1 - 1/3 - max(strwidth(grid_lines(xdata, xsubset))),
grid_lines(xdata, xsubset),
noquote(format(grid_lines(xdata, xsubset), justify = "right")),
col = theme$labels,
offset = 0,
pos = 4,
cex = 0.9)
text(NROW(xdata[xsubset]) + 1/3,
grid_lines(xdata, xsubset),
noquote(format(grid_lines(xdata, xsubset), justify = "right")),
col = theme$labels,
offset = 0,
pos = 4,
cex = 0.9)
})
# data
adx_ylim <- c(0, 1.02 * max(adx[plot_object$Env$xsubset], na.rm = TRUE))
plot_object$add_frame(ylim = adx_ylim, asp = 1, fixed = TRUE)
plot_object$next_frame()
exp <- c(y_axis_expr, exp, y_label_expr)
plot_object$add(exp, env = c(lenv, plot_object$Env), expr = TRUE)
plot_object
} # }}}
# add_Vo {{{
add_Vo <- function(...) {
lenv <- new.env()
lenv$plot_vo <- function(x, ...) {
# this is local to this function, but can be anywhere visible
xdata <- x$Env$xdata # internal main series
xsubset <- x$Env$xsubset # subset of series to plot
vo <- x$Env$vo[xsubset] # get and set ylim
if(is.OHLC(xdata[xsubset])) {
Opens <- as.numeric(Op(xdata[xsubset]))
Highs <- as.numeric(Hi(xdata[xsubset]))
Lows <- as.numeric(Lo(xdata[xsubset]))
Closes <- as.numeric(Cl(xdata[xsubset]))
}
bar.col <- ifelse(Opens < Closes, x$Env$theme$up.col, x$Env$theme$dn.col)
bar.border <- ifelse(Opens < Closes, x$Env$theme$up.border, x$Env$theme$dn.border)
#cur_ylim <- x$get_ylim()
#cur_ylim[[x$get_frame()]] <- range(vo)
#x$set_ylim(cur_ylim)
x.pos <- 1:NROW(vo)
min.vol <- min(vo)
segments(axTicksByTime(xdata[xsubset],ticks.on=x$Env$ticks.on),
range(na.omit(vo))[1],
axTicksByTime(xdata[xsubset],ticks.on=x$Env$ticks.on),
range(na.omit(vo))[2], col=x$Env$theme$grid)
rect(x.pos-1/3, min.vol, x.pos+1/3, vo, col=bar.col, border=bar.border,...) # base graphics call
}
# map all passed args (if any) to 'lenv' environment
mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(...)), list(...))
exp <- parse(text=gsub("list","plot_vo",as.expression(substitute(list(x=current.chob(),...)))),
srcfile=NULL)
plot_object <- current.chob()
xdata <- plot_object$Env$vo
xsubset <- plot_object$Env$xsubset
theme <- plot_object$theme
vo <- xdata[xsubset]
lenv$xdata <- xdata # xdata in lenv is
plot_object$add_frame(ylim=c(0,1),asp=0.15)
plot_object$next_frame()
text.exp <- expression(text(c(0,
0+strwidth(paste("Volume:",sep=""))),
0.5,
c(paste("Volume:",sep=""),prettyNum(last(xdata[xsubset]),big.mark=",")),
col=ifelse(diff(last(xdata[xsubset],2)) >0, theme$up.col, theme$dn.col),adj=c(0,0),cex=0.9,offset=0,pos=4))
plot_object$add(rect(par("usr")[1],0,par("usr")[2],1,col=theme$grid,border=NA))
plot_object$add(text.exp, env=c(lenv,plot_object$Env), expr=TRUE)
lenv$grid_lines <- function(xdata,x) { seq(0,1) }
# add grid lines
exp <- c(expression(abline(h=grid_lines(xdata,xsubset),col=theme$grid)),
# add axis labels/boxes
expression(text(0,grid_lines(xdata,xsubset),
sprintf("%+d",grid_lines(xdata,xsubset)),
col=theme$labels,offset=0,pos=2)),
expression(text(length(xsubset),grid_lines(xdata,xsubset),
sprintf("%+d",grid_lines(xdata,xsubset)),
col=theme$labels,offset=0,pos=4)),exp)
plot_object$add_frame(ylim=range(vo),asp=1) # need to have a value set for ylim
plot_object$next_frame()
plot_object$replot(exp,env=c(lenv, plot_object$Env),expr=TRUE)
plot_object
} # }}}
update_charting_warning <- function() {
if(is.null(getOption("chartSeries_warning"))) {
warning("chartSeries functionality is being deprecated for chart_Series")
options(chartSeries_warning=TRUE)
}
}
quantmod/R/modelData.R 0000644 0001762 0000144 00000001370 14657447467 014351 0 ustar ligges users "modelData" <- function(x,data.window=NULL,exclude.training=FALSE)
{
model.data <- x@model.data;
if(!is.null(data.window))
{
if(length(data.window) > 2) {
model.data <- model.data[index(model.data) %in% data.window];
} else {
start.date.index <- index(model.data[which(index(model.data) >= as.Date(data.window[1],origin='1970-01-01'))])
end.date.index <- index(model.data[which(index(model.data) <= as.Date(data.window[2],origin='1970-01-01'))])
date.range <- as.Date(intersect(start.date.index,end.date.index),origin='1970-01-01')
model.data <- model.data[date.range]
}
}
if(exclude.training == TRUE)
{
model.data <- model.data[!index(model.data) %in% x@training.data];
}
return(model.data);
}
quantmod/R/Price.transformations.R 0000644 0001762 0000144 00000022544 15002467345 016735 0 ustar ligges users ###############################################################################
# Utility functions for handling price data
###############################################################################
# get price column(s) from a timeseries
#
# Will attempt to locate price column(s) from a time series with rational defaults.
#
# May be subset by symbol and preference.
# \code{prefer} Preference will be for any commonly used financial time series price description,
# e.g. 'trade', 'close', 'bid', 'ask' with specific tests and matching for types and column names
# currently supported in R, but a default grep match will be performed if one of the supported types doesn't match.
#
# @param x A data object with columns containing data to be extracted
# @param symbol text string containing the symbol to extract
# @param prefer preference for any particular type of price, see Details
# @param \dots any other passthrough parameters
# @export
getPrice <- function (x, symbol=NULL, prefer=NULL,...)
{
# first subset on symbol, if present
if(!is.null(symbol)){
loc<-grep(symbol, colnames(x))
if (!identical(loc, integer(0))) {
x<-x[,loc]
} else {
stop(paste("subscript out of bounds: no column name containing",symbol))
}
}
if(is.null(prefer)){
# default to trying Price, then Trade, then Close
if(has.Price(x)) prefer='price'
else if(has.Trade(x)) prefer='trade'
else if(has.Cl(x)) prefer='close'
else stop("subscript out of bounds, no price was discernible from the data")
}
if(!is.null(prefer)){
loc <- NULL
switch(prefer,
Op =, open =, Open = { loc <- has.Op(x,which=TRUE) },
Hi =, high =, High = { loc <- has.Hi(x,which=TRUE) },
Lo =, low =, Low = { loc <- has.Lo(x,which=TRUE) },
Cl =, close =, Close = { loc <- has.Cl(x,which=TRUE) },
Bid =, bid = { loc <- has.Bid(x,which=TRUE) },
Ask =, ask =, Offer =, offer = { loc <- has.Ask(x,which=TRUE) },
Mid =, mid =, Midpoint =, midpoint = { loc <- has.Mid(x,which=TRUE) },
Trade =, trade = { loc <- has.Trade(x,which=TRUE) },
Price =, price = { loc <- has.Price(x,which=TRUE) },
{loc <- grep(prefer,colnames(x))}
)
if (!identical(loc, integer(0))) return(x[, loc])
else stop("subscript out of bounds, no price was discernible from the data")
}
}
# @export
is.BBO <- function (x)
{
if (all(has.Bid(x), has.Ask(x))) {
TRUE
}
else FALSE
}
# @export
is.TBBO <- function (x)
{
if (all(has.Trade(x),has.Qty(x),has.Bid(x), has.Ask(x))) {
TRUE
}
else FALSE
}
# @export
is.BAM <- function(x) {
if (all(has.Bid(x), has.Ask(x), has.Mid(x))) {
TRUE
}
else FALSE
}
# @export
is.BATM <- function(x) {
if (all(has.Bid(x), has.Ask(x), has.Trade(x), has.Mid(x))) {
TRUE
}
else FALSE
}
# @export
has.Bid <- function(x, which = FALSE)
{
colAttr <- attr(x, "Bid")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
#first try with "price" for data that has both bid.size and bid.price
loc <- grep("bid.*price", colnames(x), ignore.case=TRUE)
if (identical(loc, integer(0))) #If no column named bid.price
loc <- grep("bid", colnames(x), ignore.case=TRUE) #look for bid
if (!identical(loc, integer(0))) {
return(if(which) loc else TRUE)
} else FALSE
}
# @export
has.BidSize <- function(x, which = FALSE)
{
colAttr <- attr(x, "BidSize")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
loc <- grep("bid.*(size|qty|quantity)", colnames(x), ignore.case=TRUE)
if (!identical(loc, integer(0))) {
return(if(which) loc else TRUE)
} else FALSE
}
# @export
has.Ask <- function(x, which = FALSE)
{
colAttr <- attr(x, "Ask") #case sensitive; doesn't work for SYMBOL.Ask :-(
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
#first try with "price" for data that has both ask.size and ask.price
loc <- grep("(ask|offer).*price", colnames(x), ignore.case=TRUE)
if (identical(loc, integer(0))) #if that failed, try to find just "ask|offer"
loc <- grep("(ask|offer|ofr)", colnames(x), ignore.case=TRUE)
if (!identical(loc, integer(0))) {
return(if(which) loc else TRUE)
} else FALSE
}
# @export
has.AskSize <- function(x, which = FALSE)
{
colAttr <- attr(x, "AskSize")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
loc <- grep("(ask|offer).*(size|qty|quantity)", colnames(x), ignore.case=TRUE)
if (!identical(loc, integer(0))) {
return(if(which) loc else TRUE)
} else FALSE
}
# @export
has.Price <- function(x, which = FALSE)
{
colAttr <- attr(x, "Price")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
locBidAsk <- c(has.Bid(x, which=TRUE),has.Ask(x, which=TRUE))
loc <- grep("price", colnames(x), ignore.case=TRUE)
loc <- loc[!(loc %in% locBidAsk)]
if (!identical(loc, integer(0))) {
return(if(which) loc else TRUE)
} else FALSE
}
# @export
has.Trade <- function(x, which = FALSE)
{
colAttr <- attr(x, "Trade")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
loc <- grep("trade", colnames(x), ignore.case=TRUE)
if (!identical(loc, integer(0))) {
return(if(which) loc else TRUE)
} else FALSE
}
has.Mid <- function(x, which=FALSE) {
colAttr <- attr(x, "Mid")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
loc <- grep("Mid", colnames(x), ignore.case = TRUE)
if (!identical(loc, integer(0)))
return(ifelse(which, loc, TRUE))
ifelse(which, loc, FALSE)
}
has.Chg <- function(x, which=FALSE) {
colAttr <- attr(x, "Chg")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
loc <- grep("(chg|change)", colnames(x), ignore.case=TRUE)
if (!identical(loc, integer(0)))
return(ifelse(which, loc, TRUE))
ifelse(which, loc, FALSE)
}
#has.Un <- function(x, which=FALSE) {
# loc <- grep("Unadj", colnames(x), ignore.case = TRUE)
# if (!identical(loc, integer(0)))
# return(ifelse(which, loc, TRUE))
# ifelse(which, loc, FALSE)
#}
# check for Trade, Bid, and Ask/Offer (BBO/TBBO), Quantity, and Price data
#
# A set of functions to check for appropriate TBBO/BBO and price column
# names within a data object, as well as the availability and
# position of those columns.
# @param x data object
# @param which disply position of match
# @aliases
# has.Trade
# has.Ask
# has.AskSize
# has.Bid
# has.BidSize
# has.Price
# is.BBO
# is.TBBO
# @export
has.Qty <- function(x, which = FALSE)
{
colAttr <- attr(x, "Qty")
if(!is.null(colAttr))
return(if(which) colAttr else TRUE)
locBidAsk <- c(has.Bid(x, which=TRUE),has.Ask(x, which=TRUE))
loc <- grep("qty", colnames(x), ignore.case=TRUE)
loc <- loc[!(loc %in% locBidAsk)]
if (!identical(loc, integer(0))) {
return(if(which) loc else TRUE)
} else FALSE
}
# Column setting functions
set.AllColumns <- function(x) {
cols <- c("Op","Hi","Lo","Cl","Vo","Ad","Price","Trade","Qty",
"Bid","BidSize","Ask","AskSize","Mid","Chg")
for(col in cols) {
try(x <- do.call(paste("set",col,sep="."), list(x)), silent=TRUE )
}
return(x)
}
set.Chg <- function(x, error=TRUE) {
if(has.Chg(x))
attr(x,"Chg") <- has.Chg(x, which=TRUE)
return(x)
}
set.Mid <- function(x, error=TRUE) {
if(has.Mid(x))
attr(x,"Mid") <- has.Mid(x, which=TRUE)
return(x)
}
set.Ad <- function(x, error=TRUE) {
if(has.Ad(x))
attr(x,"Ad") <- has.Ad(x, which=TRUE)
return(x)
}
set.Bid <- function(x, error=TRUE) {
if(has.Bid(x))
attr(x,"Bid") <- has.Bid(x, which=TRUE)
return(x)
}
set.BidSize <- function(x, error=TRUE) {
if(has.BidSize(x))
attr(x,"BidSize") <- has.BidSize(x, which=TRUE)
return(x)
}
set.Hi <- function(x, error=TRUE) {
if(has.Hi(x))
attr(x,"Hi") <- has.Hi(x, which=TRUE)
return(x)
}
set.Lo <- function(x, error=TRUE) {
if(has.Lo(x))
attr(x,"Lo") <- has.Lo(x, which=TRUE)
return(x)
}
set.Op <- function(x, error=TRUE) {
if(has.Op(x))
attr(x,"Op") <- has.Op(x, which=TRUE)
return(x)
}
set.Qty <- function(x, error=TRUE) {
if(has.Qty(x))
attr(x,"Qty") <- has.Qty(x, which=TRUE)
return(x)
}
set.Vo <- function(x, error=TRUE) {
if(has.Vo(x))
attr(x,"Vo") <- has.Vo(x, which=TRUE)
return(x)
}
set.Ask <- function(x, error=TRUE) {
if(has.Ask(x))
attr(x,"Ask") <- has.Ask(x, which=TRUE)
return(x)
}
set.AskSize <- function(x, error=TRUE) {
if(has.AskSize(x))
attr(x,"AskSize") <- has.AskSize(x, which=TRUE)
return(x)
}
set.Cl <- function(x, error=TRUE) {
if(has.Cl(x))
attr(x,"Cl") <- has.Cl(x, which=TRUE)
return(x)
}
set.Price <- function(x, error=TRUE) {
if(has.Price(x))
attr(x,"Price") <- has.Price(x, which=TRUE)
return(x)
}
set.Trade <- function(x, error=TRUE) {
if(has.Trade(x))
attr(x,"Trade") <- has.Trade(x, which=TRUE)
return(x)
}
###############################################################################
# R (http://r-project.org/) quantmod
#
# Copyright (c) 2009-2010
# Peter Carl, Dirk Eddelbuettel, Brian G. Peterson, Jeffrey Ryan, and Joshua Ulrich
#
# This library is distributed under the terms of the GNU Public License (GPL)
# for full details see the file COPYING
#
# $Id: orders.R 240 2010-02-09 17:17:18Z braverock $
#
###############################################################################
quantmod/R/axTicksByTime2.R 0000644 0001762 0000144 00000004107 14654457715 015254 0 ustar ligges users axTicksByTime2 <-
function (x, ticks.on = "auto", k = 1, labels = TRUE, format.labels = TRUE,
ends = TRUE, gt = 2, lt = 25)
{
if (timeBased(x))
x <- xts(rep(1, length(x)), x)
#tick.opts <- c("years", "months", "days", "hours",
# "minutes", "seconds")
tick.opts <- c("years", "months", "weeks", "days")
tick.k.opts <- c(1,1,1,1)
if (ticks.on %in% tick.opts) {
cl <- ticks.on[1]
ck <- k
}
else {
tick.opts <- paste(tick.opts, tick.k.opts)
is <- structure(rep(0, length(tick.opts)), .Names = tick.opts)
for (i in 1:length(tick.opts)) {
y <- strsplit(tick.opts[i], " ")[[1]]
ep <- endpoints(x, y[1], as.numeric(y[2]))
if(i>1 && is[i-1] == length(ep)-1)
break
is[i] <- length(ep) - 1
if (is[i] > lt)
break
}
nms <- rev(names(is)[which(is > gt & is < lt)])[1]
cl <- strsplit(nms, " ")[[1]][1]
ck <- as.numeric(strsplit(nms, " ")[[1]][2])
}
if (is.na(cl) || is.na(ck) || is.null(cl)) {
return(c(1,NROW(x)))
#ep <- NULL
}
else ep <- endpoints(x, cl, ck)
if (ends)
ep <- ep + c(rep(1, length(ep) - 1), 0)
if (labels) {
if (is.logical(format.labels) || is.character(format.labels)) {
unix <- ifelse(.Platform$OS.type == "unix", TRUE,
FALSE)
#time.scale <- periodicity(x)$scale
#fmt <- ifelse(unix, "%n%b%n%Y", "%b %Y")
fmt <- switch(cl,
"years"="%Y",
"months"="%b",
"days"="%d",
"weeks"="W%W",
"hours"="%H:%M",
"minutes"="%H:%M:%S",
"seconds"="%H:%M:%S")
if(ndays(x) > 1 && cl %in% c("hours","minutes","seconds")) {
fmt <- paste("%b-%d",fmt)
}
names(ep) <- format(index(x)[ep], fmt)
}
else names(ep) <- as.character(index(x)[ep])
}
ep
}
quantmod/R/buildModel.methods.R 0000644 0001762 0000144 00000015356 14654457715 016204 0 ustar ligges users `buildModel.glm` <-
function(quantmod,training.data=training.data,...)
{
gl <- glm(formula=quantmod@model.formula,data=training.data,...);
return(list("fitted"=gl,
"inputs"=attr(terms(gl),"term.labels")));
}
`buildModel.lm` <-
function(quantmod,training.data,...)
{
l <- lm(formula=quantmod@model.formula,data=training.data,...);
return(list("fitted"=l,
"inputs"=attr(terms(l),"term.labels")));
}
`buildModel.step` <-
function(quantmod,training.data,...)
{
s <- step(lm(formula=quantmod@model.formula,data=training.data,...),...);
return(list("fitted"=s,
"inputs"=NULL));
}
`buildModel.loess` <-
function(quantmod,training.data,...)
{
l <- loess(quantmod@model.formula,data=training.data,...);
return(list("fitted"=l,
"inputs"=attr(terms(l),"term.labels")));
}
####### quantile regression method 'rq' - requires package quantreg
`buildModel.rq` <-
function(quantmod,training.data,...)
{
if(is.method.available('rq','quantreg')) {
#r <- rq(quantmod@model.formula,data=training.data,...)
r <- do.call('rq',list(quantmod@model.formula,data=training.data,...))
return(list("fitted"=r,
"inputs"=attr(terms(r),"term.labels")))
}
}
####### resistant regression method 'lqs' - requires package MASS
`buildModel.lqs` <-
function(quantmod,training.data,...)
{
if(is.method.available('lqs','MASS')) {
#lq <- lqs(quantmod@model.formula,data=training.data,...)
lq <- do.call('lqs',list(quantmod@model.formula,data=training.data,...))
return(list("fitted"=lq,
"inputs"=attr(terms(lq),"term.labels")))
}
}
####### robust regression method 'rlm' - requires package MASS
`buildModel.rlm` <-
function(quantmod,training.data,...)
{
if(is.method.available('lqs','MASS')) {
#rl <- rlm(quantmod@model.formula,data=training.data,...)
rl <- do.call('rlm',list(quantmod@model.formula,data=training.data,...))
return(list("fitted"=rl,
"inputs"=attr(terms(rl),"term.labels")))
}
}
####### neural net method - requires package nnet
`buildModel.nnet` <-
function(quantmod,training.data,...)
{
if(is.method.available('nnet','nnet')) {
#nn <- nnet(quantmod@model.formula,data=training.data,...)
nn <- do.call('nnet',list(quantmod@model.formula,data=training.data,...))
return(list("fitted"=nn,
"inputs"=attr(terms(nn),"term.labels")))
}
}
`predictModel.nnet` <-
function(object,data,...)
{
if(is.method.available('nnet','nnet')) {
predict(object,data,...)
}
}
####### projection pursuit regression method - requires stats
`buildModel.ppr` <-
function(quantmod,training.data,...)
{
#p <- ppr(quantmod@model.formula,data=training.data,...)
p <- do.call('ppr',list(quantmod@model.formula,data=training.data,...))
return(list("fitted"=p,
"inputs"=attr(terms(p),"term.labels")))
}
####### mars method - requires package mda
`buildModel.mars` <-
function(quantmod,training.data,...)
{
if(is.method.available('mars','mda')) {
x <- training.data[,-1]
y <- training.data[,1]
#m <- mars(x=x,y=y,...)
m <- do.call('mars',list(x=x,y=y,...))
return(list("fitted"=m,
"inputs"=colnames(x)))
}
}
`predictModel.mars` <-
function(object,data,...)
{
if(is.method.available('mars','mda')) {
predict(object,data[,-1])
}
}
####### polymars method - requires package polspline
`buildModel.polymars` <-
function(quantmod,training.data,...)
{
if(is.method.available('polymars','polspline')) {
responses <- training.data[,1]
predictors <- training.data[,-1]
#m <- polymars(responses,predictors,...)
m <- do.call('polymars',list(responses,predictors,...))
return(list("fitted"=m,
"inputs"=colnames(predictors)))
}
}
`predictModel.polymars` <-
function(object,data,...)
{
if(is.method.available('polymars','polspline')) {
predict(object,data[,-1]);
}
}
####### lars method - requires package lars
`buildModel.lars` <-
function(quantmod,training.data,...)
{
if(is.method.available('lars','lars')) {
x <- training.data[,-1]
y <- training.data[,1]
#m <- lars(x=x,y=y,...)
m <- do.call('lars',list(x=x,y=y,...))
return(list("fitted"=m,
"inputs"=colnames(x)))
}
}
`predictModel.lars` <-
function(object,data,lars.s,...)
{
if(is.method.available('lars','lars')) {
lars.s = min(lars.s,object$Cp)
predict(object,data[,-1],s=lars.s,...)$fit
}
}
####### rpart method - requires package rpart
`buildModel.rpart` <-
function(quantmod,training.data,...)
{
if(is.method.available('rpart','rpart')) {
#rp <- rpart(quantmod@model.formula,data=training.data,...);
rp <- do.call('rpart',list(quantmod@model.formula,data=training.data,...))
return(list("fitted"=rp,
"inputs"=attr(terms(rp),"term.labels")));
}
}
`predictModel.rpart` <-
function(object,data,...)
{
if(is.method.available('rpart','rpart')) {
predict(object,data,...)
}
}
####### tree method - requires package tree
`buildModel.tree` <-
function(quantmod,training.data,...)
{
if(is.method.available('tree','tree')) {
#rp <- tree(quantmod@model.formula,data=training.data,...);
rp <- do.call('tree',list(quantmod@model.formula,data=training.data,...))
return(list("fitted"=rp,
"inputs"=attr(terms(rp),"term.labels")));
}
}
`predictModel.tree` <-
function(object,data,...)
{
if(is.method.available('tree','tree')) {
predict(object,data,...)
}
}
####### randomForest method - requires package randomForest
`buildModel.randomForest` <-
function(quantmod,training.data,...)
{
if(is.method.available('randomForest','randomForest')) {
#rp <- randomForest(quantmod@model.formula,data=training.data,...)
rp <- do.call('randomForest',list(quantmod@model.formula,data=training.data,...))
return(list("fitted"=rp,
"inputs"=attr(terms(rp),"term.labels")))
}
}
`predictModel.randomForest` <-
function(object,data,...)
{
if(is.method.available('randomForest','randomForest')) {
predict(object,data,...)
}
}
`buildModel.svm` <-
function(quantmod,training.data,...)
{
if(is.method.available('svm','e1071')) {
#rp <- svm(formula(quantmod),data=training.data,...)
rp <- do.call('svm',list(formula(quantmod),data=training.data,...))
return(list('fitted'=rp,attr(terms(rp),'term.labels')))
}
}
`predictModel.svm` <-
function(object,data,...)
{
if(is.method.available('svm','e1071')) {
predict(object,data[-NROW(data),],...)
}
}
`is.method.available` <-
function(method,package)
{
if(!package %in% .packages()) {
if(package %in% .packages(all.available=TRUE)) {
cat(paste("loading required package:",package,"\n"))
library(package,character.only=TRUE)
} else {
stop(paste('package',sQuote(package),'containing',
sQuote(method),'unable to be located'))
}
}
return(TRUE)
}
quantmod/R/addTDI.R 0000644 0001762 0000144 00000003053 14654457715 013542 0 ustar ligges users # Trend Direction Index from TTR by Josh Ulrich
#
# chartSeries interface by Jeffrey A. Ryan 2008
#
# addTDI
`addTDI` <-
function (n = 20, multiple = 2, ..., on = NA, legend = "auto")
{
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
x <- Cl(x)
x <- TDI(price = x, n = n, multiple = multiple)
yrange <- NULL
chobTA <- new("chobTA")
if (NCOL(x) == 1) {
chobTA@TA.values <- x[lchob@xsubset]
}
else chobTA@TA.values <- x[lchob@xsubset, ]
chobTA@name <- "chartTA"
if (any(is.na(on))) {
chobTA@new <- TRUE
}
else {
chobTA@new <- FALSE
chobTA@on <- on
}
chobTA@call <- match.call()
legend.name <- gsub("^addTDI", "Trend Detection Index ", deparse(match.call()))
gpars <- c(list(...), list(col = 5:6))[unique(names(c(list(col = 5:6),
list(...))))]
chobTA@params <- list(xrange = lchob@xrange, yrange = yrange,
colors = lchob@colors, color.vol = lchob@color.vol, multi.col = lchob@multi.col,
spacing = lchob@spacing, width = lchob@width, bp = lchob@bp,
x.labels = lchob@x.labels, time.scale = lchob@time.scale,
isLogical = is.logical(x), legend = legend, legend.name = legend.name,
pars = list(gpars))
if (is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA, chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new, 1,
0)
do.call("chartSeries.chob", list(lchob))
invisible(chobTA)
}
else {
return(chobTA)
}
}
quantmod/R/chob.R 0000644 0001762 0000144 00000003523 15002467345 013352 0 ustar ligges users .chob <- new.env()
.chob$.chob <- list(NULL)
`write.chob` <-
function(x,pos)
{
orig.chob <- get.chob()
if(missing(pos)) pos <- length(orig.chob)+1
orig.chob[[pos]] <- x
.chob$.chob <- orig.chob
invisible(1)
}
`get.chob` <-
function()
{
x <- .chob$.chob
return(x)
}
`release.chob` <-
function(n)
{
if(missing(n)) {
x <- list(NULL)
} else {
x <- get.chob()[-n]
}
.chob$.chob <- x
invisible(1)
}
`plot.chobTA` <-
function(x,y,...)
{
lchob <- get.chob()[[dev.cur()]]
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,x)
lchob@windows <- lchob@windows + ifelse(x@new,1,0)
do.call('chartSeries.chob',list(lchob))
}
setClass("chob",
representation(
device="ANY",
call="call",
xdata='ANY',
xsubset='ANY',
name="character",
type="character",
passed.args="ANY",
windows="numeric",
xrange="numeric",
yrange="numeric",
log.scale="logical",
length="numeric",
color.vol="logical",multi.col="logical",
show.vol="logical",show.grid="logical",
line.type="character",bar.type="character",
xlab="character",ylab="character",
spacing="numeric",width="numeric",
bp="numeric",x.labels="character",
colors="ANY",layout="ANY",time.scale="ANY",
minor.ticks="logical",
major.ticks="ANY"
)
)
setClass("chobTA",
representation(
call="call",
on="ANY",
new="logical",
TA.values="ANY",
name="character",
params="ANY"
)
)
setMethod("show","chobTA",
function(object) {
cat(paste("",sep=""),"\n")
invisible(object)
}
)
quantmod/R/addWPR.R 0000644 0001762 0000144 00000004210 14657447467 013574 0 ustar ligges users
# addWPR {{{
`addWPR` <- function(n=14) {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- TRUE
xx <- if(is.OHLC(x)) {
cbind(Hi(x),Lo(x),Cl(x))
} else if(is.null(dim(x))) {
x
} else {
x[,1]
}
wpr <- WPR(xx,n=n)
chobTA@TA.values <- as.numeric(wpr)[lchob@xsubset]
chobTA@name <- "chartWPR"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} #}}}
# chartWPR {{{
`chartWPR` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
n <- x@params$n
wpr <- x@TA.values
y.range <- seq(-0.1, max(abs(wpr),
na.rm = TRUE), length.out = length(x.range)) * 1.05
# create appropriately scaled empty plot area
plot(x.range,y.range,type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
COLOR <- "#0033CC"
lines(seq(1,length(x.range),by=spacing),wpr,col=COLOR,lwd=1,type='l')
text(0, last(y.range)*.9,
paste("Williams %R (", x@params$n,"):", sep = ""),
pos = 4)
text(0, last(y.range)*.9,
paste("\n\n\n",sprintf("%.3f",last(wpr)), sep = ""), col = COLOR,
pos = 4)
axis(2)
box(col=x@params$colors$fg.col)
} # }}}
quantmod/R/getModelData.R 0000644 0001762 0000144 00000016321 15002467345 014771 0 ustar ligges users getModelData <- function(x, na.rm=TRUE) {
model <- x
if (!is.quantmod(model))
stop(sQuote("x"), "must be of class", dQuote("quantmod"),
"\n")
if (length(model@model.inputs) == 0) {
build.vars <- c(model@model.target, model@build.inputs)
}
else {
build.vars <- c(model@model.target, model@model.inputs)
}
model.symbols <- vars <- all.vars(model@model.spec)
env <- new.env()
lapply(vars,
function(V) {
if(!exists(V)) {
getSymbols(V, env=env)
} else {
assign(V, get(V), env)
}
}
)
target.data <- get(model.symbols[[1]], env)
total.columns = NULL
for (j in 1:length(model.symbols)) {
if (j == 1) {
m <- as.xts(target.data)
}
else {
m <- merge(m, as.xts(get(model.symbols[[j]], env)),
join = "inner")
}
total.columns[j] <- NCOL(m)
}
fullIndex <- index(m)
# m <- as.data.frame(m)
from.col = 1
for (i in 1:length(model.symbols)) {
assign(model.symbols[[i]], m[, from.col:(total.columns[i])], env)
from.col = total.columns[i] + 1
}
mf <- xts(model.frame(model@model.spec, data = env, na.action = NULL), fullIndex)
if (na.rm)
mf <- rbind(na.exclude(mf[-NROW(mf), ]), mf[NROW(mf),
])
colnames(mf) <- lapply(colnames(mf), function(x) {
gsub("[) ]", "", gsub("[(,=^:'\"]", ".", x))
})
model@model.data <- mf
model@build.inputs <- colnames(mf)[-1]
model@model.formula = as.formula(paste(colnames(mf)[1], "~",
paste(colnames(mf)[-1], collapse = "+"), sep = ""))
return(model)
#model.frame(spec, data=env)
}
..getModelData <- function(x, na.rm=TRUE) {
model <- x
if (!is.quantmod(model))
stop(sQuote("x"), "must be of class", dQuote("quantmod"),
"\n")
if (length(model@model.inputs) == 0) {
build.vars <- c(model@model.target, model@build.inputs)
}
else {
build.vars <- c(model@model.target, model@model.inputs)
}
model.symbols <- model@symbols
missing.symbols = NULL
for (i in 1:length(model.symbols)) {
if (!exists(model.symbols[[i]], 1)) {
missing.symbols <- c(missing.symbols, model.symbols[[i]])
}
else {
assign(model.symbols[[i]], get(model.symbols[[i]],
1), environment())
}
}
if (length(missing.symbols > 0))
getSymbols(missing.symbols, env = environment())
target.data <- get(model.symbols[[1]], environment())
total.columns = NULL
for (j in 1:length(model.symbols)) {
if (j == 1) {
m <- as.xts(target.data)
}
else {
m <- merge(m, xts(get(model.symbols[[j]], environment())),
join = "inner")
}
total.columns[j] <- NCOL(m)
}
fullIndex <- index(m)
# m <- as.data.frame(m)
from.col = 1
for (i in 1:length(model.symbols)) {
assign(model.symbols[[i]], m[, from.col:(total.columns[i])],
environment())
from.col = total.columns[i] + 1
}
mf <- xts(model.frame(model@model.spec, data = environment(),
na.action = NULL), fullIndex)
if (na.rm)
mf <- rbind(na.exclude(mf[-NROW(mf), ]), mf[NROW(mf),
])
colnames(mf) <- lapply(colnames(mf), function(x) {
gsub("[) ]", "", gsub("[(,=^:'\"]", ".", x))
})
model@model.data <- mf
model@build.inputs <- colnames(mf)[-1]
model@model.formula = as.formula(paste(colnames(mf)[1], "~",
paste(colnames(mf)[-1], collapse = "+"), sep = ""))
return(model)
}
".getModelData" <-
function(x,na.rm=TRUE)
{
as.POSIXorDate <- function(x) {
if(inherits(x, "POSIXt")) {
return(x)
} else {
x <- as.Date(x,origin='1970-01-01')
return(x)
}
}
model <- x
if(!is.quantmod(model))
stop(sQuote('x'),"must be of class",dQuote("quantmod"),"\n");
if(length(model@model.inputs) == 0) {
#if model.inputs is not yet defined, create full zoo object for building
build.vars <- c(model@model.target,model@build.inputs);
} else {
#else create data object with only relevant model.inputs
build.vars <- c(model@model.target,model@model.inputs);
}
model.symbols <- model@symbols;
missing.symbols = NULL
for(i in 1:length(model.symbols)) {
if(!exists(model.symbols[[i]],1)) {
## create vector of symbols to retrieve from getSymbols call
missing.symbols <- c(missing.symbols,model.symbols[[i]])
} else {
## get symbols from GlobaEnv and place in this environment
assign(model.symbols[[i]],get(model.symbols[[i]],1),environment())
## NEED to coerce to quantmod.OHLC and zoo object
}
}
if(length(missing.symbols > 0)) getSymbols(missing.symbols,env=environment())
target.data <- get(model.symbols[[1]],environment())
if(inherits(target.data, "zoo")) {
target.dates <- index(target.data)
} else {
target.dates <- rownames(target.data)
}
#price.level <- paste(c("Op(","Hi(","Lo(","Cl("),model@product,")",sep="");
total.columns = NULL
for(j in 1:length(model.symbols)) { # build single zoo object
if(j == 1) {
m <- merge(zoo(as.matrix(target.data),as.POSIXorDate(target.dates))) #target columns
} else {
m <- merge(m,
zoo(as.matrix(get(model.symbols[[j]],environment())), #input columns from symbol i
as.POSIXorDate(index(get(model.symbols[[j]],environment())))))
}
total.columns[j] <- NCOL(m)
}
fullIndex <- index(m)
m <- as.data.frame(m)
from.col = 1
for(i in 1:length(model.symbols)) { # assign portions of
assign(model.symbols[[i]],m[,from.col:(total.columns[i])],environment())
from.col = total.columns[i] + 1
}
mf <- zoo(model.frame(model@model.spec,data=environment(),na.action=NULL),fullIndex);
#pl.formula <- as.formula(paste('Op(',model@product,') ~ ',
# paste(c('Hi(',' + Lo(',' + Cl('),model@product,
# ')',collapse=''),sep=''));
#pl.mf <- zoo(model.frame(pl.formula,data=environment()),as.Date(target.dates))
if(na.rm) mf <- rbind(na.exclude(mf[-NROW(mf),]),mf[NROW(mf),]);
colnames(mf) <- lapply(colnames(mf),function(x)
{ gsub("[) ]","",gsub("[(,=^:'\"]",".",x)) });
#colnames(pl.mf) <- lapply(price.level,function(x)
# { gsub("[) ]","",gsub("[(,=:'\"]",".",x)) });
#colnames(pl.mf) <- paste(model@product,c('.Open','.High','.Low','.Close'),sep='')
model@model.data <- mf;
#model@price.levels <- pl.mf;
model@build.inputs <- colnames(mf)[-1]
model@model.formula = as.formula(paste(colnames(mf)[1],'~',
paste(colnames(mf)[-1],collapse='+'),
sep=''))
##removeSymbols()
return(model);
}
"stripModelData" <-
function(model) {
if(!inherits(model, "quantmod")) stop("model must be of class 'quantmod'");
model@model.data <- zoo(0,0);
model@price.levels <- zoo(0,0);
return(model);
}
quantmod/R/tradeLog.R 0000644 0001762 0000144 00000005663 14654457715 014223 0 ustar ligges users setOldClass('Date')
setClass("tradeLog",representation(
date="Date",
trade.id="numeric",
action="character",
underlying="character",
price="numeric",
quantity="numeric",
trade.value="numeric",
gain.loss="numeric",
account.value="numeric",
currency="character",
currency.symbol='character',
start.date="Date",
exch='character'
),
prototype = list(
date=Sys.Date(),
trade.id=0,
action='',
underlying='',
price=0,
quantity=0,
trade.value=0,
gain.loss=0,
account.value=10000,
currency='USD',
currency.symbol='$',
start.date=Sys.Date(),
exch=''
)
)
setMethod("show","tradeLog",
function(object)
{
cat(paste("Trade Log\t\t\tInitial Balance: ",object@account.value[1],
" ",object@currency,"\n\n",sep=''))
if(object@trade.id > 0) {
# if no trades, don't show log
tradeLog <- cbind(object@trade.id,object@action,object@underlying,
object@price,object@quantity,
object@trade.value,object@gain.loss,object@account.value)
colnames(tradeLog) <- c("ID","Action","Underlying",
"Price","Quantity",
"Gain(Loss)","Value","Account.Balance")
print(zoo(tradeLog,order.by=object@date))
}
})
"tradeLog" <-
function(initial.value=10000,currency="USD",currency.symbol="$",
underlying='')
{
start.date <- Sys.Date()
tradeLog <- new('tradeLog',account.value=initial.value,currency=currency,
currency.symbol=currency.symbol,
underlying=underlying,
start.date=start.date)
invisible(tradeLog)
}
"as.zoo.tradeLog" <- function() {}
"as.data.frame.tradeLog" <- function() {}
"as.tradeLog.tradeLog" <- function() {}
"as.matrix.tradeLog" <- function() {}
"addTrade" <-
function(x,date,action,price,quantity,
underlying=NULL,currency=NULL,currency.symbol=NULL,
exch=NULL)
{
}
"reverseTrade" <- function() {}
"adjustTrade" <- function() {}
"cancelTrade" <- function() {}
"print.tradeLog" <- function() {}
"show.tradeLog" <- function() {}
"plot.tradeLog" <- function() {}
"summary.tradeLog" <- function() {}
"periodReturn.tradeLog" <- function() {}
quantmod/R/addVo.R 0000644 0001762 0000144 00000011453 15002467345 013475 0 ustar ligges users
# addVo {{{
`addVo` <- function(log.scale=FALSE) {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
if(!lchob@show.vol || !has.Vo(x))
return(invisible(new('chobTA', new=FALSE, name="chartNULL", call=match.call())))
Volumes <- Vo(x)
max.vol <- max(Volumes,na.rm=TRUE)
vol.scale <- list(100, "100s")
if (max.vol > 10000)
vol.scale <- list(1000, "1000s")
if (max.vol > 1e+05)
vol.scale <- list(10000, "10,000s")
if (max.vol > 1e+06)
vol.scale <- list(1e+05, "100,000s")
if (max.vol > 1e+07)
vol.scale <- list(1e+06, "millions")
if(lchob@color.vol && is.OHLC(x)) {
# calculate colors for bars, if applicable.
Opens <- Op(x)
Closes <- Cl(x)
if(lchob@multi.col) {
# colored bars - 4 color
last.Closes <- as.numeric(Lag(Closes))
last.Closes[1] <- Closes[1]
bar.col <- ifelse(Opens < Closes,
ifelse(Opens < last.Closes,
lchob@colors$dn.up.col,
lchob@colors$up.up.col),
ifelse(Opens < last.Closes,
lchob@colors$dn.dn.col,
lchob@colors$up.dn.col))
} else {
# colored bars - 2 color
bar.col <- ifelse(Opens < Closes,
lchob@colors$up.col,
lchob@colors$dn.col)
}
# 1 color bars
} else bar.col <- ifelse(!is.null(lchob@colors$Vo.bar.col),
lchob@colors$Vo.bar.col,lchob@colors$border)
border.col <- ifelse(is.null(lchob@colors$border),
bar.col,lchob@colors$border)
bar.col <- bar.col[lchob@xsubset]
chobTA <- new("chobTA")
chobTA@new <- TRUE
chobTA@TA.values <- (Volumes/vol.scale[[1]])[lchob@xsubset]
chobTA@name <- "chartVo"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
vol.scale=vol.scale,
x.labels=lchob@x.labels,
log.scale=log.scale,
bar.col=bar.col,border.col=border.col,
time.scale=lchob@time.scale)
chobTA@params$thin <- ifelse(lchob@type %in% c('bars','matchsticks'),TRUE,FALSE)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} # }}}
# chartVo {{{
`chartVo` <-
function(x) {
# if volume is to be plotted, do so here
# scale volume - vol.divisor
if(!inherits(x, "chobTA")) stop("chartVo requires a suitable chobTA object")
Volumes <- x@TA.values
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
# multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
log.scale <- ifelse(x@params$log.scale,"y","")
vol.scale <- x@params$vol.scale
if(x@new) {
plot.new()
plot.window(xlim=c(1, x@params$xrange[2] * spacing),
ylim=c(min(Volumes,na.rm=TRUE),max(Volumes,na.rm=TRUE)),
log=log.scale)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
abline(h=axTicks(2), col=x@params$colors$grid.col, lty='dotted')
}
x.pos <- 1 + spacing * (1:length(Volumes) - 1)
bar.col <- if(x@params$color.vol) {
x@params$bar.col
} else x@params$border.col
border.col <- x@params$border.col
if(x@params$thin) {
# plot thin volume bars if appropriate
segments(x.pos,0,x.pos,Volumes,col=bar.col)
} else {
rect(x.pos-spacing/3,0,x.pos+spacing/3,Volumes,
col=bar.col,border=border.col)
}
legend.text <- list(list(
legend=c(paste("Volume (",vol.scale[[2]],"):",sep=''),format(last(Volumes)*vol.scale[[1]],big.mark=',')),
text.col=c(x@params$colors$fg.col, last(bar.col))
))
legend("topleft",
legend=c(paste("Volume (",vol.scale[[2]],"):",sep=''),format(last(Volumes)*vol.scale[[1]],big.mark=',')),
text.col=c(x@params$colors$fg.col, last(bar.col)), bty="n", y.intersp=0.95)
# text(0, max(Volumes,na.rm=TRUE) * .9, "Volume:",pos=4)
# text(0, max(Volumes,na.rm=TRUE) * .9,
# paste("\n\n\n",format(last(Volumes)*vol.scale[[1]],big.mark=','), sep = ""),
# pos = 4,col=last(bar.col))
axis(2)
box(col=x@params$colors$fg.col)
invisible(vector('list',2))
} # }}}
quantmod/R/dropTA.R 0000644 0001762 0000144 00000006071 15002467345 013631 0 ustar ligges users `swapTA` <-
function(ta1,ta2,occ1=1,occ2=1,dev) {
if(missing(ta1) || missing(ta2)) stop("two TA indicator required")
# default to the current device if none specified
if(missing(dev)) dev <- dev.cur()
ta.list <- listTA(dev)
# get the current chob
lchob <- get.chob()[[dev]]
# make indicator name match original call
if(regexpr("^add",ta1) == -1) ta1 <- paste("add",ta1,sep='')
if(regexpr("^add",ta2) == -1) ta2 <- paste("add",ta2,sep='')
# locate the TA which needs to be removed
which.ta1 <- which(ta1==sapply(ta.list,
function(x) deparse(x[[1]])))[occ1]
which.ta2 <- which(ta2==sapply(ta.list,
function(x) deparse(x[[1]])))[occ2]
tmp.ta1 <- lchob@passed.args$TA[[which.ta1]]
tmp.ta2 <- lchob@passed.args$TA[[which.ta2]]
lchob@passed.args$TA[[which.ta1]] <- tmp.ta2
lchob@passed.args$TA[[which.ta2]] <- tmp.ta1
do.call("chartSeries.chob",list(lchob))
write.chob(lchob,lchob@device)
}
`moveTA` <-
function(ta,pos,occ=1,dev) {
pos <- pos - 1
if(missing(ta)) stop("no TA indicator specified")
# default to the current device if none specified
if(missing(dev)) dev <- dev.cur()
ta.list <- listTA(dev)
# get the current chob
lchob <- get.chob()[[dev]]
# make indicator name match original call
if(regexpr("^add",ta) == -1) ta <- paste("add",ta,sep='')
# locate the TA which needs to be removed
which.ta <- which(ta==sapply(ta.list,
function(x) deparse(x[[1]])))[occ]
if(is.na(which.ta)) stop("no TA")
lchob@passed.args$TA <- append(lchob@passed.args$TA[-which.ta],
lchob@passed.args$TA[which.ta],
after=pos)
do.call("chartSeries.chob",list(lchob))
write.chob(lchob,lchob@device)
}
`dropTA` <-
function(ta,occ=1,dev,all=FALSE) {
if(all) return(do.call('dropTA', list(1:length(listTA()))))
if(missing(ta)) stop("no TA indicator specified")
# default to the current device if none specified
if(missing(dev)) dev <- dev.cur()
ta.list <- listTA(dev)
# get the current chob
lchob <- get.chob()[[dev]]
sel.ta <- NULL
for(cta in 1:length(ta)) {
if(is.character(ta[cta])) {
# make indicator name match original call
if(regexpr("^add",ta[cta]) == -1) ta[cta] <- paste("add",ta[cta],sep='')
# locate the TA which needs to be removed
which.ta <- which(ta[cta]==sapply(ta.list,
function(x) deparse(x[[1]])))[occ]
} else which.ta <- cta
# skip and warn if no indicator found
if(!is.na(which.ta)) {
# decrease window count if necessary
if(lchob@passed.args$TA[[which.ta]]@new)
lchob@windows <- lchob@windows - 1
sel.ta <- c(sel.ta,which.ta)
}
}
if(is.null(sel.ta)) stop("nothing to remove")
# remove TA from current list
lchob@passed.args$TA <- lchob@passed.args$TA[-sel.ta]
if(length(lchob@passed.args$TA) < 1)
lchob@passed.args$TA <- list()
# redraw chart
do.call("chartSeries.chob",list(lchob))
write.chob(lchob,lchob@device)
}
quantmod/R/addEMV.R 0000644 0001762 0000144 00000003300 14654457715 013544 0 ustar ligges users # Arm's Ease of Movement Index by Josh Ulrich from TTR
#
# chartSeries implementation by Jeffrey A. Ryan 2008
#
# addEMV
`addEMV` <-
function (volume, n = 9, maType, vol.divisor = 10000, ..., on = NA,
legend = "auto")
{
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
x <- EMV(HL = HLC(x)[,-3], volume = Vo(x), n = n, maType = maType,
vol.divisor = vol.divisor)
yrange <- NULL
chobTA <- new("chobTA")
if (NCOL(x) == 1) {
chobTA@TA.values <- x[lchob@xsubset]
}
else chobTA@TA.values <- x[lchob@xsubset, ]
chobTA@name <- "chartTA"
if (any(is.na(on))) {
chobTA@new <- TRUE
}
else {
chobTA@new <- FALSE
chobTA@on <- on
}
chobTA@call <- match.call()
legend.name <- gsub("^.*[(]", " Ease of Movement (", deparse(match.call()))#,
#extended = TRUE)
gpars <- c(list(...), list(col = 6:7))[unique(names(c(list(col = 6:7),
list(...))))]
chobTA@params <- list(xrange = lchob@xrange, yrange = yrange,
colors = lchob@colors, color.vol = lchob@color.vol, multi.col = lchob@multi.col,
spacing = lchob@spacing, width = lchob@width, bp = lchob@bp,
x.labels = lchob@x.labels, time.scale = lchob@time.scale,
isLogical = is.logical(x), legend = legend, legend.name = legend.name,
pars = list(gpars))
if (is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA, chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new, 1,
0)
chartSeries.chob <- chartSeries.chob
do.call("chartSeries.chob", list(lchob))
invisible(chobTA)
}
else {
return(chobTA)
}
}
quantmod/R/updateModel.R 0000644 0001762 0000144 00000000254 14654457715 014714 0 ustar ligges users "updateModel" <-
function(fitted.model,quantmod) {
quantmod@model.inputs <- fitted.model@model.inputs;
quantmod@fitted.model <- fitted.model;
return(quantmod);
}
quantmod/R/symbols.R 0000644 0001762 0000144 00000000712 14654457715 014140 0 ustar ligges users #
# symbols via yahoo:
# 'http://download.finance.yahoo.com/d/quotes.csv?s=WPP&f=nsl1d1t1c1ohgv'
# symbol list:
# http://www.nasdaq.com/reference/comlookup.stm#viewdownload
#
# NASDAQ
# http://www.nasdaq.com//asp/symbols.asp?exchange=Q&start=0
# AMEX
# http://www.nasdaq.com//asp/symbols.asp?exchange=1&start=0
# NYSE
# http://www.nasdaq.com//asp/symbols.asp?exchange=N&start=0
# > NYSE[2]$V2[-grep('\\^|/',NYSE[2]$V2,perl=TRUE)]
quantmod/R/modelReturn.R 0000644 0001762 0000144 00000006424 15002467345 014742 0 ustar ligges users "modelReturn" <- function(tR.results,trade.dates=NULL,ret.type='months', leverage=1,exclude.training=TRUE)
{
quantmodReturn <- new("quantmodReturn");
trade.signal <- tR.results$signal;
trade.start <- start(trade.signal);
trade.end <- end(trade.signal);
holding.period <- trade.end - trade.start;
days.tradeable <- length(trade.signal);
days.traded <- sum(abs(trade.signal),na.rm=TRUE);
trade.percentage <- days.traded / days.tradeable;
# model.data <- modelData(tR.results@model,trade.dates,exclude.training=exclude.training)
model.index <- index(trade.signal);
model.results <- trade.signal[,1] * leverage * trade.signal[,2];
model.results[which(is.na(model.results))] <- 0;
model.cumret <- cumprod(1+model.results);
signal.accuracy <- length(model.results[as.numeric(model.results) > 0])/length(model.results);
pos.days <- trade.signal[which(trade.signal[,1] > 0),]
if(NROW(pos.days) > 0) {
pos.days.accuracy <- sum(ifelse(pos.days[,1]*pos.days[,2] > 0, 1, 0))/NROW(pos.days)
pos.days.results <- pos.days[,1]*pos.days[,2]
} else {
pos.days.accuracy <- pos.days.results <- NA
}
neg.days <- trade.signal[which(trade.signal[,1] < 0),]
if(NROW(neg.days) > 0) {
neg.days.accuracy <- sum(ifelse(neg.days[,1]*neg.days[,2] > 0, 1, 0))/NROW(neg.days)
neg.days.results <- neg.days[,1]*neg.days[,2]
} else {
neg.days.accuracy <- neg.days.results <- NA
}
signal.summary <- table(trade.signal[,2])
if(any(signal.summary==0) || dim(signal.summary)==1) {
warning("Model results are all one direction.")
}
raw.signal.bias <- mean(trade.signal[,2])
CAGR <- as.numeric((model.cumret[trade.end])^(1/(as.numeric(holding.period)/252))-1);
HPR <- as.numeric(model.cumret[length(model.cumret)])-1;
accuracy <- zoo(NULL,model.index);
directional.accuracy = list(
raw.signal.bias,pos.days.accuracy,neg.days.accuracy,
pos.days.results,neg.days.results)
periods <- match.arg(ret.type,c("weeks","months","quarters","years"),several.ok=TRUE)
# period.options <- c("weeks","months","quarters","years");
# periods <- period.options[pmatch(ret.type,period.options)];
# returnsBy <- merge(model.cumret,model.results);
# for(i in 1:length(periods))
# {
# this.period <- periods[i];
# this.bp <- breakpoints(trade.signal,by=this.period,TRUE);
# accuracy <- merge(accuracy,zoo(period.apply(x=model.results,INDEX=this.bp,function(x) {
# length(x[as.numeric(x) > 0])/length(x)
# }),model.index[this.bp]));
# returnsBy <- merge(returnsBy,returnBy(x=model.results,dat=trade.signal,by=this.period)[,2]);
# }
# colnames(returnsBy) <- c("cum.return","days",periods);
if(NCOL(accuracy)>1) colnames(accuracy) <- periods;
returnsBy <- allReturns(model.cumret)
quantmodReturn@returnsBy <- returnsBy;
quantmodReturn@dist.of.returns <- lapply(as.data.frame(returnsBy), function(x) as.numeric(summary(x))[1:6])
quantmodReturn@results <- model.results;
quantmodReturn@returns <- model.cumret;
# quantmodReturn@CAGR <- sprintf("%.4f%%", CAGR*100);
# quantmodReturn@HPR <- sprintf("%.2f%%",HPR*100);
quantmodReturn@CAGR <- CAGR
quantmodReturn@HPR <- HPR
quantmodReturn@accuracy <- accuracy
quantmodReturn@directional.accuracy <- directional.accuracy;
return(quantmodReturn);
}
quantmod/R/addSMI.R 0000644 0001762 0000144 00000005356 14657447467 013570 0 ustar ligges users
# addSMI {{{
`addSMI` <- function(n=13,slow=25,fast=2,signal=9,ma.type='EMA') {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- TRUE
xx <- if(is.OHLC(x)) {
cbind(Hi(x),Lo(x),Cl(x))
} else if(is.null(dim(x))) {
x
} else {
x[,1]
}
smi <- SMI(xx, n=n, nFast=fast,
nSlow=slow, nSig=signal, maType=ma.type)
# subset here
# smi <- smi[lchob@sindex]
chobTA@TA.values <- smi[lchob@xsubset,]
chobTA@name <- "chartSMI"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n,slow=slow,fast=fast,signal=signal,
ma.type=ma.type)
#if(is.null(sys.call(-1))) {
# TA <- lchob@passed.args$TA
# lchob@passed.args$TA <- c(TA,chobTA)
# lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
# do.call('chartSeries.chob',list(lchob))
# invisible(chobTA)
#} else {
return(chobTA)
#}
} #}}}
# chartSMI {{{
`chartSMI` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
smi <- x@TA.values
y.range <- seq(-max(abs(smi[,1]), na.rm = TRUE), max(abs(smi[,1]),
na.rm = TRUE), length.out = length(x.range)) * 1.05
if(x@new) {
plot(x.range,y.range,type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
}
COLOR <- "#0033CC"
SIGNAL <- "#BFCFFF"
lines(seq(1,length(x.range),by=spacing),
smi[,1],col=COLOR,lwd=1,type='l')
lines(seq(1,length(x.range),by=spacing),
smi[,2],col=SIGNAL,lwd=1,lty='dotted',type='l')
text(0, last(y.range) * .9,
paste("Stochastic Momentum Index (",
paste(x@params$n,x@params$fast,x@params$slow,x@params$signal,sep=','),
"):", sep = ""),
pos = 4)
text(0, last(y.range)*.9,
paste("\n\n\nSMI: ",sprintf("%.3f",last(smi[,1])), sep = ""), col = COLOR,
pos = 4)
text(0, last(y.range)*.9,
paste("\n\n\n\n\nSignal: ",
sprintf("%.3f",last(smi[,2])), sep = ""), col = SIGNAL,
pos = 4)
axis(2)
box(col=x@params$colors$fg.col)
} # }}}
quantmod/R/addOBV.R 0000644 0001762 0000144 00000003100 14654457715 013541 0 ustar ligges users # On Balance Volume by Josh Ulrich from TTR
#
# chartSeries implementation by Jeffrey A. Ryan 2008
#
# addOBV
`addOBV` <-
function (..., on = NA, legend = "auto")
{
lchob <- get.current.chob()
x <- try.xts(lchob@xdata, error=FALSE)
x <- OBV(price = Cl(x), volume = Vo(x))
yrange <- NULL
chobTA <- new("chobTA")
if (NCOL(x) == 1) {
chobTA@TA.values <- x[lchob@xsubset]
}
else chobTA@TA.values <- x[lchob@xsubset, ]
chobTA@name <- "chartTA"
if (any(is.na(on))) {
chobTA@new <- TRUE
}
else {
chobTA@new <- FALSE
chobTA@on <- on
}
chobTA@call <- match.call()
legend.name <- gsub("^.*[(]", " On Balance Volume (", deparse(match.call()))#,
#extended = TRUE)
gpars <- c(list(...), list(col=4))[unique(names(c(list(col=4), list(...))))]
chobTA@params <- list(xrange = lchob@xrange, yrange = yrange,
colors = lchob@colors, color.vol = lchob@color.vol, multi.col = lchob@multi.col,
spacing = lchob@spacing, width = lchob@width, bp = lchob@bp,
x.labels = lchob@x.labels, time.scale = lchob@time.scale,
isLogical = is.logical(x), legend = legend, legend.name = legend.name,
pars = list(gpars))
if (is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA, chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new, 1,
0)
chartSeries.chob <- chartSeries.chob
do.call("chartSeries.chob", list(lchob))
invisible(chobTA)
}
else {
return(chobTA)
}
}
quantmod/R/getOptionChain.R 0000644 0001762 0000144 00000013107 15002467345 015351 0 ustar ligges users `getOptionChain` <-
function(Symbols, Exp=NULL, src="yahoo", ...) {
Call <- paste("getOptionChain",src,sep=".")
if(missing(Exp)) {
optionChain <- do.call(Call, list(Symbols=Symbols, ...))
} else {
optionChain <- do.call(Call, list(Symbols=Symbols, Exp=Exp, ...))
}
# only return non- NULL elements
optionChain[!vapply(optionChain, is.null, logical(1))]
}
getOptionChain.yahoo <- function(Symbols, Exp, ..., session=NULL)
{
NewToOld <- function(x, tz = NULL) {
if(is.null(x) || length(x) < 1)
return(NULL)
# clean up colnames, in case there's weirdness in the JSON
names(x) <- tolower(gsub("[[:space:]]", "", names(x)))
# set cleaned up colnames to current output colnames
cnames <- c(contractsymbol = "ContractID",
contractsize = "ConractSize",
currency = "Currency",
expiration = "Expiration",
strike = "Strike",
lastprice = "Last",
change = "Chg",
percentchange = "ChgPct",
bid = "Bid",
ask = "Ask",
volume = "Vol",
openinterest = "OI",
lasttradedate = "LastTradeTime",
impliedvolatility = "IV",
inthemoney = "ITM")
# create template data.frame for results
N <- NROW(x)
d <- structure(
list(ContractID = rep(NA_character_, N),
ConractSize = rep(NA_character_, N),
Currency = rep(NA_character_, N),
Expiration = rep(NA_integer_, N),
Strike = rep(NA_real_, N),
Last = rep(NA_real_, N),
Chg = rep(NA_real_, N),
ChgPct = rep(NA_real_, N),
Bid = rep(NA_real_, N),
Ask = rep(NA_real_, N),
Vol = rep(NA_integer_, N),
OI = rep(NA_integer_, N),
LastTradeTime = rep(NA_integer_, N),
IV = rep(NA_real_, N),
ITM = rep(NA, N)),
row.names = c(NA, -N), class = "data.frame")
# fill in available results
result.colnames <- cnames[names(x)]
d[, result.colnames] <- x
# convert expiration to POSIXct for theta decay calculations
d$Expiration <- as.POSIXct(d$Expiration, origin = "1970-01-01", tz = "UTC")
# convert trade time to exchange timezone
d$LastTradeTime <- .POSIXct(d$LastTradeTime, tz=tz)
return(d)
}
if (is.null(session)) {
session <- .yahooSession()
}
if (!session$can.crumb) {
stop("Unable to obtain yahoo crumb. If this is being called from a GDPR country, Yahoo requires GDPR consent, which cannot be scripted")
}
# Don't check the expiry date if we're looping over dates we just scraped
checkExp <- !hasArg(".expiry.known") || !match.call(expand.dots=TRUE)$.expiry.known
# Construct URL
urlExp <- paste0("https://query2.finance.yahoo.com/v7/finance/options/", Symbols[1],
"?crumb=", session$crumb)
# Add expiry date to URL
if(!checkExp)
urlExp <- paste0(urlExp, "&date=", Exp)
# Fetch data (jsonlite::fromJSON will handle connection)
tbl <- try(jsonlite::fromJSON(curl::curl(urlExp, handle = session$h)), silent = TRUE)
if(inherits(tbl, "try-error")) {
msg <- attr(tbl, "condition")[["message"]]
expDate <- .Date(Exp / 86400)
warning("no data for '", Symbols[1], "' expiry ", expDate,
", omitting\n\t(server response: ", msg, ")",
immediate. = TRUE, call. = FALSE)
return(NULL)
}
# Only return nearest expiry (default served by Yahoo Finance), unless the user specified Exp
if(!missing(Exp) && checkExp) {
all.expiries <- tbl$optionChain$result$expirationDates[[1]]
all.expiries.posix <- .POSIXct(as.numeric(all.expiries), tz="UTC")
if(is.null(Exp)) {
# Return all expiries if Exp = NULL
out <- lapply(all.expiries, getOptionChain.yahoo, Symbols=Symbols, .expiry.known=TRUE, session=session)
# Expiry format was "%b %Y", but that's not unique with weeklies. Change
# format to "%b.%d.%Y" ("%Y-%m-%d wouldn't be good, since names should
# start with a letter or dot--naming things is hard).
return(setNames(out, format(all.expiries.posix, "%b.%d.%Y")))
} else {
# Ensure data exist for user-provided expiry date(s)
if(inherits(Exp, "Date"))
valid.expiries <- as.Date(all.expiries.posix) %in% Exp
else if(inherits(Exp, "POSIXt"))
valid.expiries <- all.expiries.posix %in% Exp
else if(is.character(Exp)) {
expiry.range <- range(unlist(lapply(Exp, .parseISO8601, tz="UTC")))
valid.expiries <- all.expiries.posix >= expiry.range[1] &
all.expiries.posix <= expiry.range[2]
}
if(all(!valid.expiries))
stop("Provided expiry date(s) not found. Available dates are: ",
paste(as.Date(all.expiries.posix), collapse=", "))
expiry.subset <- all.expiries[valid.expiries]
if(length(expiry.subset) == 1)
return(getOptionChain.yahoo(Symbols, expiry.subset, .expiry.known=TRUE, session=session))
else {
out <- lapply(expiry.subset, getOptionChain.yahoo, Symbols=Symbols, .expiry.known=TRUE, session=session)
# See comment above regarding the output names
return(setNames(out, format(all.expiries.posix[valid.expiries], "%b.%d.%Y")))
}
}
}
dftables <- lapply(tbl$optionChain$result$options[[1]][,c("calls","puts")], `[[`, 1L)
tz <- tbl$optionChain$result$quote$exchangeTimezoneName[1L]
dftables <- lapply(dftables, NewToOld, tz=tz)
dftables
}
quantmod/R/addVolatility.R 0000644 0001762 0000144 00000003043 14654457715 015261 0 ustar ligges users # volatility from TTR by Josh Ulrich
#
# chartSeries interface by Jeffrey A. Ryan 2008
#
# addVolatility
`addVolatility` <-
function (n = 10, calc = "close", N = 260, ..., on = NA, legend = "auto")
{
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
x <- OHLC(x)
x <- volatility(OHLC = x, n = n, calc = calc, N = N)
yrange <- NULL
chobTA <- new("chobTA")
if (NCOL(x) == 1) {
chobTA@TA.values <- x[lchob@xsubset]
}
else chobTA@TA.values <- x[lchob@xsubset, ]
chobTA@name <- "chartTA"
if (any(is.na(on))) {
chobTA@new <- TRUE
}
else {
chobTA@new <- FALSE
chobTA@on <- on
}
chobTA@call <- match.call()
legend.name <- gsub("^add", "", deparse(match.call()))
gpars <- c(list(...), list(col = 8))[unique(names(c(list(col = 8),
list(...))))]
chobTA@params <- list(xrange = lchob@xrange, yrange = yrange,
colors = lchob@colors, color.vol = lchob@color.vol, multi.col = lchob@multi.col,
spacing = lchob@spacing, width = lchob@width, bp = lchob@bp,
x.labels = lchob@x.labels, time.scale = lchob@time.scale,
isLogical = is.logical(x), legend = legend, legend.name = legend.name,
pars = list(gpars))
if (is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA, chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new, 1,
0)
do.call("chartSeries.chob", list(lchob))
invisible(chobTA)
}
else {
return(chobTA)
}
}
quantmod/R/buildModel.R 0000644 0001762 0000144 00000004010 14657447467 014531 0 ustar ligges users `bM` <-
function(x,FUN,subset,...) {
if(!is.quantmod(x)) stop('x must be a quantmod object')
FUN <- as.character(paste("buildModel.",deparse(substitute(FUN)),sep=''))
training.data <- x@model.data[subset]
mcall <- do.call(FUN,list(quantmod=x,training.data=training.data, ...))
x@fitted.model <- mcall$fitted
x@model.inputs <- as.character(mcall$inputs)
x@build.date = as.character(Sys.time())
x@model.id <- paste(class(mcall$fitted)[length(class(mcall$fitted))],
as.numeric(Sys.time()),sep='')
x@training.data <- index(training.data)
invisible(x)
}
"buildModel" <-
function(x,method,training.per,...) {
as.POSIXorDate <- function(x) {
class.of.index <- class(index(model.data))
if("POSIXt" %in% class.of.index) {
if("POSIXlt" %in% class.of.index) {
x <- as.POSIXlt(x)
} else {
x <- as.POSIXct(x)
}
} else {
x <- as.Date(x)
}
x
}
model.id=deparse(substitute(x))
if(length(training.per) != 2) stop("training.per must be of length 2");
model.data <- x@model.data;
start.date.index <- index(model.data[which(index(model.data) >= as.POSIXorDate(training.per[1]))])
end.date.index <- index(model.data[which(index(model.data) <= as.POSIXorDate(training.per[2]))])
training.dates <- as.POSIXorDate(intersect(as.character(start.date.index),
as.character(end.date.index)));
method <- as.character(paste("buildModel.",method,sep=''));
training.data <- model.data[training.dates];
formula <- x@model.formula
mcall <- do.call(method,list(quantmod=x,training.data=training.data, ...));
x@fitted.model <- mcall$fitted;
x@model.inputs <- as.character(mcall$inputs);
x@build.date = as.character(Sys.time());
x@model.id <- paste(class(mcall$fitted)[length(class(mcall$fitted))],
as.numeric(Sys.time()),sep='');
x@training.data <- (training.dates);
invisible(x);
}
quantmod/R/getSymbols.skeleton.R 0000644 0001762 0000144 00000004573 14654457715 016434 0 ustar ligges users # getSymbols.skeleton {{{
"getSymbols.skeleton" <-
function(Symbols,env,
# additional source specific params
return.class="zoo",
...) {
importDefaults("")
this.env <- environment()
for(var in names(list(...))) {
assign(var,list(...)[[var]], this.env)
}
# additional defaults to be saved
# used if getSymbolLookup has been set
# for a specific SYMBOL
default.return.class <- return.class
if(missing(verbose)) verbose <- FALSE
if(missing(auto.assign)) auto.assign <- TRUE
#################################################################
# Loop through all possible Symbols given in function call
#
#################################################################
for(i in 1:length(Symbols)) {
#################################################################
# repeat the following 2 assignments for all default arguments
return.class <- getSymbolLookup()[[Symbols[[i]]]]$return.class
return.class <- ifelse(is.null(return.class),default.return.class,
return.class)
#################################################################
if(verbose) cat("loading ",Symbols[[i]],".....")
#################################################################
# source specific code to fetch data
# this is the core functionality of the method
#################################################################
fr <- # assign to 'fr'ame
if(verbose)
cat("done.\n")
#################################################################
# convert to a zoo/xts object. indexing by proper format
fr <- zoo(fr[,-1],as.Date(fr[,1],origin='1970-01-01'))
# change colnames if necessary. Following handle OHLC code from yahoo
colnames(fr) <- paste(toupper(gsub('\\^','',Symbols[[i]])),
c('Open','High','Low','Close','Volume','Adjusted'),
sep='.')
# convert.time.series to whichever class is specified by 'return.class'
fr <- convert.time.series(fr=fr,return.class=return.class)
Symbols[[i]] <- # assign Symbol name to be used in environment
# make effort to make a legal R name
#################################################################
if(auto.assign)
assign(Symbols[[i]],fr,env)
}
if(auto.assign)
return(Symbols)
return(fr)
}
#}}}
quantmod/R/loadSymbols.R 0000644 0001762 0000144 00000004066 14772047315 014736 0 ustar ligges users `download.SymbolNames` <-
function(exchange, cache.file='', quiet=TRUE) {
exchange <- match.arg(toupper(exchange),
c("NYSE","NASDAQ","AMEX","OTC","MF","MP"))
if(cache.file == '') {
cache.file <- getOption('symbolNamesFile')
if(is.null(cache.file)) {
cache.file <- tempfile()
on.exit(unlink(cache.file))
}
}
if(!is.null(cache.file)) {
eval(parse(text=
paste("options(symbolNamesFile.",exchange," = cache.file)",sep="")))
}
FILE <- switch(exchange,
NASDAQ="nasdaqlisted.txt",
AMEX =,
NYSE ="otherlisted.txt",
OTC ="otclisted.txt",
MF ="mfundslist.txt",
MP ="mpidlist.txt")
download.file(paste("ftp://ftp.nasdaqtrader.com/SymbolDirectory/",FILE,sep=""),
destfile=cache.file, quiet=quiet)
}
`download.OptionSymbols` <-
function(cache.file=NULL) {
src <- 'http://www.cboe.com/publish/ScheduledTask/MktData/cboesymboldir2.csv'
}
#`getSymbolName` <-
#function(name,exchange) {
# found <- grep(name,db,perl=TRUE)
#}
`getOptionSymbol` <-
function(desc,src='yahoo',optionSymbolsFile) {
# source: http://www.optionsxpress.com/educate/opt_symbols_aspx
dd <- paste(strsplit(desc,';'))[[1]]
d.out <- ''
for(d in dd) {
d <- strsplit(d,' ')[[1]]
Symbol <- d[1] # lookup this
month <- match.arg(toupper(d[2]),toupper(month.abb))
strike <- as.numeric(d[3])
right <- match.arg(toupper(d[4]),c("CALL","PUT"))
exp.codes <- data.frame(toupper(month.abb),c(rep('CALL',12),rep('PUT',12)),LETTERS[1:24])
exp.code <- LETTERS[intersect(which(exp.codes==month,TRUE)[,1],
which(exp.codes==right,TRUE)[,1])]
strike.codes <- rbind(
matrix(rep(c(0,100,200,300,400,500),20),nrow=20,byrow=TRUE)+seq(5,100,5),
matrix(rep(seq(0,150,30),6),nrow=6,byrow=TRUE)+seq(7.5,32.5,5))
strike.code <- LETTERS[which(strike.codes==strike,TRUE)[,1]]
if(src=='yahoo') src <- ".X"
d.out <- paste(d.out,paste(Symbol,exp.code,strike.code,src,sep=''),sep=';')
}
d.out
}
quantmod/R/getDividends.R 0000644 0001762 0000144 00000004540 15002467345 015050 0 ustar ligges users `getDividends` <-
function(Symbol,from='1970-01-01',to=Sys.Date(),env=parent.frame(),src='yahoo',
auto.assign=FALSE,auto.update=FALSE,verbose=FALSE,split.adjust=TRUE,...,
curl.options=list()) {
tmp.symbol <- Symbol
if(missing(env)) {
env <- parent.frame(1)
} else {
if(exists(Symbol, envir = env, inherits = FALSE)) {
tmp.symbol <- get(Symbol, envir = env)
}
if(!missing(auto.assign) && !isTRUE(auto.assign) && !is.null(env)) {
warning("ignoring 'auto.assign = FALSE' because 'env' is specified")
}
auto.assign <- TRUE
}
if(is.null(env))
auto.assign <- FALSE
Symbol.name <- ifelse(!is.character(Symbol),
deparse(substitute(Symbol)),
as.character(Symbol))
from.posix <- .dateToUNIX(from)
to.posix <- .dateToUNIX(to)
handle <- .getHandle()
yahoo.URL <- .yahooJsonURL(Symbol.name, from.posix, to.posix, "1d")
yahoo.URL <- paste0(yahoo.URL, "&events=div|splits")
conn <- curl::curl(yahoo.URL,handle=handle)
json <- try(jsonlite::fromJSON(conn, simplifyVector = FALSE)$chart$result, silent = TRUE)
if(inherits(json, "try-error")) {
msg <- paste0("Unable to import dividends for ", Symbol.name,
".\n", attr(json, "condition")$message)
stop(msg)
}
div.events <- json[[1]][["events"]][["dividends"]]
if(!is.null(div.events)) {
div.to.xts <- function(x) {
xts(x$amount, as.Date(.POSIXct(x$date, "UTC")))
}
# dividends from Yahoo are split-adjusted
divs <- do.call(rbind, lapply(div.events, div.to.xts))
split.events <- json[[1]][["events"]][["splits"]]
if(!split.adjust && !is.null(split.events)) {
# un-adjust dividends for splits
spl.to.xts <- function(x) {
ratio <- x$numerator/x$denominator
xts(ratio, as.Date(.POSIXct(x$date, "UTC")))
}
splits <- do.call(rbind, lapply(split.events, spl.to.xts))
divs <- divs * adjRatios(splits=merge(splits, index(divs)))[,1]
}
fr <- divs
colnames(fr) <- paste(Symbol.name,'div',sep='.')
} else {
fr <- xts(numeric(0), .Date(integer(0)))
}
if(is.xts(tmp.symbol)) {
if(auto.update) {
xtsAttributes(tmp.symbol) <- list(dividends=fr)
assign(Symbol.name,tmp.symbol,envir=env)
}
} else if(auto.assign) {
assign(paste(Symbol.name,'div',sep='.'),fr,envir=env)
} else fr
}
quantmod/R/returnBy.R 0000644 0001762 0000144 00000000624 14654457715 014264 0 ustar ligges users "returnBy" <-
function(x,dat,by,...)
{
bp <- endpoints(dat,by);
end.value <- period.apply(cumprod(1+x),bp, function(x) x[length(x)]);
per.change <- diff(c(1,end.value))/c(1,end.value[-length(end.value)]);
zret <- zoo(cbind(end.value,per.change),index(dat)[bp]);
change.name <- paste("change.by.",as.character(by),sep='');
colnames(zret) <- c("cumulative.ret",change.name);
return(zret);
}
quantmod/R/oanda.R 0000644 0001762 0000144 00000012015 14654457715 013531 0 ustar ligges users `oanda.currencies` <-
structure(list(oanda.df.1.length.oanda.df...2....1. = c("US Dollar",
"Afghanistan Afghani", "Albanian Lek", "Algerian Dinar", "Andorran Franc",
"Andorran Peseta", "Angolan Kwanza", "Angolan New Kwanza", "Argentine Peso",
"Armenian Dram", "Aruban Florin", "Australian Dollar", "Austrian Schilling",
"Azerbaijan Manat", "Azerbaijan New Manat", "Bahamian Dollar",
"Bahraini Dinar", "Bangladeshi Taka", "Barbados Dollar", "Belarusian Ruble",
"Belgian Franc", "Belize Dollar", "Bermudian Dollar", "Bhutan Ngultrum",
"Bolivian Boliviano", "Bosnian Mark", "Botswana Pula", "Brazilian Real",
"British Pound", "Brunei Dollar", "Bulgarian Lev", "Burundi Franc",
"CFA Franc BCEAO", "CFA Franc BEAC", "CFP Franc", "Cambodian Riel",
"Canadian Dollar", "Cape Verde Escudo", "Cayman Islands Dollar",
"Chilean Peso", "Chinese Yuan Renminbi", "Colombian Peso", "Comoros Franc",
"Congolese Franc", "Costa Rican Colon", "Croatian Kuna", "Cuban Convertible Peso",
"Cuban Peso", "Cyprus Pound", "Czech Koruna", "Danish Krone",
"Djibouti Franc", "Dominican R. Peso", "Dutch Guilder", "ECU",
"East Caribbean Dollar", "Ecuador Sucre", "Egyptian Pound", "El Salvador Colon",
"Estonian Kroon", "Ethiopian Birr", "Euro", "Falkland Islands Pound",
"Fiji Dollar", "Finnish Markka", "French Franc", "Gambian Dalasi",
"Georgian Lari", "German Mark", "Ghanaian Cedi", "Ghanaian New Cedi",
"Gibraltar Pound", "Gold (oz.)", "Greek Drachma", "Guatemalan Quetzal",
"Guinea Franc", "Guyanese Dollar", "Haitian Gourde", "Honduran Lempira",
"Hong Kong Dollar", "Hungarian Forint", "Iceland Krona", "Indian Rupee",
"Indonesian Rupiah", "Iranian Rial", "Iraqi Dinar", "Irish Punt",
"Israeli New Shekel", "Italian Lira", "Jamaican Dollar", "Japanese Yen",
"Jordanian Dinar", "Kazakhstan Tenge", "Kenyan Shilling", "Kuwaiti Dinar",
"Kyrgyzstanian Som", "Lao Kip", "Latvian Lats", "Lebanese Pound",
"Lesotho Loti", "Liberian Dollar", "Libyan Dinar", "Lithuanian Litas",
"Luxembourg Franc", "Macau Pataca", "Macedonian Denar", "Malagasy Ariary",
"Malagasy Franc", "Malawi Kwacha", "Malaysian Ringgit", "Maldive Rufiyaa",
"Maltese Lira", "Mauritanian Ouguiya", "Mauritius Rupee", "Mexican Peso",
"Moldovan Leu", "Mongolian Tugrik", "Moroccan Dirham", "Mozambique Metical",
"Mozambique New Metical", "Myanmar Kyat", "NL Antillian Guilder",
"Namibia Dollar", "Nepalese Rupee", "New Zealand Dollar", "Nicaraguan Cordoba Oro",
"Nigerian Naira", "North Korean Won", "Norwegian Kroner", "Omani Rial",
"Pakistan Rupee", "Palladium (oz.)", "Panamanian Balboa", "Papua New Guinea Kina",
"Paraguay Guarani", "Peruvian Nuevo Sol", "Philippine Peso",
"Platinum (oz.)", "Polish Zloty", "Portuguese Escudo", "Qatari Rial",
"Romanian Lei", "Romanian New Lei", "Russian Rouble", "Rwandan Franc",
"Samoan Tala", "Sao Tome/Principe Dobra", "Saudi Riyal", "Serbian Dinar",
"Seychelles Rupee", "Sierra Leone Leone", "Silver (oz.)", "Singapore Dollar",
"Slovak Koruna", "Slovenian Tolar", "Solomon Islands Dollar",
"Somali Shilling", "South African Rand", "South-Korean Won",
"Spanish Peseta", "Sri Lanka Rupee", "St. Helena Pound", "Sudanese Dinar",
"Sudanese Old Pound", "Sudanese Pound", "Suriname Dollar", "Suriname Guilder",
"Swaziland Lilangeni", "Swedish Krona", "Swiss Franc", "Syrian Pound",
"Taiwan Dollar", "Tanzanian Shilling", "Thai Baht", "Tonga Pa'anga",
"Trinidad/Tobago Dollar", "Tunisian Dinar", "Turkish Lira", "Turkish New Lira",
"Turkmenistan Manat", "Uganda Shilling", "Ukraine Hryvnia", "Uruguayan Peso",
"Utd. Arab Emir. Dirham", "Vanuatu Vatu", "Venezuelan Bolivar",
"Vietnamese Dong", "Yemeni Rial", "Yugoslav Dinar", "Zambian Kwacha",
"Zimbabwe Dollar")), .Names = "oanda.df.1.length.oanda.df...2....1.", row.names = c("USD",
"AFN", "ALL", "DZD", "ADF", "ADP", "AOA", "AON", "ARS", "AMD",
"AWG", "AUD", "ATS", "AZM", "AZN", "BSD", "BHD", "BDT", "BBD",
"BYR", "BEF", "BZD", "BMD", "BTN", "BOB", "BAM", "BWP", "BRL",
"GBP", "BND", "BGN", "BIF", "XOF", "XAF", "XPF", "KHR", "CAD",
"CVE", "KYD", "CLP", "CNY", "COP", "KMF", "CDF", "CRC", "HRK",
"CUC", "CUP", "CYP", "CZK", "DKK", "DJF", "DOP", "NLG", "XEU",
"XCD", "ECS", "EGP", "SVC", "EEK", "ETB", "EUR", "FKP", "FJD",
"FIM", "FRF", "GMD", "GEL", "DEM", "GHC", "GHS", "GIP", "XAU",
"GRD", "GTQ", "GNF", "GYD", "HTG", "HNL", "HKD", "HUF", "ISK",
"INR", "IDR", "IRR", "IQD", "IEP", "ILS", "ITL", "JMD", "JPY",
"JOD", "KZT", "KES", "KWD", "KGS", "LAK", "LVL", "LBP", "LSL",
"LRD", "LYD", "LTL", "LUF", "MOP", "MKD", "MGA", "MGF", "MWK",
"MYR", "MVR", "MTL", "MRO", "MUR", "MXN", "MDL", "MNT", "MAD",
"MZM", "MZN", "MMK", "ANG", "NAD", "NPR", "NZD", "NIO", "NGN",
"KPW", "NOK", "OMR", "PKR", "XPD", "PAB", "PGK", "PYG", "PEN",
"PHP", "XPT", "PLN", "PTE", "QAR", "ROL", "RON", "RUB", "RWF",
"WST", "STD", "SAR", "RSD", "SCR", "SLL", "XAG", "SGD", "SKK",
"SIT", "SBD", "SOS", "ZAR", "KRW", "ESP", "LKR", "SHP", "SDD",
"SDP", "SDG", "SRD", "SRG", "SZL", "SEK", "CHF", "SYP", "TWD",
"TZS", "THB", "TOP", "TTD", "TND", "TRL", "TRY", "TMM", "UGX",
"UAH", "UYU", "AED", "VUV", "VEB", "VND", "YER", "YUN", "ZMK",
"ZWD"), class = "data.frame")
quantmod/R/addTA.R 0000644 0001762 0000144 00000157640 15002467345 013426 0 ustar ligges users #
# At present all TA functionality is in this file
#
# TA implemented and charting optimized:
#
# BBands,CCI,CMF,CMO,DPO,EMA,Envelope,MACD,Momentum,
# RSI,SMA,SMI,Vo,WPR
# TA implemented, charting not completed/optimized:
#
# ADX,ATR,DEMA,EVWMA,Expiry,Lines,ROC,SAR,TRIX,WMA,ZLEMA
# TA not yet implemented (and some may not be)
#
# CLV,CMD,OBV,KST,TDI,WHF,Aroon,ChAD,ChVol,WilliamsAD,
# Points, Stoch, SD, ...???
# addMomentum {{{
`addMomentum` <- function(n=1) {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- TRUE
# needs to accept any arguments for x, not just close
xx <- if(is.OHLC(x)) {
Cl(x)
} else x
mom <- momentum(xx,n=n)
chobTA@TA.values <- mom[lchob@xsubset]
chobTA@name <- "chartMomentum"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} #}}}
# chartMomentum {{{
`chartMomentum` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
n <- x@params$n
mom <- x@TA.values
y.range <- seq(-max(abs(mom),na.rm=TRUE),max(abs(mom),na.rm=TRUE),
length.out=length(x.range)) * 1.05
plot(x.range,y.range,
type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
COLOR <- "#0033CC"
abline(h=0,col="#666666",lwd=1,lty='dotted')
lines(seq(1,length(x.range),by=spacing),mom,col=COLOR,lwd=2,type='l')
text(0, last(y.range)*.9,
paste("Momentum (", x@params$n, "):"),pos=4)
text(0, last(y.range)*.9,
paste("\n\n\n",sprintf("%.2f",last(mom)),sep=''),
col = COLOR, pos = 4)
axis(2)
box(col=x@params$colors$fg.col)
} # }}}
# addCCI {{{
`addCCI` <- function(n=20, maType="SMA", c=0.015) {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- TRUE
xx <- if(is.OHLC(x)) {
cbind(Hi(x),Lo(x),Cl(x))
} else x
cci <- CCI(xx,n=n,maType=maType,c=c)
chobTA@TA.values <- cci[lchob@xsubset]
chobTA@name <- "chartCCI"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n,maType=maType,c=c)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} #}}}
# chartCCI {{{
`chartCCI` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
n <- x@params$n
cci <- x@TA.values
y.range <- seq(-max(abs(cci),na.rm=TRUE),
max(abs(cci),na.rm=TRUE),
length.out=length(x.range))*1.05
plot(x.range,y.range,
type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
usr <- par('usr')
# draw shading in -100:100 y-range
rect(usr[1],-100,usr[2],100,col=x@params$colors$BBands$fill)
# fill upper and lower areas
xx <- seq(1,length(x.range),by=spacing)
cci.above <- ifelse(cci >= 100,cci, 100)
cci.below <- ifelse(cci <= -100,cci,-100)
polygon(c(xx,rev(xx)),c(cci.above,rep(100,length(xx))),col="red")
polygon(c(xx,rev(xx)),c(cci.below,rep(-100,length(xx))),col="red")
# draw CCI
lines(seq(1,length(x.range),by=spacing),cci,col='red',lwd=1,type='l')
# draw dotted guide line at 0
abline(h=0,col='#666666',lwd=1,lty='dotted')
# add indicator name and last value
text(0, last(y.range)*.9,
paste("Commodity Channel Index (", x@params$n, ",",
x@params$c,"):",sep=''),pos=4)
text(0, last(y.range)*.9,
paste("\n\n\n",sprintf("%.2f",last(cci)),sep=''), col = 'red',
pos = 4)
axis(2)
box(col=x@params$colors$fg.col)
} # }}}
# addADX {{{
`addADX` <- function(n=14, maType="EMA", wilder=TRUE) {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- TRUE
if(!is.OHLC(x)) stop("only applicable to HLC series")
adx <- ADX(cbind(Hi(x),Lo(x),Cl(x)),n=n,maType=maType,wilder=wilder)
chobTA@TA.values <- adx[lchob@xsubset,]
chobTA@name <- "chartADX"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n,maType=maType,wilder=wilder)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} #}}}
# chartADX {{{
`chartADX` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
n <- x@params$n
adx <- x@TA.values
plot(x.range,seq(min(adx[,4]*.975,na.rm=TRUE),
max(adx[,4]*1.05,na.rm=TRUE),length.out=length(x.range)),
type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
# draw DIp
lines(seq(1,length(x.range),by=spacing),adx[,1],col='green',lwd=1,type='l')
# draw DIn
lines(seq(1,length(x.range),by=spacing),adx[,2],col='red',lwd=1,type='l')
# draw ADX
lines(seq(1,length(x.range),by=spacing),adx[,4],col='blue',lwd=2,type='l')
# draw upper and lower guidelines
abline(h=20,col='#666666',lwd=1,lty='dotted')
abline(h=40,col='#666666',lwd=1,lty='dotted')
#title(ylab=paste('SMI(',paste(param,collapse=','),')',sep=''))
axis(2)
box(col=x@params$colors$fg.col)
} # }}}
# addATR {{{
`addATR` <- function(n=14, maType="EMA", ...) {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- TRUE
if(!is.OHLC(x)) stop("only applicable to HLC series")
atr <- ATR(cbind(Hi(x),Lo(x),Cl(x)),n=n,maType=maType,...)
chobTA@TA.values <- atr[lchob@xsubset,]
chobTA@name <- "chartATR"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n,maType=maType)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} #}}}
# chartATR {{{
`chartATR` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
n <- x@params$n
atr <- x@TA.values
plot(x.range,seq(min(atr[,2]*.975,na.rm=TRUE),
max(atr[,2]*1.05,na.rm=TRUE),length.out=length(x.range)),
type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
# draw ADX
lines(seq(1,length(x.range),by=spacing),atr[,2],col='blue',lwd=2,type='l')
axis(2)
box(col=x@params$colors$fg.col)
} # }}}
# addTRIX {{{
`addTRIX` <- function(n=20, signal=9, maType="EMA", percent=TRUE) {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- TRUE
xx <- if(is.OHLC(x)) {
Cl(x)
} else x
trix <- TRIX(xx,n=n,nSig=signal,maType=maType,percent=percent)
chobTA@TA.values <- trix[lchob@xsubset,]
chobTA@name <- "chartTRIX"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n,signal=signal,maType=maType,percent=percent)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} #}}}
# chartTRIX {{{
`chartTRIX` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
n <- x@params$n
trix <- x@TA.values
plot(x.range,seq(min(trix[,1]*.975,na.rm=TRUE),
max(trix[,1]*1.05,na.rm=TRUE),length.out=length(x.range)),
type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
# draw TRIX
lines(seq(1,length(x.range),by=spacing),trix[,1],col='green',lwd=1,type='l')
# draw Signal
lines(seq(1,length(x.range),by=spacing),trix[,2],col='#999999',lwd=1,type='l')
axis(2)
box(col=x@params$colors$fg.col)
} # }}}
# addDPO {{{
`addDPO` <- function(n=10, maType="EMA", shift=n/2+1, percent=FALSE) {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- TRUE
# should really allow for _any_ series to be used, like MA (FIXME)
xx <- if(is.OHLC(x)) {
Cl(x)
} else x
dpo <- DPO(xx,n=n,maType=maType,shift=shift,percent=percent)
chobTA@TA.values <- dpo[lchob@xsubset]
chobTA@name <- "chartDPO"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n,maType=maType,shift=shift,percent=percent)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} #}}}
# chartDPO {{{
`chartDPO` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
n <- x@params$n
dpo <- x@TA.values
y.range <- seq(-max(abs(dpo), na.rm = TRUE), max(abs(dpo),
na.rm = TRUE), length.out = length(x.range)) * 1.05
if(x@new) {
plot(x.range,y.range,
type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
}
xx <- seq(1,length(x.range),by=spacing)
dpo.tmp <- dpo
dpo.tmp[is.na(dpo)] <- 0
dpo.positive <- ifelse(dpo.tmp >= 0,dpo.tmp,0)
dpo.negative <- ifelse(dpo.tmp < 0,dpo.tmp,0)
polygon(c(xx,rev(xx)),c(dpo.positive,rep(0,length(dpo))),col=x@params$colors$up.col)
polygon(c(xx,rev(xx)),c(dpo.negative,rep(0,length(dpo))),col=x@params$colors$dn.col)
abline(h=0,col="#999999")
text(0, last(y.range)*.9,
paste("De-trended Price Oscillator (", x@params$n,"):", sep = ""),
pos = 4)
text(0, last(y.range)*.9,
paste("\n\n\n",sprintf("%.3f",last(na.omit(dpo))), sep = ""),
col = ifelse(last(dpo) > 0,x@params$colors$up.col,x@params$colors$dn.col),
pos = 4)
axis(2)
box(col=x@params$colors$fg.col)
# y.range <- seq(-max(abs(dpo), na.rm = TRUE), max(abs(dpo),
# na.rm = TRUE), length.out = length(x.range)) * 1.05
# plot(x.range, y.range, type = "n", axes = FALSE, ann = FALSE)
#
# grid(NA,NULL,col=x@params$colors$grid.col)
#
# # draw DPO
# lines(seq(1,length(x.range),by=spacing),dpo,col='green',lwd=1,type='l')
#
# #title(ylab=paste('SMI(',paste(param,collapse=','),')',sep=''))
# axis(2)
# box(col=x@params$colors$fg.col)
} # }}}
# addRSI {{{
`addRSI` <- function(n=14,maType='EMA',wilder=TRUE) {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- TRUE
xx <- if(is.OHLC(x)) {
Cl(x)
} else x
rsi <- RSI(xx,n=n,maType=maType,wilder=wilder)
chobTA@TA.values <- rsi[lchob@xsubset]
chobTA@name <- "chartRSI"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n, wilder=wilder,maType=maType)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} #}}}
# chartRSI {{{
`chartRSI` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
param <- x@params$param; ma.type <- x@params$ma.type
rsi <- x@TA.values
y.range <- seq(min(rsi,na.rm=TRUE)*.975,max(rsi,na.rm=TRUE)*1.05,
length.out=length(x.range))
if(x@new) {
plot(x.range,y.range,type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
}
lines(seq(1,length(x.range),by=spacing),rsi,col='#0033CC',lwd=2,type='l')
lines(seq(1,length(x.range),by=spacing),rsi,col='#BFCFFF',lwd=1,lty='dotted',type='l')
text(0, last(y.range)*.9,
paste("Relative Strength Index (", x@params$n,"):", sep = ""),
pos = 4)
text(0, last(y.range)*.9,
paste("\n\n\n",sprintf("%.3f",last(rsi)), sep = ""), col = '#0033CC',
pos = 4)
axis(2)
box(col=x@params$colors$fg.col)
} # }}}
# addROC {{{
`addROC` <- function(n=1,type=c('discrete','continuous'),col='red') {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- TRUE
xx <- if(is.OHLC(x)) {
Cl(x)
} else x
type <- match.arg(type)
roc <- ROC(xx,n=n,type=type,na.pad=TRUE)
chobTA@TA.values <- roc[lchob@xsubset]
chobTA@name <- "chartROC"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n,type=type,col=col)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} #}}}
# chartROC {{{
`chartROC` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
#param <- x@params$param; ma.type <- x@params$ma.type
roc <- x@TA.values
if(x@new) {
plot(x.range,seq(min(roc*.975,na.rm=TRUE),max(roc*1.05,na.rm=TRUE),length.out=length(x.range)),
type='n',axes=FALSE,ann=FALSE)
grid(NA,NULL,col=x@params$colors$grid.col)
}
lines(seq(1,length(x.range),by=spacing),roc,col=x@params$col,lwd=2,type='l')
#title(ylab=paste('RSI(',paste(c(n.up,collapse=','),')',sep=''))
axis(2)
box(col=x@params$colors$fg.col)
} # }}}
# addBBands {{{
`addBBands` <- function(n=20,sd=2,maType='SMA',draw='bands',on=-1) {
draw.options <- c('bands','percent','width')
draw <- draw.options[pmatch(draw,draw.options)]
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
if(draw=='bands') {
chobTA@new <- FALSE
} else {
chobTA@new <- TRUE
on <- NULL
}
xx <- if(is.OHLC(x)) {
cbind(Hi(x),Lo(x),Cl(x))
} else x
bb <- BBands(xx,n=n,maType=maType,sd=sd)
chobTA@TA.values <- bb[lchob@xsubset,]
chobTA@name <- "chartBBands"
chobTA@call <- match.call()
chobTA@on <- on
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n,ma=maType,sd=sd,
draw=draw)
return(chobTA)
} #}}}
# chartBBands {{{
`chartBBands` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
bband.col <- ifelse(!is.null(x@params$colors$BBands$col),
x@params$colors$BBands$col,'red')
bband.fill <- ifelse(!is.null(x@params$colors$BBands$fill),
x@params$colors$BBands$fill,x@params$colors$bg.col)
# bband col vector
# lower.band, middle.band, upper.band, %b, bb.width
if(length(bband.col) == 1) # no user specified
bband.col <- c(bband.col,'grey',rep(bband.col,3))
param <- x@params$param; ma.type <- x@params$ma.type
bb <- x@TA.values
if(x@params$draw == 'bands') {
# draw Bollinger Bands on price chart
if(x@on[1] > 0) {
lines(seq(1,length(x.range),by=spacing),
bb[,1],col=bband.col[1],lwd=1,lty='dashed')
lines(seq(1,length(x.range),by=spacing),
bb[,3],col=bband.col[3],lwd=1,lty='dashed')
lines(seq(1,length(x.range),by=spacing),
bb[,2],col=bband.col[2],lwd=1,lty='dotted')
} else {
xx <- seq(1,length(x.range),by=spacing)
polygon(c(xx,rev(xx)),
c(bb[,1],rev(bb[,3])),col=bband.fill,border=NA)
lines(seq(1,length(x.range),by=spacing),
bb[,1],col=bband.col[1],lwd=1,lty='dashed')
lines(seq(1,length(x.range),by=spacing),
bb[,3],col=bband.col[3],lwd=1,lty='dashed')
lines(seq(1,length(x.range),by=spacing),
bb[,2],col=bband.col[2],lwd=1,lty='dotted')
}
# return the text to be pasted
legend.text <- list()
legend.text[[1]] <- list(legend=paste("Bollinger Bands (",
paste(x@params$n,x@params$sd,sep=","),") [Upper/Lower]: ",
sprintf("%.3f",last(bb[,3])),"/",
sprintf("%.3f",last(bb[,1])), sep = ""),
text.col = bband.col[3])
invisible(legend.text)
} else
if(x@params$draw == 'percent') {
# draw %B in new frame
y.range <- seq(min(bb[,4], na.rm = TRUE) * .9,
max(abs(bb[,4]), na.rm = TRUE) * 1.05,
length.out = length(x.range))
plot(x.range, y.range, type = "n", axes = FALSE, ann = FALSE)
grid(NA,NULL,col=x@params$colors$grid.col)
lines(seq(1,length(x.range),by=spacing), bb[,4],
col=bband.col[4],lwd=1)
text(0,last(y.range) * .9, paste("Bollinger %b (",
paste(x@params$n,x@params$sd,sep=","), "): ",
sep=""), pos=4)
text(0,last(y.range) * .9, paste("\n\n\n",
sprintf("%.3f",last(bb[,4])), sep = ""),
pos=4, col=bband.col[4])
axis(2)
box(col = x@params$colors$fg.col)
} else {
# draw width in new frame
# (high band - low band) / middle band
bbw <- (bb[,3] - bb[,1]) / bb[,2]
y.range <- seq(min(bbw, na.rm = TRUE) * .9,
max(abs(bbw), na.rm = TRUE) * 1.05,
length.out = length(x.range))
plot(x.range, y.range, type = "n", axes = FALSE, ann = FALSE)
grid(NA,NULL,col=x@params$colors$grid.col)
lines(seq(1,length(x.range),by=spacing), bbw,
col=bband.col[5],lwd=1)
text(0,last(y.range) * .9, paste("Bollinger Band Width (",
paste(x@params$n,x@params$sd,sep=","), "): ",
sep=""), pos=4)
text(0,last(y.range) * .9, paste("\n\n\n",
sprintf("%.3f",last(bbw)), sep = ""),
pos=4, col=bband.col[5])
axis(2)
box(col = x@params$colors$fg.col)
}
} # }}}
# addEnvelope {{{
`addEnvelope` <- function(n=20,p=2.5,maType='SMA',...,on=1) {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- FALSE
xx <- if(is.OHLC(x)) {
Cl(x)
} else x
ma <- do.call(maType,list(xx,n=n,...))
mae <- cbind(ma*(1-p/100),ma,ma*(1+p/100))
chobTA@TA.values <- mae[lchob@xsubset,]
chobTA@name <- "chartEnvelope"
chobTA@call <- match.call()
chobTA@on <- on
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
n=n,p=p,maType=maType)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} #}}}
# chartEnvelope {{{
`chartEnvelope` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
mae <- x@TA.values
if(x@on[1] > 0) {
lines(seq(1,length(x.range),by=spacing),mae[,1],col='blue',lwd=1,lty='dotted')
lines(seq(1,length(x.range),by=spacing),mae[,3],col='blue',lwd=1,lty='dotted')
#lines(seq(1,length(x.range),by=spacing),mae[,2],col='grey',lwd=1,lty='dotted')
} else {
xx <- seq(1,length(x.range),by=spacing)
polygon(c(xx,rev(xx)), c(mae[,1],rev(mae[,3])),col='#282828',border=NA)
lines(seq(1,length(x.range),by=spacing),mae[,1],col='blue',lwd=1,lty='dotted')
lines(seq(1,length(x.range),by=spacing),mae[,3],col='blue',lwd=1,lty='dotted')
#lines(seq(1,length(x.range),by=spacing),mae[,2],col='grey',lwd=1,lty='dotted')
}
# return the text to be pasted
txt <- list()
txt[[1]] <- list(text=paste("Moving Ave. Envelope (",
paste(x@params$n,x@params$p,sep=","),") [Upper/Lower]: ",
sprintf("%.3f",last(mae[,3])),"/",
sprintf("%.3f",last(mae[,1])), sep = ""), col = 'blue')
invisible(txt)
} # }}}
# addSAR {{{
`addSAR` <- function(accel=c(0.02,0.2),col='blue') {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- FALSE
if(!is.OHLC(x)) stop("SAR requires HL series")
sar <- SAR(cbind(Hi(x),Lo(x)),accel=accel)
chobTA@TA.values <- sar[lchob@xsubset]
chobTA@name <- "chartSAR"
chobTA@call <- match.call()
chobTA@on <- 1
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
accel=accel,col=col)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} #}}}
# chartSAR {{{
`chartSAR` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
sar <- x@TA.values
points(seq(1,length(x.range),by=spacing),sar,col=x@params$col,cex=0.5)
} # }}}
# addMACD {{{
`addMACD` <- function(fast=12,slow=26,signal=9,type='EMA',histogram=TRUE,col) {
lchob <- get.current.chob()
x <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- TRUE
if(missing(col)) {
col <- c('#999999','#777777', '#BBBBBB','#FF0000')
}
xx <- if(is.OHLC(x)) {
Cl(x)
} else x
macd <- MACD(xx,nFast=fast,nSlow=slow,nSig=signal,maType=type)
chobTA@TA.values <- macd[lchob@xsubset,]
chobTA@name <- "chartMACD"
chobTA@call <- match.call()
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
fast=fast,slow=slow,signal=signal,
col=col,histo=histogram
)
return(chobTA)
} #}}}
# chartMACD {{{
`chartMACD` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
col <- x@params$col
macd <- x@TA.values
y.range <- seq(-max(abs(macd),na.rm=TRUE),max(abs(macd),na.rm=TRUE),
length.out=length(x.range)) * 1.05
if(x@new) {
plot(x.range,y.range,type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
grid(NA,NULL,col=x@params$colors$grid.col)
}
if(x@params$histo) {
x.pos <- 1 + spacing * (1:NROW(macd) -1)
cols <- ifelse((macd[,1]-macd[,2]) > 0, col[1],col[2])
rect(x.pos - spacing/5,0,x.pos + spacing/5, macd[,1]-macd[,2],
col=cols,border=cols)
}
lines(seq(1,length(x.range),by=spacing),macd[,1],col=col[3],lwd=1)
lines(seq(1,length(x.range),by=spacing),macd[,2],col=col[4],lwd=1,lty='dotted')
legend("topleft",
legend=c(paste("Moving Average Convergence Divergence (",
paste(x@params$fast,x@params$slow,x@params$signal,sep=','),"):", sep = ""),
paste("MACD:",sprintf("%.3f",last(macd[,1]))),
paste("Signal:",sprintf("%.3f",last(macd[,2])))),
text.col=c(x@params$colors$fg.col, col[3], col[4]), bty='n', y.intersp=0.95)
# text(0, last(y.range)*.9,
# paste("Moving Average Convergence Divergence (",
# paste(x@params$fast,x@params$slow,x@params$signal,sep=','),"):", sep = ""),
# pos = 4)
# text(0, last(y.range)*.9,
# paste("\n\n\nMACD: ",sprintf("%.3f",last(macd[,1])), sep = ""),
# col = col[3],pos = 4)
# text(0, last(y.range)*.9,
# paste("\n\n\n\n\n\nSignal: ",sprintf("%.3f",last(macd[,2])), sep = ""),
# col = col[4],pos = 4)
axis(2)
box(col=x@params$colors$fg.col)
} # }}}
# addShading {{{
`addShading` <- function(when,on=-1,overlay=TRUE,col='blue') {
lchob <- get.current.chob()
chobTA <- new("chobTA")
chobTA@new <- !overlay
x <- lchob@xdata
i <- when
tclass(x) <- "POSIXct"
POSIXindex <- index(x)
if (missing(i))
i <- 1:NROW(x)
if (timeBased(i))
i <- as.character(as.POSIXct(i))
if (is.character(i)) {
i <- strsplit(i, ';')[[1]]
i.tmp <- NULL
for (ii in i) {
if (!identical(grep("::", ii), integer(0))) {
dates <- strsplit(ii, "::")[[1]]
first.time <- ifelse(dates[1] == "", POSIXindex[1],
do.call("firstof", as.list(as.numeric(strsplit(dates[1],
":|-|/| ")[[1]]))))
last.time <- ifelse(length(dates) == 1, POSIXindex[length(POSIXindex)],
do.call("lastof", as.list(as.numeric(strsplit(dates[2],
":|-|/| ")[[1]]))))
}
else {
dates <- ii
first.time <- do.call("firstof", as.list(as.numeric(strsplit(dates,
":|-|/| ")[[1]])))
last.time <- do.call("lastof", as.list(as.numeric(strsplit(dates,
":|-|/| ")[[1]])))
}
i.tmp <- c(i.tmp, which(POSIXindex <= last.time &
POSIXindex >= first.time))
}
i <- i.tmp
}
xstart <- unique(c(i[1],i[which(diff(i) != 1)+1]))
xend <- unique(c(i[which(diff(i) != 1)-1], rev(i)[1]))
chobTA@TA.values <- x
chobTA@name <- "chartShading"
chobTA@call <- match.call()
chobTA@on <- on # used for deciding when to draw...
chobTA@params <- list(xrange=lchob@xrange,
yrange=lchob@yrange,
colors=lchob@colors,
spacing=lchob@spacing,
width=lchob@width,
xsubset=lchob@xsubset,
time.scale=lchob@time.scale,
xstart=xstart,xend=xend
)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} # }}}
# chartShading {{{
`chartShading` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
y.range <- x@params$yrange
xstart <- x@params$xstart
xend <- x@params$xend
rect(((xstart-1)*spacing+1)-width/2, rep(y.range[1]*.95,length(xstart)),
((xend-1)*spacing+1)+width/2, rep(y.range[2]*1.05,length(xend)),
col=c(x@params$colors$BBands$fill),border=NA)
#abline(v=(x@params$v-1)*spacing+1,col=x@params$col)
} # }}}
# addLines {{{
`addLines` <- function(x,h,v,on=1,overlay=TRUE,col='blue') {
if(missing(x)) x <- NULL
if(missing(h)) h <- NULL
if(missing(v)) v <- NULL
lchob <- get.current.chob()
chobTA <- new("chobTA")
chobTA@new <- !overlay
chobTA@TA.values <- NULL # single numeric vector
chobTA@name <- "chartLines"
chobTA@call <- match.call()
chobTA@on <- on # used for deciding when to draw...
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
col=col,h=h,x=x,v=v)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} # }}}
# chartLines {{{
`chartLines` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
if(!is.null(x@params$x)) {
# draw lines given positions specified in x
lines(x=(x@params$x-1)*spacing+1,col=x@params$col)
}
if(!is.null(x@params$h)) {
# draw horizontal lines given positions specified in h
abline(h=x@params$h,col=x@params$col)
}
if(!is.null(x@params$v)) {
# draw vertical lines given positions specified in v
abline(v=(x@params$v-1)*spacing+1,col=x@params$col)
}
} # }}}
# addPoints {{{
`addPoints` <- function(x,y=NULL,type='p',pch=20,
offset=1,col=2,bg=2,cex=1,
on=1,overlay=TRUE) {
lchob <- get.current.chob()
xdata <- as.matrix(lchob@xdata)
chobTA <- new("chobTA")
chobTA@new <- !overlay
chobTA@TA.values <- xdata[lchob@xsubset,]
chobTA@name <- "chartPoints"
chobTA@call <- match.call()
chobTA@on <- on # used for deciding when to draw...
if(missing(bg)) bg <- col
xsubset <- x %in% lchob@xsubset
if(NROW(x) != NROW(y)) stop('x and y must be of equal lengths')
x <- x[xsubset]
if(!is.null(y))
y <- y[xsubset]
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
subset=lchob@xsubset,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
x=x,y=y,type=type,offset=offset,
pch=pch,col=col,bg=bg,cex=cex)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} # }}}
# chartPoints {{{
`chartPoints` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
xdata <- x@TA.values
x.points <- which(x@params$subset %in% x@params$x)
y.points <- x@params$y
type <- x@params$type
offset <- x@params$offset
pch <- x@params$pch
col <- x@params$col
bg <- x@params$bg
cex <- x@params$cex
# if OHLC and above - get Hi, else Lo
# if univariate - get value
y.data <- if(is.OHLC(xdata)) {
if(offset > 1) {
Hi(xdata)
} else Lo(xdata)
} else xdata
if(is.null(y.points)) y.points <- y.data[x.points] * offset
points(x=(x.points-1) * spacing + 1, y=y.points,
type=type,pch=pch,col=col,bg=bg,cex=cex)
} # }}}
# addEMA {{{
`addEMA` <- function(n=10,wilder=FALSE,ratio=NULL,on=1,with.col=Cl,overlay=TRUE,col='blue') {
lchob <- get.current.chob()
chobTA <- new("chobTA")
chobTA@new <- !overlay
# get the appropriate data - from the approp. src
if(on==1) {
x <- as.matrix(lchob@xdata)
if(!is.OHLC(x) && missing(with.col)) with.col <- 1
if(is.function(with.col)) {
x.tmp <- do.call(with.col,list(x))
} else x.tmp <- x[,with.col]
} else {
# get values from TA...
which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new))
target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]]
x <- as.matrix(target.TA@TA.values)
if(missing(with.col)) with.col <- 1
if(is.function(with.col)) {
x.tmp <- do.call(with.col,list(x))
} else x.tmp <- x[,with.col]
}
ma.tmp <- NULL
for(i in 1:length(n)) {
ma <- EMA(x.tmp,n=n[i],wilder=wilder[1],
ratio=ratio[1])
ma.tmp <- cbind(ma.tmp,ma)
}
chobTA@TA.values <- matrix(ma.tmp[lchob@xsubset,],ncol=NCOL(ma.tmp))
chobTA@name <- "chartEMA"
chobTA@call <- match.call()
chobTA@on <- on # used for deciding when to draw...
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
col=col,n=n,wilder=wilder,ratio=ratio)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} # }}}
# chartEMA {{{
`chartEMA` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
if(length(x@params$n) != length(x@params$col)) {
colors <- 3:10
} else colors <- x@params$col
chart.key <- list()
for(li in 1:length(x@params$n)) {
ma <- x@TA.values[,li]
if(x@new) {
par(new=TRUE)
plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)),
type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
# title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep=''))
axis(2)
box(col=x@params$colors$fg.col)
}
lines(seq(1,length(x.range),by=spacing),ma,col=colors[li],lwd=1,type='l')
chart.key[[li]] <- list(text=paste("EMA (",
paste(x@params$n[li],sep=","),"): ",
sprintf("%.3f",last(ma)),
sep = ""), col = colors[li])
}
invisible(chart.key)
} # }}}
# addSMA {{{
`addSMA` <- function(n=10,on=1,with.col=Cl,overlay=TRUE,col='brown') {
lchob <- get.current.chob()
chobTA <- new("chobTA")
chobTA@new <- !overlay
# get the appropriate data - from the approp. src
if(on==1) {
x <- as.matrix(lchob@xdata)
if(!is.OHLC(x) && missing(with.col)) with.col <- 1
if(is.function(with.col)) {
x.tmp <- do.call(with.col,list(x))
} else x.tmp <- x[,with.col]
} else {
# get values from TA...
which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new))
target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]]
x <- as.matrix(target.TA@TA.values)
if(missing(with.col)) with.col <- 1
if(is.function(with.col)) {
x.tmp <- do.call(with.col,list(x))
} else x.tmp <- x[,with.col]
}
ma.tmp <- NULL
for(i in 1:length(n)) {
ma <- SMA(x.tmp,n=n[i])
ma.tmp <- cbind(ma.tmp,ma)
}
chobTA@TA.values <- matrix(ma.tmp[lchob@xsubset,],ncol=NCOL(ma.tmp)) # single numeric vector
chobTA@name <- "chartSMA"
chobTA@call <- match.call()
chobTA@on <- on # used for deciding when to draw...
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
col=col,n=n)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} # }}}
# chartSMA {{{
`chartSMA` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
if(length(x@params$n) != length(x@params$col)) {
colors <- c(4:10,3)
} else colors <- x@params$col
chart.key <- list()
for(li in 1:length(x@params$n)) {
ma <- x@TA.values[,li]
if(x@new) {
par(new=TRUE)
plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)),
type='n',axes=FALSE,ann=FALSE)
coords <- par('usr')
rect(coords[1],coords[3],coords[2],coords[4],col=x@params$colors$area)
#title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep=''))
axis(2)
box(col=x@params$colors$fg.col)
}
lines(seq(1,length(x.range),by=spacing),ma,col=colors[li],lwd=1,type='l')
chart.key[[li]] <- list(text = paste("SMA (", paste(x@params$n[li],
sep = ","), "): ", sprintf("%.3f", last(ma)), sep = ""),
col = colors[li])
}
invisible(chart.key)
} # }}}
# addWMA {{{
`addWMA` <- function(n=10,wts=1:n,on=1,with.col=Cl,overlay=TRUE,col='green') {
lchob <- get.current.chob()
chobTA <- new("chobTA")
chobTA@new <- !overlay
# get the appropriate data - from the approp. src
if(on==1) {
x <- as.matrix(lchob@xdata)
if(!is.OHLC(x) && missing(with.col)) with.col <- 1
if(is.function(with.col)) {
x.tmp <- do.call(with.col,list(x))
} else x.tmp <- x[,with.col]
} else {
# get values from TA...
which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new))
target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]]
x <- as.matrix(target.TA@TA.values)
if(missing(with.col)) with.col <- 1
if(is.function(with.col)) {
x.tmp <- do.call(with.col,list(x))
} else x.tmp <- x[,with.col]
}
chobTA@TA.values <- x.tmp[lchob@xsubset]
chobTA@name <- "chartWMA"
chobTA@call <- match.call()
chobTA@on <- on # used for deciding when to draw...
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
col=col,n=n,wts=wts)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} # }}}
# chartWMA {{{
`chartWMA` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
if(length(x@params$n) < length(x@params$col)) {
colors <- 3:10
} else colors <- x@params$col
for(li in 1:length(x@params$n)) {
ma <- WMA(x@TA.values,n=x@params$n[li],wts=x@params$wts)
if(x@new) {
par(new=TRUE)
plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)),
type='n',axes=FALSE,ann=FALSE)
title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep=''))
axis(2)
box(col=x@params$colors$fg.col)
}
lines(seq(1,length(x.range),by=spacing),ma,col=colors[li],lwd=1,type='l')
}
} # }}}
# addDEMA {{{
`addDEMA` <- function(n=10,on=1,with.col=Cl,overlay=TRUE,col='pink') {
lchob <- get.current.chob()
chobTA <- new("chobTA")
chobTA@new <- !overlay
# get the appropriate data - from the approp. src
if(on==1) {
x <- as.matrix(lchob@xdata)
if(!is.OHLC(x) && missing(with.col)) with.col <- 1
if(is.function(with.col)) {
x.tmp <- do.call(with.col,list(x))
} else x.tmp <- x[,with.col]
} else {
# get values from TA...
which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new))
target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]]
x <- as.matrix(target.TA@TA.values)
if(missing(with.col)) with.col <- 1
if(is.function(with.col)) {
x.tmp <- do.call(with.col,list(x))
} else x.tmp <- x[,with.col]
}
chobTA@TA.values <- x.tmp[lchob@xsubset]
chobTA@name <- "chartDEMA"
chobTA@call <- match.call()
chobTA@on <- on # used for deciding when to draw...
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
col=col,n=n)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} # }}}
# chartDEMA {{{
`chartDEMA` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
if(length(x@params$n) < length(x@params$col)) {
colors <- 3:10
} else colors <- x@params$col
for(li in 1:length(x@params$n)) {
ma <- DEMA(x@TA.values,n=x@params$n[li])
if(x@new) {
par(new=TRUE)
plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)),
type='n',axes=FALSE,ann=FALSE)
title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep=''))
axis(2)
box(col=x@params$colors$fg.col)
}
lines(seq(1,length(x.range),by=spacing),ma,col=colors[li],lwd=1,type='l')
}
} # }}}
# addEVWMA {{{
`addEVWMA` <- function(n=10,on=1,with.col=Cl,overlay=TRUE,col='yellow') {
lchob <- get.current.chob()
chobTA <- new("chobTA")
chobTA@new <- !overlay
# get the appropriate data - from the approp. src
if(on==1) {
x <- as.matrix(lchob@xdata)
if(!is.OHLC(x) && missing(with.col)) with.col <- 1
if(is.function(with.col)) {
x.tmp <- cbind(do.call(with.col,list(x)),Vo(x))
} else x.tmp <- x[,with.col]
} else {
# get values from TA...
which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new))
target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]]
x <- as.matrix(target.TA@TA.values)
if(missing(with.col)) with.col <- 1
if(is.function(with.col)) {
x.tmp <- do.call(with.col,list(x))
} else x.tmp <- x[,with.col]
}
if(!has.Vo(x)) return()
chobTA@TA.values <- cbind(x.tmp,Vo(x))[lchob@xsubset,] # Price + Volume
chobTA@name <- "chartEVWMA"
chobTA@call <- match.call()
chobTA@on <- on # used for deciding when to draw...
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
col=col,n=n)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} # }}}
# chartEVWMA {{{
`chartEVWMA` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
if(length(x@params$n) < length(x@params$col)) {
colors <- 3:10
} else colors <- x@params$col
for(li in 1:length(x@params$n)) {
ma <- EVWMA(x@TA.values[,1],x@TA.values[,2],n=x@params$n[li])
if(x@new) {
par(new=TRUE)
plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)),
type='n',axes=FALSE,ann=FALSE)
title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep=''))
axis(2)
box(col=x@params$colors$fg.col)
}
lines(seq(1,length(x.range),by=spacing),ma,col=colors[li],lwd=1,type='l')
}
} # }}}
# addZLEMA {{{
`addZLEMA` <- function(n=10,ratio=NULL,on=1,with.col=Cl,overlay=TRUE,col='red') {
lchob <- get.current.chob()
chobTA <- new("chobTA")
chobTA@new <- !overlay
# get the appropriate data - from the approp. src
if(on==1) {
x <- as.matrix(lchob@xdata)
if(!is.OHLC(x) && missing(with.col)) with.col <- 1
if(is.function(with.col)) {
x.tmp <- do.call(with.col,list(x))
} else x.tmp <- x[,with.col]
} else {
# get values from TA...
which.TA <- which(sapply(lchob@passed.args$TA,function(x) x@new))
target.TA <- eval(lchob@passed.args$TA[which.TA][on-1])[[1]]
if(missing(with.col)) with.col <- 1
x <- as.matrix(target.TA@TA.values)
if(missing(with.col)) {
warning('missing "with.col" argument')
invisible(return())
}
if(is.function(with.col)) {
x.tmp <- do.call(with.col,list(x))
} else x.tmp <- x[,with.col]
}
chobTA@TA.values <- x.tmp[lchob@xsubset]
chobTA@name <- "chartZLEMA"
chobTA@call <- match.call()
chobTA@on <- on # used for deciding when to draw...
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
col=col,n=n,ratio=ratio)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} # }}}
# chartZLEMA {{{
`chartZLEMA` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
if(length(x@params$n) < length(x@params$col)) {
colors <- 3:10
} else colors <- x@params$col
for(li in 1:length(x@params$n)) {
ma <- ZLEMA(x@TA.values,n=x@params$n[li],ratio=x@params$ratio)
if(x@new) {
par(new=TRUE)
plot(x.range,seq(min(ma*.975),max(ma*1.05),length.out=length(x.range)),
type='n',axes=FALSE,ann=FALSE)
title(ylab=paste('EMA(',paste(x@params$n[li],collapse=','),')',sep=''))
axis(2)
box(col=x@params$colors$fg.col)
}
lines(seq(1,length(x.range),by=spacing),ma,col=colors[li],lwd=1,type='l')
}
} # }}}
# addExpiry {{{
`addExpiry` <- function(type='options',lty='dotted') {
lchob <- get.current.chob()
chobTA <- new("chobTA")
chobTA@new <- FALSE
# get the appropriate data - from the approp. src
#if(from.fig==1) {
x <- lchob@xdata
if(type=='options') {
index.of.exp <- options.expiry(x)
} else index.of.exp <- futures.expiry(x)
chobTA@TA.values <- index.of.exp[index.of.exp %in% lchob@xsubset] # single numeric vector
chobTA@name <- "chartExpiry"
chobTA@call <- match.call()
chobTA@on <- 1
chobTA@params <- list(xrange=lchob@xrange,
colors=lchob@colors,
color.vol=lchob@color.vol,
multi.col=lchob@multi.col,
spacing=lchob@spacing,
width=lchob@width,
bp=lchob@bp,
x.labels=lchob@x.labels,
time.scale=lchob@time.scale,
col=col,lty=lty)
if(is.null(sys.call(-1))) {
TA <- lchob@passed.args$TA
lchob@passed.args$TA <- c(TA,chobTA)
lchob@windows <- lchob@windows + ifelse(chobTA@new,1,0)
do.call('chartSeries.chob',list(lchob))
invisible(chobTA)
} else {
return(chobTA)
}
} # }}}
# chartExpiry {{{
`chartExpiry` <-
function(x) {
spacing <- x@params$spacing
width <- x@params$width
x.range <- x@params$xrange
x.range <- seq(x.range[1],x.range[2]*spacing)
multi.col <- x@params$multi.col
color.vol <- x@params$color.vol
for(ex in 1:length(x@TA.values)) {
abline(v=x@TA.values[ex]*spacing,lty=x@params$lty,col=x@params$colors$Expiry)
}
} # }}}
# get.current.chob {{{
`get.current.chob` <- function() {
first.chob <- which(sapply(sys.frames(),function(x) exists('chob',envir=x)))[1]
if(!is.na(first.chob)) {
lchob <- get('chob',envir=first.chob)
# if(exists('chob',envir=sys.frames()[[sys.parent()]])) {
# if(identical(sys.frames()[[sys.parent()]],.GlobalEnv))
# stop("why are you calling this directly?")
# lchob <- get('chob',envir=sys.frames()[[sys.parent()]])
} else {
gchob <- get.chob()
#protect against NULL device or windows not drawn to yet
if(dev.cur()==1 || length(gchob) < dev.cur())
stop("improperly set or missing graphics device")
current.chob <- which(sapply(gchob,
function(x) {
ifelse(inherits(x, "chob") &&
x@device==as.numeric(dev.cur()),TRUE,FALSE)
}))
if(identical(current.chob,integer(0))) stop("no current plot")
lchob <- gchob[[current.chob]]
}
return(lchob)
} #}}}
quantmod/demo/ 0000755 0001762 0000144 00000000000 13253773663 013045 5 ustar ligges users quantmod/demo/chartSeries.R 0000644 0001762 0000144 00000001713 13253773663 015446 0 ustar ligges users # chartSeries demo
# Jeffrey A. Ryan 2008
require(quantmod)
chartSeries.demo <- function(x) {
data(sample_matrix, package="xts")
data <- as.xts(sample_matrix)
cat("A simple xts object:\n")
print(str(data))
cat("chartSeries(data)\n")
chartSeries(data)
readline("Press to continue")
cat("Now we can add builtin indicators:\n\n")
cat("Moving Average Convergence Divergence Indicator (from TTR)\n> addMACD()\n")
plot(addMACD())
readline("Press to continue")
cat("Add Bollinger Bands\n> addBBands()\n")
plot(addBBands())
readline("Press to continue")
cat("Drop Bollinger Bands\n> dropTA('BBands')\n")
dropTA('BBands')
readline("Press to continue")
cat("Zoom chart from full data to last 3 months\n> zoomChart(\"last 3 months\")\n")
zoomChart('last 3 months')
readline("Press to continue")
cat("Zoom back to full data\n> zoomChart()\n\n")
zoomChart()
rm(data)
}
chartSeries.demo(data)
quantmod/demo/00Index 0000644 0001762 0000144 00000000051 13253773663 014173 0 ustar ligges users chartSeries The demo for chartSeries
quantmod/NAMESPACE 0000644 0001762 0000144 00000017256 15002467345 013342 0 ustar ligges users export(quantmodenv, .quantmodEnv)
S3method(print, quantmodEnv)
# NAMESPACE file for quantmod
import(methods, zoo, xts, TTR)
importFrom(graphics,
abline,
axTicks,
axis,
box,
grid,
layout,
legend,
lines,
locator,
par,
plot,
plot.new,
plot.window,
points,
polygon,
rect,
segments,
strwidth,
text,
title)
importFrom(grDevices,
colorRampPalette,
dev.cur,
dev.off)
importFrom(stats,
anova,
as.formula,
as.ts,
coef,
coefficients,
end,
fitted,
fitted.values,
formula,
glm,
lag,
lm,
loess,
logLik,
model.frame,
na.exclude,
na.omit,
predict,
resid,
residuals,
sd,
setNames,
start,
step,
terms,
vcov)
importFrom(utils,
browseURL,
download.file,
getAnywhere,
modifyList,
read.csv,
read.delim,
read.table,
select.list,
str,
type.convert,
URLencode)
# new plotting functions (experimental)
export(new.replot,
current.chob,
chart_Series, add_Series,
add_EMA,
add_EVWMA,
add_WMA,
add_SMA,
add_DEMA,
add_VWAP,
add_GMMA,
add_ADX,
add_Vo,add_BBands,add_RSI,add_SMI,add_TA,
chart_theme, chart_pars,
add_axis,
add_MACD, zoom_Chart)
export(axTicksByValue)
export(axTicksByTime2)
S3method(plot, replot)
S3method(print, replot)
S3method(str, replot)
#export(.chob,write.chob,get.chob,release.chob)
export(.chob)
export(.chart.theme,chartTheme)
export(listTA,
setTA,
unsetTA,
addTA,
chartTA,
newTA,
dropTA,
moveTA,
swapTA
)
export(
# quantmod-only code
addVo, # volume
addExpiry, # expiration dates
addEnvelope, # envelope
addShading, chartShading,
addLines,
addPoints
# package:graphics functionality wrappers NYI
#add.lines,
#add.points,
#add.curve,
#add.rect,
#add.segments,
)
# TTR functionality
export(
# Moving Averages
addSMA, # simple moving average
addEMA, # exponential moving average
addWMA, # weigthed moving average
addDEMA, # double exponential moving average
addEVWMA, # elastic, volume-weighted moving average
addZLEMA, # zero lag exponential moving average
# not yet implemented
#addVHF, # vertical horizontal filter
#addWilliamsAD, # william's AD
addOBV, # on balance volume
addCLV, # close location value
addEMV, # ease of movement
addChAD, # chaikin AD
addChVol, # chaikin Volatility
addVolatility, # volatility (close, garman.klass, parkinson, rogers.satchell)
addZigZag, # Zig-Zag
addAroon, # aroon
addAroonOsc, # aroon oscillator
addKST, # know sure thing
addMFI, # money flow index
addTDI, # trend detection index
addSMI, # stochastic momentum index
addADX, # directional movement index
addDPO, # de-trended price oscillator
addCCI, # commodity channel index
addCMF, # chaikin money flow
addCMO, # chande momentum oscillator
addMomentum, # momentum
addATR, # average true range
addTRIX, # triple smoothed exponential oscillator
addRSI, # relative strength index
addROC, # rate of change
addWPR, # william's %R
addSAR, # parabolic stop-and-reverse
addMACD, # moving average convergence divergence
addBBands # Bollinger Bands
#addPctB # Bollinger %b
#addBBwidth # Bollinger band width
)
export(
modelData,
modelSignal,
Op, has.Op,
Lo, has.Lo,
Hi, has.Hi,
Cl, has.Cl,
Vo, has.Vo,
Ad, has.Ad,
# Price extraction functions
getPrice,
is.BBO, is.TBBO,
has.Bid,
has.Ask,
has.Price,
has.Trade,
has.Qty,
OHLC, has.OHLC, is.OHLC, # OHLC extraction and test
OHLCV, has.OHLCV, is.OHLCV, # OHLCV extraction and test
HLC, has.HLC, is.HLC, # HLC extraction and test
HL, has.HL, is.HL, # HLC extraction and test
# quick delta calculation functions
OpCl, OpOp, ClCl, ClOp, OpHi, OpLo, LoCl, HiCl, LoHi,
seriesHi,seriesLo,
seriesIncr, seriesDecr,
seriesAccel, seriesDecel,
findPeaks,
findValleys,
peak, # deprecated
valley, # deprecated
Delt,
Next,
Lag,
options.expiry,futures.expiry,
periodReturn,
dailyReturn,weeklyReturn,monthlyReturn,quarterlyReturn,annualReturn,
yearlyReturn,
allReturns,
tradeModel,
# saveModels,
# loadModels,
# period.apply,
# breakpoints,
specifyModel,
getModelData,
# predictModel,
getFinancials,getFin,
viewFinancials,viewFin,
getDividends,
getSplits,
getQuote,
standardQuote,
yahooQF,
yahooQuote.EOD,
getOptionChain,
attachSymbols,
flushSymbols,
loadSymbols,
getSymbols,
getSymbols.MySQL,
getSymbols.SQLite,
getSymbols.mysql,
getSymbols.FRED,
getSymbols.yahoo,
getSymbols.yahooj,
getSymbols.oanda,
getSymbols.tiingo,
#getSymbols.Bloomberg,
#getSymbols.IBrokers,
getSymbols.csv,
getSymbols.rda,
getSymbols.RData,
getSymbols.google,
getSymbols.av,
getSymbols.alphavantage,
getFX,
getMetals,
oanda.currencies,
adjustOHLC,
showSymbols,
removeSymbols,
saveSymbols,
fittedModel,
buildModel,
buildData,
is.quantmod,
is.quantmodResults,
as.quantmod.OHLC)
export(
# symbol lookup utilities
setSymbolLookup,
getSymbolLookup,
saveSymbolLookup,
loadSymbolLookup
)
#export(tradeLog)
#export(gainloss)
export(
# main charting functions
chartSeries,
reChart,
saveChart,
zoomChart,
zooom,
barChart,
lineChart,
candleChart,
matchChart
)
# Defaults functionality
export(
importDefaults,
setDefaults,
unsetDefaults,
getDefaults
)
# S3 methods
S3method(seriesHi,default)
S3method(seriesHi,timeSeries)
S3method(seriesHi,ts)
S3method(seriesLo,default)
S3method(seriesLo,timeSeries)
S3method(seriesLo,ts)
S3method(print,financials)
S3method(print,chart.theme)
S3method(Next,zoo)
S3method(Next,numeric)
S3method(Next,data.frame)
S3method(Next,quantmod.OHLC)
S3method(Lag,default)
S3method(Lag,numeric)
S3method(Lag,data.frame)
S3method(Lag,zoo)
S3method(Lag,xts)
S3method(Lag,quantmod.OHLC)
S3method(formula,quantmod)
S3method(fitted,quantmod)
S3method(fitted.values,quantmod)
S3method(coef,quantmod)
S3method(coefficients,quantmod)
S3method(logLik,quantmod)
S3method(vcov,quantmod)
S3method(residuals,quantmod)
S3method(resid,quantmod)
S3method(anova,quantmod)
S3method(plot,quantmod)
S3method(plot,chobTA)
S3method(plot,quantmodResults)
S3method(print,quantmodResults)
S3method(as.zoo,data.frame)
S3method(as.zoo,quantmod.OHLC)
S3method(as.quantmod.OHLC,data.frame)
S3method(as.quantmod.OHLC,zoo)
S3method(as.quantmod.OHLC,quantmod.OHLC)
S3method('[',quantmod.OHLC)
#S3method(periodReturn,zoo)
#S3method(periodReturn,quantmod.OHLC)
#S3method(periodReturn,quantmodResults)
S3method(predictModel,default)
S3method(predictModel,nnet)
S3method(predictModel,mars)
S3method(predictModel,polymars)
S3method(predictModel,lars)
S3method(predictModel,rpart)
S3method(predictModel,tree)
S3method(predictModel,randomForest)
# trade signal functionality
exportClass(quantmod)
#exportClass(quantmodResults,quantmodReturn)
exportClass(quantmodReturn)
exportClass(tradeLog)
exportClass(chob,chobTA)
exportMethods(show,summary,'fittedModel<-')
quantmod/NEWS.md 0000644 0001762 0000144 00000067675 15024632162 013226 0 ustar ligges users ### Changes in 0.4.28 (2025-06-18)
1. Fix FRED URL. Thanks to Nicole Mirea (@nimirea) for the report!
[#439](https://github.com/joshuaulrich/quantmod/issues/439)
1. Thanks to Michael Chirico for a couple PRs to handle some minor edge cases.
[#436](https://github.com/joshuaulrich/quantmod/pull/436)
[#437](https://github.com/joshuaulrich/quantmod/pull/437)
1. Replace "YHOO" with "AAPL" where it is used in documentation, especially
in examples. Thanks to @dougedmunds for the report!
[#435](https://github.com/joshuaulrich/quantmod/issues/435)
1. Update `getSymbols.csv()` documentation to note that you have to set the
`format` argument if the date in the CSV is not in a standard format.
Thanks to @reddogg24 for the report that led to this change.
[#428](https://github.com/joshuaulrich/quantmod/issues/428)
### Changes in 0.4.27 (2025-04-06)
1. Reduce `getQuote()` batch size from 199 to 99. Yahoo started to throw an
error for requests of 100 or more symbols at a time. Thanks to @zlfang00
for the report and Ethan B. Smith for the patch!
[#432](https://github.com/joshuaulrich/quantmod/issues/432)
[#433](https://github.com/joshuaulrich/quantmod/pull/433)
1. Follow best practices by removing the encosing '{}' in
`setGeneric("fittedModel<-", ...)`. Thanks to Michael Chirico for the PR!
[#431](https://github.com/joshuaulrich/quantmod/pull/431)
1. Improve detection of ambiguous 'OHLCVA' colnames in all extractor functions
(e.g. `Cl()`, `OHLC()`). This is especially important for `Lo()` because
`quantmod::getSymbols("LOW")` returns an object where every column name
contains the pattern "LOW.". Another example is `TTR::stoch()`, which
returns a column named "slowD". Thanks to Ethan B. Smith for the patch!
[#24](https://github.com/joshuaulrich/quantmod/issues/24)
[#305](https://github.com/joshuaulrich/quantmod/pull/305)
[#306](https://github.com/joshuaulrich/quantmod/pull/306)
[#426](https://github.com/joshuaulrich/quantmod/pull/426)
1. Continue steps to remove `quantmod:::as.zoo.data.frame()` by throwing a
warning every time `quantmod::as.zoo.data.frame()` is called. Previously
a message was printed the first time the function was called.
[#414](https://github.com/joshuaulrich/quantmod/pull/414)
1. Add `ClOp()` function to calculate the return between Close[t-1] and Open[t].
Thanks to Gabriel Kaiser (@GabrielKaiserQFin) for the contribution!
[#412](https://github.com/joshuaulrich/quantmod/pull/412)
### Changes in 0.4.26 (2024-02-14)
1. Fix `chart_Series()` when 'TA' is a vector. Thanks to @comintel for the
report.
[#403](https://github.com/joshuaulrich/quantmod/issues/403)
1. Fix `getOptionChain.yahoo()` by using the Yahoo Finance 'crumb' like we
do in `getSymbols()` and `getQuote()`. Thanks to @cotyreh for the report.
[#407](https://github.com/joshuaulrich/quantmod/issues/407)
### Changes in 0.4.25 (2023-08-21)
1. Fix `getQuote.yahoo()` for API changes. Thanks to Ethan B. Smith for the
report and patch! Also add error message for users in GDPR countries, since
we cannot automatically consent to GDPR and the request fails without
consent.
[#392](https://github.com/joshuaulrich/quantmod/issues/392)
[#393](https://github.com/joshuaulrich/quantmod/issues/393)
[#395](https://github.com/joshuaulrich/quantmod/issues/395)
1. Fix `getQuote.yahoo()` when the user only requested metrics that do not have
have a value for 'regularMarketTime'. Set the value to NA in these cases
so the output remains the same regardless of whether the endpoint returns
a 'regularMarketTime' or not. Thanks to @mehdiMBH for the report!
[#255](https://github.com/joshuaulrich/quantmod/issues/255)
1. Add fields to `getQuote.yahoo()` that are returned when no fields are
explicitly requested. Thanks to @Courvoisier13 for the report!
[#335](https://github.com/joshuaulrich/quantmod/issues/335)
1. Add intraday endpoint to `getSymbols.yahoo()`. Thanks to @kapsner for the
report and patch! Also allow suppressing the warning if more than 7 days
of data are requested (@eddelbuettel).
[#351](https://github.com/joshuaulrich/quantmod/issues/351)
[#381](https://github.com/joshuaulrich/quantmod/issues/381)
[#399](https://github.com/joshuaulrich/quantmod/issues/399)
1. Add warning if `getSymbols()` is called with tickers that are reserved words
because accessing them requires back-quotes (e.g. ``NA``).
[#401](https://github.com/joshuaulrich/quantmod/issues/401)
1. Fix `allReturns()` when 'subset' is specified. Thanks to @Panagis1980 for
the report!
[#402](https://github.com/joshuaulrich/quantmod/issues/402)
### Changes in 0.4.24 (2023-07-17)
1. Fix `getSymbols.oanda()` URL. Thanks to @macray76 for the report.
[#387](https://github.com/joshuaulrich/quantmod/issues/387)
### Changes in 0.4.23 (2023-06-14)
1. Fix `getQuote.yahoo()` error. Thanks to Ethan B. Smith for the report and
patch!
[#382](https://github.com/joshuaulrich/quantmod/issues/382)
[#383](https://github.com/joshuaulrich/quantmod/issues/383)
1. Add `name` argument to `add_TA()`. Thanks to @SamoPP for the suggestion!
[#377](https://github.com/joshuaulrich/quantmod/issues/377)
[#205](https://github.com/joshuaulrich/quantmod/issues/205)
### Changes in 0.4.22 (2023-04-05)
1. Move jsonlite from Suggests to Imports so it doesn't cause a problem
when a package that doesn't also Suggest jsonlite uses getSymbols().
Thanks to Kurt Hornik for the report and fix!
[#380](https://github.com/joshuaulrich/quantmod/issues/380)
### Changes in 0.4.21 (2023-03-29)
1. Fix S3 method issues. R-devel (83995-ish) added a check for possible S3
method issues. Register methods it found that were not registered:
`str.replot()`, `seriesHi.timeSeries()`, and `seriesLo.timeSeries()`.
It was also confused by `range.bars()` and `unique.formula.names()`. Remove
`unique.formula.names()` because it wasn't exported or used internally.
Rename `range.bars()` to `rangeBars()`, which isn't exported.
Thanks to Kurt Hornik for the report!
[#375](https://github.com/joshuaulrich/quantmod/issues/375)
1. Remove "^" prefix from `getSymbols()` return value. When the 'Symbols'
argument has a "^" prefix and `auto.assign = TRUE`:
* `getSymbols()` removes the "^" from the object it creates, but
* returns the 'Symbols' argument unchanged, and
* removes the "^" from the column names of the object it creates.
The example below will create an object named `IXIC` but the value of
`sym` will be "^IXIC".
```r
sym <- getSymbols("^IXIC")
```
That means `x <- get(sym)` will not work because an object named `^IXIC`
doesn't exist.
[#371](https://github.com/joshuaulrich/quantmod/issues/371)
1. Add 'from' and 'to' arguments to `getSymbols.FRED()`. Users expect to be
able to set the 'from' and 'to' arguments for FRED data like they can for
Yahoo data. Those values were ignored and the entire series was always
returned.
[#368](https://github.com/joshuaulrich/quantmod/issues/368)
1. Change interval to 1d for `getDividends()` and `getSplits()`. The "3mo"
setting caused some dividends to be missing for companies that issued monthly
dividends. Note that the response to this request also includes all the OHLCV
data. But it's small (less than 1MB for 60+ years of daily data).
[#372](https://github.com/joshuaulrich/quantmod/issues/372)
1. Handle errors in `getSplits()` and `getDividends()`. `getDividends()` didn't
handle cases where the download failed, or when dividends needed to be
split-adjusted but there were no splits. It also tried to set colnames
on the empty xts object that's returned when there are no dividends.
`getSplits()` had the same colnames issue. Check for no splits by testing
for `NULL` because that's more explicit. Thanks to Chris Cheung for the
report!
[#366](https://github.com/joshuaulrich/quantmod/issues/366)
1. Export `HL()`, `is.HL()`, and `has.HL()` functions and add documentation.
These were added in 0.4.18 but not exported or included in the documentation.
1. Use Yahoo Finance v8 JSON endpoint and remove the v7 CSV endpoint. There
seems to be a rate limit for the number of tickers you can request via the CSV
endpoint. The [yfinance python library](https://github.com/ranaroussi/yfinance)
uses the JSON endpoint and doesn't seem to have rate limit issues.
[#360](https://github.com/joshuaulrich/quantmod/issues/360)
[#362](https://github.com/joshuaulrich/quantmod/issues/362)
[#364](https://github.com/joshuaulrich/quantmod/issues/364)
### Changes in 0.4.20 (2022-04-29)
1. Remove check for Yahoo Finance cookies because the site no longer
responds with a cookie, and that caused the connection attempt to fail.
This affected `getSymbols()`, `getDividends()`, and `getSplits()`.
Thanks to several users for reporting, and especially to @pverspeelt and
@alihru for investigating potential fixes!
[#358](https://github.com/joshuaulrich/quantmod/issues/358)
1. Update `getSymbols.yahooj()` for changes to the web page.
[#312](https://github.com/joshuaulrich/quantmod/issues/312)
1. Add `HL()` and supporting functions. These are analogues to `HLC()`,
`OHLC()`, etc. Thanks for Karl Gauvin for the nudge to implement them.
1. Add adjusted close to `getSymbols.tiingo()` output. Thanks to Ethan Smith
for the suggestion and patch!
[#289](https://github.com/joshuaulrich/quantmod/issues/289)
[#345](https://github.com/joshuaulrich/quantmod/pull/345)
1. Use a Date index for `getSymbols.tiingo()` daily data. Thanks to Ethan
Smith for the report!
[#350](https://github.com/joshuaulrich/quantmod/issues/350)
1. Remove unneeded arguments to the `getSymbols.tiingo()` implementation.
Thanks to Ethan Smith for the suggestion and patch!
[#343](https://github.com/joshuaulrich/quantmod/issues/343)
[#344](https://github.com/joshuaulrich/quantmod/pull/344)
1. Load dividends and splits data into the correct environment when the user
provides a value for the `env` argument. The previous behavior always loaded
the data into the environment the function was called from. Thanks to
Stewart Wright for the report and patch!
[#33](https://github.com/joshuaulrich/quantmod/issues/33)
1. Make `getOptionChain()` return all the fields that Yahoo Finance provides.
Thanks to Adam Childers (@rhizomatican) for the patch!
[#318](https://github.com/joshuaulrich/quantmod/issues/318)
[#336](https://github.com/joshuaulrich/quantmod/pull/336)
1. Add [orats](https://docs.orats.io) as a source for `getOptionChain()`.
Thanks to Steve Bronder (@SteveBronder) for the suggestion and implementation!
[#325](https://github.com/joshuaulrich/quantmod/pull/325)
1. Improve the error message when `getSymbols()` cannot import data for a
symbol because the symbol is not valid or does not have historical data.
Thanks to Peter Carl for the report.
[#333](https://github.com/joshuaulrich/quantmod/issues/333)
1. Fix the `getMetals()` example in the documentation. The example section
previously had an example of `getFX()`. Thanks to Gerhard Nachtmann
(@nachti) for the report and patch!
[#330](https://github.com/joshuaulrich/quantmod/issues/330)
1. Fix `getQuote()` so it returns data when the ticker symbol contains an "&".
Thanks to @pankaj3009 for the report!
[#324](https://github.com/joshuaulrich/quantmod/issues/324)
1. Fix `addMACD()` when `col` is specified. Thanks to @nvalueanalytics for the
report!
[#321](https://github.com/joshuaulrich/quantmod/issues/321)
### Changes in 0.4.18 (2020-11-29)
1. Fix issues handling https:// in `getSymbols.yahooj()`. Thanks to @lobo1981
and @tchevri for the reports and @ethanbsmith for the suggestion to move
from XML to xml2.
[#310](https://github.com/joshuaulrich/quantmod/issues/310)
[#312](https://github.com/joshuaulrich/quantmod/issues/312)
1. Fix `getSymbols.yahoo()`, `getDividends()`, and `getSplits()` so they all
handle download errors and retry again. Thanks for @helgasoft for the report
on `getSymbols.yahoo()` and @msfsalla for the report on `getDividends()` and
`getSplits()`.
[#307](https://github.com/joshuaulrich/quantmod/issues/307)
[#314](https://github.com/joshuaulrich/quantmod/issues/314)
1. Add implied volatility and last trade date to `getOptionChain()` output.
Thanks to @hd2581 and @romanlelek for the reports. And thanks to
@rjvelasquezm for noticing the error when `lastTradeDate` is `NULL`.
[#224](https://github.com/joshuaulrich/quantmod/issues/224)
[#304](https://github.com/joshuaulrich/quantmod/issues/304)
1. Fix `getOptionChain()` to throw a warning and return `NULL` for every
expiry that doesn't have data.
[#299](https://github.com/joshuaulrich/quantmod/issues/299)
1. Add "Defaults" handling to `getQuote()` and `getQuote.yahoo()`. Thanks to
@ethanbsmith for the report.
[#291](https://github.com/joshuaulrich/quantmod/issues/291)
1. Add Bid and Ask fields to the output from `getQuote()`. Thanks to @jrburl
for the report and PR.
[#302](https://github.com/joshuaulrich/quantmod/pull/302)
1. Fix "Defaults" to handle unexported function (e.g. `getQuote.av()`. Thanks
to @helgasoft for the report.
[#316](https://github.com/joshuaulrich/quantmod/issues/316)
1. `importDefaults()` doesn't call `get()` on vector with length > 1. Thanks
to Kurt Hornik for the report.
[#319](https://github.com/joshuaulrich/quantmod/issues/319)
### Changes in 0.4.17 (2020-03-31)
1. `chartTheme()` now works when quantmod is not attached. Thanks to Kurt
Hornik for the report.
### Changes in 0.4-16 (2020-03-08)
1. Remove disk I/O from `getSymbols()` and `getQuote()`. This avoids any disk
contention, and makes the implementation pattern more consistent with other
functions that import data. Thanks to Ethan Smith suggestion and PR.
[#280](https://github.com/joshuaulrich/quantmod/issues/280)
[#281](https://github.com/joshuaulrich/quantmod/pull/281)
1. Make `getQuote()` robust to symbols without data, so it does not error if
one or more symbols are not found. Also return quotes in the same order as
the 'Symbols' argument. Thanks to Ethan Smith feature request and PR.
[#279](https://github.com/joshuaulrich/quantmod/issues/279)
[#282](https://github.com/joshuaulrich/quantmod/pull/282)
[#288](https://github.com/joshuaulrich/quantmod/pull/288)
1. Handle semicolon-delimited symbol string handling to main `getQuote()`
function. This makes `getQuote()` consistent with `getSymbols()`. Thanks to
Ethan Smith suggestion and PR.
[#284](https://github.com/joshuaulrich/quantmod/issues/284)
[#285](https://github.com/joshuaulrich/quantmod/pull/285)
1. Fix ex-dividend and pay date mapping. `getQuote()` returned the dividend
pay date labeled as the ex-dividend date. Thanks to @matiasandina for the
report.
[#287](https://github.com/joshuaulrich/quantmod/issues/287)
1. Fix Yahoo Finance split ratio. The delimiter changed from "/" to ":".
For example, a 2-for-1 split was 1/2 but is now "2:1". Thanks to @helgasoft
for the report.
[#292](https://github.com/joshuaulrich/quantmod/issues/292)
1. Error messages from `getQuote.alphavantage()` and `getQuote.tiingo()` no
longer contain the API key when symbols can't be found.
[#286](https://github.com/joshuaulrich/quantmod/issues/286)
1. Fix `getQuote.alphavantage()` by replacing the defunct batch quote request
with a loop over the single quote request. Thanks to @helgasoft for the
report and patch.
[#296](https://github.com/joshuaulrich/quantmod/issues/296)
1. Update `getOptionChain()` to handle empty volume or open interest
Thank to @jrburl for the report and PR.
[#299](https://github.com/joshuaulrich/quantmod/issues/299)
[#300](https://github.com/joshuaulrich/quantmod/pull/300)
### Changes in 0.4-15 (2019-06-15)
1. Add an environment variable to control whether to run tests that import
from Yahoo Finance. `getDividends()` tests were failing because Yahoo
Finance wasn't returning all dividend history for "CF".
1. Write one message the first time `quantmod::as.zoo.data.frame()` is called.
This method was added years before `zoo::as.zoo.data.frame()` existed, but
it should be deprecated in favor of the zoo version. The package that owns
the class should also own the methods.
### Changes in 0.4-14 (2019-03-23)
#### BUG FIXES
1. Fix `getSymbols.tiingo()` so the Open and Close columns aren't swapped.
Thanks to Steve Bronder for the report and PR.
[#233](https://github.com/joshuaulrich/quantmod/pull/233)
[#234](https://github.com/joshuaulrich/quantmod/issues/234)
1. Fix `getQuote.yahoo()` for quotes in multiple timezones. Thanks to
Philippe Verspeelt for the report and PR.
[#246](https://github.com/joshuaulrich/quantmod/issues/246)
[#248](https://github.com/joshuaulrich/quantmod/pull/248)
1. Update `getDividends()` because Yahoo Finance now provides raw dividends
instead of split-adjusted dividends. Thanks to Douglas Barnard for the
report.
[#253](https://github.com/joshuaulrich/quantmod/issues/253)
1. Fix `futures.expiry()`. Thanks to @pjheink for the report.
[#257](https://github.com/joshuaulrich/quantmod/issues/257)
1. Fix `getSymbols.tiingo()` to return correct columns for ticker "LOW".
Thanks to @srtg4we5gsetrgwhreyt the report.
[#259](https://github.com/joshuaulrich/quantmod/issues/259)
1. Fix `getSymbols.yahooj()` to avoid infinite loop when the requested
symbol doesn't have data. Thanks to Wouter Thielen for the review.
[#63](https://github.com/joshuaulrich/quantmod/issues/63)
1. Update `getSplits()` because Yahoo Finance now provides the actual split
adjustment ratio, instead of the inverse (e.g. now 1/2 instead of 2/1).
[#265](https://github.com/joshuaulrich/quantmod/issues/265)
#### NEW FEATURES
1. Extend `getQuote()` to support Tiingo. Thanks to Ethan Smith for the
feature request and PR.
[#247](https://github.com/joshuaulrich/quantmod/issues/247)
[#250](https://github.com/joshuaulrich/quantmod/pull/250)
1. Extend `getSymbols()` to catch errors for individual ticker symbols and
continue processing any remaining ticker symbols, instead of throwing an
error. More useful error messages are also provided. Thanks to @helgasoft
for testing and feedback.
[#135](https://github.com/joshuaulrich/quantmod/issues/135)
### Changes in 0.4-13 (2018-04-13)
#### BUG FIXES
1. Fix `getQuote.yahoo()` when a field has no data for all requested tickers.
[#208](https://github.com/joshuaulrich/quantmod/issues/208)
1. Expose weekly and monthly adjusted prices from Alpha Vantage's API.
[#212](https://github.com/joshuaulrich/quantmod/issues/212)
1. Fix `saveChart()` (it actually saves a chart now!).
[#154](https://github.com/joshuaulrich/quantmod/issues/154)
1. Update Oanda URL, which fixes `getSymbols.oanda()` and `getFX()`.
[#225](https://github.com/joshuaulrich/quantmod/issues/225)
#### NEW FEATURES
1. Add `getQuote.alphavantage()`, thanks to Ethan Smith for the PR.
[#213](https://github.com/joshuaulrich/quantmod/issues/213)
[#223](https://github.com/joshuaulrich/quantmod/issues/223)
1. Add `getSymbols.tiingo()` to import data from [Tiingo](https://www.tiingo.com/).
Thanks to Steve Bronder for the PR.
[#220](https://github.com/joshuaulrich/quantmod/issues/220)
#### BREAKING CHANGES
1. Google Finance no longer provides data for historical prices or financial
statements, so all Google data sources are defunct.
[#221](https://github.com/joshuaulrich/quantmod/issues/221)
### Changes in 0.4-12 (2017-12-02)
#### BUG FIXES
1. `chartSeries()` now honors `show.grid` argument. Thanks to Ethan Smith.
[#200](https://github.com/joshuaulrich/quantmod/issues/200)
1. `getQuote.yahoo()` uses the new JSON API.
[#197](https://github.com/joshuaulrich/quantmod/issues/197)
1. `getSymbols.yahoo()` is more careful about converting UNIX timestamps to
character when creating the query URL.
[#202](https://github.com/joshuaulrich/quantmod/issues/202)
### Changes in 0.4-11 (2017-10-06)
#### BUG FIXES
1. `getSymbols.yahoo()`
* Don't try to un-adjust the OHLC for splits and/or dividends. Return data
as-is and leave any (un-)adjustments to the end user.
[#174](https://github.com/joshuaulrich/quantmod/issues/174)
* Add ability to pass `curl.options` to `curl.download()`.
[#177](https://github.com/joshuaulrich/quantmod/issues/177)
#### NEW FEATURES
1. `getSymbols.av()` can download data from [Alpha Vantage](https://www.alphavantage.co/).
Thanks to Paul Teetor for the contribution.
[#176](https://github.com/joshuaulrich/quantmod/issues/176)
### Changes in 0.4-10 (2017-06-20)
#### BUG FIXES
1. `getSymbols.yahoo()`
* Avoid cached response from Yahoo Finance proxy.
[#166](https://github.com/joshuaulrich/quantmod/issues/166)
* Set `from` argument back to 1900-01-01.
[#157](https://github.com/joshuaulrich/quantmod/issues/157)
1. `getSymbols()` no longer warns if called with namespace
(i.e. `quantmod::getSymbols()`).
[#134](https://github.com/joshuaulrich/quantmod/issues/134)
1. `as.zoo.data.frame()` now ignores `row.date` argument if called with
`order.by`.
[#168](https://github.com/joshuaulrich/quantmod/issues/168)
### Changes in 0.4-9 (2017-05-29)
#### BUG FIXES
1. `getSymbols.yahoo()` uses the new API.
[#157](https://github.com/joshuaulrich/quantmod/issues/157)
1. `getOptionChain.yahoo()` returns `NULL` when there are no calls/puts instead
of `list()`.
[#155](https://github.com/joshuaulrich/quantmod/issues/155)
#### NEW FEATURES
1. `getSymbols.yahoo()` gains a `periodicity` argument, for use by
`tseries::get.hist.quote()`.
[#162](https://github.com/joshuaulrich/quantmod/issues/162)
### Changes in 0.4-8 (2017-04-19)
#### BUG FIXES
1. `getSymbols.google()`:
* Honor all arguments set via `setSymbolLookup()`.
* Correctly parse dates in non-English locales.
1. Fix `getSymbols.oanda()`.
1. Fix `add_TA()` when called from a function.
1. Remove 'its' package references (it was archived).
1. Update Yahoo Finance URLs to HTTPS to avoid redirect.
1. Update FRED URL to avoid redirect.
#### NEW FEATURES
1. Add `split.adjust` argument to `getDividends()`.
1. Add readme, contributing, and issue template files for GitHub.
### Changes in 0.4-7 (2016-10-24)
1. Let `jsonlite::fromJSON()` manage connections in `getOptionChain.yahoo()`.
1. Update omegahat URL at CRAN's request.
### Changes in 0.4-6 (2016-08-28)
1. Remove unused `unsetSymbolLookup()`.
1. Add documentation for `getPrice()`.
1. Fix subsetting in `addTRIX()`.
1. Fix `getSymbols.oanda()` to use https.
1. Fix `getOptionChain.yahoo()` to download JSON instead of scrape HTML.
### Changes in 0.4-5 (2015-07-24)
1. Ensure `add*MA()` functions use Close column by default.
1. Correct `Delt()` docs (type argument default value was wrong).
1. Ensure tempfiles are always removed.
1. In `getSymbols.csv()`:
* Fix format argument handling.
* Ensure date column is character before calling `as.Date()`.
* Add `col.names` argument.
1. Fix `dbConnect()` call (changed in `RMySQL_0.10`) in `getSymbols.MySQL()`.
1. Automatically detect OHLC vs OHLCVA in `getSymbols.yahooj()`.
1. Handle long vectors in `setDefaults()`.
1. Fix `getSymbols.FRED() for https.
1. Fix `getOptionChain.yahoo() for spaces in table headers.
1. Add `importFrom` for all non-base packages.
### Changes in 0.4-4 (2015-03-08)
1. Added `getSymbols.yahooj()` to pull data from Yahoo Finance Japan (Thanks to
Wouter Thielen for the contribution.
[#14](https://github.com/joshuaulrich/quantmod/issues/14)).
1. Fixed `getOptionChain.yahoo()` to handle the new options page layout.
[#27](https://github.com/joshuaulrich/quantmod/issues/27)
1. Fixed `getSymbols.oanda()` to handle the new URL structure and CSV format.
[#36](https://github.com/joshuaulrich/quantmod/issues/36)
### Changes in 0.4-3 (2014-12-15)
1. Change maintainer from Jeffrey Ryan to Joshua Ulrich
1. Copy required functionality from the (archived) Defaults package into
quantmod and remove dependency on Defaults.
1. Incorporate several bug fixes and patches.
### Changes in 0.4-0
* getSymbols now uses parent.frame() when auto.assign=TRUE. This
will cause slightly different behavior than previous versions
using .GlobalEnv, but is more functional in design.
* getSymbols now allows for env=NULL, which will behave
as if auto.assign=FALSE is set.
* Upcoming changes for version 0.5-0 will include deprecating
auto assignment from within getSymbols calls. This will instead
be moved to the loadSymbols function, to better match get/load
behaviors in base R. For the transition, auto.assign will be
available to force pre 0.5-0 behaviors, but will be discouraged.
The env= arg will be used for multiple symbol assigns.
### Changes in 0.3-7
* addTA now handles logical vectors or logical xtsible objects
by drawing bands on chart window
* addTA can now draw on or under any window via 'on=' arg
* chartSeries now cleanly handles series without volume automatically
* addVo has new log.scale option
### Changes in 0.3-6
#### MODIFICATIONS
* Delt (and functions that call) now defaults
to 'arithmetic' (discrete) calculations vs. the previous behavior
of 'log' (continuous) calculation. This is more inline with
expected behavior
#### NEW FUNCTIONALITY
* addTA and newTA allow for dynamic indicator additions with little coding
### Changes in 0.3-2
#### BUG FIXES
* matched broken TTR calls, aligned arguments between packages
* 'name' of chart was being evaluated somewhere in the process,
resulting in the object becoming a string. Fixed in this release.
#### MODIFICATIONS
* continuing the move of time-series functionality to the 'xts' package
* added new TTR functions to addTA.
* added underlay charting to main area (BBands) as well as much
more advanced shading and labeling.
* chartSeries converts incoming 'x' argument to xts object for
more universal handling. Not fully sorted out - but better than
before.
* new subset argument to allow for xts-style subsetting
#### NEW FUNCTIONALITY
* new TTR functions - ATR, CCI, CMF, CMO, DPO, Lines, Momentum, TRIX
### Changes in 0.3-1
#### BUG FIXES
* new depends - on CRAN and R-Forge package xts for time-series handling internally
* options.expiry and futures.expiry now use universal %w to check weekdays
* Rmetrics change resulted in as.timeSeries moving to fSeries. New suggest and assoc. changes
#### MODIFICATIONS
* Added ability to plot series with missing values (like those in a 'ts' series)
Volume with missing obs. is still broken - to be fixed in 0.3-2
### Changes in 0.3-0
#### BUG FIXES
* Fixed factor bug in getSymbols.FRED. Thanks to Josh Ulrich
* Fixed bug in [.quantmod.OHLC method when i/j was missing,
also now returns quantmod.OHLC object consistently
#### MODIFICATIONS
* Added high frequency data handling - to.minutes, to.hourly,
to.daily. Additional work done to accomodate within rest of
framework
* getSymbols downloads now to temp file - instead of directly to
memory. Fixed R issue in certain Windows installations
* getSymbols now returns a character array of symbol names
written to environment.
* getSymbols includes new arg - auto.assign. If set to FALSE
will behave like standard R functions and simply return
loaded object. Requires user assignment via '<-'
* Better handling of timeSeries, ts, its within entire package
#### NEW FUNCTIONALITY
* chartSeries rewrite. Now manages charting with S4 objects
stored quietly in memory. Allowing for dynamic redraws used
in applying technical indicators and overlays
* addTA functions. New charting tools to add technicals to
charts dynamically. More on the way
* listTA, setTA, unsetTA to handle default TA args
* chartTheme function to customize chart 'look'
* last/first functions now take character strings to describe
in words the subsetting to do. Also negative value support
for opposite behavior. Additional _keep_ arg will assign
removed data to an attribute _keep_ with the object
* getSymbols.SQLite support. Still very clunky - though that is SQLite.
* getFX and getMetals for direct download of those types
* getQuote downloads Last,Change,Open,High,Low,Volume from Yahoo
* added documentation and fixed documentation
quantmod/inst/ 0000755 0001762 0000144 00000000000 15002467345 013065 5 ustar ligges users quantmod/inst/tinytest/ 0000755 0001762 0000144 00000000000 15002467345 014750 5 ustar ligges users quantmod/inst/tinytest/test-getSymbols.R 0000644 0001762 0000144 00000007034 15002467345 020204 0 ustar ligges users library(quantmod)
# Tests for getSymbols
test.web.endpoints <- Sys.getenv("QUANTMOD_TEST_WEB_ENDPOINTS")
if (nzchar(test.web.endpoints)) {
# Checks for Alpha Vantage
apikey <- Sys.getenv("QUANTMOD_AV_API_KEY")
if (nzchar(apikey)) {
ibm_daily_unadj <- getSymbols("IBM", src = "av", api.key = apikey,
adjusted = FALSE, periodicity = "daily", auto.assign = FALSE)
ibm_daily_adj <- getSymbols("IBM", src = "av", api.key = apikey,
adjusted = TRUE, periodicity = "daily", auto.assign = FALSE)
stopifnot(has.Ad(ibm_daily_adj))
Sys.sleep(60) #AV throttles to 5 calls per minute
ibm_weekly_unadj <- getSymbols("IBM", src = "av", api.key = apikey,
adjusted = FALSE, periodicity = "weekly", auto.assign = FALSE)
ibm_weekly_adj <- getSymbols("IBM", src = "av", api.key = apikey,
adjusted = TRUE, periodicity = "weekly", auto.assign = FALSE)
stopifnot(has.Ad(ibm_weekly_adj))
ibm_monthly_unadj <- getSymbols("IBM", src = "av", api.key = apikey,
adjusted = FALSE, periodicity = "monthly", auto.assign = FALSE)
ibm_monthly_adj <- getSymbols("IBM", src = "av", api.key = apikey,
adjusted = TRUE, periodicity = "monthly", auto.assign = FALSE)
stopifnot(has.Ad(ibm_monthly_adj))
}
}
# Checks to ensure caught errors do not prevent other symbols from loading.
# Use one symbol that always works (e.g. from disk) and another that fails.
data(sample_matrix, package = "xts")
IBM <- as.xts(sample_matrix)
cn <- c("Open", "High", "Low", "Close")
td <- tempdir()
tf <- file.path(td, "IBM.rda")
save(IBM, file = tf)
tf <- file.path(td, "IBM.csv")
write.zoo(IBM, file = tf, sep = ",")
rm(IBM)
e <- new.env()
# Test getSymbols() works if only passed one symbol that does not have data.
x <- try({
getSymbols("IBM;WYSIWYG", env = e, src = "csv", dir = td, col.names = cn)
}, silent = TRUE)
expect_true(exists("IBM", e))
rm(IBM, pos = e)
x <- try({
getSymbols("IBM;WYSIWYG", env = e, src = "rda", dir = td, col.names = cn)
}, silent = TRUE)
expect_true(exists("IBM", e))
rm(IBM, pos = e)
if (nzchar(test.web.endpoints)) {
x <- try({
getSymbols("IBM;WYSIWYG", env = e, src = "yahoo")
}, silent = TRUE)
expect_true(exists("IBM", e))
rm(IBM, pos = e)
if (nzchar(apikey)) {
x <- try({
getSymbols("IBM;WYSIWYG", env = e, src = "av", api.key = apikey)
}, silent = TRUE)
expect_true(exists("IBM", e))
rm(IBM, pos = e)
}
x <- try({
getSymbols("DGS10;WYSIWYG", env = e, src = "FRED")
}, silent = TRUE)
expect_true(exists("DGS10", e))
rm(DGS10, pos = e)
x <- try({
getSymbols("EUR/USD;WYS/WYG", env = e, src = "oanda")
}, silent = TRUE)
expect_true(exists("EURUSD", e))
rm(EURUSD, pos = e)
# Ensure getSymbols() errors if only passed one symbol that does not have data.
# "csv" and "rda" already skip missing symbols
x <- try({
getSymbols("WYSIWYG", env = e, src = "yahoo")
}, silent = TRUE)
expect_inherits(x, "try-error")
x <- try({
getSymbols("WYSIWYG", env = e, src = "FRED")
}, silent = TRUE)
expect_inherits(x, "try-error")
if (nzchar(apikey)) {
x <- try({
getSymbols("WYSIWYG", env = e, src = "av", api.key = apikey)
}, silent = TRUE)
expect_inherits(x, "try-error")
}
x <- try({
getSymbols("WYS/WYG", env = e, src = "oanda")
}, silent = TRUE)
expect_inherits(x, "try-error")
# Individual getSymbols() "methods" should not error if only passed one symbol.
setSymbolLookup(AAPL = "yahoo", DGS10 = "FRED")
getSymbols("AAPL;DGS10", env = e)
expect_true(exists("AAPL", e))
expect_true(exists("DGS10", e))
}
quantmod/inst/tinytest/test-getSplits.R 0000644 0001762 0000144 00000000456 15002467345 020033 0 ustar ligges users library(quantmod)
test.web.endpoints <- Sys.getenv("QUANTMOD_TEST_WEB_ENDPOINTS")
# Ensure getSplits() returns the expected ratio
if (nzchar(test.web.endpoints)) {
aapl.spl <- as.numeric(getSplits("AAPL")["/2018"])
expected <- c(0.5, 0.5, 0.5, 1/7)
expect_true(all.equal(aapl.spl, expected))
}
quantmod/inst/tinytest/test-misc.R 0000644 0001762 0000144 00000003157 15002467345 017011 0 ustar ligges users av.key <- Sys.getenv("QUANTMOD_AV_API_KEY")
tiingo.key <- Sys.getenv("QUANTMOD_TIINGO_API_KEY")
test.web.endpoints <- Sys.getenv("QUANTMOD_TEST_WEB_ENDPOINTS")
if (nzchar(test.web.endpoints)) {
# should throw an error
errorKey <- "d116c846835e633aacedb1a31959dd2724cd67b8"
x <- try(
quantmod::getSymbols("AAPL", src = "tiingo", data.type = "csv", api.key = errorKey)
, silent = TRUE)
expect_inherits(x, "try-error")
x <- try(
quantmod::getSymbols("AAPL", src = "tiingo", data.type = "json", api.key = errorKey)
, silent = TRUE)
expect_inherits(x, "try-error")
syms <- c("SPY", "WYSIWYG")
symstr <- paste(syms, collapse = ";")
x <- try(getQuote(symstr, src = "yahoo"), silent = TRUE)
expect_inherits(x, "data.frame")
expect_true(all(rownames(x) == syms))
expect_true(!is.na(x["SPY", "Last"]) && is.na(x["WYSIWYG", "Last"]))
#test batch handling
x <- getQuote(c("SPY", paste0(LETTERS, 1:199), "IWM"), src = "yahoo")
expect_inherits(x, "data.frame")
expect_true(nrow(x) == 201L)
if (av.key != "") {
x <- try(getQuote(symstr, src = "av", api.key = av.key), silent = TRUE)
expect_inherits(x, "data.frame") && all(rownames(x) == syms)
}
if (tiingo.key != "") {
x <- try(getQuote(symstr, src = "tiingo", api.key = tiingo.key), silent = TRUE)
expect_inherits(x, "data.frame")
expect_true(all(rownames(x) == syms))
}
# ensure symbol order is preserved
syms <- sample(c("SPY", "TLT", "IWM", "QQQ", "WYSIWYG"))
x <- try(getQuote(syms, src = "yahoo"), silent = TRUE)
expect_inherits(x, "data.frame")
expect_true(all(rownames(x) == syms))
}
quantmod/inst/tinytest/test-getDividends.R 0000644 0001762 0000144 00000000624 15002467345 020463 0 ustar ligges users library(quantmod)
test.web.endpoints <- Sys.getenv("QUANTMOD_TEST_WEB_ENDPOINTS")
# split-adjusted by default
#if (nzchar(test.web.endpoints)) {
if (FALSE) {
cf.div.adj <- as.numeric(getDividends("CF")["2015"])
expect_true(all.equal(cf.div.adj, rep(0.3, 4)))
cf.div.raw <- as.numeric(getDividends("CF", split.adjust = FALSE)["2015"])
expect_true(all.equal(cf.div.raw, c(1.5, 1.5, 0.3, 0.3)))
}
quantmod/inst/tinytest/test-has.R 0000644 0001762 0000144 00000006564 15002467345 016636 0 ustar ligges users library(quantmod)
library(tinytest)
data(sample_matrix, package = "xts")
stock <- as.xts(sample_matrix)
stock$Volume <- stock$Close
stock$Adjusted <- stock$Close
simple.colnames <- c("Open", "High", "Low", "Close", "Volume", "Adjusted")
# basic functionality
colnames(stock) <- paste("MSFT", simple.colnames, sep = ".")
expect_true(has.Op(stock))
expect_true(has.Hi(stock))
expect_true(has.Lo(stock))
expect_true(has.Cl(stock))
expect_true(has.Vo(stock))
expect_true(has.Ad(stock))
expect_true(is.HLC(stock))
expect_true(all(has.HLC(stock)))
expect_true(is.OHLC(stock))
expect_true(all(has.OHLC(stock)))
expect_true(is.OHLCV(stock))
expect_true(all(has.OHLCV(stock)))
# Test which for has/OHLC functions.
expect_equal(has.Op(stock, which = TRUE), 1)
expect_equal(has.Hi(stock, which = TRUE), 2)
expect_equal(has.Lo(stock, which = TRUE), 3)
expect_equal(has.Cl(stock, which = TRUE), 4)
expect_equal(has.Vo(stock, which = TRUE), 5)
expect_equal(has.Ad(stock, which = TRUE), 6)
expect_equal(has.HLC(stock, which = TRUE), c(2,3,4))
expect_equal(has.OHLC(stock, which = TRUE), c(1,2,3,4))
expect_equal(has.OHLCV(stock, which = TRUE), c(1,2,3,4,5))
#has.OHLC will test underlying has.Op, has.Cl, etc. It will NOT test has.Ad
colnames(stock) <- simple.colnames
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
colnames(stock) <- paste("OPEN", simple.colnames, sep = ".")
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
colnames(stock) <- paste("HIGH", simple.colnames, sep = ".")
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
colnames(stock) <- paste("LOW", simple.colnames, sep = ".")
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
colnames(stock) <- paste("CLOSE", simple.colnames, sep = ".")
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
colnames(stock) <- paste("VOLUME", simple.colnames, sep = ".")
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
colnames(stock) <- paste("ADJUSTED", simple.colnames, sep = ".")
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
colnames(stock) <- paste("ILOW", simple.colnames, sep = ".")
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
colnames(stock) <- paste("LOW.W", simple.colnames, sep = ".")
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
colnames(stock) <- paste("LOW_A", simple.colnames, sep = ".")
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
colnames(stock) <- paste("^LOW", simple.colnames, sep = ".")
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
colnames(stock) <- paste("My.LOW", simple.colnames, sep = ".")
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
colnames(stock) <- paste("VLOWY", simple.colnames, sep = ".")
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
# low in colname returned by function TTR::stoch()
colnames(stock) <- paste("LOW", simple.colnames, sep = ".")
stock$slowD <- stock[,4]
expect_true(all(has.OHLCV(stock)))
expect_equal(has.OHLCV(stock, which = T), c(1,2,3,4,5))
stock$slowD <- NULL
quantmod/man/ 0000755 0001762 0000144 00000000000 15024631336 012660 5 ustar ligges users quantmod/man/Defaults.Rd 0000644 0001762 0000144 00000013617 15002467345 014731 0 ustar ligges users \name{Defaults}
\alias{importDefaults}
\alias{getDefaults}
\alias{setDefaults}
\alias{unsetDefaults}
\title{ Manage Default Argument Values for quantmod Functions }
\description{
Use globally specified defaults, if set, in place of formally specified
default argument values. Allows user to specify function defaults
different than formally supplied values, e.g. to change poorly performing
defaults, or satisfy a different preference.
}
\usage{
setDefaults(name, ...)
unsetDefaults(name, confirm = TRUE)
getDefaults(name = NULL, arg = NULL)
importDefaults(calling.fun)
}
\arguments{
\item{name}{ name of function, quoted or unquoted (see Details) }
\item{\dots}{ name=value default pairs }
\item{confirm}{ prompt before unsetting defaults }
\item{arg}{ values to retrieve }
\item{calling.fun}{ name of function to act upon }
}
\details{
\describe{
\item{setDefaults}{
Provides a wrapper to \R \code{options} that allows the user to
specify any name=value pair for a function's formal arguments.
Only formal name=value pairs specified will be updated.
Values do not have to be respecified in subsequent calls to
\code{setDefaults}, so it is possible to add new defaults for each
function one at a time, without having to retype all previous values.
Assigning \code{NULL} to any argument will remove the argument from
the defaults list.
\code{name} can be an unquoted, bare symbol only at the top-level. It
must be a quoted character string if you call \code{setDefaults} inside
a function.
}
\item{unsetDefaults}{
Removes name=value pairs from the defaults list.
}
\item{getDefaults}{
Provides access to the stored user defaults. Single arguments need
not be quoted, multiple arguments must be in a character vector.
}
\item{importDefaults}{
A call to \code{importDefaults} should be placed on the first line
in the body of the function. It checks the user's environment for
globally specified default values for the called function. These
defaults can be specified by the user with a call to
\code{setDefaults}, and will override any default formal
parameters, in effect replacing the original defaults with user
supplied values instead. Any user-specified values in the parent
function (that is, the function containing \code{importDefaults})
will override the values set in the global default environment.
}
}
}
\value{
\item{setDefaults}{
None. Used for it's side effect of setting a list of default
arguments by function.
}
\item{unsetDefaults}{
None. Used for it's side effect of unsetting default arguments by
function.
}
\item{getDefaults}{
A named list of defaults and associated values, similar to
\code{formals}, but only returning values set by \code{setDefaults}
for the \code{name} function. Calling \code{getDefaults()} (without
arguments) returns in a character vector of all functions currently
having defaults set (by \code{setDefaults}).
This \emph{does not} imply that the returned function names are able
to accept defaults (via \code{importDefaults}), rather that they have
been set to store user defaults. All values can also be viewed with a
call to \code{getOption(name_of_function.Default)}.
}
\item{importDefaults}{
None. Used for its side-effect of loading all non-\code{NULL} user-
specified default values into the current function's environment,
effectively changing the default values passed in the parent function
call. Like formally defined defaults in the function definition,
default values set by \code{importDefaults} take lower precedence
than arguments specified by the user in the function call.
}
}
\author{ Jeffrey A. Ryan }
\note{
\describe{
\item{setDefaults}{
At present it is not possible to specify \code{NULL} as a replacement
for a non-\code{NULL} default, as the process interprets \code{NULL}
values as being not set, and will simply use the value specified
formally in the function. If \code{NULL} is what is desired, it is
necessary to include this in the function call itself.
Any arguments included in the actual function call will take
precedence over \code{setDefaults} values, as well as the standard
formal function values. This conforms to the current user
experience in \R.
Like \code{options}, default settings are \emph{not} kept across
sessions. Currently, it is \emph{not} possible to pass values for
\dots arguments, only formally specified arguments in the original
function definition.
}
\item{unsetDefaults}{
\code{unsetDefaults} removes the \emph{all} entries from the
\code{options} lists for the specified function. To remove single
function default values simply set the name of the argument to
\code{NULL} in \code{setDefaults}.
}
\item{importDefaults}{
When a function implements \code{importDefaults}, non-named
arguments \emph{may} be ignored if a global default has been set
(i.e. not \code{NULL}). If this is the case, simply name the
arguments in the calling function.
This \emph{should} also work for functions retrieving formal
parameter values from \code{options}, as it assigns a value to the
parameter in a way that looks like it was passed in the function
call. So any check on \code{options} would presumably disregard
\code{importDefaults} values if an argument was passed to the
function.
}
}
}
\seealso{
\code{\link{options}}
}
\examples{
my.fun <- function(x=3)
{
importDefaults('my.fun')
x^2
}
my.fun() # returns 9
setDefaults(my.fun, x=10)
my.fun() # returns 100
my.fun(x=4) # returns 16
getDefaults(my.fun)
formals(my.fun)
unsetDefaults(my.fun, confirm=FALSE)
getDefaults(my.fun)
my.fun() # returns 9
}
\keyword{ utilities }
quantmod/man/create.binding.Rd 0000644 0001762 0000144 00000002516 15000510306 016012 0 ustar ligges users \name{create.binding}
\alias{create.binding}
\title{ Create DDB Bindings }
\description{
Internal function used in \code{attachSymbols}
to create active bindings for symbols defined in a \code{DDB} object.
}
\usage{
create.binding(s,
lsym,
rsym,
gsrc,
mem.cache = TRUE,
file.cache = !mem.cache,
cache.dir = tempdir(),
envir,...)
}
\arguments{
\item{s}{ symbol name }
\item{lsym}{ function to convert to local name (legal R name) }
\item{rsym}{ function to convert to remote name (source name) }
\item{gsrc}{ corresponds to 'src' arg in getSymbols call }
\item{mem.cache}{ cache to memory }
\item{file.cache}{ cache to disk }
\item{cache.dir}{ directory to cache to/from }
\item{envir}{ environment name (character) }
\item{\dots}{ arguments to pass to getSymbols call }
}
\details{
Low level function to create bindings during initial
demand-database construction.
}
\value{
Called for its side effect of creating active bindings
to symbols.
}
\references{ Mark, Roger, ? }
\author{ Jeffrey A. Ryan }
\note{
This is code used internally by attachSymbols. User's may modify
this to accomodate different systems. The upstream functions
needn't maintain consistency with this interface.
Use as a guide or template.
}
\keyword{ misc }
quantmod/man/saveChart.Rd 0000644 0001762 0000144 00000003450 15000510306 015054 0 ustar ligges users \name{saveChart}
\alias{saveChart}
\title{ Save Chart to External File }
\description{
Save selected chart to an external file.
}
\usage{
saveChart(.type = "pdf", ..., dev = dev.cur())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{.type}{ type of export. See Details. }
\item{\dots}{ arguments to pass to device }
\item{dev}{ which device should be exported }
}
\details{
This function wraps the base R function \code{pdf},
\code{postscript}, \code{png}, \code{jpeg}, and \code{bitmap}.
The \code{.type} argument must specify which device
driver is desired.
The currently active device is used if \code{dev} is
missing. The result is an exact copy (within the device limits)
of the chart specified.
The name of the resultant file is derived from the name of the chart,
with the appropriate extension appended. (from \code{.type}). Specifying
the appropriate device file/filename will override this name.
The caller may specify any parameters that are valid for the device called.
Internally, effort is made to match the dimensions of the device being
used to create the output file. User supplied dimensions will override this
internal calculation.
}
\value{
A file in the current directory (default) matching the type of
the output requested.
}
\author{ Jeffrey A. Ryan }
\note{
As this uses \code{do.call} internally to create the new output device,
any device that makes use of R conventions should be acceptable as a
value for \code{.type}
}
\seealso{ \code{\link{pdf}}
\code{\link{png}}
\code{\link{jpeg}}
\code{\link{bitmap}}
\code{\link{postscript}}
}
\examples{
\dontrun{
getSymbols("AAPL")
chartSeries(AAPL)
require(TTR)
addBBands()
saveChart('pdf')
saveChart('pdf', width=13)
}
}
\keyword{ aplot }
\keyword{ device }
\keyword{ dplot }
quantmod/man/getModelData.Rd 0000644 0001762 0000144 00000002076 15002467345 015511 0 ustar ligges users \name{getModelData}
\alias{getModelData}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Update model's dataset }
\description{
Update currently specified or built model with most recent data.
}
\usage{
getModelData(x, na.rm = TRUE)
}
\arguments{
\item{x}{ An object of class \code{quantmod} }
\item{na.rm}{ Boolean. Remove NA values. Defaults to TRUE }
}
\details{
Primarily used within specify model calls,
\code{getModelData} is used to retrieve the appropriate underlying variables,
and apply model specified transformations automatically.
It can be used to also update a current model in memory with the most recent data.
}
\value{
Returns object of class \code{quantmod.OHLC}
}
\author{ Jeffrey Ryan }
\seealso{
\code{\link{getSymbols}} load data
\code{\link{specifyModel}} create model structure
\code{\link{buildModel}} construct model
\code{\link{modelData}} extract model dataset
}
\examples{
\dontrun{
my.model <- specifyModel(Next(OpCl(QQQ)) ~ Lag(Cl(NDX),0:5))
getModelData(my.model)
}
}
\keyword{ datasets }% at least one, from doc/KEYWORDS
quantmod/man/setTA.Rd 0000644 0001762 0000144 00000003231 15000510306 014151 0 ustar ligges users \name{setTA}
\alias{setTA}
\alias{unsetTA}
\alias{listTA}
\title{ Manage TA Argument Lists }
\description{
Used to manage the TA arguments used inside \code{chartSeries}
calls.
}
\usage{
setTA(type = c("chartSeries", "barChart", "candleChart"))
listTA(dev)
}
\arguments{
\item{type}{ the function to apply defaults TAs to }
\item{dev}{ the device to display TA arguments for }
}
\details{
\code{setTA} and \code{unsetTA} provide a simple
way to reuse the same TA arguments for multiple
charts. By default all charting functions will be
set to use the current chart's defaults.
It is important to note that the \emph{current} device
will be used to extract the list of TA arguments to apply.
This is done with a call to listTA internally, and followed
by calls to setDefaults of the appropriate functions.
An additional way to set default TA arguments for subsequent
charts is via \code{setDefaults}. See the examples.
}
\value{
Called for its side-effect of setting the default
TA arguments to quantmod's charting functions.
}
\author{ Jeffrey A. Ryan }
\note{
Using \code{setDefaults} directly will require the vector
of default TA calls to be wrapped in a call to
\code{substitute} to prevent unintended evaluations; \emph{OR}
a call to \code{listTA} to get the present TA arguments. This last
approach is what \code{setTA} wraps.
}
\seealso{ \code{\link{chartSeries}},
\code{\link{addTA}} }
\examples{
\dontrun{
listTA()
setTA()
# a longer way to accomplish the same
setDefaults(chartSeries,TA=listTA())
setDefaults(barCart,TA=listTA())
setDefaults(candleChart,TA=listTA())
setDefaults(chartSeries,TA=substitute(c(addVo(),addBBands())))
}
}
\keyword{ utilities }
quantmod/man/getSymbols.oanda.Rd 0000644 0001762 0000144 00000004513 15002467345 016366 0 ustar ligges users \name{getSymbols.oanda}
\alias{getSymbols.oanda}
\alias{oanda.currencies}
\title{ Download Currency and Metals Data from Oanda.com }
\description{
Access to 191 currency and metal prices, downloadable
as more that 36000 currency pairs from Oanda.com.
Downloads \code{Symbols} to specified \code{env} from
\url{https://www.oanda.com} historical currency database.
This method is not meant to be called directly, instead
a call to \code{getSymbols("x",src="oanda")} will
in turn call this method. It is documented for the
sole purpose of highlighting the arguments accepted,
and to serve as a guide to creating additional
getSymbols 'methods'.
}
\usage{
getSymbols.oanda(Symbols,
env,
return.class = "xts",
from = Sys.Date() - 179,
to = Sys.Date(),
...)
}
\arguments{
\item{Symbols}{ a character vector specifying the names
of each symbol to be loaded - expressed as a currency pair.
(e.g. U.S. Dollar to Euro rate would be expressed as
a string \dQuote{USD/EUR}. The naming convention follows from
Oanda.com, and a table of possible values is
available by calling \code{oanda.currencies} }
\item{env}{ where to create objects. }
\item{return.class}{ class of returned object }
\item{from}{ Start of series expressed as "CCYY-MM-DD" }
\item{to}{ Start of series expressed as "CCYY-MM-DD" }
\item{\dots}{ additional parameters }
}
\details{
Meant to be called internally by getSymbols only.
Oanda data is 7 day daily average price data, that is Monday through Sunday.
Oanda only provides historical data for the past 180 days. getSymbols will
return as much data as possible, and warn when the \code{from} date is more
than 180 days ago.
}
\value{
A call to getSymbols(Symbols,src="oanda") will load into the specified
environment one object for each 'Symbol' specified, with class
defined by 'return.class'. Presently this may be 'ts',
'zoo', 'xts', or 'timeSeries'.
}
\note{
Oanda rates are quoted as one unit of base currency to the
equivelant amount of foreign
currency.
}
\references{ Oanda.com \url{https://www.oanda.com} }
\author{ Jeffrey A. Ryan }
\seealso{ Currencies: \code{\link{getSymbols.FRED}},
\code{\link{getSymbols}} }
\examples{
\dontrun{
getSymbols("USD/EUR",src="oanda")
getSymbols("USD/EUR",src="oanda",from="2005-01-01")
}
}
\keyword{ datasets }
quantmod/man/Delt.Rd 0000644 0001762 0000144 00000003737 15000510306 014034 0 ustar ligges users \name{Delt}
\alias{Delt}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Calculate Percent Change }
\description{
Calculate the k-period percent difference within one series, or
between two series. Primarily used to calculate the percent change
from one period to another of a given series, or to calculate
the percent difference between two series over the full series.
}
\usage{
Delt(x1, x2 = NULL, k = 0, type = c("arithmetic", "log"))
}
\arguments{
\item{x1}{ \emph{m x 1} vector }
\item{x2}{ \emph{m x 1} vector }
\item{k}{ change over \code{k}-periods. default k=1 when x2 is NULL. }
\item{type}{ type of difference. log or arithmetic (default). }
}
\details{
When called with only \code{x1}, the one period percent change of the
series is returned by default. Internally this happens by copying
x1 to x2. A two period difference would be specified with \code{k=2}.
If called with both \code{x1} and \code{x2}, the difference between
the two is returned. That is, k=0. A one period difference would be
specified by \code{k=1}. \code{k} may also be a vector to calculate
more than one period at a time. The results will then be an m x length(k)
Arithmetic differences are used by default:
Lag = (x2(t) - x1(t-k))/x1(t-k)
Log differences are calculated:
Lag = log(x2(t)/x1(t-k))
}
\value{
An matrix of \code{length(x1)} rows and \code{length(k)} columns.
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{OpOp}} \code{\link{OpCl}} }
\examples{
Stock.Open <- c(102.25,102.87,102.25,100.87,103.44,103.87,103.00)
Stock.Close <- c(102.12,102.62,100.12,103.00,103.87,103.12,105.12)
Delt(Stock.Open) #one period pct. price change
Delt(Stock.Open,k=1) #same
Delt(Stock.Open,type='arithmetic') #using arithmetic differences (default)
Delt(Stock.Open,type='log') #using log differences
Delt(Stock.Open,Stock.Close) #Open to Close pct. change
Delt(Stock.Open,Stock.Close,k=0:2) #...for 0,1, and 2 periods
}
\keyword{ utilities }
quantmod/man/TA.Rd 0000644 0001762 0000144 00000007174 15002467345 013467 0 ustar ligges users \name{TA}
\alias{TA}
\alias{dropTA}
\alias{moveTA}
\alias{swapTA}
\alias{addTRIX}
\alias{addATR}
\alias{addCMF}
\alias{addDPO}
\alias{addCMO}
\alias{addCLV}
\alias{addEMV}
\alias{addAroon}
\alias{addAroonOsc}
\alias{addVolatility}
\alias{addOBV}
\alias{addChVol}
\alias{addChAD}
\alias{addKST}
\alias{addMFI}
\alias{addTDI}
\alias{addZigZag}
\alias{addLines}
\alias{addPoints}
\alias{addMomentum}
\alias{addEnvelope}
\title{ Add Technical Indicator to Chart }
\description{
Functions to add technical indicators to a chart.
}
\details{
The general mechanism to add technical analysis studies or overlays
to a financial chart created with \code{chartSeries}.
General TA charting tool functions:
\itemize{
\item \code{addTA}: add data as custom indicator
\item \code{dropTA}: remove technical indicator
\item \code{moveTA}: move a technical indicator
\item \code{swapTA}: swap two technical indicators
}
Current technical indicators include:
\itemize{
\item \code{addADX}: add Welles Wilder's Directional Movement Indicator
\item \code{addATR}: add Average True Range
\item \code{addAroon}: add Aroon Indicator
\item \code{addAroonOsc}: add Aroon Oscillator
\item \code{addBBands}: add Bollinger Bands
\item \code{addCCI}: add Commodity Channel Index
\item \code{addCMF}: add Chaiken Money Flow
\item \code{addChAD}: add Chaiken Accumulation Distribution Line
\item \code{addChVol}: add Chaiken Volatility
\item \code{addCMO}: add Chande Momentum Oscillator
\item \code{addDEMA}: add Double Exponential Moving Average
\item \code{addDPO}: add Detrended Price Oscillator
\item \code{addEMA}: add Exponential Moving Average
\item \code{addEMV}: add Arm's Ease of Movement
\item \code{addEnvelope}: add Moving Average Envelope
\item \code{addEVWMA}: add Exponential Volume Weighted Moving Average
\item \code{addExpiry}: add options or futures expiration lines
\item \code{addKST}: add Know Sure Thing
\item \code{addLines}: add line(s)
\item \code{addMACD}: add Moving Average Convergence Divergence
\item \code{addMFI}: add Money Flow Index
\item \code{addMomentum}: add Momentum
\item \code{addOBV}: add On-Balance Volume
\item \code{addPoints}: add point(s)
\item \code{addROC}: add Rate of Change
\item \code{addRSI}: add Relative Strength Indicator
\item \code{addSAR}: add Parabolic SAR
\item \code{addSMA}: add Simple Moving Average
\item \code{addSMI}: add Stochastic Momentum Index
\item \code{addTDI}: add Trend Direction Index
\item \code{addTRIX}: add Triple Smoothed Exponential Oscillator
\item \code{addVo}: add Volume (if available)
\item \code{addVolatility}: add volatility
\item \code{addWMA}: add Weighted Moving Average
\item \code{addWPR}: add Williams Percent R
\item \code{addZigZag}: add Zig Zag
\item \code{addZLEMA}: add ZLEMA
}
See the individual functions for specific implementation and argument details. Details
of the underlying TTR implementations can be found in \pkg{TTR}.
The primary changes between the add*** version of an indicator and the
\pkg{TTR} base function is the absense of the data argument in the former.
Notable additions include \code{on}, \code{with.col}.
}
\value{
Called for its side effects, an object to class \code{chobTA}
will be returned invisibly. If called from the \R command line
the method will draw the appropriate indicator on the current chart.
}
\note{
Calling any of the above methods from within a function or script
will generally require them to be wrapped in a \code{plot} call
as they rely on the context of the call to initiate the actual
charting addition.
}
\references{ Josh Ulrich - TTR package }
\author{ Jeffrey A. Ryan }
\keyword{ aplot }
quantmod/man/buildData.Rd 0000644 0001762 0000144 00000003305 15002467345 015044 0 ustar ligges users \name{buildData}
\alias{buildData}
\title{ Create Data Object for Modelling }
\description{
Create one data object from multiple sources, applying
transformations via standard \R formula mechanism.
}
\usage{
buildData(formula, na.rm = TRUE, return.class = "zoo")
}
\arguments{
\item{formula}{ an object of class \code{formula} (or one
that can be coerced to that class): a symbolic description
of the desired output data object, with the \code{dependent} side
corresponding to first column, and the \code{independent} parameters of
the formula assigned to the remaining columns. }
\item{na.rm}{ drop rows with missing values? }
\item{return.class}{ one of "zoo","data.frame","ts","timeSeries" }
}
\details{
Makes available for use \emph{outside} the \pkg{quantmod} workflow a dataset
of appropriately transformed variables, using the same mechanism
underlying \code{specifyModel}. Offers the ability to apply transformations
to raw data using a common formula mechanism, without having to explicitly
merge different data objects.
Interally calls \code{specifyModel} followed by \code{modelData}, with the
returned object being coerced to the desired 'return.class' if possible,
otherwise returns a \code{zoo} object.
See \code{getSymbols} and \code{specifyModel} for more information
regarding proper usage.
}
\value{
An object of class \code{return.class}.
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{getSymbols}}, \code{\link{specifyModel}},
\code{\link{modelData}} }
\examples{
\dontrun{
buildData(Next(OpCl(DIA)) ~ Lag(TBILL) + I(Lag(OpHi(DIA))^2))
buildData(Next(OpCl(DIA)) ~ Lag(TBILL), na.rm=FALSE)
buildData(Next(OpCl(DIA)) ~ Lag(TBILL), na.rm=FALSE, return.class="ts")
}
}
\keyword{ datagen }
quantmod/man/attachSymbols.Rd 0000644 0001762 0000144 00000007335 15002467345 015777 0 ustar ligges users \name{attachSymbols}
\alias{attachSymbols}
\alias{flushSymbols}
\title{ Attach and Flush DDB }
\description{
Attach a demand database (lazy load) as a new environment.
}
\usage{
attachSymbols(DB = DDB_Yahoo(),
pos = 2,
prefix = NULL,
postfix = NULL,
mem.cache = TRUE,
file.cache = !mem.cache,
cache.dir = tempdir())
flushSymbols(DB = DDB_Yahoo())
}
\arguments{
\item{DB}{ A \code{DDB} data base object }
\item{pos}{ position in search path to attach DB }
\item{prefix}{ character to prefix all symbols with }
\item{postfix}{ character to postfix all symbols with }
\item{mem.cache}{ should objects be cached in memory }
\item{file.cache}{ should objects be cached in on disk }
\item{cache.dir}{ directory to use for \code{file.cache=TRUE} }
}
\details{
An experimental function to allow access to remote objects without
requiring explicit calls to a loading function.
\code{attachSymbols} requires a \code{DDB} object
to define where the data is to come from, as well as what symbols are
loaded on-demand.
attachSymbols calls the method referred to
by the \code{DDB} object. In the default case this is
\code{DDB_Yahoo}. See this function for specific details
about the Yahoo implementation.
The individual methods make use of \code{getSymbols} to
load the data. This requires a corresponding
getSymbols method.
Internally, attachSymbols makes use of quantmod's unexported
create.bindings to dynamically create active
bindings to each symbol listed in the DDB object.
In turn, create.bindings uses one of two \R methods to
create the binding to the names required. This depends
on the cache method requested.
Immediately after a call to attachSymbols, a new
environment is attached that contains the names of
objects yet to be loaded. This is similar to the
lazy-load mechanism in \R, though extended to be both
more general and easier to use.
It is important to note that no data is loaded at this stage.
What occurs instead is that these symbols now have active bindings
using either \code{delayedAssign} (mem.cache) or
\code{makeActiveBinding} (file.cache).
During all future requests for the object(s) in question,
the binding will be used to determine how this data is
loaded into R. \code{mem.cache} will simply load the
data from its corresponding source (as defined by the DDB object)
and leave it in the environment specified in the original call.
The effect of this is to allow lazy-loading of data from
a variety of external sources (Yahoo in the default case).
Once loaded, these are cached in \R's memory. Nothing further
differentiates these from standard variables. This also means
that the environment will grow as more symbols are loaded.
If the \code{file.cache} option is set, the data is loaded from
its source the first time the symbol is referenced. The difference
is that the data is then written to a temporary file and maintained
there. Data is loaded and subsequently removed upon each
request for the object. See \code{makeActiveBinding} for details
of how this occurs at the \R level.
A primary advantage of using the file.cache option is the ability
to maintain hundreds or thousands of
objects in your current session without using
memory, or explicitly loading and removing.
The main downside of this approach is the that data must be loaded
from disk each time, with the corresponding (if generally negligible)
overhead of file access.
}
%\value{
%
%}
\references{ Luke's stuff and Mark Brevington and Roger Peng }
\author{ Jeffrey A. Ryan }
\note{
This function is new, and all aspects may change in the near future.
}
\seealso{ \code{delayedAssign}, \code{makeActiveBinding} }
\examples{
\dontrun{
attachSymbols()
SBUX
QQQ
ls()
}
}
\keyword{ misc }
quantmod/man/addSAR.Rd 0000644 0001762 0000144 00000001232 15000510306 014226 0 ustar ligges users \name{addSAR}
\alias{addSAR}
\title{ Add Parabolic Stop and Reversal to Chart }
\description{
Add Parabolic Stop and Reversal indicator overlay to chart.
}
\usage{
addSAR(accel = c(0.02, 0.2), col = "blue")
}
\arguments{
\item{accel}{ Accelleration factors - see SAR }
\item{col}{ color of points (optional) }
}
\details{
see 'SAR' in \pkg{TTR} for specific details and references.
}
\value{
A SAR overlay will be drawn on the current
chart. A chobTA object will be returned silently.
}
\references{ see SAR in \pkg{TTR} written by Josh Ulrich }
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{addTA}}}
\examples{
\dontrun{
addSAR()
}
}
\keyword{ utilities }
quantmod/man/has.Rd 0000644 0001762 0000144 00000004614 15002467345 013732 0 ustar ligges users \name{has.OHLC}
\alias{has.Ask}
\alias{has.Bid}
\alias{has.Price}
\alias{has.Qty}
\alias{has.Trade}
\alias{is.BBO}
\alias{is.TBBO}
\alias{has.Ad}
\alias{has.Op}
\alias{has.Hi}
\alias{has.Lo}
\alias{has.Cl}
\alias{has.Vo}
\alias{has.OHLC}
\alias{has.OHLCV}
\alias{is.OHLC}
\alias{is.OHLCV}
\alias{has.HLC}
\alias{is.HLC}
\alias{has.HL}
\alias{is.HL}
\title{ Check For OHLC Data }
\description{
A set of functions to check for appropriate
OHLC and HLC column names within a data object, as well
as the availability and position of those columns.
}
\usage{
is.OHLC(x)
has.OHLC(x, which = FALSE)
is.OHLCV(x)
has.OHLCV(x, which = FALSE)
is.HLC(x)
has.HLC(x, which = FALSE)
is.HL(x)
has.HL(x, which = FALSE)
has.Op(x, which = FALSE)
has.Hi(x, which = FALSE)
has.Lo(x, which = FALSE)
has.Cl(x, which = FALSE)
has.Vo(x, which = FALSE)
has.Ad(x, which = FALSE)
is.BBO(x)
is.TBBO(x)
has.Ask(x, which = FALSE)
has.Bid(x, which = FALSE)
has.Price(x, which = FALSE)
has.Qty(x, which = FALSE)
has.Trade(x, which = FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{x}{ data object }
\item{which}{ display position of match }
}
\details{
Mostly used internally by \pkg{quantmod}, they can be useful
for checking whether an object
can be used in OHLC requiring functions like \code{Op},
\code{OpCl}, etc.
Columns names must contain the full description of data,
that is, Open, High, Low, Close, Volume or Adjusted. Abbreviations
will return \code{FALSE} (or \code{NA} when \code{which = TRUE}). See
\code{\link{quantmod.OHLC}} for details of \pkg{quantmod}
naming conventions.
The "is" functions only return \code{TRUE} when the objects has the relevant
column names:
\itemize{
\item \code{is.HL}: High, Low
\item \code{is.HLC}: High, Low, Close
\item \code{is.OHLC}: Open, High, Low, Close
}
The search for relevant column names is not case sensitive.
Any additional columns in the object does not affect the return value.
}
\value{
A logical value indicating success or failure by default.
If \code{which = TRUE}, a numeric value representing the column position
will be returned.
\code{is.OHLC}, \code{is.HL}, and \code{is.HLC} return a single logical value,
either \code{TRUE} or \code{FALSE}.
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{quantmod.OHLC}},\code{\link{OHLC.Transformations}} }
\examples{
\dontrun{
getSymbols("AAPL")
is.OHLC(AAPL)
has.OHLC(AAPL)
has.Ad(AAPL)
}
}
\keyword{ utilities }
quantmod/man/getQuote.Rd 0000644 0001762 0000144 00000004676 15002467345 014764 0 ustar ligges users \name{getQuote}
\alias{getQuote}
\alias{standardQuote}
\alias{yahooQF}
\alias{yahooQuote.EOD}
\title{ Download Current Stock Quote }
\description{
Fetch current stock quote(s) from specified source. At present this only
handles sourcing quotes from Yahoo Finance and Alpha Vantage, but it can be
extended to additional sources.
}
\usage{
getQuote(Symbols, src = "yahoo", what, ...)
standardQuote(src="yahoo")
yahooQF(names)
yahooQuote.EOD
}
\arguments{
\item{Symbols}{ character string of symbols, separated by semi-colons }
\item{src}{ source of data ("yahoo" and "av" are currently implemented) }
\item{what}{ what should be retrieved }
\item{names}{ which data should be retrieved }
\item{\dots}{ currently unused }
}
\value{
The number of symbols per request is limited to 200 for Yahoo! and 100 for
Alpha Vantage. \code{getQuote} will make multiple requests if more than the
maximum number of symbols are requested. It will then combine the results of
all the requests and return one data frame. The data frame will contain a
column for each requested data field, and the requested symbols will be stored
in the row names.
In order to import quotes from Alpha Vantage, you must obtain an
\emph{API key} by completing a free, one-time registration at their website:
\url{https://www.alphavantage.co/}. Then you can call \code{getQuote} with
\code{src = "av"} and \code{api.key = "[your key]"}.
The \code{what} argument allows for specific data to be requested. For
\code{getQuote.yahoo}, the value of \code{what} should be a \code{quoteFormat}
object like that returned by \code{standardQuote}. The \code{yahooQF} function
will create an interactive selection tool if the \code{what} argument is
missing. The \code{what} argument is currently ignored for Alpha Vantage data
because only a few fields are available.
\code{standardQuote} currently only applies to the Yahoo! data source. It
returns a \code{quoteFormat} object to use with the \code{getQuote} function.
\code{yahooQuote.EOD} is a constant \code{quoteFormat} object for OHLCV data.
}
\references{
Yahoo! Finance \url{https://finance.yahoo.com}
Alpha Vantage \url{https://www.alphavantage.co}
}
\author{
Jeffrey A. Ryan (Yahoo)
Ethan B. Smith (Alpha Vantage)
}
\seealso{ \code{\link{getSymbols}}, \code{\link{getSymbols.av}} }
\examples{
yahooQuote.EOD
\dontrun{
getQuote("AAPL")
getQuote("QQQ;SPY;^VXN",what=yahooQF(c("Bid","Ask")))
standardQuote()
yahooQF()
}
}
\keyword{ IO }
\keyword{ data }
quantmod/man/addCCI.Rd 0000644 0001762 0000144 00000001246 15000510306 014204 0 ustar ligges users \name{addCCI}
\alias{addCCI}
\title{ Add Commodity Channel Index }
\description{
Add Commodity Channel Index
}
\usage{
addCCI(n = 20, maType="SMA", c=0.015)
}
\arguments{
\item{n}{ periods to use for DX calculation}
\item{maType}{ moving average type }
\item{c}{ Constant to apply to the mean deviation.}
}
\details{
See 'CCI' in \pkg{TTR} for specific details and references.
}
\value{
An CCI indicator will be draw in a new window on the current
chart. A chobTA object will be returned silently.
}
\references{ see CCI in \pkg{TTR} written by Josh Ulrich }
\author{Jeffrey A. Ryan }
\seealso{ \code{\link{addTA}} }
\examples{
\dontrun{
addCCI()
}
}
\keyword{utilities}
quantmod/man/getSymbols.yahoo.Rd 0000644 0001762 0000144 00000006607 15002467345 016431 0 ustar ligges users \name{getSymbols.yahoo}
\alias{getSymbols.yahoo}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Download OHLC Data From Yahoo Finance }
\description{
Downloads \code{Symbols} to specified \code{env}
from \sQuote{finance.yahoo.com}. This method is
not to be called directly, instead a call to
\code{getSymbols(Symbols,src='yahoo')} will in
turn call this method. It is documented for the
sole purpose of highlighting the arguments
accepted, and to serve as a guide to creating
additional getSymbols \sQuote{methods}.
}
\usage{
getSymbols.yahoo(Symbols,
env,
return.class = 'xts',
index.class = 'Date',
from = "2007-01-01",
to = Sys.Date(),
...,
periodicity = "daily",
curl.options = list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{Symbols}{ a character vector specifying
the names of each symbol to be loaded}
\item{env}{ where to create objects. (.GlobalEnv) }
\item{return.class}{ class of returned object }
\item{index.class}{ class of returned object index (xts only) }
\item{from}{ Retrieve data no earlier than this date.
(2007-01-01)}
\item{to}{ Retrieve data through this date (Sys.Date())}
\item{\dots}{ additional parameters }
\item{periodicity}{ periodicity of data to query and return. Must be
one of "daily", "weekly", "monthly". ("daily") }
\item{curl.options}{ options passed to \code{curl::handle_setopt} }
}
\details{
Meant to be called internally by \code{getSymbols} (see also).
One of a few currently defined methods for loading
data for use with \pkg{quantmod}. Essentially a
simple wrapper to the underlying Yahoo! finance site's
historical data download.
}
\section{Warning}{
As of quantmod 0.4-9, \code{getSymbols.yahoo} has been patched to
work with changes to Yahoo Finance, which also included the following
changes to the raw data:
\itemize{
\item The adjusted close column appears to no longer include dividend adjustments
\item The close column appears to be adjusted for splits twice
\item The open, high, and low columns are adjusted for splits, and
\item The raw data may contain missing values.
}
}
\value{
A call to getSymbols.yahoo will load into the specified
environment one object for each
\code{Symbol} specified, with class defined
by \code{return.class}. Presently this may be \code{ts},
\code{zoo}, \code{xts}, or \code{timeSeries}.
In the case of xts objects, the indexing will be by Date. This
can be altered with the \code{index.class} argument. See
\code{indexClass} for more information on changing index classes.
}
\references{ Yahoo Finance: \url{https://finance.yahoo.com} }
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{getSymbols}},
\code{\link{setSymbolLookup}} }
\examples{
\dontrun{
# All 3 getSymbols calls return the same
# MSFT to the global environment
# The last example is what NOT to do!
## Method #1
getSymbols('MSFT',src='yahoo')
## Method #2
setDefaults(getSymbols,src='yahoo')
# OR
setSymbolLookup(MSFT='yahoo')
getSymbols('MSFT')
#########################################
## NOT RECOMMENDED!!!
#########################################
## Method #3
getSymbols.yahoo('MSFT',env=globalenv())
}
}
\keyword{ data }
quantmod/man/getSymbols.SQLite.Rd 0000644 0001762 0000144 00000004340 15002467345 016443 0 ustar ligges users \name{getSymbols.SQLite}
\alias{getSymbols.SQLite}
\title{ Retrieve Data from SQLite Database }
\description{
Fetch data from SQLite database. As with other methods
extending \code{getSymbols}
this function should \emph{NOT} be called directly.
}
\usage{
getSymbols.SQLite(Symbols,
env,
return.class = 'xts',
db.fields = c("row_names",
"Open",
"High",
"Low",
"Close",
"Volume",
"Adjusted"),
field.names = NULL,
dbname = NULL,
POSIX = TRUE,
...)
}
\arguments{
\item{Symbols}{ a character vector specifying the names of each
symbol to be loaded }
\item{env}{ where to create the objects }
\item{return.class}{ desired class of returned object }
\item{db.fields}{ character vector naming fields to retrieve }
\item{field.names}{ names to assign to returned columns }
\item{dbname}{ database name }
\item{POSIX}{ are rownames numeric }
\item{\dots}{ additional arguments }
}
\details{
Meant to be called internally by \code{getSymbols} (see also)
One of a few currently defined methods for loading data for use
with 'quantmod'. Its use requires the packages 'DBI' and 'RSQLite',
along with a SQLite database.
The purpose of this abstraction is to make transparent the
'source' of the data, allowing instead the user to concentrate on
the data itself.
}
\value{
A call to getSymbols.SQLite will load into the specified
environment one object for each 'Symbol' specified, with class
defined by 'return.class'.
}
\references{
\itemize{
\cite{SQLite \url{https://www.sqlite.org/index.html}}
\cite{David A. James
RSQLite: SQLite interface for R
}
\cite{R-SIG-DB. DBI: R Database Interface}
}
}
\author{Jeffrey A. Ryan}
\note{
This function is experimental at best, and has not been
thoroughly tested. Use with caution, and please report
any bugs to the maintainer of quantmod.
}
\seealso{ \code{\link{getSymbols}}}
\examples{
\dontrun{
getSymbols("QQQ",src="SQLite")
}
}
\keyword{ utilities }
quantmod/man/buildModel.Rd 0000644 0001762 0000144 00000004351 15002467345 015235 0 ustar ligges users \name{buildModel}
\alias{buildModel}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Build quantmod model given specified fitting method }
\description{
Construct and attach a fitted model of type \code{method} to \code{quantmod} object.
}
\usage{
buildModel(x, method, training.per, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{x}{ An object of class \code{quantmod} created with \code{\link{specifyModel}} or
an \R formula }
\item{training.per}{ character vector representing dates in ISO 8601 format
\dQuote{CCYY-MM-DD} or \dQuote{CCYY-MM-DD HH:MM:SS}
of length 2}
\item{method}{ A character string naming the fitting method.
See details section for available methods, and
how to create new methods.}
\item{\dots}{ Additional arguments to method call }
}
\details{
Currently available methods include:
lm, glm, loess, step, ppr,
rpart[rpart], tree[tree],
randomForest[randomForest], mars[mda],
polymars[polspline], lars[lars], rq[quantreg],
lqs[MASS], rlm[MASS], svm[e1071], and nnet[nnet].
The \code{training.per} \emph{should} match the undelying date
format of the time-series data used in modelling. Any other style
may not return what you expect.
Additional methods wrappers can be created to allow for modelling
using custom functions. The only requirements are for a wrapper
function to be constructed taking parameters \code{quantmod},
\code{training.data}, and \dots. The function must return the
fitted model object and have a predict method available.
It is possible to add predict methods if non exist by
adding an S3 method for predictModel. The \code{
buildModel.skeleton} function can be used for new methods.
}
\value{
An object of class \code{quantmod} with fitted model attached
}
\author{ Jeffrey Ryan }
\note{ See \code{buildModel.skeleton} for information on adding additional methods
}
\seealso{ \code{\link{specifyModel}} \code{\link{tradeModel}} }
\examples{
\dontrun{
getSymbols('QQQ',src='yahoo')
q.model = specifyModel(Next(OpCl(QQQ)) ~ Lag(OpHi(QQQ),0:3))
buildModel(q.model,method='lm',training.per=c('2006-08-01','2006-09-30'))
}
}
\keyword{ models }% at least one, from doc/KEYWORDS
quantmod/man/modelData.Rd 0000644 0001762 0000144 00000002331 15000510306 015023 0 ustar ligges users \name{modelData}
\alias{modelData}
\title{ Extract Dataset Created by specifyModel }
\description{
Extract from a \code{quantmod} object the
dataset created for use in modelling.
specifyModel creates a \code{zoo} object for
use in subsequent workflow stages (
\code{buildModel},\code{tradeModel}) that
combines all model inputs, from a variety
of sources, into one model frame.
\code{modelData} returns this object.
}
\usage{
modelData(x, data.window = NULL, exclude.training = FALSE)
}
\arguments{
\item{x}{ a \code{quantmod} object }
\item{data.window}{ a character vector of subset start
and end dates to return }
\item{exclude.training}{ remove training period }
}
\details{
When a model is created by \code{specifyModel}, it
is attached to the returned object. One of the
slots of this S4 class is \code{model.data}.
}
\value{
an object of class \code{zoo} containing all
transformations to data specified in
\code{specifyModel}.
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{specifyModel}},\code{\link{getModelData}} }
\examples{
\dontrun{
m <- specifyModel(Next(OpCl(SPY)) ~ Cl(SPY) + OpHi(SPY) + Lag(Cl(SPY)))
modelData(m)
}
}
\keyword{ data}
\keyword{ utilities }% __ONLY ONE__ keyword per line
quantmod/man/peak.Rd 0000644 0001762 0000144 00000002053 15000510306 014052 0 ustar ligges users \name{findPeaks}
\alias{findPeaks}
\alias{findValleys}
\alias{peak}
\alias{valley}
\title{ Find Peaks and Valleys In A Series }
\description{
Functions to find the peaks (tops) and valleys (bottoms)
of a given series.
}
\usage{
findPeaks(x, thresh=0)
findValleys(x, thresh=0)
}
\arguments{
\item{x}{ a time series or vector }
\item{thresh}{ minimum peak/valley threshold }
}
\value{
A vector of integers corresponding to peaks/valleys.
As a peak[valley] is defined as the highest[lowest] value in a series,
the function can only define it after a change in direction
has occurred. This means that the function will always
return the first period \emph{after} the peak/valley of the
data, so as not to accidentally induce a look-ahead bias.
}
\author{ Jeffrey A. Ryan }
\examples{
findPeaks(sin(1:10))
p <- findPeaks(sin(seq(1,10,.1)))
sin(seq(1,10,.1))[p]
plot(sin(seq(1,10,.1))[p])
plot(sin(seq(1,10,.1)),type='l')
points(p,sin(seq(1,10,.1))[p])
}
% Add one or more standard keywords, see file 'KEYWORDS' in the
% R documentation directory.
\keyword{ misc }
quantmod/man/getFinancials.Rd 0000644 0001762 0000144 00000004350 15002467345 015723 0 ustar ligges users \name{getFinancials}
\alias{getFinancials}
\alias{viewFinancials}
\alias{getFin}
\alias{viewFin}
\title{ Download and View Financial Statements }
\description{
Download Income Statement, Balance Sheet, and Cash Flow Statements.
}
\usage{
getFinancials(Symbol, env = parent.frame(), src = "google",
auto.assign = TRUE,
...)
viewFinancials(x, type=c('BS','IS','CF'), period=c('A','Q'),
subset = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{Symbol}{ one or more valid google symbol, as a character vector or
semi-colon delimited string }
\item{env}{ where to create the object }
\item{src}{ currently no sources are implemented }
\item{auto.assign}{ should results be loaded to the environment }
\item{\dots}{ currently unused }
\item{x}{ an object of class financials }
\item{type}{ type of statement to view }
\item{period}{ period of statement to view }
\item{subset}{ \sQuote{xts} style subset string }
}
\details{
A utility to download financial statements for publicly traded companies.
Individual statements can be accessed using
standard \R list extraction tools, or by
using \code{viewFinancials}.
\code{viewFinancials} allows for the use of
date subsetting as available in the \pkg{xts}
package, as well as the specification of
the type of statement to view. BS for balance
sheet, IS for income statement, and CF for cash flow
statement. The period argument is used to identify
which statements to view - (A) for annual and (Q)
for quarterly.
}
\value{
Six individual matrices organized in a list of class \sQuote{financials}:
\item{ IS }{ a list containing (Q)uarterly and (A)nnual Income Statements }
\item{ BS }{ a list containing (Q)uarterly and (A)nnual Balance Sheets }
\item{ CF }{ a list containing (Q)uarterly and (A)nnual Cash Flow Statements }
}
\author{ Jeffrey A. Ryan }
\note{
As with all free data, you may be getting exactly what you pay for.
Sometimes that may be absolutely nothing.
}
\examples{
\dontrun{
getFinancials('JAVA') # returns JAVA.f to "env"
getFin('AAPL') # returns AAPL.f to "env"
viewFin(JAVA.f, "IS", "Q") # Quarterly Income Statement
viewFin(AAPL.f, "CF", "A") # Annual Cash Flows
str(AAPL.f)
}
}
\keyword{ utilities }
quantmod/man/chobTA-class.Rd 0000644 0001762 0000144 00000002071 15000510306 015375 0 ustar ligges users \name{chobTA-class}
\docType{class}
\alias{chobTA-class}
\alias{show,chobTA-method}
\title{A Technical Analysis Chart Object }
\description{ Internal storage class for handling arbitrary TA objects }
\section{Objects from the Class}{
Objects of class \code{chobTA} are created and returned invisibly
through calls to addTA-style functions.
}
\section{Slots}{
\describe{
\item{\code{call}:}{Object of class \code{"call"} ~~ }
\item{\code{on}:}{Object of class \code{"ANY"} ~~ }
\item{\code{new}:}{Object of class \code{"logical"} ~~ }
\item{\code{TA.values}:}{Object of class \code{"ANY"} ~~ }
\item{\code{name}:}{Object of class \code{"character"} ~~ }
\item{\code{params}:}{Object of class \code{"ANY"} ~~ }
}
}
\section{Methods}{
\describe{
\item{show}{\code{signature(object = "chobTA")}: ... }
}
}
\author{ Jeffrey A. Ryan }
\note{ It is of no external vaule to handle chobTA objects directly }
\seealso{
\code{\link{addTA}}, ~~~
or \code{\linkS4class{chob}} for links to other classes
}
\examples{
showClass("chobTA")
}
\keyword{classes}
quantmod/man/getMetals.Rd 0000644 0001762 0000144 00000004052 15002467345 015100 0 ustar ligges users \name{getMetals}
\alias{getMetals}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Download Daily Metals Prices }
\description{
Download daily metals prices from oanda.
}
\usage{
getMetals(Metals,
from = Sys.Date() - 179,
to = Sys.Date(),
base.currency="USD",
env = parent.frame(),
verbose = FALSE,
warning = TRUE,
auto.assign = TRUE, ...)
}
\arguments{
\item{Metals}{ metals expressed in common name or symbol form }
\item{from}{ start date expressed in ISO CCYY-MM-DD format }
\item{to}{ end date expressed in ISO CCYY-MM-DD format }
\item{base.currency}{ which currency should the price be in }
\item{env}{ which environment should they be loaded into }
\item{verbose}{ be verbose }
\item{warning}{ show warnings }
\item{auto.assign}{ use auto.assign }
\item{\dots}{ additional parameters to be passed to getSymbols.oanda method }
}
\details{
A convenience wrapper to \code{getSymbols(x,src='oanda')}.
The most useful aspect of getMetals is the ability to specify the Metals
in terms of underlying 3 character symbol or by name (e.g. XAU (gold) , XAG (silver),
XPD (palladium), or XPT (platinum)).
There are unique aspects of any continuously traded commodity, and it
is recommended that the user visit \url{https://www.oanda.com} for
details on specific pricing issues.
See \code{getSymbols} and \code{getSymbls.oanda} for more detail.
}
\value{
Data will be assigned
automatically to the environment specified (the parent environment by default).
If \code{auto.assign = FALSE}, the data from a single metal
request will simply be returned from the function call.
If \code{auto.assign = TRUE} is used (the default)
a vector of downloaded symbol names will be returned.
See \code{getSymbols} and \code{getSymbols.oanda} for more detail.
}
\references{ Oanda.com \url{https://www.oanda.com} }
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{getSymbols}}, \code{\link{getSymbols.oanda}} }
\examples{
\dontrun{
getMetals(c("gold","XPD"))
getMetals("plat",from="2005-01-01")
}
}
\keyword{ utilities}
quantmod/man/getSymbols.yahooj.Rd 0000644 0001762 0000144 00000006051 15002467345 016574 0 ustar ligges users \name{getSymbols.yahooj}
\alias{getSymbols.yahooj}
\title{ Download OHLC Data From Yahoo! Japan Finance }
\description{
Downloads \code{Symbols} to specified \code{env}
from \sQuote{finance.yahoo.co.jp}. This method is
not to be called directly, instead a call to
\code{getSymbols(Symbols,src='yahooj')} will in
turn call this method. It is documented for the
sole purpose of highlighting the arguments
accepted, and to serve as a guide to creating
additional getSymbols \sQuote{methods}.
}
\usage{
getSymbols.yahooj(Symbols,
env,
return.class = 'xts',
index.class = 'Date',
from = "2007-01-01",
to = Sys.Date(),
...)
}
\arguments{
\item{Symbols}{ a character vector specifying
the names of each symbol to be loaded}
\item{env}{ where to create objects. (.GlobalEnv) }
\item{return.class}{ class of returned object }
\item{index.class}{ class of returned object index (xts only) }
\item{from}{ Retrieve data no earlier than this date.
(2007-01-01)}
\item{to}{ Retrieve data through this date (Sys.Date())}
\item{\dots}{ additional parameters }
}
\details{
Meant to be called internally by \code{getSymbols} (see also).
One of the few currently defined methods for loading
data for use with \pkg{quantmod}. Essentially a
simple wrapper to the underlying Yahoo! Japan finance site's
historical data download.
The string \sQuote{YJ} will be prepended to the \code{Symbols} because
Japanese ticker symbols usually start with a number and it is cumbersome
to use variable names that start with a number in the R environment.
It is recommended to prepend the ticker symbols with \sQuote{YJ} yourself
if you use \code{setSymbolLookup}. That will make it possible for the main
\code{getSymbols} function to find the symbols in the lookup table.
}
\value{
A call to getSymbols.yahooj will load into the specified
environment one object for each
\code{Symbol} specified, with class defined
by \code{return.class}. Presently this may be \code{ts},
\code{zoo}, \code{xts}, or \code{timeSeries}.
In the case of xts objects, the indexing will be by Date. This
can be altered with the \code{index.class} argument. See
\code{indexClass} for more information on changing index classes.
}
\references{ Yahoo! Japan Finance: \url{https://finance.yahoo.co.jp} }
\author{ Wouter Thielen }
\seealso{ \code{\link{getSymbols}},
\code{\link{setSymbolLookup}} }
\examples{
\dontrun{
# All 4 getSymbols calls return the same
# Sony (6758.T) OHLC to the global environment
# The last example is what NOT to do!
## Method #1
getSymbols('6758.T',src='yahooj')
## Method #2
getSymbols('YJ6758.T',src='yahooj')
## Method #3
setDefaults(getSymbols,src='yahooj')
# OR
setSymbolLookup(YJ6758.T='yahooj')
getSymbols('YJ6758.T')
#########################################
## NOT RECOMMENDED!!!
#########################################
## Method #4
getSymbols.yahooj('6758.T',env=globalenv())
}
}
\keyword{ data }
quantmod/man/quantmod-package.Rd 0000644 0001762 0000144 00000002255 15002467345 016377 0 ustar ligges users \name{quantmod-package}
\alias{quantmod-package}
\alias{quantmod}
\alias{quantmodenv}
\docType{package}
\title{
Quantitative Financial Modelling Framework
}
\description{
Quantitative Financial Modelling and Trading Framework for R
}
\details{
The quantmod package for R is designed to
assist the quantitative trader in the
development, testing, and deployment
of statistically based trading models.
\emph{What quantmod IS}
A rapid prototyping environment, with comprehensive
tools for data management and visualization.
where quant traders can quickly
and cleanly explore and build trading models.
\emph{What quantmod is NOT}
A replacement for anything statistical.
It has no 'new' modelling routines or
analysis tool to speak of. It does now
offer charting not currently available
elsewhere in R, but most everything else
is more of a wrapper to what you already
know and love about the langauge
and packages you currently use.
quantmod makes modelling easier by removing
the repetitive workflow issues surrounding
data management, modelling interfaces,
and performance analysis.
}
\author{
Jeffrey A. Ryan
Maintainer: Joshua M. Ulrich
}
\keyword{ package }
quantmod/man/newTA.Rd 0000644 0001762 0000144 00000017336 15000510306 014162 0 ustar ligges users \name{newTA}
\alias{newTA}
\alias{addTA}
\alias{chartTA}
\title{ Create A New TA Indicator For chartSeries }
\description{
Functions to assist in the creation of indicators or
content to be drawn on plots produced by chartSeries.
}
\usage{
addTA(ta,
order = NULL,
on = NA,
legend = "auto",
yrange = NULL,
...)
newTA(FUN,
preFUN,
postFUN,
on = NA,
yrange = NULL,
legend.name,
fdots = TRUE,
cdots = TRUE,
data.at = 1,
...)
}
\arguments{
\item{ta}{ data to be plotted }
\item{order}{ which should the columns (if > 1) be plotted }
\item{legend}{ what custom legend text should be added to the chart. }
\item{FUN}{ Main filter function name - as a symbol }
\item{preFUN}{ Pre-filter transformation or extraction function }
\item{postFUN}{ Post-filter transformation or extraction function }
\item{on}{ where to draw }
\item{yrange}{ length 2 vector of y-axis range }
\item{legend.name}{ optional legend heading, automatically derived otherwise }
\item{fdots}{ should any \dots be included in the main filter call }
\item{cdots}{ should any \dots be included in the resultant function object.
\code{fdots=TRUE} will override this to TRUE. }
\item{data.at}{ which arguement to the main filter function is for data. }
\item{\dots}{ any additonal graphical parameters/default to be included. }
}
\details{
Both \code{addTA} and \code{newTA} can be used to
dynamically add custom content to a displayed chart.
\code{addTA} takes a series of values, either in
a form coercible to \code{xts} or of the same length as
the charted series has rows, and displays the results in
either a new TA sub-window, or over/underlayed on
the main price chart. If the object can be coerced to
\code{xts}, the time values present must only be within
the original series time-range. Internally a merge
of dates occurs and will allow for the plotting
of discontinuous series.
The \code{order} argument allows for multiple column
data to be plotted in an order that makes the most visual
sense.
Specifying a \code{legend} will override the standard
parsing of the addTA call to attempt a guess at a suitable
title for the sub-chart. Specifying this will cause the standard
last value to \emph{not} be printed.
The \dots arg to \code{addTA} is used to set graphical parameters
interpretable by \code{lines}.
\code{newTA} acts as more of a skeleton function, taking
functions as arguments, as well as charting parameters,
and returns a function that can be called in the same
manner as the built-in TA tools, such as \code{addRSI} and
\code{addMACD}. Essentially a dynamic code generator
that allows for highly customizable chart tools with
minimal (possibly zero) coding. It is also possible
to modify the resultant code to further change behavior.
To create a new TA function with \code{newTA} certain arguments
must be specified.
The \code{FUN} argument is a function symbol (or coercible to such)
that is the primary filter to be used on the core-data of a chartSeries
chart. This can be like most of the functions
within the \pkg{TTR} package --- e.g. RSI or EMA. The resultant object
of the function call will be equal to calling the function
on the original data passed into the chartSeries function that created the
chart. It should be coercible to a matrix object, of one or more
columns of output. By default all columns of output will be added to the chart,
unless suppressed by passing the appropriately positioned \code{type='n'} as
the \dots arg. Note that this will not suppress the labels added to the chart.
The \code{preFUN} argument will be called on the main chart's data prior
to passing it to FUN. This must be a function symbol or a character
string of the name function to be called.
The \code{postFUN} argument will be called on the resultant data
returned from the \code{FUN} filter. This is useful for extracting
the relevant data from the returned filter data. Like \code{preFUN}
it must be a function symbol or a character string of the name
of the function to be called.
The \code{yrange} argument is used to provide a custom
scale to the y-axis. If \code{NULL} the min and
max of the data to be plotted will be used for the y-axis
range.
The \code{on} is used to identify which subchart to add the
graphic to. By default, \code{on=NA} will draw the series
in a new subchart below the last indicator. Setting this
to either a positive or negative value will allow for
the series to be super-imposed on, or under, the (sub)chart
specified, respectively. A value of 1 refers to the main chart, and at present
is the only location supported.
\code{legend.name} will change the main label for a new plot.
\code{fdots} and \code{cdots} enable inclusion or suppression
of the \dots within the resulting TA code's call to \code{FUN},
or the argument list of the new TA function, respectively.
In order to facilitate user-specified graphical
parameters it is usually desireable to not impose
artificial limits on the end-user
with constraints on types of parameters available.
By default the new TA function will include the dots
argument, and the internal FUN call will keep all arguments, including
the dots. This may pose issues if the internal function then
passes those \dots arguments to a function that can't handle them.
The final argument is \code{data.at} which is the position
in the \code{FUN} argument list which expects the data
to be passed in at. This default to the sensible
first position, though can be changed at the time of creation
by setting this argument to the required value.
While the above functions are usually sufficient
to construct very pleasing graphical additions to
a chart, it may be necessary to modify by-hand
the code produced. This can be accomplished by
dumping the function to a file, or using \code{fix}
on it during an interactive session.
Another item of note, with respect to \code{newTA} is the
naming of the main legend label. Following
addTA convention, the first \sQuote{add} is stripped
from the function name, and the rest of the call's
name is used as the label. This can be overridden
by specifying \code{legend.name} in the construction
of the new TA call, or by passing \code{legend} into
the new TA function. Subtle differences exist, with
the former being the preferred solution.
While both functions can be used to build new indicators
without any understanding of the internal chartSeries process,
it may be beneficial in more complex cases to have a knowledge
of the multi-step process involved in creating a chart via
chartSeries.
to be added...
}
\value{
\code{addTA} will invisibly return an S4 object of
class \code{chobTA}. If this function is called
interactively, the \code{chobTA} object will be
evaluated and added to the current chart.
\code{newTA} will return a function object that
can either be assigned or evaluated. Evaluating
this function will follow the logic of any standard
addTA-style call, returning invisibly a \code{chobTA}
object, or adding to the chart.
}
\author{ Jeffrey A. Ryan }
\note{
Both interfaces are meant to fascilitate custom
chart additions. \code{addTA} is for
adding any arbitrary series to a chart, where-as
\code{newTA} works with the underlying series with
the main chart object. The latter also
acts as a dynamic TA skeleton generation tool
to help develop reusable TA generation code
for use on any chart.
}
\seealso{ \code{\link{chartSeries}},
\code{\link{TA}},
\code{\linkS4class{chob}},
\code{\linkS4class{chobTA}} }
\examples{
\dontrun{
getSymbols('SBUX')
barChart(SBUX)
addTA(EMA(Cl(SBUX)), on=1, col=6)
addTA(OpCl(SBUX), col=4, type='b', lwd=2)
# create new EMA TA function
newEMA <- newTA(EMA, Cl, on=1, col=7)
newEMA()
newEMA(on=NA, col=5)
}
}
\keyword{ aplot }
\keyword{ dplot }
\keyword{ hplot }
quantmod/man/quantmod-class.Rd 0000644 0001762 0000144 00000003664 15000510306 016076 0 ustar ligges users \name{quantmod-class}
\docType{class}
\alias{quantmod-class}
\alias{summary,quantmod-method}
\alias{show,quantmod-method}
\alias{fittedModel<--methods}
\alias{fittedModel<-,quantmod-method}
\alias{quantmodResults-class}
\alias{show,quantmodResults-method}
\alias{quantmodReturn-class}
\alias{tradeLog-class}
\alias{show,tradeLog-method}
\title{Class "quantmod" }
\description{ Objects of class \code{quantmod} help to
manage the process of model building within the quantmod
package. Created automatically by a call to \code{specifyModel}
they carry information to be used by a variety of accessor
functions and methods.
}
\section{Objects from the Class}{
Objects can be created by calls of the form \code{new("quantmod", ...)}.
Normally objects are created as a result of a call to \code{specifyModel}.
}
\section{Slots}{
\describe{
\item{\code{model.id}:}{Object of class \code{"character"} ~~ }
\item{\code{model.spec}:}{Object of class \code{"formula"} ~~ }
\item{\code{model.formula}:}{Object of class \code{"formula"} ~~ }
\item{\code{model.target}:}{Object of class \code{"character"} ~~ }
\item{\code{model.inputs}:}{Object of class \code{"character"} ~~ }
\item{\code{build.inputs}:}{Object of class \code{"character"} ~~ }
\item{\code{symbols}:}{Object of class \code{"character"} ~~ }
\item{\code{product}:}{Object of class \code{"character"} ~~ }
\item{\code{price.levels}:}{Object of class \code{"zoo"} ~~ }
\item{\code{training.data}:}{Object of class \code{"Date"} ~~ }
\item{\code{build.date}:}{Object of class \code{"Date"} ~~ }
\item{\code{fitted.model}:}{Object of class \code{"ANY"} ~~ }
\item{\code{model.data}:}{Object of class \code{"zoo"} ~~ }
\item{\code{quantmod.version}:}{Object of class \code{"numeric"} ~~ }
}
}
\section{Methods}{
No methods defined with class "quantmod" in the signature.
}
\author{ Jeffrey A. Ryan }
\examples{
showClass("quantmod")
}
\keyword{classes}
quantmod/man/addMACD.Rd 0000644 0001762 0000144 00000001620 15000510306 014306 0 ustar ligges users \name{addMACD}
\alias{addMACD}
\title{ Add Moving Average Convergence Divergence to Chart }
\description{
Add Moving Average Convergence Divergence indicator to chart.
}
\usage{
addMACD(fast = 12, slow = 26, signal = 9, type = "EMA", histogram = TRUE, col)
}
\arguments{
\item{fast}{ fast period }
\item{slow}{ slow period }
\item{signal}{ signal period }
\item{type}{ type of MA to use. Single values will be replicated }
\item{histogram}{ include histogram }
\item{col}{ colors to use for lines (optional) }
}
\details{
See and 'MACD' in \pkg{TTR} for specific
details and implementation references.
}
\value{
A MACD indicator will be draw in a new window on the
current chart. A chobTA object will be returned silently.
}
\references{ see MACD in \pkg{TTR} written by Josh Ulrich}
\author{Jeffrey A. Ryan }
\seealso{ \code{\link{addTA}} }
\examples{
\dontrun{
addMACD()
}
}
\keyword{ utilities }
quantmod/man/addRSI.Rd 0000644 0001762 0000144 00000001247 15000510306 014244 0 ustar ligges users \name{addRSI}
\alias{addRSI}
\title{ Add Relative Strength Index to Chart }
\description{
Add a Relative Strength Index indicator to chart.
}
\usage{
addRSI(n = 14, maType = "EMA", wilder = TRUE)
}
\arguments{
\item{n}{ periods }
\item{maType}{ type of MA to use }
\item{wilder}{ use wilder (see EMA) }
}
\details{
see 'RSI' in \pkg{TTR} for specific details and references.
}
\value{
An RSI indicator will be draw in a new window on the current
chart. A chobTA object will be returned silently.
}
\references{ see RSI in \pkg{TTR} written by Josh Ulrich }
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{addTA}} }
\examples{
\dontrun{
addRSI()
}
}
\keyword{ utilities }
quantmod/man/getOptionChain.orats.Rd 0000644 0001762 0000144 00000004472 15002467345 017223 0 ustar ligges users \name{getOptionChain.orats}
\alias{getOptionChain.orats}
\title{ Download Option Chain Data from orats }
\description{
Function to download option chain data from orats.
}
\usage{
getOptionChain.orats(Symbols, Exp, api.key, dte, delta)
}
\arguments{
\item{Symbols}{ The name of the underlying symbol. Source \sQuote{yahoo} only
allows for a single ticker while source \sQuote{orats} can return multiple tickers.}
\item{Exp}{ One or more expiration dates, NULL, or an ISO-8601 style string.
If \code{Exp} is missing, only the front month contract will be returned.
}
\item{api.key}{ A character vector for the key given with an account for
accessing the orats API. If missing, the function will look for an
environment variable \code{ORATS_API_KEY} containing the API key.}
\item{dte}{ A vector of two integers giving
a range of expiry dates to subset the results by.}
\item{delta}{A vector of two integers giving
a range deltas to subset the results by.}
}
\details{
This function is a wrapper to data-provider specific
APIs. By default the data is sourced from yahoo.
}
\value{
For orats, returns A named list containing five data.frames, one
each for calls and puts that follows a similar form to the return
from yahoo, but does not have a Last price and instead has a
Ticker column for multiple ticker requests. The *_extra data.frames
contain additional information from the \sQuote{orats} API end point
whose definitions are available at the URL in the references.
If more than one expiration was requested, The results will be returned as
a list within list of length \code{length(Exp)}.
Each element of this list will be named with the expiration
month, day, and year (\%b.\%d.\%Y).
If \code{Exp} is set to \code{NULL}, all expirations
will be returned. Not explicitly setting will only
return the front month.
}
\references{
\url{https://docs.orats.io/datav2-api-guide/data.html#strikes}
}
\author{Steve Bronder }
\examples{
\dontrun{
# Only the front-month expiry
AAPL.OPT <- getOptionChain("AAPL",
api.key = Sys.getenv("ORATS_API_KEY"))
# All expiries
AAPL.OPTS <- getOptionChain("AAPL", NULL,
api.key = Sys.getenv("ORATS_API_KEY"))
# All 2015 and 2016 expiries
AAPL.2015 <- getOptionChain("AAPL", "2015/2016",
api.key = Sys.getenv("ORATS_API_KEY"))
}
}
\keyword{ utilities }% __ONLY ONE__ keyword per line
quantmod/man/periodReturn.Rd 0000644 0001762 0000144 00000006774 15002467345 015652 0 ustar ligges users \name{periodReturn}
\alias{periodReturn}
\alias{allReturns}
\alias{dailyReturn}
\alias{weeklyReturn}
\alias{monthlyReturn}
\alias{quarterlyReturn}
\alias{yearlyReturn}
\alias{annualReturn}
\title{ Calculate Periodic Returns }
\description{
Given a set of prices, return
periodic returns.
}
\usage{
periodReturn(x,
period='monthly',
subset=NULL,
type='arithmetic',
leading=TRUE,
...)
dailyReturn(x, subset=NULL, type='arithmetic',
leading=TRUE, ...)
weeklyReturn(x, subset=NULL, type='arithmetic',
leading=TRUE, ...)
monthlyReturn(x, subset=NULL, type='arithmetic',
leading=TRUE, ...)
quarterlyReturn(x, subset=NULL, type='arithmetic',
leading=TRUE, ...)
annualReturn(x, subset=NULL, type='arithmetic',
leading=TRUE, ...)
yearlyReturn(x, subset=NULL, type='arithmetic',
leading=TRUE, ...)
allReturns(x, subset=NULL, type='arithmetic',
leading=TRUE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{x}{ object of state prices, or an OHLC type object }
\item{period}{ character string indicating time period. Valid entries are
\sQuote{daily}, \sQuote{weekly},
\sQuote{monthly}, \sQuote{quarterly}, \sQuote{yearly}. All
are accessible from wrapper functions described below.
Defaults to monthly returns (same as monthlyReturn)}
\item{subset}{ an xts/ISO8601 style subset string }
\item{type}{ type of returns: arithmetic (discrete) or log (continuous) }
\item{leading}{ should incomplete leading period returns be returned }
\item{\dots}{ passed along to to.period }
}
\details{
\code{periodReturn} is the underlying function for wrappers:
\itemize{
\item \code{allReturns: } calculate all available return periods
\item \code{dailyReturn: } calculate daily returns
\item \code{weeklyReturn: } calculate weekly returns
\item \code{monthlyReturn: } calculate monthly returns
\item \code{quarterlyReturn: } calculate quarterly returns
\item \code{annualReturn: } calculate annual returns
}
}
\value{
Returns object of the class that was originally passed in,
with the possible exception of monthly and quarterly return
indicies being changed to class \code{yearmon} and \code{yearqtr}
where available. This can be overridden with the \code{indexAt}
argument passed in the \ldots to the \code{to.period} function.
By default, if \code{subset} is NULL, the full dataset will
be used.
}
\note{
Attempts are made to re-convert the resultant series to its original
class, if supported by the xts package. At present, objects inheriting
from the \sQuote{ts} class are returned as \code{xts} objects. This
is to make the results more visually appealling and informative. All
\code{xts} objects can be converted to class \code{ts} with
\code{as.ts} if that is desirable.
The first and final row of returned object will have the period return to last date,
i.e. this week/month/quarter/year return to date even if the start/end is not the start/end
of the period. Leading period calculations can be suppressed by setting \code{leading=FALSE}.
}
\author{ Jeffrey A. Ryan }
\seealso{\code{\link{getSymbols}}}
\examples{
\dontrun{
getSymbols('QQQ',src='yahoo')
allReturns(QQQ) # returns all periods
periodReturn(QQQ,period='yearly',subset='2003::') # returns years 2003 to present
periodReturn(QQQ,period='yearly',subset='2003') # returns year 2003
rm(QQQ)
}
}
\keyword{ utilities }% at least one, from doc/KEYWORDS
quantmod/man/addADX.Rd 0000644 0001762 0000144 00000001257 15000510306 014224 0 ustar ligges users \name{addADX}
\alias{addADX}
\title{ Add Directional Movement Index }
\description{
Add Directional Movement Index
}
\usage{
addADX(n = 14, maType="EMA", wilder=TRUE)
}
\arguments{
\item{n}{ periods to use for DX calculation}
\item{maType}{ moving average type }
\item{wilder}{ should Welles Wilder EMA be used? }
}
\details{
See 'ADX' in \pkg{TTR} for specific details and references.
}
\value{
An ADX indicator will be draw in a new window on the current
chart. A chobTA object will be returned silently.
}
\references{ see ADX in \pkg{TTR} written by Josh Ulrich }
\author{Jeffrey A. Ryan }
\seealso{ \code{\link{addTA}} }
\examples{
\dontrun{
addADX()
}
}
\keyword{utilities}
quantmod/man/addWPR.Rd 0000644 0001762 0000144 00000001103 15000510306 014246 0 ustar ligges users \name{addWPR}
\alias{addWPR}
\title{ Add William's Percent R to Chart }
\description{
Add William's percent R indiator to the current chart.
}
\usage{
addWPR(n = 14)
}
\arguments{
\item{n}{ periods }
}
\details{
see 'WPR' in \pkg{TTR} for details and references.
}
\value{
A William's percent R indicator will be draw in a new window on the current
chart. A chobTA object will be returned silently.
}
\references{ see 'WPR' in \pkg{TTR} written by Josh Ulrich }
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{addTA}}}
\examples{
\dontrun{
addWPR()
}
}
\keyword{ utilities }
quantmod/man/getSymbols.av.Rd 0000644 0001762 0000144 00000011254 15002467345 015712 0 ustar ligges users \name{getSymbols.av}
\alias{getSymbols.av}
\alias{getSymbols.alphavantage}
\alias{getSymbols.Alphavantage}
\alias{getSymbols.alphVantage}
\alias{getSymbols.AlphVantage}
\title{ Download OHLC Data from Alpha Vantage }
\description{
Downloads historical or realtime equity price data
from \url{https://www.alphavantage.co/}.
Free registration is required.
}
\usage{
getSymbols.av(Symbols, env, api.key,
return.class = "xts",
periodicity = "daily",
adjusted = FALSE,
interval = "1min",
output.size = "compact",
data.type = "json",
...)
}
\arguments{
\item{Symbols}{ a character vector specifying the names
of the symbols to be loaded}
\item{env}{ where to create objects (environment) }
\item{api.key}{ the API key issued by Alpha Vantage when you registered (character)}
\item{return.class}{ class of returned object, see Value (character) }
\item{periodicity}{ one of \code{"daily"}, \code{"weekly"}, \code{"monthly"}, or \code{"intraday"} }
\item{adjusted}{if TRUE, include a column of closing prices
adjusted for dividends and splits}
\item{interval}{one of \code{"1min"}, \code{"5min"}, \code{"15min"}, \code{"30min"}, or \code{"60min"}
(intraday data only)}
\item{output.size}{ either \code{"compact"} or \code{"full"} }
\item{data.type}{ either \code{"json"} or \code{"csv"} }
\item{\dots}{ additional parameters as per \code{\link{getSymbols}} }
}
\details{
Meant to be called internally by \code{getSymbols} only.
This method is not meant to be called directly, instead
a call to \code{getSymbols("x", src="av")} will
in turn call this method. It is documented for the
sole purpose of highlighting the arguments accepted.
You must register with Alpha Vantage in order to download their data,
but the one-time registration is fast and free.
Register at their web site, \url{https://www.alphavantage.co/},
and you will receive an \emph{API key}:
a short string of alphanumeric characters (e.g., "FU4U").
Provide the API key every time you call \code{getSymbols};
or set it globally using \code{setDefaults(getSymbols.av, api.key="yourKey")}.
The Alpha Vantage site provides daily, weekly, monthly, and intraday data.
Use \code{periodicity} to select one.
Note that intraday data will includes today's data (delayed) if downloaded
while the market is open, which is pretty cool.
Set \code{adjusted=TRUE} to include a column of closing prices adjusted for
dividends and stock splits (available only for daily, weekly, and monthly data).
The intraday data is provided as a sequence of OHLC bars.
Use the \code{interval} argument to determine the "width" of the bars:
1 minute bars, 5 minutes bars, 15 minutes bars, etc.
By default Alpha Vantage returns the 100 most-recent data points (\code{output.size="compact"}).
Set \code{output.size="full"} to obtain the entire available history.
For daily, weekly, and monthly data, Alpha Vantage says the available data is up to 20 years;
for intraday data, the available history is the most recent 10 or 15 days.
Be forewarned that downloading \code{full} data requires more time than \code{compact} data, of course.
Alpha Vantage provides access to data via two APIs. You can choose the API via
the \code{data.type} argument. \code{data.type="json"}, the default, will
import data using the JSON API. This API includes additional metadata (e.g.
last updated time, timezone, etc) that is not provided via the CSV API.
}
\value{
A call to \code{getSymbols(Symbols, src="av")} will create objects
in the specified environment,
one object for each \code{Symbol} specified.
The object class of the object(s) is determined by \code{return.class}.
Presently this may be \code{"ts"}, \code{"zoo"}, \code{"xts"}, or \code{"timeSeries"}.
}
% \note{
% [TBD]
% }
\references{ Alpha Vantage documentation available at \url{https://www.alphavantage.co/} }
\author{ Paul Teetor }
\seealso{
\code{\link{getSymbols}},
\code{\link{getSymbols.yahoo}},
\code{\link{getSymbols.google}}
}
\examples{
\dontrun{
# You'll need the API key given when you registered
getSymbols("IBM", src="av", api.key="yourKey")
# The default output.size="compact" returns only the most recent 100 rows.
# Set output.size="full" for all available data.
getSymbols("IBM", src="av", api.key="yourKey", output.size="full")
# Intraday data is available for the most recent 10 or 15 days
# and includes quasi-realtime data (i.e., 20-minute delayed)
getSymbols("IBM", src="av", api.key="yourKey", output.size="full",
periodicity="intraday")
# Repeating your API key every time is tedious.
# Fortunately, you can set a global default.
setDefaults(getSymbols.av, api.key="yourKey")
getSymbols("IBM", src="av")
}
}
quantmod/man/getSymbols.rda.Rd 0000644 0001762 0000144 00000004644 15002467345 016057 0 ustar ligges users \name{getSymbols.rda}
\alias{getSymbols.rda}
\alias{getSymbols.RData}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Load Data from R Binary File }
\description{
Downloads \code{Symbols} to specified \code{env}
from local R data file. This method is
not to be called directly, instead a call to
\code{getSymbols(Symbols,src='rda')} will in
turn call this method. It is documented for the
sole purpose of highlighting the arguments
accepted, and to serve as a guide to creating
additional getSymbols \sQuote{methods}.
}
\usage{
getSymbols.rda(Symbols,
env,
dir="",
return.class = "xts",
extension="rda",
col.names=c("Open","High","Low","Close","Volume","Adjusted"),
...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{Symbols}{ a character vector specifying
the names of each symbol to be loaded}
\item{env}{ where to create objects. (.GlobalEnv) }
\item{dir}{ directory of rda/RData file }
\item{return.class}{ class of returned object }
\item{extension}{ extension of R data file }
\item{col.names}{ data column names }
\item{\dots}{ additional parameters }
}
\details{
Meant to be called internally by \code{getSymbols} (see also).
One of a few currently defined methods for loading
data for use with \pkg{quantmod}. Essentially a
simple wrapper to the underlying \R \code{load}.
}
\value{
A call to getSymbols.csv will load into the specified
environment one object for each
\code{Symbol} specified, with class defined
by \code{return.class}. Presently this may be \code{ts},
\code{zoo}, \code{xts}, \code{data.frame},
or \code{timeSeries}.
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{getSymbols}},
\code{\link{load}},
\code{\link{setSymbolLookup}} }
\examples{
\dontrun{
# All 3 getSymbols calls return the same
# MSFT to the global environment
# The last example is what NOT to do!
## Method #1
getSymbols('MSFT',src='rda')
getSymbols('MSFT',src='RData')
## Method #2
setDefaults(getSymbols,src='rda')
# OR
setSymbolLookup(MSFT='rda')
# OR
setSymbolLookup(MSFT=list(src='rda'))
getSymbols('MSFT')
#########################################
## NOT RECOMMENDED!!!
#########################################
## Method #3
getSymbols.rda('MSFT',verbose=TRUE,env=globalenv())
}
}
\keyword{ data }
quantmod/man/is.quantmod.Rd 0000644 0001762 0000144 00000000655 15000510306 015402 0 ustar ligges users \name{is.quantmod}
\alias{is.quantmod}
\alias{is.quantmodResults}
\title{ Test If Object of Type quantmod }
\description{
Test if object is of type \code{quantmod} or
\code{quantmodResults}.
}
\usage{
is.quantmod(x)
is.quantmodResults(x)
}
\arguments{
\item{x}{ object to test }
}
\value{
Boolean TRUE or FALSE
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{specifyModel}}, \code{\link{tradeModel}} }
\keyword{ utilities }
quantmod/man/addSMI.Rd 0000644 0001762 0000144 00000001327 15000510306 014236 0 ustar ligges users \name{addSMI}
\alias{addSMI}
\title{ Add Stochastic Momentum Indicator to Chart }
\description{
Add Stochastic Momentum Indicator to chart.
}
\usage{
addSMI(n=13,slow=25,fast=2,signal=9,ma.type="EMA")
}
\arguments{
\item{n}{ periods }
\item{slow}{ slow }
\item{fast}{ fast }
\item{signal}{ signal }
\item{ma.type}{ MA tyep to use, recycled as necessary }
}
\details{
see 'SMI in \pkg{TTR} for specifics and references.
}
\value{
An SMI indicator will be draw in a new window on the current
chart. A chobTA object will be returned silently.
}
\references{ see SMI in \pkg{TTR} written by Josh Ulrich }
\author{ Jeffrey A. Ryan }
\seealso{\code{\link{addTA}}}
\examples{
\dontrun{
addSMI()
}
}
\keyword{ utilities }
quantmod/man/getDividends.Rd 0000644 0001762 0000144 00000004067 15002467345 015572 0 ustar ligges users \name{getDividends}
\alias{getDividends}
\title{ Load Financial Dividend Data }
\description{
Download, or download and append stock dividend data
from Yahoo! Finance.
}
\usage{
getDividends(Symbol,
from = "1970-01-01",
to = Sys.Date(),
env = parent.frame(),
src = "yahoo",
auto.assign = FALSE,
auto.update = FALSE,
verbose = FALSE,
split.adjust = TRUE,
...,
curl.options = list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{Symbol}{ The Yahoo! stock symbol }
\item{from}{ date from in CCYY-MM-DD format }
\item{to}{ date to in CCYY-MM-DD format }
\item{env}{ where to create object }
\item{src}{ data source (only yahoo is valid at present)}
\item{auto.assign}{ should results be loaded to env}
\item{auto.update}{ automatically add dividend to data object }
\item{verbose}{ display status of retrieval }
\item{split.adjust}{ adjust dividends for splits (\code{TRUE} by default
because that's what Yahoo returns)}
\item{\dots}{ currently unused }
\item{curl.options}{ options passed to \code{curl::curl} }
}
\details{
Eventually destined to be a wrapper function along the lines
of \code{getSymbols} to different sources - this currently
only support Yahoo data.
}
\value{
If auto.assign is TRUE, the symbol will be written
to the environment specified in \code{env} with a
.div appended to the name.
If auto.update is TRUE and the object is of class
\code{xts}, the dividends will be included as an
attribute of the original object and be reassigned
to the environment specified by \code{env}.
All other cases will return the dividend data
as an \code{xts} object.
}
\references{ Yahoo! Finance: \url{https://finance.yahoo.com}}
\author{ Jeffrey A. Ryan }
\note{
This function is very preliminary - and will most likely
change significantly in the future.
}
\seealso{ \code{\link{getSymbols}} }
\examples{
\dontrun{
getSymbols("MSFT")
getDividends("MSFT")
getDividends(MSFT)
}
}
\keyword{ utilities }
quantmod/man/getOptionChain.Rd 0000644 0001762 0000144 00000003565 15002467345 016076 0 ustar ligges users \name{getOptionChain}
\alias{getOptionChain}
\title{ Download Option Chains }
\description{
Function to download option chain data from
data providers.
}
\usage{
getOptionChain(Symbols, Exp = NULL, src="yahoo", \dots)
}
\arguments{
\item{Symbols}{ The name of the underlying symbol. Source \sQuote{yahoo} only
allows for a single ticker while source \sQuote{orats} can return multiple tickers.}
\item{Exp}{ One or more expiration dates, NULL, or an ISO-8601 style string.
If \code{Exp} is missing, only the front month contract will be returned.
}
\item{src}{ Source of data. One of \sQuote{yahoo} or \sQuote{orats} with
a default of \sQuote{yahoo}.}
\item{\dots}{ Additional parameters.}
}
\details{
This function is a wrapper to data-provider specific
APIs. By default the data is sourced from yahoo.
}
\value{
A named list containing two data.frames, one
for calls and one for puts. If more than one
expiration was requested, this two-element list
will be contained within list of length \code{length(Exp)}.
Each element of this list will be named with the expiration
month, day, and year (for Yahoo sourced data).
If \code{Exp} is set to \code{NULL}, all expirations
will be returned. Not explicitly setting will only
return the front month.
}
\author{ Jeffrey A. Ryan, Joshua M. Ulrich, Steve Bronder }
\references{
\url{https://finance.yahoo.com},
\url{https://docs.orats.io/datav2-api-guide/data.html#strikes}
}
\examples{
\dontrun{
# Only the front-month expiry
AAPL.OPT <- getOptionChain("AAPL")
# All expiries
AAPL.OPTS <- getOptionChain("AAPL", NULL)
# All 2015 and 2016 expiries
AAPL.2015 <- getOptionChain("AAPL", "2015/2016")
# Using orats backend
NFLX.AAPL.2021 <- getOptionChain(c("NFLX", "AAPL"), "2021", src = "orats",
api.key = Sys.getenv("ORATS_API_KEY"))
}
}
\seealso{\code{\link{getOptionChain.orats}}}
\keyword{ utilities }% __ONLY ONE__ keyword per line
quantmod/man/getSymbols.MySQL.Rd 0000644 0001762 0000144 00000006711 15002467345 016253 0 ustar ligges users \name{getSymbols.MySQL}
\alias{getSymbols.MySQL}
\alias{getSymbols.mysql}
\title{ Retrieve Data from MySQL Database }
\description{
Fetch data from MySQL database. As with other
methods extending the \code{getSymbols} function,
this should \emph{NOT} be called directly. Its
documentation is meant to highlight the formal
arguments, as well as provide a reference for
further user contributed data tools.
}
\usage{
getSymbols.MySQL(Symbols,
env,
return.class = 'xts',
db.fields = c("date", "o", "h", "l", "c", "v", "a"),
field.names = NULL,
user = NULL,
password = NULL,
dbname = NULL,
host = "localhost",
port = 3306,
...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{Symbols}{ a character vector specifying
the names of each symbol to be loaded}
\item{env}{ where to create objects. (.GlobalEnv)}
\item{return.class}{ desired class of returned object.
Can be xts,
zoo, data.frame, or ts. (zoo)}
\item{db.fields}{ character vector indicating
names of fields to retrieve}
\item{field.names}{ names to assign to returned columns }
\item{user}{ username to access database }
\item{password}{ password to access database }
\item{dbname}{ database name }
\item{host}{ database host }
\item{port}{ database port }
\item{\dots}{ currently not used }
}
\details{
Meant to be called internally by \code{getSymbols} (see also)
One of a few currently defined methods for loading data for
use with \pkg{quantmod}. Its use requires the packages
\pkg{DBI} and \pkg{MySQL}, along with a running
MySQL database with tables corresponding to the
\code{Symbol} name.
The purpose of this abstraction is to make transparent the
\sQuote{source} of the data, allowing instead the user to
concentrate on the data itself.
}
\value{
A call to getSymbols.MySQL will load into the specified
environment one object for each \code{Symbol} specified,
with class defined by \code{return.class}.
}
\references{
\itemize{
\cite{MySQL AB \url{https://www.mysql.com}}
\cite{
Jeroen Ooms and David James and Saikat DebRoy and Hadley Wickham and Jeffrey Horner (2019).
RMySQL: Database Interface and 'MySQL' Driver for R.
\url{https://CRAN.R-project.org/package=RMySQL}}
\cite{R-SIG-DB. DBI: R Database Interface}
}
}
\author{ Jeffrey A. Ryan }
\note{
The default configuration needs a table named
for the Symbol specified (e.g. MSFT), with
column names date,o,h,l,c,v,a. For table
layout changes it is best to use
\code{setDefaults(getSymbols.MySQL,...)} with
the new db.fields values specified.
}
\seealso{ \code{\link{getSymbols}},
\code{\link{setSymbolLookup}} }
\examples{
\dontrun{
# All 3 getSymbols calls return the same
# MSFT to the global environment
# The last example is what NOT to do!
setDefaults(getSymbols.MySQL,user='jdoe',password='secret',
dbname='tradedata')
## Method #1
getSymbols('MSFT',src='MySQL')
## Method #2
setDefaults(getSymbols,src='MySQL')
# OR
setSymbolLookup(MSFT='MySQL')
getSymbols('MSFT')
#########################################
## NOT RECOMMENDED!!!
#########################################
## Method #3
getSymbols.MySQL('MSFT',env=globalenv())
}
}
\keyword{ data }
quantmod/man/getSymbols.csv.Rd 0000644 0001762 0000144 00000005166 15024566307 016106 0 ustar ligges users \name{getSymbols.csv}
\alias{getSymbols.csv}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Load Data from csv File }
\description{
Downloads \code{Symbols} to specified \code{env}
from local comma seperated file. This method is
not to be called directly, instead a call to
\code{getSymbols(Symbols,src='csv')} will in
turn call this method. It is documented for the
sole purpose of highlighting the arguments
accepted, and to serve as a guide to creating
additional getSymbols \sQuote{methods}.
}
\usage{
getSymbols.csv(Symbols,
env,
dir="",
return.class = "xts",
extension="csv",
col.names=c("Open","High","Low","Close","Volume","Adjusted"),
...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{Symbols}{ a character vector specifying
the names of each symbol to be loaded}
\item{env}{ where to create objects. (.GlobalEnv) }
\item{dir}{ directory of csv file }
\item{return.class}{ class of returned object }
\item{extension}{ extension of csv file }
\item{col.names}{ data column names }
\item{\dots}{ additional parameters }
}
\details{
Meant to be called internally by \code{getSymbols} (see also).
One of a few currently defined methods for loading
data for use with \pkg{quantmod}. Essentially a
simple wrapper to the underlying \R \code{read.csv}.
}
\value{
A call to getSymbols.csv will load into the specified
environment one object for each
\code{Symbol} specified, with class defined
by \code{return.class}. Presently this may be \code{ts},
\code{zoo}, \code{xts}, or \code{timeSeries}.
}
\note{
This has yet to be tested on a windows platform. It \emph{should} work
though file seperators may be an issue.
You may need to set the \code{format} argument in the call if the date is not
in a standard format in your file. For example \code{format = "\%m/\%d/\%Y"}.
See \code{\link{strptime}} for format parameters.
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{getSymbols}},
\code{\link{read.csv}},
\code{\link{setSymbolLookup}} }
\examples{
\dontrun{
# All 3 getSymbols calls return the same
# MSFT to the global environment
# The last example is what NOT to do!
## Method #1
getSymbols('MSFT',src='csv')
## Method #2
setDefaults(getSymbols,src='csv')
# OR
setSymbolLookup(MSFT='csv')
getSymbols('MSFT')
#########################################
## NOT RECOMMENDED!!!
#########################################
## Method #3
getSymbols.csv('MSFT',verbose=TRUE,env=globalenv())
}
}
\keyword{ data }
quantmod/man/addVo.Rd 0000644 0001762 0000144 00000001251 15000510306 014166 0 ustar ligges users \name{addVo}
\alias{addVo}
\title{ Add Volume to Chart }
\description{
Add Volume of a series, if available, to the current chart.
This is the default TA argument for all charting functions.
}
\usage{
addVo(log.scale=FALSE)
}
\arguments{
\item{log.scale}{ use log-scale for volume }
}
\details{
Add volume bars to current chart if data object contains
appropriate volume column.
log.scale will transform the series via standard R graphics mechanisms.
}
\value{
Volume will be draw in a new window on the current
chart. A chobTA object will be returned silently.
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{addTA}}}
\examples{
\dontrun{
addVo()
}
}
\keyword{ utilities }
quantmod/man/getSplits.Rd 0000644 0001762 0000144 00000003666 15002467345 015143 0 ustar ligges users \name{getSplits}
\alias{getSplits}
\title{ Load Financial Split Data }
\description{
Download, or download and append stock split data
from Yahoo! Finance.
}
\usage{
getSplits(Symbol,
from = "1970-01-01",
to = Sys.Date(),
env = parent.frame(),
src = "yahoo",
auto.assign = FALSE,
auto.update = FALSE,
verbose = FALSE,
...,
curl.options = list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{Symbol}{ The Yahoo! stock symbol }
\item{from}{ date from in CCYY-MM-DD format }
\item{to}{ date to in CCYY-MM-DD format }
\item{env}{ where to create object }
\item{src}{ data source (only yahoo is valid at present)}
\item{auto.assign}{ should results be loaded to env}
\item{auto.update}{ automatically add split to data object }
\item{verbose}{ display status of retrieval }
\item{\dots}{ currently unused }
\item{curl.options}{ options passed to \code{curl::curl} }
}
\details{
Eventually destined to be a wrapper function along the lines
of \code{getSymbols} to different sources - this currently
only support Yahoo data.
}
\value{
If auto.assign is TRUE, the symbol will be written
to the environment specified in \code{env} with a
.div appended to the name.
If auto.update is TRUE and the object is of class
\code{xts}, the dividends will be included as an
attribute of the original object and be reassigned
to the environment specified by \code{env}.
All other cases will return the split data
as an \code{xts} object. \code{NA} is returned if there
is no split data.
}
\references{ Yahoo! Finance: \url{https://finance.yahoo.com}}
\author{ Josh Ulrich }
\note{
This function is very preliminary - and will most likely
change significantly in the future.
}
\seealso{ \code{\link{getSymbols}}, \code{\link{getDividends}} }
\examples{
\dontrun{
getSymbols("MSFT")
getSplits("MSFT")
getSplits(MSFT)
}
}
\keyword{ utilities }
quantmod/man/quantmod-defunct.Rd 0000644 0001762 0000144 00000001464 15002467345 016435 0 ustar ligges users \name{quantmod-defunct}
\alias{quantmod-defunct}
\title{Defunct Functions in Package \pkg{quantmod}}
% NOTE: need \alias{.} here for each function
\alias{getSymbols.google}
\alias{getFin.google}
\alias{getFinancials.google}
%
\description{
The functionality listed here is no longer part of \pkg{quantmod}.
}
\usage{
# Defunct in 0.4-13
# getFin(Symbol, src = "google")
# getFinancials(Symbol, src = "google")
getSymbols.google(Symbols, env, return.class = "xts", from = "2007-01-01",
to = Sys.Date(), ...)
}
\details{
Google Finance stopped providing data in March, 2018. This included historical
price data, and also financial information. This affected \code{getFinancials},
\code{getFin}, and \code{getSymbols} when \code{src = "google"}.
}
\seealso{
\code{\link{Defunct}}
}
\keyword{internal}
quantmod/man/Next.Rd 0000644 0001762 0000144 00000004273 15000510306 014056 0 ustar ligges users \name{Next}
\alias{Next}
\alias{Next.quantmod.OHLC}
\alias{Next.zoo}
\alias{Next.data.frame}
\alias{Next.numeric}
\title{ Advance a Time Series }
\description{
Create a new series with all values advanced forward one period.
The value of period 1, becomes the value at period 2,
value at 2 becomes the original value at 3, etc. The opposite
of \code{Lag}. \code{NA} is used to fill.
}
\usage{
Next(x, k = 1)
\method{Next}{quantmod.OHLC}(x,k=1)
\method{Next}{zoo}(x,k=1)
\method{Next}{data.frame}(x,k=1)
\method{Next}{numeric}(x,k=1)
}
\arguments{
\item{x}{ vector or series to be advanced }
\item{k}{ periods to advance }
}
\details{
Shift series k-periods up, appending \code{NA}s to end of series.
Specifically designed to handle \code{quantmod.OHLC} and
\code{zoo} series within the \pkg{quantmod} workflow.
If no S3 method is found, a call to \code{lag} in \pkg{base} is made,
with the indexing reversed to shift the time series forward.
}
\value{
The original \code{x} appended with \code{k} \code{NA}s and
missing the leading \code{k} values.
The returned series maintains the number of obs. of the original.
Unlike \code{Lag}, only one value for \code{k} is allowed.
}
\author{ Jeffrey A. Ryan }
\note{
This function's purpose is to get the \dQuote{next} value of
the data you hope to forecast, e.g. a stock's closing value
at t+1. Specifically to be used within
the \pkg{quantmod} framework of \code{specifyModel}, as a
functional wrapper to the LHS of the model equation.
It is not magic - and thus will not get tomorrow's values\ldots
}
\seealso{ \code{\link{specifyModel}}, \code{\link{Lag}} }
\examples{
Stock.Close <- c(102.12,102.62,100.12,103.00,103.87,103.12,105.12)
Close.Dates <- as.Date(c(10660,10661,10662,10665,10666,10667,10668),origin="1970-01-01")
Stock.Close <- zoo(Stock.Close,Close.Dates)
Next(Stock.Close) #one period ahead
Next(Stock.Close,k=1) #same
merge(Next(Stock.Close),Stock.Close)
\dontrun{
# a simple way to build a model of next days
# IBM close, given todays. Technically both
# methods are equal, though the former is seen
# as more intuitive...ymmv
specifyModel(Next(Cl(IBM)) ~ Cl(IBM))
specifyModel(Cl(IBM) ~ Lag(Cl(IBM)))
}
}
\keyword{ misc }
\keyword{ datagen }
quantmod/man/fittedModel.Rd 0000644 0001762 0000144 00000004760 15000510306 015401 0 ustar ligges users \name{fittedModel}
\alias{fittedModel}
\alias{fittedModel<-}
\alias{formula.quantmod}
\alias{plot.quantmod}
\alias{coefficients.quantmod}
\alias{coef.quantmod}
\alias{residuals.quantmod}
\alias{resid.quantmod}
\alias{fitted.values.quantmod}
\alias{fitted.quantmod}
\alias{anova.quantmod}
\alias{logLik.quantmod}
\alias{vcov.quantmod}
\title{ quantmod Fitted Objects }
\description{
Extract and replace fitted models from
\code{quantmod} objects built with
\code{buildModel}. All objects fitted
through methods specified in \code{buildModel}
calls can be extracted for further analysis.
}
\usage{
fittedModel(object)
\method{formula}{quantmod}(x, \dots)
\method{plot}{quantmod}(x, \dots)
\method{coefficients}{quantmod}(object, \dots)
\method{coef}{quantmod}(object, \dots)
\method{residuals}{quantmod}(object, \dots)
\method{resid}{quantmod}(object, \dots)
\method{fitted.values}{quantmod}(object, \dots)
\method{fitted}{quantmod}(object, \dots)
\method{anova}{quantmod}(object, \dots)
\method{logLik}{quantmod}(object, \dots)
\method{vcov}{quantmod}(object, \dots)
}
\arguments{
\item{object}{ a \code{quantmod} object }
\item{x}{ a suitable object }
\item{\dots}{ additional arguments }
}
\details{
Most often used to extract the final fitted
object of the modelling process, usually for
further analysis with tools outside
the \pkg{quantmod} package.
Most common methods to apply to fitted objects
are available to the parent \code{quantmod}
object. At present, one can call directly the
following S3 methods on a built model as if
calling directly on the fitted object.
See *Usage* section.
It is also \emph{possible} to add
a fitted model to an object. This
may be of value when applying heuristic
rule sets for trading approaches, or when
fine tuning already fit models by hand.
}
\value{
Returns an object matching that returned
by a call to the method specified in
\code{buildModel}.
}
\author{ Jeffrey A. Ryan }
\note{
The replacement function \code{fittedModel<-}
is highly experimental, and may or may not
continue into further releases.
The fitted model added \emph{must} use the
same names as appear in the \code{quantmod}
object's dataset.
}
\seealso{ \code{\link{quantmod}},\code{\link{buildModel}} }
\examples{
\dontrun{
x <- specifyModel(Next(OpCl(DIA)) ~ OpCl(VIX))
x.lm <- buildModel(x,method='lm',training.per=c('2001-01-01','2001-04-01'))
fittedModel(x.lm)
coef(fittedModel(x.lm))
coef(x.lm) # same
vcov(fittedModel(x.lm))
vcov(x.lm) # same
}
}
\keyword{ models }
quantmod/man/chartTheme.Rd 0000644 0001762 0000144 00000004520 15002467345 015237 0 ustar ligges users \name{chartTheme}
\alias{chartTheme}
\alias{.chart.theme}
\title{ Create A Chart Theme }
\description{
Create a chart.theme object for use within chartSeries
to manage desired chart colors.
}
\usage{
chartTheme(theme = "black", ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{theme}{ name of base theme }
\item{\dots}{ name=value pairs to modify }
}
\details{
Used as an argument to the chartSeries family of functions,
\code{chartTheme} allows for on-the-fly modification
of pre-specified chart \sQuote{themes}. Users can modify
a pre-built theme in-place, or copy the theme to a new
variable for use in subsequent charting calls.
Internally a chart.theme object is nothing more than
a list of values organized by chart components. The primary
purpose of this is to facilitate minor modification on
the fly, as well as provide a template for larger changes.
Setting style arguments for TA calls via chartTheme requires
the user to pass the styles as name=value pairs with a name
containing the TA call in question. See examples for assistance.
Current components that may be modified with appropriate
values:
\itemize{
\item \code{fg.col}: foreground color
\item \code{bg.col}: background color
\item \code{grid.col}: grid color
\item \code{border}: border color
\item \code{minor.tick}: minor tickmark color
\item \code{major.tick}: major tickmark color
\item \code{up.col}: up bar/candle color
\item \code{dn.col}: down bar/candle color
\item \code{up.up.col}: up after up bar/candle color
\item \code{up.dn.col}: up after down bar/candle color
\item \code{dn.dn.col}: down after down bar/candle color
\item \code{dn.up.col}: down after up bar/candle color
\item \code{up.border}: up bar/candle border color
\item \code{dn.border}: down bar/candle border color
\item \code{up.up.border}: up after up bar/candle border color
\item \code{up.dn.border}: up after down bar/candle border color
\item \code{dn.dn.border}: down after down bar/candle border color
\item \code{dn.up.border}: down after up bar/candle border color
}
}
\value{
A chart.theme object
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{chartSeries}} }
\examples{
chartTheme()
chartTheme('white')
chartTheme('white',up.col='blue',dn.col='red')
# A TA example
chartTheme(addRSI.col='red')
str(chartTheme())
}
\keyword{ utilities }
quantmod/man/zoomChart.Rd 0000644 0001762 0000144 00000004612 15000510306 015103 0 ustar ligges users \name{zoomChart}
\alias{zooom}
\alias{zoom}
\alias{zoomChart}
\title{ Change Zoom Level Of Current Chart }
\description{
Using \pkg{xts} style date subsetting, zoom into
or out of the current chart.
}
\usage{
zooom(n=1, eps=2)
zoomChart(subset, yrange=NULL)
}
\arguments{
\item{n}{ the number of interactive view changes per call }
\item{eps}{ the distance between clicks to be considered a valid subset request }
\item{subset}{ a valid subset string }
\item{yrange}{ override y-scale }
}
\details{
These function allow for viewing of specific
areas of a chart produced by \code{chartSeries}
by simply specifying the dates of interest
\code{zooom} is an interactive chart version
of \code{zoomChart} which utilizes the standard
\R device interaction tool \code{locator} to
estimate the subset desired. This estimate is
then passed to zoomChart for actual redrawing.
At present it is
quite experimental in its interface and arguments.
Its usage entails a call to \code{zooom()} followed
by the selection of the leftmost and rightmost points
desired in the newly zoomed chart. This selection
is accomplished by the user left-clicking each extreme
point. Two click are required to determine the level
of zooming. Double clicking will reset the chart to
the full data range. The arguments and internal
working of this function are likely to change dramatically
in future releases, though its use will likely remain.
Standard format for the \code{subset} argument
is the same as the subsetting for xts objects,
which is how the data is stored internally for
rendering.
Calling \code{zoomChart} with no arguments (NULL)
resets the chart to the original data.
Examples include '2007' for all of the year 2007,
'2007::2008' for years 2007 through 2008, '::2007'
for all data from the beginning of the set to the
end of 2007, '2007::' all data from the beginning of
2007 through the end of the data. For specifics
regarding the level of detail and internal interpretation
please see \code{[.xts}
}
\value{
This function is called for its side effect - notably
changing the perspective of the current chart, and
changing its formal subset level. The underlying
data attached to the chart is left unchanged.
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{chartSeries}} }
\examples{
\dontrun{
data(sample_matrix)
chartSeries(sample_matrix)
zoomChart('2007-04::')
zoomChart()
zooom() # interactive example
}
}
\keyword{ utilities }
quantmod/man/chartSeries.Rd 0000644 0001762 0000144 00000014374 15002467345 015437 0 ustar ligges users \name{chartSeries}
\alias{chartSeries}
\alias{barChart}
\alias{candleChart}
\alias{matchChart}
\alias{lineChart}
\alias{reChart}
\alias{current.chob}
\alias{.chob}
\title{ Create Financial Charts }
\description{
Charting tool to create standard financial charts
given a time series like object. Serves as the base function for
future technical analysis additions. Possible chart
styles include candles, matches (1 pixel candles), bars,
and lines. Chart may have white or black background.
\code{reChart} allows for dynamic changes to the chart without
having to respecify the full chart parameters.
}
\usage{
chartSeries(x,
type = c("auto", "candlesticks", "matchsticks", "bars","line"),
subset = NULL,
show.grid = TRUE,
name = NULL,
time.scale = NULL,
log.scale = FALSE,
TA = 'addVo()',
TAsep=';',
line.type = "l",
bar.type = "ohlc",
theme = chartTheme("black"),
layout = NA,
major.ticks='auto', minor.ticks=TRUE,
yrange=NULL,
plot=TRUE,
up.col,dn.col,color.vol = TRUE, multi.col = FALSE,
...)
reChart(type = c("auto", "candlesticks", "matchsticks", "bars","line"),
subset = NULL,
show.grid = TRUE,
name = NULL,
time.scale = NULL,
line.type = "l",
bar.type = "ohlc",
theme = chartTheme("black"),
major.ticks='auto', minor.ticks=TRUE,
yrange=NULL,
up.col,dn.col,color.vol = TRUE, multi.col = FALSE,
...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{x}{ an OHLC object - see details }
\item{type}{ style of chart to draw }
\item{subset}{ xts style date subsetting argument }
\item{show.grid}{ display price grid lines? }
\item{name}{ name of chart }
\item{time.scale}{ what is the timescale? automatically deduced (broken) }
\item{log.scale}{ should the y-axis be log-scaled? }
\item{TA}{ a vector of technical indicators and params, or character strings }
\item{TAsep}{ TA delimiter for TA strings }
\item{line.type}{ type of line in line chart }
\item{bar.type}{ type of barchart - ohlc or hlc }
\item{theme}{ a chart.theme object }
\item{layout}{ if \code{NULL} bypass internal layout }
\item{major.ticks}{ where should major ticks be drawn}
\item{minor.ticks}{ should minor ticks be draw? }
\item{yrange}{ override y-scale }
\item{plot}{ should plot be drawn }
\item{up.col}{ up bar/candle color }
\item{dn.col}{ down bar/candle color }
\item{color.vol}{ color code volume? }
\item{multi.col}{ 4 color candle pattern }
\item{\dots}{ additional parameters }
}
\details{
Currently displays standard style OHLC charts familiar
in financial applications, or line charts when
not passes OHLC data. Works with objects having explicit
time-series properties.
Line charts are created with close data, or from single
column time series.
The \code{subset} argument can be used to specify a
particular area of the series to view. The underlying
series is left intact to allow for TA functions to
use the full data set. Additionally, it is possible
to use syntax borrowed from the \code{first} and \code{last}
functions, e.g. \sQuote{last 4 months}.
\code{TA} allows for the inclusion of a variety of
chart overlays and tecnical indicators. A full list is
available from \code{addTA}. The default TA argument is
\code{addVo()} - which adds volume, if available, to the
chart being drawn.
\code{theme} requires an object of class \code{chart.theme}, created
by a call to \code{chartTheme}. This function can be used to modify the
look of the resulting chart. See \code{chart.theme} for details.
\code{line.type} and \code{bar.type} allow further fine tuning of
chart styles to user tastes.
\code{multi.col} implements a color coding scheme used in some
charting applications, and follows the following rules:
\itemize{
\item grey => Op[t] < Cl[t] and Op[t] < Cl[t-1]
\item white => Op[t] < Cl[t] and Op[t] > Cl[t-1]
\item red => Op[t] > Cl[t] and Op[t] < Cl[t-1]
\item black => Op[t] > Cl[t] and Op[t] > Cl[t-1]
}
\code{reChart} takes any number of arguments from the original
chart call --- and redraws the chart with the updated parameters.
One item of note: if multiple color bars/candles are desired,
it is necessary to respecify the \code{theme} argument. Additionally
it is not possible to change TA parameters at present. This must be
done with addTA/dropTA/swapTA/moveTA commands.
}
\value{
Returns a standard chart plus volume, if available, suitably scaled.
If \code{plot=FALSE} a chob object will be returned.
}
\author{ Jeffrey A. Ryan }
\references{ Josh Ulrich - \pkg{TTR} package and multi.col coding }
\note{
Most details can be fine-tuned within the function, though the code
does a reasonable job of scaling and labelling axes for the user.
The current implementation maintains a record of actions carried
out for any particular chart. This is used to recreate the original when
adding new indicator. A list of applied TA actions is available with a call
to \code{listTA}. This list can be assigned to a variable and used in new
chart calls to recreate a set of technical indicators. It is also possible
to force all future charts to use the same indicators by calling \code{setTA}.
Additional motivation to add outlined candles to allow
for scaling and advanced color coding is owed to Josh Ulrich, as
are the base functions (from \pkg{TTR}) for the yet to be
released technical analysis charting code.
Many improvements in the current version were the result of conversations with
Gabor Grothendieck. Many thanks to him.
}
\seealso{ \code{\link{getSymbols}}, \code{\link{addTA}}, \code{\link{setTA}},
\code{\link{chartTheme}} }
\examples{
\dontrun{
getSymbols("AAPL")
chartSeries(AAPL)
chartSeries(AAPL, subset='last 4 months')
chartSeries(AAPL, subset='2007::2008-01')
chartSeries(AAPL,theme=chartTheme('white'))
chartSeries(AAPL,TA=NULL) #no volume
chartSeries(AAPL,TA=c(addVo(),addBBands())) #add volume and Bollinger Bands from TTR
addMACD() # add MACD indicator to current chart
setTA()
chartSeries(AAPL) #draws chart again, this time will all indicators present
}
}
% Add one or more standard keywords, see file 'KEYWORDS' in the
% R documentation directory.
\keyword{ utilities }
quantmod/man/addMA.Rd 0000644 0001762 0000144 00000003115 15002467345 014120 0 ustar ligges users \name{addMA}
\alias{addMA}
\alias{addSMA}
\alias{add_SMA}
\alias{addEMA}
\alias{add_EMA}
\alias{addWMA}
\alias{add_WMA}
\alias{addDEMA}
\alias{add_DEMA}
\alias{addEVWMA}
\alias{add_EVWMA}
\alias{addZLEMA}
\alias{add_VWAP}
\alias{add_GMMA}
\title{ Add Moving Average to Chart }
\description{
Add one or more moving averages to a chart.
}
\usage{
addSMA(n = 10, on = 1, with.col = Cl, overlay = TRUE, col = "brown")
addEMA(n = 10, wilder = FALSE, ratio=NULL, on = 1,
with.col = Cl, overlay = TRUE, col = "blue")
addWMA(n = 10, wts=1:n, on = 1, with.col = Cl, overlay = TRUE, col = "green")
addDEMA(n = 10, on = 1, with.col = Cl, overlay = TRUE, col = "pink")
addEVWMA(n = 10, on = 1, with.col = Cl, overlay = TRUE, col = "yellow")
addZLEMA(n = 10, ratio=NULL, on = 1, with.col = Cl, overlay = TRUE, col = "red")
}
\arguments{
\item{n}{ periods to average over }
\item{wilder}{ logical; use wilder? }
\item{wts}{ a vector of weights }
\item{ratio}{ a smoothing/decay ratio }
\item{on}{ apply to which figure (see below) }
\item{with.col}{ using which column of data (see below) }
\item{overlay}{ draw as overlay }
\item{col}{ color of MA }
}
\details{
see the appropriate base MA functions in \pkg{TTR} for
more details and references.
}
\value{
A moving average indicator will be draw on the current
chart. A chobTA object will be returned silently.
}
\references{ see MovingAverages in \pkg{TTR} written by Josh Ulrich }
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{addTA}}}
\examples{
\dontrun{
addSMA()
addEMA()
addWMA()
addDEMA()
addEVWMA()
addZLEMA()
}
}
\keyword{ utilities }
quantmod/man/addExpiry.Rd 0000644 0001762 0000144 00000001201 15000510306 015055 0 ustar ligges users \name{addExpiry}
\alias{addExpiry}
\title{ Add Contract Expiration Bars to Chart }
\description{
Apply options or futures expiration vertical bars
to current chart.
}
\usage{
addExpiry(type = "options", lty = "dotted")
}
\arguments{
\item{type}{ options or futures expiration }
\item{lty}{ type of lines to draw }
}
\details{
See options.expiry and futures.expiry in \pkg{quantmod}
for details and limitations.
}
\value{
Expiration lines will be drawn at appropriate dates.
A chibTA object will be returned silently.
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{addTA}} }
\examples{
\dontrun{
addExpiry()
}
}
\keyword{ utilities }
quantmod/man/specifyModel.Rd 0000644 0001762 0000144 00000005563 15002467345 015606 0 ustar ligges users \name{specifyModel}
\alias{specifyModel}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Specify Model Formula For quantmod Process }
\description{
Create a single reusable model specification for subsequent buildModel calls.
An object of class \code{quantmod} is created that can be then be reused with different
modelling methods and parameters. No data frame is specified, as data is retrieved
from potentially multiple environments, and internal calls to getSymbols.
}
\usage{
specifyModel(formula, na.rm=TRUE)
}
\arguments{
\item{formula}{an object of class \code{formula} (or one that can be coerced to
that class): a symbolic description of the model to be fitted.
The details of model specifcation are given under Details.}
\item{na.rm}{remove all incomplete rows.}
}
\details{
Models are specified through the standard formula mechanism.
As financial models may include a
variety of financial and economic indicators,
each differing in source, frequency, and/or class,
a single mechanism to specify sources is
included within a call to specifyModel.
See \code{getModelData} for details of
how this process works.
Currently, objects of class \code{quantmod.OHLC},
\code{zoo} and \code{ts} are supported within the
model formula.
All symbols are first retrieved from the global environment, without inheritence.
If an object is not found in the global environment, it is added to a
list of objects to load through the \code{getSymbols}
function. getSymbols retrieves each
object specified by using information
as to its location specified apriori
via \code{setDefaults} or \code{setSymbolLookup}.
Internally all data is coerced to \code{zoo},\code{data.frame},
or \code{numeric} classes.
}
\value{
Returns an object of class \code{quantmod}.
Use \code{modelData} to extract
full data set as \code{zoo} object.
}
\author{ Jeffrey Ryan }
\references{
quantmod.com \url{http://www.quantmod.com}
}
\note{ It is possible to include any supported series
in the formula by simply specifying
the object's symbol. See *Details* for a list
of currently supported classes.
Use \code{getSymbols.skeleton} to create additional
methods of data sourcing, e.g. from a proprietary
data format or currently unimplemented source
(Bloomberg, Oracle).
See \code{getSymbols.MySQL} and \code{getSymbols.yahoo}
for examples of adding additional functionality}
\seealso{ \code{\link{getModelData}},\code{\link{getSymbols}},
\code{\link{buildModel}},\code{\link{tradeModel}},\code{\link{formula}}
\code{\link{setSymbolLookup}}}
\examples{
\dontrun{
# if QQQ is not in the Global environment, an attempt will be made
# to retrieve it from the source specified with getSymbols.Default
specifyModel(Next(OpCl(QQQ)) ~ Lag(OpHi(QQQ),0:3) + Hi(DIA))
}
}
\keyword{ models }% at least one, from doc/KEYWORDS
quantmod/man/getSymbols.FRED.Rd 0000644 0001762 0000144 00000005552 15002467345 016030 0 ustar ligges users \name{getSymbols.FRED}
\alias{getSymbols.FRED}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Download Federal Reserve Economic Data - FRED(R) }
\description{
R access to over 11,000 data series accessible
via the St. Louis Federal Reserve Bank's FRED system.
Downloads \code{Symbols} to specified \code{env}
from \sQuote{research.stlouisfed.org}. This method is
not to be called directly, instead a call to
\code{getSymbols(Symbols,src='FRED')} will in
turn call this method. It is documented for the
sole purpose of highlighting the arguments
accepted, and to serve as a guide to creating
additional getSymbols \sQuote{methods}.
}
\usage{
getSymbols.FRED(Symbols,
env,
return.class = "xts",
...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{Symbols}{ a character vector specifying
the names of each symbol to be loaded}
\item{env}{ where to create objects. (.GlobalEnv) }
\item{return.class}{ class of returned object }
\item{\dots}{ additional parameters }
}
\details{
Meant to be called internally by \code{getSymbols} (see also).
One of many methods for loading
data for use with \pkg{quantmod}. Essentially a
simple wrapper to the underlying FRED
data download site.
Naming conventions must follow those as seen
on the Federal Reserve Bank of St Louis's
website for FRED. A lookup facility will hopefully
be incorporated into \pkg{quantmod} in the near future.
}
\value{
A call to getSymbols.FRED will load into the specified
environment one object for each
\code{Symbol} specified, with class defined
by \code{return.class}. Presently this may be \code{ts},
\code{zoo}, \code{xts}, or \code{timeSeries}.
}
\note{
FRED changed its URL scheme for the downloads from http:// to
https://. If \code{getSymbols.FRED} fails for this reason, try
one of the following solutions:
\enumerate{
\item{Explicitly pass \code{method} via the \code{getSymbols}
call (or via \code{setDefaults}).}
\item{Install \pkg{downloader}, which may be able to
automagically determine a suitable method.}
\item{Set the \code{download.file.method} global option.}
}
}
\references{ St. Louis Fed: Economic Data - FRED \url{https://fred.stlouisfed.org/}
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{getSymbols}},
\code{\link{setSymbolLookup}} }
\examples{
\dontrun{
# All 3 getSymbols calls return the same
# CPI data to the global environment
# The last example is what NOT to do!
## Method #1
getSymbols('CPIAUCNS',src='FRED')
## Method #2
setDefaults(getSymbols,src='FRED')
# OR
setSymbolLookup(CPIAUCNS='FRED')
getSymbols('CPIAUCNS')
#########################################
## NOT RECOMMENDED!!!
#########################################
## Method #3
getSymbols.FRED('CPIAUCNS',env=globalenv())
}
}
\keyword{ data }
quantmod/man/getSymbols.Rd 0000644 0001762 0000144 00000020552 15002467345 015306 0 ustar ligges users \name{getSymbols}
\alias{getSymbols}
\alias{getSymbols.Bloomberg}
\alias{loadSymbols}
\alias{showSymbols}
\alias{removeSymbols}
\alias{saveSymbols}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Load and Manage Data from Multiple Sources }
\description{
Functions to load and manage \code{Symbols} in
specified environment. Used by \code{\link{specifyModel}}
to retrieve symbols specified in first step of modelling
procedure. Not a true S3 method, but methods for different
data sources follow an S3-like naming convention. Additional
methods can be added by simply adhering to the convention.
Current \code{src} methods available are: yahoo, google,
MySQL, FRED, csv, RData, oanda, and av.
Data is loaded silently \emph{without} user
assignment by default.
}
\usage{
getSymbols(Symbols = NULL,
env = parent.frame(),
reload.Symbols = FALSE,
verbose = FALSE,
warnings = TRUE,
src = "yahoo",
symbol.lookup = TRUE,
auto.assign = getOption('getSymbols.auto.assign',TRUE),
...)
loadSymbols(Symbols = NULL,
env = parent.frame(),
reload.Symbols = FALSE,
verbose = FALSE,
warnings = TRUE,
src = "yahoo",
symbol.lookup = TRUE,
auto.assign = getOption('loadSymbols.auto.assign',TRUE),
...)
showSymbols(env=parent.frame())
removeSymbols(Symbols=NULL,env=parent.frame())
saveSymbols(Symbols = NULL,
file.path=stop("must specify 'file.path'"),
env = parent.frame())
}
\arguments{
\item{Symbols}{ a character vector specifying
the names of each symbol to be loaded}
\item{env}{ where to create objects. Setting env=NULL is equal to auto.assign=FALSE }
\item{reload.Symbols}{ boolean to reload current symbols
in specified environment. (FALSE)}
\item{verbose}{ boolean to turn on status of retrieval.
(FALSE)}
\item{warnings}{ boolean to turn on warnings. (TRUE)}
\item{src}{ character string specifying sourcing method.
(yahoo)}
\item{symbol.lookup}{ retrieve symbol's sourcing method
from external lookup (TRUE) }
\item{auto.assign}{ should results be loaded to \code{env}
If \code{FALSE}, return results instead.
As of 0.4-0, this is the same as setting env=NULL.
Defaults to \code{TRUE} }
\item{file.path}{ character string of file location }
\item{\dots}{ additional parameters }
}
\details{
\code{getSymbols} is a wrapper to load data from
various sources, local or remote. Data is
fetched via one of the available \code{getSymbols} methods
and either saved in the \code{env} specified - the \code{parent.frame()}
by default -- or returned to the caller. The functionality derives from \code{base::load}
behavior and semantics, i.e. is assigned automatically
to a variable in the specified environment \emph{without} the
user explicitly assigning the returned data to a variable. The assigned variable
name is that of the respective Symbols value.
The previous sentence's point warrants repeating - getSymbols is called
for its side effects, and by default\emph{does not} return the data object
loaded. The data is \sQuote{loaded} silently by the function
into the environment specified.
If automatic assignment is not desired, \code{env} may be set to NULL, or
\code{auto.assign} set to FALSE.
The early versions of getSymbols assigned each object into the user's
.GlobalEnv by name (pre 2009 up to versions less than 0.4-0).
This behavior is now supported by manually setting
env=.GlobalEnv. As of version 0.4-0, the environment is set
to parent.frame(), which preserved the user workspace when
called within another scope.
\emph{This behavior is expect to change for getSymbols as of 0.5-0, and all
results will instead be explicitly returned to the caller
unless a \code{auto.assign} is set to \code{TRUE}.}
Many thanks to Kurt Hornik and Achim Zeileis for suggesting this change, and
further thanks to Dirk Eddelbuettel for encouraging the move to a more functional
default by 0.5-0.
Using auto.assign=TRUE, the variable chosen is an \R-legal name derived
from the symbol being loaded. It is possible, using
\code{setSymbolLookup} to specify an alternate
name if the default is not desired. See that function for
details.
If auto.assign=FALSE or env=NULL (as of 0.4-0)
the data will be returned from the call, and will require
the user to assign the results himself. Note that only \emph{one} symbol
at a time may be requested when auto assignment is disabled.
Most, if not all, documentation and functionality related
to model construction and testing in \pkg{quantmod}
assumes that auto.assign remains set to TRUE and \code{env} is
a valid environment object for the calls related to those functions.
Upon completion a list of
loaded symbols is stored in the specified environment
under the name \code{.getSymbols}.
Objects loaded by \code{getSymbols} with auto.assign=TRUE
can be viewed with
\code{showSymbols} and
removed by a call to \code{removeSymbols}. Additional
data loading \dQuote{methods} can be
created simply by following the S3-like naming
convention where getSymbols.NAME
is used for your function NAME. See \code{getSymbols}
source code.
\code{setDefaults(getSymbols)} can be used to
specify defaults for \code{getSymbols} arguments.
\code{setDefaults(getSymbols.MySQL)} may be used for arguments
specific to \code{getSymbols.MySQL}, etc.
The \dQuote{sourcing} of data is managed internally
through a complex lookup procedure. If \code{symbol.lookup}
is TRUE (the default), a check is made if any symbol
has had its source specified by \code{setSymbolLookup}.
If not set, the process continues by checking to see if
\code{src} has been specified by the user in the
function call. If not, any \code{src} defined with
\code{setDefaults(getSymbols,src=)} is used.
Finally, if none of the other source rules apply
the default \code{getSymbols} \code{src} method is
used (\sQuote{yahoo}).
}
\value{
Called for its side-effect with \code{env} set to a
valid environment and auto.assign=TRUE,
\code{getSymbols} will load into the specified
\code{env} one object for each
\code{Symbol} specified, with class defined
by \code{return.class}. Presently this may be \code{ts},
\code{zoo}, \code{xts}, or \code{timeSeries}.
If env=NULL or auto.assign=FALSE an object of type
\code{return.class} will be returned.
}
\author{ Jeffrey A. Ryan }
\note{
As of version 0.4-0, the default \code{env} value is now
\code{parent.frame()}. In interactive use this should provide
the same functionality as the previous version.
While it is possible to load symbols as classes other
than \code{zoo}, \pkg{quantmod} requires most, if not
all, data to be of class \code{zoo} or inherited
from \code{zoo} - e.g. \code{xts}. The additional
methods are meant mainly to be of use for those
using the functionality outside of the \pkg{quantmod} workflow.
}
\seealso{ \code{\link{getModelData}},\code{\link{specifyModel}},
\code{\link{setSymbolLookup}},
\code{\link{getSymbols.csv}},
\code{\link{getSymbols.RData}},
\code{\link{getSymbols.oanda}},
\code{\link{getSymbols.yahoo}},
\code{\link{getSymbols.google}},
\code{\link{getSymbols.FRED}},
\code{\link{getFX}},
\code{\link{getMetals}},
}
\examples{
\dontrun{
setSymbolLookup(QQQ='yahoo',SPY='google')
# loads QQQ from yahoo (set with setSymbolLookup)
# loads SPY from MySQL (set with setSymbolLookup)
getSymbols(c('QQQ','SPY'))
# loads Ford market data from yahoo (the formal default)
getSymbols('F')
# loads symbol from MySQL database (set with setDefaults)
getSymbols('DIA', verbose=TRUE, src='MySQL')
# loads Ford as time series class ts
getSymbols('F',src='yahoo',return.class='ts')
# load into a new environment
data.env <- new.env()
getSymbols("AAPL", env=data.env)
ls.str(data.env)
# constrain to local scope
try(local( {
getSymbols("AAPL") # or getSymbols("AAPL", env=environment())
str(AAPL)
}))
exists("AAPL") # FALSE
# assign into an attached environment
attach(NULL, name="DATA.ENV")
getSymbols("AAPL", env=as.environment("DATA.ENV"))
ls("DATA.ENV")
detach("DATA.ENV")
# directly return to caller
str( getSymbols("AAPL", env=NULL) )
str( getSymbols("AAPL", auto.assign=FALSE) ) # same
}
}
\keyword{ data }
quantmod/man/quantmod.OHLC.Rd 0000644 0001762 0000144 00000002257 15000510306 015514 0 ustar ligges users \name{quantmod.OHLC}
\alias{quantmod.OHLC}
\alias{as.quantmod.OHLC}
\alias{quantmod.OHLC}
\title{ Create Open High Low Close Object }
\description{
Coerce an object with the apporpriate columns to class
\code{quantmod.OHLC}, which extends zoo.
}
\usage{
as.quantmod.OHLC(x,
col.names = c("Open", "High",
"Low", "Close",
"Volume", "Adjusted"),
name = NULL, ...)
}
\arguments{
\item{x}{ object of class \code{zoo} }
\item{col.names}{ suffix for columns }
\item{name}{ name to attach unique column suffixes to,
defaults to the object name }
\item{\dots}{ additional arguments (unused) }
}
\details{
\code{quantmod.OHLC} is actually just a renaming of an object
of class \code{zoo}, with the convention of NAME.Open, NAME.High, ...
for the column names.
Additionally methods may be written to handle or check for the above conditions
within other functions - as is the case within the \pkg{quantmod} package.
}
\value{
An object of class c('quantmod.OHLC','zoo')
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{OHLC.Transformations}}, \code{\link{getSymbols}} }
\keyword{ data }
quantmod/man/internal-quantmod.Rd 0000644 0001762 0000144 00000000264 15000510306 016576 0 ustar ligges users \name{internal-quantmod}
\alias{.quantmodEnv}
\alias{addShading}
\alias{chartShading}
\title{ Internal quantmod Objects }
\description{
To be documented...
}
\keyword{ utilities }
quantmod/man/modelSignal.Rd 0000644 0001762 0000144 00000001215 15000510306 015367 0 ustar ligges users \name{modelSignal}
\alias{modelSignal}
\title{ Extract Model Signal Object }
\description{
Extract model signal object from quantmodResults object
as an object of class \code{zoo}.
}
\usage{
modelSignal(x)
}
\arguments{
\item{x}{ object of class \code{quantmodResults} }
}
\details{
For use after a call to \code{tradeModel} to extract the generated
signal of a given \code{quantmod} model. Normally this would
not need to be called by the end user unless he was manually
post processing the trade results.
}
\value{
A \code{zoo} object indexed by signal dates.
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{tradeModel}} }
\keyword{ utilities }
quantmod/man/getSymbols.tiingo.Rd 0000644 0001762 0000144 00000005637 15002467345 016605 0 ustar ligges users \name{getSymbols.tiingo}
\alias{getSymbols.tiingo}
\title{ Download OHLC Data from Tiingo }
\description{
Downloads historical or realtime equity price data
from \url{https://www.tiingo.com/}.
Registration is required.
}
\usage{
getSymbols.tiingo(Symbols, env, api.key,
return.class="xts",
periodicity="daily",
adjust=FALSE,
from='2007-01-01',
to=Sys.Date(),
...)
}
\arguments{
\item{Symbols}{ a character vector specifying the names
of the symbols to be loaded}
\item{env}{ where to create objects (environment) }
\item{api.key}{ the API key issued by Tiingo when you registered (character)}
\item{return.class}{ class of returned object, see Value (character) }
\item{periodicity}{ one of \code{"daily"}, \code{"weekly"}, \code{"monthly"}, or \code{"Annually"} }
\item{adjust}{ adjust for dividends and splits? (FALSE) }
\item{from}{ Retrieve data no earlier than this date. (2007-01-01)}
\item{to}{ Retrieve data through this date (Sys.Date())}
\item{\dots}{ additional parameters as per \code{\link{getSymbols}} }
}
\details{
Meant to be called internally by \code{getSymbols} only.
This method is not meant to be called directly, instead
a call to \code{getSymbols("x", src="tiingo")} will
in turn call this method. It is documented for the
sole purpose of highlighting the arguments accepted.
You must register with Tiingo in order to download their data.
Register at their web site, \url{https://www.tiingo.com},
and you will receive an \emph{API key}:
a short string of alphanumeric characters (e.g., "FU4U").
Provide the API key every time you call \code{getSymbols};
or set it globally using \code{setDefaults(getSymbols.tiingo, api.key="yourKey")}.
Tiingo provides daily, weekly, monthly, and annual data.
Use \code{periodicity} to select one.
This API accessor will return adjusted or unadjusted OHLC as well as split and dividend information.
For daily, weekly, and monthly data, Tiingo says the available data is up to 30 years;
}
\value{
A call to \code{getSymbols(Symbols, src="tiingo")} will create objects
in the specified environment,
one object for each \code{Symbol} specified.
The object class of the object(s) is determined by \code{return.class}.
Presently this may be \code{"ts"}, \code{"zoo"}, \code{"xts"}, or \code{"timeSeries"}.
}
% \note{
% [TBD]
% }
\references{ Tiingo documentation available at \url{https://www.tiingo.com} }
\author{ Steve Bronder }
\seealso{
\code{\link{getSymbols}},
\code{\link{getSymbols.yahoo}},
\code{\link{getSymbols.av}}
}
\examples{
\dontrun{
# You'll need the API key given when you registered
getSymbols("IBM", src="tiingo", api.key="yourKey")
# Repeating your API key every time is tedious.
# Fortunately, you can set a global default.
setDefaults(getSymbols.tiingo, api.key="yourKey")
getSymbols("IBM", src="tiingo")
}
}
quantmod/man/OHLC.Transformations.Rd 0000644 0001762 0000144 00000007565 15002467345 017104 0 ustar ligges users \name{OHLC.Transformations}
\alias{OHLC.Transformations}
\alias{getPrice}
\alias{Ad}
\alias{Cl}
\alias{ClCl}
\alias{ClOp}
\alias{Hi}
\alias{HiCl}
\alias{Lo}
\alias{LoCl}
\alias{LoHi}
\alias{Op}
\alias{OpCl}
\alias{OpHi}
\alias{OpLo}
\alias{OpOp}
\alias{Vo}
\alias{HL}
\alias{HLC}
\alias{OHLC}
\alias{OHLCV}
\alias{seriesHi}
\alias{seriesLo}
\alias{seriesIncr}
\alias{seriesDecr}
\alias{seriesAccel}
\alias{seriesDecel}
\title{ Extract and Transform OHLC Time-Series Columns }
\description{
Extract (transformed) data from a suitable OHLC object.
Column names must contain the
complete description - either \dQuote{Open}, \dQuote{High},
\dQuote{Low}, \dQuote{Close},
\dQuote{Volume}, or \dQuote{Adjusted} - though may
also contain additional characters. This is the default for objects
returned from most \code{getSymbols} calls.
In the case of functions consisting of combined
Op, Hi, Lo, Cl (e.g. \code{ClCl(x)}) the one period
transformation will be applied.
For example, to return the Open to Close of a
object it is
possible to call \code{OpCl(x)}. If multiple periods
are desired a call to the function \code{Delt} is
necessary.
\code{seriesLo} and \code{seriesHi} will return the
low and high, respectively, of a given series.
\code{seriesAccel}, \code{seriesDecel}, \code{seriesIncr},
and \code{seriesDecr}, return a vector of logicals
indicating if the series is accellerating, decellerating,
increasing, or decreasing. This is managed by \code{diff},
which provides NA fill and suitable re-indexing. These
are here to make trade rules easier to read.
\code{HL} extracts the High and Low columns.
\code{HLC} extracts the High, Low, and Close columns.
\code{OHLC} extracts the Open, High, Low, and Close columns.
These functions are merely to speed the model
specification process. All columns may also be extracted
through standard R methods.
Assignment will not work at present.
\code{getPrice} will attempt to extract price column(s) from a time series,
using sensible defaults. Additionally, the user may provide by symbol and price
preference.
}
\usage{
Op(x)
Hi(x)
Lo(x)
Cl(x)
Vo(x)
Ad(x)
seriesHi(x)
seriesLo(x)
seriesIncr(x, thresh=0, diff.=1L)
seriesDecr(x, thresh=0, diff.=1L)
OpCl(x)
ClCl(x)
ClOp(x)
HiCl(x)
LoCl(x)
LoHi(x)
OpHi(x)
OpLo(x)
OpOp(x)
HL(x)
HLC(x)
OHLC(x)
OHLCV(x)
getPrice(x, symbol=NULL, prefer=NULL, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{x}{ A data object with columns containing
data to be extracted. }
\item{thresh}{ noise threshold (seriesIncr/seriesDecr) }
\item{diff.}{ differencing (seriesIncr/seriesDecr) }
\item{symbol}{ text string containing the symbol to extract }
\item{prefer}{ price type preference (see Details) }
\item{\dots}{ not currently used }
}
\details{
Internally, the code uses grep to locate the appropriate
columns. Therefore it is necessary to use inputs with
column names matching the requirements in the description
section, though the exact naming convention is not as important.
\code{prefer} can be used with \code{getPrice} to extract many commonly used
financial time series prices descriptions (e.g. open, high, low, close, bid,
ask/offer, midpoint, trade, price). If the value of \code{prefer} does not
match one of the currently supported types, it will be matched against the
object column names using \code{grep}.
}
\value{
Returns an object of the same class as the original
series, with the appropriately column names
if applicable and/or possible. The only exceptions are for \code{quantmod.OHLC}
objects which will be returned as \code{zoo} objects, and calls to
\code{seriesLo} and \code{seriesHi} which \emph{may} return a numeric
value instead of the original object type.
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{specifyModel}} }
\examples{
\dontrun{
getSymbols('IBM',src='yahoo')
Ad(IBM)
Cl(IBM)
ClCl(IBM)
seriesHi(IBM)
seriesHi(Lo(IBM))
removeSymbols('IBM')
}
}
\keyword{ utilities }
quantmod/man/getFX.Rd 0000644 0001762 0000144 00000003121 15002467345 014164 0 ustar ligges users \name{getFX}
\alias{getFX}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Download Exchange Rates }
\description{
Download exchange rates or metals prices from oanda.
}
\usage{
getFX(Currencies,
from = Sys.Date() - 179,
to = Sys.Date(),
env = parent.frame(),
verbose = FALSE,
warning = TRUE,
auto.assign = TRUE, ...)
}
\arguments{
\item{Currencies}{ Currency pairs expressed as \sQuote{CUR/CUR} }
\item{from}{ start date expressed in ISO CCYY-MM-DD format }
\item{to}{ end date expressed in ISO CCYY-MM-DD format }
\item{env}{ which environment should they be loaded into }
\item{verbose}{ be verbose }
\item{warning}{ show warnings }
\item{auto.assign}{ use auto.assign }
\item{\dots}{ additional parameters to be passed to getSymbols.oanda method }
}
\details{
A convenience wrapper to \code{getSymbols(x,src='oanda')}. See
\code{getSymbols} and \code{getSymbls.oanda} for more detail.
}
\value{
Data will be assigned
automatically to the environment specified (the parent environment by default).
If \code{auto.assign = FALSE}, the data from a single metal
request will simply be returned from the function call.
If \code{auto.assign = TRUE} is used (the default)
a vector of downloaded symbol names will be returned.
See \code{getSymbols} and \code{getSymbols.oanda} for more detail.
}
\references{ Oanda.com \url{https://www.oanda.com} }
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{getSymbols}}, \code{\link{getSymbols.oanda}} }
\examples{
\dontrun{
getFX("USD/JPY")
getFX("EUR/USD",from="2005-01-01")
}
}
\keyword{ utilities}
quantmod/man/adjustOHLC.Rd 0000644 0001762 0000144 00000006173 15002467345 015121 0 ustar ligges users \name{adjustOHLC}
\Rdversion{1.1}
\alias{adjustOHLC}
\title{
Adjust Open,High,Low,Close Prices For Splits and Dividends
}
\description{
Adjust all columns of an OHLC
object for
split and dividend.
}
\usage{
adjustOHLC(x,
adjust = c("split","dividend"),
use.Adjusted = FALSE,
ratio = NULL,
symbol.name=deparse(substitute(x)))
}
\arguments{
\item{x}{ An OHLC object }
\item{adjust}{ adjust by split, dividend, or both (default) }
\item{use.Adjusted}{ use the \sQuote{Adjusted} column in Yahoo! data to adjust }
\item{ratio}{ ratio to adjust with, bypassing internal calculations }
\item{symbol.name}{ used if x is not named the same as the symbol adjusting }
}
\details{
This function calculates the adjusted
Open, High, Low, and Close prices according
to split and dividend information.
There are three methods available to
calculate the new OHLC object prices.
By default, \code{getSplits} and \code{getDividends} are
called to retrieve the respective information. These
may dispatch to custom methods following the \dQuote{.}
methodology used by quantmod dispatch. See \code{getSymbols}
for information related to extending quantmod.
This information is passed to
\code{adjRatios} from the \pkg{TTR} package, and
the resulting ratio calculations are used to adjust
to observed historical prices.
This is the most precise way to adjust a series.
The second method works only on standard
Yahoo! data containing an explicit
Adjusted column.
A final method allows for one to pass
a \code{ratio} into the function directly.
All methods proceed as follows:
New columns are derived by taking the
ratio of adjusted value to original Close, and multiplying
by the difference of the respective column and the
original Close. This is then added to the modified Close
column to arrive at the remaining \sQuote{adjusted}
Open, High, Low column values.
If no adjustment is needed, the function returns the
original data unaltered.
}
\value{
An object of the original class, with prices
adjusted for splits and dividends.
}
\references{
Yahoo Finance \url{https://finance.yahoo.com}
}
\author{
Jeffrey A. Ryan
}
\section{Warning }{
Using \code{use.Adjusted = TRUE} will be less precise
than the method that employs actual split
and dividend information. This is due to
loss of precision from Yahoo! using
Adjusted columns of only two decimal places.
The advantage is that this can be run offline,
and for short series or those with few adjustments
the loss of precision will be small.
The resulting precision loss will be from row
observation to row observation, as the calculation
will be exact for intraday values.
}
\seealso{
\code{\link{getSymbols.yahoo}}
\code{\link{getSplits}}
\code{\link{getDividends}}
}
\examples{
\dontrun{
getSymbols("AAPL", from="1990-01-01", src="yahoo")
head(AAPL)
head(AAPL.a <- adjustOHLC(AAPL))
head(AAPL.uA <- adjustOHLC(AAPL, use.Adjusted=TRUE))
# intraday adjustments are precise across all methods
# an example with Open to Close (OpCl)
head(cbind(OpCl(AAPL),OpCl(AAPL.a),OpCl(AAPL.uA)))
# Close to Close changes may lose precision
head(cbind(ClCl(AAPL),ClCl(AAPL.a),ClCl(AAPL.uA)))
}
}
\keyword{ misc }
quantmod/man/setSymbolLookup.Rd 0000644 0001762 0000144 00000006720 15002467345 016332 0 ustar ligges users \name{setSymbolLookup}
\alias{setSymbolLookup}
\alias{getSymbolLookup}
\alias{loadSymbolLookup}
\alias{saveSymbolLookup}
\title{ Manage Symbol Lookup Table }
\description{
Create and manage Symbol defaults lookup table within
\R session for use in \code{getSymbols} calls.
}
\usage{
setSymbolLookup(...)
getSymbolLookup(Symbols=NULL)
saveSymbolLookup(file,dir="")
loadSymbolLookup(file,dir="")
}
\arguments{
\item{\dots}{ name=value pairs for symbol defaults }
\item{Symbols}{ name of symbol(s) }
\item{file}{ filename }
\item{dir}{ directory of filename }
}
\details{
Use of these functions allows the user to specify
a set of default parameters for each \code{Symbol} to be
loaded.
Different sources (e.g. yahoo, MySQL, csv),
can be specified for each Symbol of
interest. The sources must be \emph{valid}
\code{getSymbols} methods - see \code{getSymbols}
for details on which methods are available, as well as
how to add additional methods.
The argument list to \code{setSymbolLookup} is
simply the unquoted name of the \code{Symbol} matched
to the desired default source, or list of Symbol
specific parameters.
For example, to signify that the stock data for
Sun Microsystems (JAVA) should be downloaded from
Yahoo! Finance, one would call
\code{setSymbolLookup(JAVA='yahoo')}
or \code{setSymbolLookup(JAVA=list(src='yahoo'))}
It is also possible to specify additional,
possibly source specific, lookup details on
a per symbol basis. These include an alternate
naming convention (useful for sites like Yahoo! where
certain non-traded symbols are prepended with a caret,
or more correctly a curcumflex accent. In that case one would
specify \code{setSymbolLookup(DJI=list(name="^DJI",src="yahoo"))})
as well as passed parameters like \code{dbname} and
\code{password} for database sources. See the
specific getSymbols function related to the source
in question for more details of each implementation.
If a single named list is passed into the function without naming
the list as a parameter, the names of this list will be presumed
to be symbol names to be added to the current list of symbols.
All changes are made to the current list, and will
persist \emph{only} until the end of the session. To \emph{always}
use the same defaults it is necessary to call
\code{setSymbolLookup} with the appropriate
parameters from a startup file (e.g.
.Rprofile) or to use \code{saveSymbolLookup} and
\code{loadSymbolLookup} to save and restore lookup
tables.
To unset a specific Symbol's defaults, simply assign
\code{NULL} to the Symbol.
}
\value{
Called for its side effects, the function changes the
\code{options} value for the specified Symbol
through a call to \code{options(getSymbols.sources=...)}
}
\author{ Jeffrey A. Ryan }
\note{
Changes are \emph{NOT} persistent across sessions,
as the table is stored in the session options by default.
This \emph{may} change to allow for an easier to
manage process, as for now it is designed to minimize
the clutter created during a typical session.
}
\seealso{ \code{\link{getSymbols}}, \code{\link{options}},}
\examples{
setSymbolLookup(QQQ='yahoo',DIA='MySQL')
getSymbolLookup('QQQ')
getSymbolLookup(c('QQQ','DIA'))
\dontrun{
## Will download QQQ from yahoo
## and load DIA from MySQL
getSymbols(c('QQQ','DIA'))
}
## Use something like this to always retrieve
## from the same source
.First <- function() {
require(quantmod,quietly=TRUE)
quantmod::setSymbolLookup(JAVA="MySQL")
}
## OR
\dontrun{
saveSymbolLookup()
loadSymbolLookup()
}
}
\keyword{ utilities }
quantmod/man/addROC.Rd 0000644 0001762 0000144 00000001233 15000510306 014225 0 ustar ligges users \name{addROC}
\alias{addROC}
\title{ Add Rate Of Change to Chart }
\description{
Add Rate Of Change indicator to chart.
}
\usage{
addROC(n = 1, type = c("discrete", "continuous"), col = "red")
}
\arguments{
\item{n}{ periods }
\item{type}{ compounding type }
\item{col}{ line color (optional) }
}
\details{
See 'ROC' in \pkg{TTR} for specific details and references.
}
\value{
A ROC indicator will be draw in a new window on the current
chart. A chobTA object will be returned silently.
}
\references{ see ROC in \pkg{TTR} written by Josh Ulrich }
\author{Jeffrey A. Ryan }
\seealso{ \code{\link{addTA}} }
\examples{
\dontrun{
addROC()
}
}
\keyword{utilities}
quantmod/man/tradeModel.Rd 0000644 0001762 0000144 00000004547 15002467345 015244 0 ustar ligges users \name{tradeModel}
\alias{tradeModel}
\title{ Simulate Trading of Fitted quantmod Object }
\description{
Simulated trading of fitted quantmod object. Given a fitted model,
tradeModel calculates the signal generated over a given historical
period, then applies specified \code{trade.rule} to calculate
and return a \code{tradeLog} object. Additional methods can then
be called to evaluate the performance of the model's strategy.
}
\usage{
tradeModel(x,
signal.threshold = c(0, 0),
leverage = 1,
return.model = TRUE,
plot.model = FALSE,
trade.dates = NULL,
exclude.training = TRUE,
ret.type = c("weeks", "months", "quarters", "years"),
...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{x}{ a quantmod object from \code{buildModel} }
\item{signal.threshold}{ a numeric vector describing simple lower
and upper thresholds before trade occurs}
\item{leverage}{ amount of leverage to apply - currently a constant }
\item{return.model}{ should the full model be returned? }
\item{plot.model}{ plot the model? }
\item{trade.dates}{ specific trade interval - defaults to full dataset }
\item{exclude.training}{ exclude the period trained on? }
\item{ret.type}{ a table of period returns }
\item{\dots}{ additional parameters needed by the underlying modelling function, if any }
}
\details{
Still highly experimental and changing. The purpose is to apply
a newly contructed model from \code{buildModel} to a new dataset
to investigate the model's trading potential.
At present all parameters are very basic. The near term changes include
allowing for a trade.rule argument to allow for a dynamic trade rule given
a set of signals. Additional the application of variable leverage and costs
will become part of the final structure.
Any suggestions as to inclusions or alterations are appreciated and should
be directed to the maintainer of the package.
}
\value{
A quantmodResults object
}
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{specifyModel}} \code{\link{buildModel}} }
\examples{
\dontrun{
m <- specifyModel(Next(OpCl(QQQ)) ~ Lag(OpHi(QQQ)))
m.built <- buildModel(m,method='rpart',training.per=c('2007-01-01','2007-04-01'))
tradeModel(m.built)
tradeModel(m.built,leverage=2)
}
}
\keyword{ models }% at least one, from doc/KEYWORDS
quantmod/man/addBBands.Rd 0000644 0001762 0000144 00000002431 15000510306 014734 0 ustar ligges users \name{addBBands}
\alias{addBBands}
\title{ Add Bollinger Bands to Chart }
\description{
Add Bollinger Bands to current chart.
}
\usage{
addBBands(n = 20, sd = 2, maType = "SMA", draw = 'bands', on = -1)
}
\arguments{
\item{n}{ number of moving average periods }
\item{maType}{ type of moving average to be used }
\item{sd}{ number of standard deviations }
\item{draw}{ indicator to draw: bands, percent, or width }
\item{on}{ which figure area of chart to apply to }
}
\details{
The primary addition to this function call over the \pkg{TTR}
version is in the \code{draw} argument. \sQuote{bands} will draw
standard Bollinger Bands, \sQuote{percent} will draw Bollinger \%b
and \sQuote{width} will draw Bolinger Bands Width. The last two will
be drawn in new figure regions.
See bollingerBands in \pkg{TTR} for specific details
as to implementation and references.
}
\value{
Bollinger Bands will be drawn, or scheduled to be drawn,
on the current chart. If \code{draw} is either percent or width
a new figure will be added to the current TA figures charted.
A chobTA object will be returned silently.
}
\references{ See bollingerBands in \pkg{TTR} written by Josh Ulrich }
\author{ Jeffrey A. Ryan }
\seealso{ \code{\link{addTA}} }
\examples{
\dontrun{
addBBands()
}
}
\keyword{ utilities }
quantmod/man/chart_Series.Rd 0000644 0001762 0000144 00000003032 15002467345 015563 0 ustar ligges users \name{chart_Series}
\alias{chart_Series}
\alias{add_Series}
\alias{add_MACD}
\alias{add_ADX}
\alias{add_BBands}
\alias{add_RSI}
\alias{add_SMI}
\alias{add_TA}
\alias{add_Vo}
\alias{add_axis}
\alias{zoom_Chart}
\alias{chart_theme}
\alias{chart_pars}
\alias{axTicksByTime2}
\alias{axTicksByValue}
\alias{new.replot}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
Experimental Charting Version 2
}
\description{
These are experimental functions for a new version of chartSeries
in quantmod. Interface, behavior, and functionality will change.
}
\usage{
chart_Series(x,
name = NULL,
type = "candlesticks",
subset = "",
TA = "",
pars = chart_pars(),
theme = chart_theme(),
clev = 0,
...)
}
\arguments{
\item{x}{
time series object
}
\item{name}{
name for chart
}
\item{type}{
one of:
}
\item{subset}{
an ISO8601 style character string indicating date range
}
\item{TA}{
a character string of semi-colon seperated TA calls.
}
\item{pars}{
chart parameters
}
\item{theme}{
chart theme
}
\item{clev}{
color level (experimental). Indicates the degree of brightness 0 is darkest color.
}
\item{\dots}{
additional parameters
}
}
\details{
These functions, when complete, will revert back to the original chartSeries naming
convention.
}
\value{
Called for graphical side effects.
}
\author{
Jeffrey A. Ryan
}
\note{
Highly experimental (read: alpha) use with caution.
}
\keyword{ dplot }% __ONLY ONE__ keyword per line
quantmod/man/Lag.Rd 0000644 0001762 0000144 00000003567 15000510306 013650 0 ustar ligges users \name{Lag}
\alias{Lag}
\alias{Lag.quantmod.OHLC}
\alias{Lag.zoo}
\alias{Lag.data.frame}
\alias{Lag.numeric}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Lag a Time Series }
\description{
Create a lagged series from data, with \code{NA} used to fill.
}
\usage{
Lag(x, k = 1)
\method{Lag}{quantmod.OHLC}(x, k = 1)
\method{Lag}{zoo}(x, k = 1)
\method{Lag}{data.frame}(x, k = 1)
\method{Lag}{numeric}(x, k = 1)
}
\arguments{
\item{x}{ vector or series to be lagged }
\item{k}{ periods to lag. }
}
\details{
Shift series k-periods down, prepending \code{NA}s to front
of series.
Specifically designed to handle \code{quantmod.OHLC} and
\code{zoo} series within the \code{quantmod} workflow.
If no S3 method is found, a call to \code{lag} in \pkg{base}
is made.
}
\value{
The original \code{x} prepended with \code{k} \code{NA}s
and missing the trailing \code{k} values.
The returned series maintains the number of obs. of the
original.
}
\author{ Jeffrey A. Ryan }
\note{
This function differs from \code{lag} by returning
the original series modified, as opposed to simply changing
the time series properties. It differs from the like
named \code{Lag} in the \pkg{Hmisc} as it deals primarily
with time-series like objects.
It is important to realize that if there is no applicable
method for \code{Lag}, the value returned will be from
\code{lag} in \pkg{base}. That is, coerced to \code{'ts'}
if necessary, and subsequently shifted.
}
\seealso{ \code{\link{lag}} }
\examples{
Stock.Close <- c(102.12,102.62,100.12,103.00,103.87,103.12,105.12)
Close.Dates <- as.Date(c(10660,10661,10662,10665,10666,10667,10668),origin="1970-01-01")
Stock.Close <- zoo(Stock.Close,Close.Dates)
Lag(Stock.Close) #lag by 1 period
Lag(Stock.Close,k=1) #same
Lag(Stock.Close,k=1:3) #lag 1,2 and 3 periods
}
\keyword{ ts }
\keyword{ datagen }
\keyword{ misc }
\concept{ trading }
quantmod/man/chob-class.Rd 0000644 0001762 0000144 00000004662 15000510306 015160 0 ustar ligges users \name{chob-class}
\docType{class}
\alias{chob-class}
\title{A Chart Object Class }
\description{Internal Objects for Tracking and Plotting Chart Changes }
\section{Objects from the Class}{
Objects are created internally through the charting
functions \code{chartSeries}, \code{barChart}, \code{lineChart}, and
\code{candleChart}.
}
\section{Slots}{
\describe{
\item{\code{device}:}{Object of class \code{"ANY"} ~~ }
\item{\code{call}:}{Object of class \code{"call"} ~~ }
\item{\code{xdata}:}{Object of class \code{"ANY"} ~~ }
\item{\code{xsubset}:}{Object of class \code{"ANY"} ~~ }
\item{\code{name}:}{Object of class \code{"character"} ~~ }
\item{\code{type}:}{Object of class \code{"character"} ~~ }
\item{\code{passed.args}:}{Object of class \code{"ANY"} ~~ }
\item{\code{windows}:}{Object of class \code{"numeric"} ~~ }
\item{\code{xrange}:}{Object of class \code{"numeric"} ~~ }
\item{\code{yrange}:}{Object of class \code{"numeric"} ~~ }
\item{\code{log.scale}:}{Object of class \code{"logical"} ~~ }
\item{\code{length}:}{Object of class \code{"numeric"} ~~ }
\item{\code{color.vol}:}{Object of class \code{"logical"} ~~ }
\item{\code{multi.col}:}{Object of class \code{"logical"} ~~ }
\item{\code{show.vol}:}{Object of class \code{"logical"} ~~ }
\item{\code{show.grid}:}{Object of class \code{"logical"} ~~ }
\item{\code{line.type}:}{Object of class \code{"character"} ~~ }
\item{\code{bar.type}:}{Object of class \code{"character"} ~~ }
\item{\code{xlab}:}{Object of class \code{"character"} ~~ }
\item{\code{ylab}:}{Object of class \code{"character"} ~~ }
\item{\code{spacing}:}{Object of class \code{"numeric"} ~~ }
\item{\code{width}:}{Object of class \code{"numeric"} ~~ }
\item{\code{bp}:}{Object of class \code{"numeric"} ~~ }
\item{\code{x.labels}:}{Object of class \code{"character"} ~~ }
\item{\code{colors}:}{Object of class \code{"ANY"} ~~ }
\item{\code{layout}:}{Object of class \code{"ANY"} ~~ }
\item{\code{time.scale}:}{Object of class \code{"ANY"} ~~ }
\item{\code{major.ticks}:}{Object of class \code{"ANY"} ~~ }
\item{\code{minor.ticks}:}{Object of class \code{"logical"} ~~ }
}
}
\section{Methods}{
No methods defined with class "chob" in the signature.
}
\author{ Jeffrey A. Ryan }
\seealso{
\code{\link{chartSeries}},
or \code{\linkS4class{chobTA}} for links to other classes
}
\examples{
showClass("chob")
}
\keyword{classes}
quantmod/man/options.expiry.Rd 0000644 0001762 0000144 00000002252 15000510306 016145 0 ustar ligges users \name{options.expiry}
\alias{options.expiry}
\alias{futures.expiry}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Calculate Contract Expirations }
\description{
Return the index of the contract expiration date. The third Friday of the
month for options, the last third Friday of the quarter for futures.
}
\usage{
options.expiry(x)
futures.expiry(x)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{x}{ a time-indexed zoo object }
}
\details{
Designed to be used within a charting context via \code{addExpiry}, the values returned
are based on the description above. Exceptions, though rare, are not accounted for.
}
\value{
A numeric vector of values to index on.
}
\references{ ~put references to the literature/web site here ~ }
\author{ Jeffrey A. Ryan }
\note{
There is currently no accounting for holidays that may interfere with
the general rule. Additionally all efforts have been focused on
US equity and futures markets.
}
\seealso{ \code{\link{addExpiry}} }
\examples{
\dontrun{
getSymbols("AAPL")
options.expiry(AAPL)
futures.expiry(AAPL)
AAPL[options.expiry(AAPL)]
}
}
\keyword{ utilities }% __ONLY ONE__ keyword per line
quantmod/DESCRIPTION 0000644 0001762 0000144 00000002375 15025063626 013624 0 ustar ligges users Package: quantmod
Type: Package
Title: Quantitative Financial Modelling Framework
Version: 0.4.28
Authors@R: c(
person(given=c("Jeffrey","A."), family="Ryan", role=c("aut","cph")),
person(given=c("Joshua","M."), family="Ulrich", role=c("cre","aut"), email="josh.m.ulrich@gmail.com"),
person(given=c("Ethan","B."), family="Smith", role="ctb"),
person(given="Wouter", family="Thielen", role="ctb"),
person(given="Paul", family="Teetor", role="ctb"),
person(given="Steve", family="Bronder", role="ctb")
)
Depends: R (>= 3.2.0), xts(>= 0.9-0), zoo, TTR(>= 0.2), methods
Imports: curl, jsonlite(>= 1.1)
Suggests: DBI, RMySQL, RSQLite, timeSeries, xml2, downloader, tinytest
Description: Specify, build, trade, and analyse quantitative financial trading strategies.
LazyLoad: yes
License: GPL-3
URL: https://www.quantmod.com/,
https://github.com/joshuaulrich/quantmod
BugReports: https://github.com/joshuaulrich/quantmod/issues
NeedsCompilation: no
Packaged: 2025-06-18 21:49:58 UTC; josh
Author: Jeffrey A. Ryan [aut, cph],
Joshua M. Ulrich [cre, aut],
Ethan B. Smith [ctb],
Wouter Thielen [ctb],
Paul Teetor [ctb],
Steve Bronder [ctb]
Maintainer: Joshua M. Ulrich
Repository: CRAN
Date/Publication: 2025-06-19 19:40:06 UTC