quantmod/0000755000176200001440000000000013764105424012110 5ustar liggesusersquantmod/NAMESPACE0000644000176200001440000001702113760466720013335 0ustar liggesusersexport(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) # new plotting functions (experimental) export(new.replot, current.chob, chart_Series, add_Series, add_EMA, add_EVWMA, add_VMA, add_WMA, add_SMA, add_DEMA, add_VWAP, add_GMMA, 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) #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 # quick delta calculation functions OpCl, OpOp, ClCl, 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,ts) S3method(seriesLo,default) 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/demo/0000755000176200001440000000000013253773663013045 5ustar liggesusersquantmod/demo/chartSeries.R0000644000176200001440000000171313253773663015446 0ustar liggesusers# 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/00Index0000644000176200001440000000005113253773663014173 0ustar liggesuserschartSeries The demo for chartSeries quantmod/man/0000755000176200001440000000000013762440201012654 5ustar liggesusersquantmod/man/getSymbols.tiingo.Rd0000644000176200001440000000645713263460400016576 0ustar liggesusers\name{getSymbols.tiingo} \alias{getSymbols.tiingo} \title{ Download OHLC Data from Tiingo } \description{ Downloads historical or realtime equity price data from \url{https://api.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(), 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 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{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="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://api.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; Tiingo 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="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/zoomChart.Rd0000644000176200001440000000461213253773663015134 0ustar liggesusers\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/getModelData.Rd0000644000176200001440000000207713253773663015523 0ustar liggesusers\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(QQQQ)) ~ Lag(Cl(NDX),0:5)) getModelData(my.model) } } \keyword{ datasets }% at least one, from doc/KEYWORDS quantmod/man/chart_Series.Rd0000644000176200001440000000303513253773663015577 0ustar liggesusers\name{chart_Series} \alias{chart_Series} \alias{add_Series} \alias{add_MACD} \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 = deparse(substitute(x)), 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/attachSymbols.Rd0000644000176200001440000000733613253773663016011 0ustar liggesusers\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 QQQQ ls() } } \keyword{ misc } quantmod/man/Lag.Rd0000644000176200001440000000356713253773663013701 0ustar liggesusers\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/quantmod.OHLC.Rd0000644000176200001440000000225713253773663015545 0ustar liggesusers\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/specifyModel.Rd0000644000176200001440000000556613762435665015624 0ustar liggesusers\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 QQQQ is not in the Global environment, an attempt will be made # to retrieve it from the source specified with getSymbols.Default specifyModel(Next(OpCl(QQQQ)) ~ Lag(OpHi(QQQQ),0:3) + Hi(DIA)) } } \keyword{ models }% at least one, from doc/KEYWORDS quantmod/man/addVo.Rd0000644000176200001440000000125113253773663014217 0ustar liggesusers\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/TA.Rd0000644000176200001440000000701713253773663013474 0ustar liggesusers\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}. Functionality marked with a \sQuote{*} is via the \pkg{TTR} package. General TA charting tool functions: \itemize{ \item{addTA}{add data as custom indicator } \item{dropTA}{remove technical indicator} \item{moveTA}{move a technical indicator} \item{swapTA}{swap two technical indicators} } Current technical indicators include: \itemize{ \item{addADX}{add Welles Wilder's Directional Movement Indicator*} \item{addATR}{add Average True Range *} \item{addAroon}{add Aroon Indicator *} \item{addAroonOsc}{add Aroon Oscillator *} \item{addBBands:}{add Bollinger Bands *} \item{addCCI}{add Commodity Channel Index *} \item{addCMF}{add Chaiken Money Flow *} \item{addChAD}{add Chaiken Accumulation Distribution Line *} \item{addChVol}{add Chaiken Volatility *} \item{addCMO}{add Chande Momentum Oscillator *} \item{addDEMA}{add Double Exponential Moving Average *} \item{addDPO}{add Detrended Price Oscillator *} \item{addEMA}{add Exponential Moving Average *} \item{addEMV}{add Arm's Ease of Movement *} \item{addEnvelope}{add Moving Average Envelope} \item{addEVWMA}{add Exponential Volume Weighted Moving Average *} \item{addExpiry}{add options or futures expiration lines} \item{addKST}{add Know Sure Thing *} \item{addLines}{add line(s)} \item{addMACD:}{add Moving Average Convergence Divergence *} \item{addMFI}{add Money Flow Index *} \item{addMomentum}{add Momentum *} \item{addOBV}{add On-Balance Volume *} \item{addPoints}{add point(s) } \item{addROC:}{add Rate of Change *} \item{addRSI}{add Relative Strength Indicator *} \item{addSAR}{add Parabolic SAR *} \item{addSMA}{add Simple Moving Average *} \item{addSMI}{add Stochastic Momentum Index *} \item{addTDI}{add Trend Direction Index *} \item{addTRIX}{add Triple Smoothed Exponential Oscillator *} \item{addVo}{add Volume if available} \item{addVolatility}{add volatility *} \item{addWMA}{add Weighted Moving Average *} \item{addWPR}{add Williams Percent R *} \item{addZigZag}{add Zig Zag *} \item{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.Rd0000644000176200001440000000330513253773663015055 0ustar liggesusers\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/addSMI.Rd0000644000176200001440000000132713253773663014267 0ustar liggesusers\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/addMA.Rd0000644000176200001440000000313513253773663014133 0ustar liggesusers\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{add_VMA} \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/addBBands.Rd0000644000176200001440000000243113253773663014765 0ustar liggesusers\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/addRSI.Rd0000644000176200001440000000124713253773663014275 0ustar liggesusers\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/create.binding.Rd0000644000176200001440000000251613253773663016043 0ustar liggesusers\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/getSymbols.FRED.Rd0000644000176200001440000000555213762440152016026 0ustar liggesusers\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/getDividends.Rd0000644000176200001440000000406713762435636015603 0ustar liggesusers\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/getSymbols.csv.Rd0000644000176200001440000000464713253773663016120 0ustar liggesusers\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. } \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/tradeModel.Rd0000644000176200001440000000455113253773663015250 0ustar liggesusers\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(QQQQ)) ~ Lag(OpHi(QQQQ))) 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/newTA.Rd0000644000176200001440000001733613253773663014213 0ustar liggesusers\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/addSAR.Rd0000644000176200001440000000123213253773663014257 0ustar liggesusers\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/Next.Rd0000644000176200001440000000427313253773663014107 0ustar liggesusers\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/getSymbols.rda.Rd0000644000176200001440000000464413253773663016070 0ustar liggesusers\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/getSymbols.MySQL.Rd0000644000176200001440000000671113606423034016246 0ustar liggesusers\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/quantmod-defunct.Rd0000644000176200001440000000156713263460400016431 0ustar liggesusers\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 functions listed here are no longer part of \pkg{quantmod}. } \usage{ # Defunct in 0.4-13 getFin(Symbol, env = parent.frame(), src = "google", auto.assign = TRUE, ...) getFinancials(Symbol, env = parent.frame(), src = "google", auto.assign = TRUE, ...) 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.google}. } \seealso{ \code{\link{Defunct}} } \keyword{internal} quantmod/man/internal-quantmod.Rd0000644000176200001440000000026413253773663016627 0ustar liggesusers\name{internal-quantmod} \alias{.quantmodEnv} \alias{addShading} \alias{chartShading} \title{ Internal quantmod Objects } \description{ To be documented... } \keyword{ utilities } quantmod/man/Defaults.Rd0000644000176200001440000001361713760466720014736 0ustar liggesusers\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/addWPR.Rd0000644000176200001440000000110313253773663014277 0ustar liggesusers\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/getMetals.Rd0000644000176200001440000000400413762435565015107 0ustar liggesusers\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 ablity 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 (parent by default). If auto.assign is set to FALSE, the data from a single metal request will simply be returned from the function call. If auto.assign 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(c("gold","XPD")) getFX("plat",from="2005-01-01") } } \keyword{ utilities} quantmod/man/saveChart.Rd0000644000176200001440000000345013253773663015105 0ustar liggesusers\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/adjustOHLC.Rd0000644000176200001440000000617313762435560015126 0ustar liggesusers\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/chob-class.Rd0000644000176200001440000000466213253773663015211 0ustar liggesusers\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/getSymbols.av.Rd0000644000176200001440000001125413263460400015702 0ustar liggesusers\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/quantmod-package.Rd0000644000176200001440000000231313606423034016365 0ustar liggesusers\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{ \packageDESCRIPTION{quantmod} 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/modelData.Rd0000644000176200001440000000233113253773663015054 0ustar liggesusers\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/quantmod-class.Rd0000644000176200001440000000366413253773663016127 0ustar liggesusers\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/OHLC.Transformations.Rd0000644000176200001440000000744213253773663017107 0ustar liggesusers\name{OHLC.Transformations} \alias{OHLC.Transformations} \alias{getPrice} \alias{Ad} \alias{Cl} \alias{ClCl} \alias{Hi} \alias{HiCl} \alias{Lo} \alias{LoCl} \alias{LoHi} \alias{Op} \alias{OpCl} \alias{OpHi} \alias{OpLo} \alias{OpOp} \alias{Vo} \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{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) HiCl(x) LoCl(x) LoHi(x) OpHi(x) OpLo(x) OpOp(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/has.Rd0000644000176200001440000000412413253773663013737 0ustar liggesusers\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} \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) 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}{ disply 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 which=TRUE). See \code{\link{quantmod.OHLC}} for details of \pkg{quantmod} naming conventions. \code{is.OHLC} (and is.HLC, similarly) will only return TRUE is there are columns for Open, High, Low and Close. Additional columns will not affect the value. } \value{ A logical value indicating success or failure by default. If which=TRUE, a numeric value representing the column position will be returned. \code{is.OHLC} and \code{is.HLC} return a single value of TRUE or FALSE. } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{quantmod.OHLC}},\code{\link{OHLC.Transformations}} } \examples{ \dontrun{ getSymbols("YHOO") is.OHLC(YHOO) has.OHLC(YHOO) has.Ad(YHOO) } } \keyword{ utilities } quantmod/man/is.quantmod.Rd0000644000176200001440000000065513253773663015433 0ustar liggesusers\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/chartSeries.Rd0000644000176200001440000001437113253773663015445 0ustar liggesusers\name{chartSeries} \alias{chartSeries} \alias{barChart} \alias{candleChart} \alias{matchChart} \alias{lineChart} \alias{reChart} \alias{current.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("YHOO") chartSeries(YHOO) chartSeries(YHOO, subset='last 4 months') chartSeries(YHOO, subset='2007::2008-01') chartSeries(YHOO,theme=chartTheme('white')) chartSeries(YHOO,TA=NULL) #no volume chartSeries(YHOO,TA=c(addVo(),addBBands())) #add volume and Bollinger Bands from TTR addMACD() # add MACD indicator to current chart setTA() chartSeries(YHOO) #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/addCCI.Rd0000644000176200001440000000124613253773663014235 0ustar liggesusers\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/addMACD.Rd0000644000176200001440000000162013253773663014337 0ustar liggesusers\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/getSymbols.oanda.Rd0000644000176200001440000000451313606423034016361 0ustar liggesusers\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/getSymbols.SQLite.Rd0000644000176200001440000000434113762440160016441 0ustar liggesusers\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("QQQQ",src="SQLite") } } \keyword{ utilities } quantmod/man/modelSignal.Rd0000644000176200001440000000121513253773663015420 0ustar liggesusers\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.yahoo.Rd0000644000176200001440000000660713762435657016445 0ustar liggesusers\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/fittedModel.Rd0000644000176200001440000000476013253773663015432 0ustar liggesusers\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/addROC.Rd0000644000176200001440000000123313253773663014256 0ustar liggesusers\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/periodReturn.Rd0000644000176200001440000000700113253773663015643 0ustar liggesusers\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('QQQQ',src='yahoo') allReturns(QQQQ) # returns all periods periodReturn(QQQQ,period='yearly',subset='2003::') # returns years 2003 to present periodReturn(QQQQ,period='yearly',subset='2003') # returns year 2003 rm(QQQQ) } } \keyword{ utilities }% at least one, from doc/KEYWORDS quantmod/man/getSymbols.yahooj.Rd0000644000176200001440000000605113762435653016604 0ustar liggesusers\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/getOptionChain.Rd0000644000176200001440000000272613762435567016110 0ustar liggesusers\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", ...) } \arguments{ \item{Symbols}{ The name of the underlying symbol. } \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. Currently only \sQuote{yahoo} is provided. } \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. } \references{ \url{https://finance.yahoo.com} } \author{ Jeffrey A. Ryan, Joshua M. Ulrich } \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") } } \keyword{ utilities }% __ONLY ONE__ keyword per line quantmod/man/options.expiry.Rd0000644000176200001440000000225213253773663016176 0ustar liggesusers\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/man/Delt.Rd0000644000176200001440000000373713253773663014065 0ustar liggesusers\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/getSymbols.Rd0000644000176200001440000002055313263460400015277 0ustar liggesusers\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 QQQQ 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("YHOO", 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/getFinancials.Rd0000644000176200001440000000435013263460400015713 0ustar liggesusers\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/buildModel.Rd0000644000176200001440000000435413253773663015251 0ustar liggesusers\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('QQQQ',src='yahoo') q.model = specifyModel(Next(OpCl(QQQQ)) ~ Lag(OpHi(QQQQ),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/getQuote.Rd0000644000176200001440000000467713263460400014755 0ustar liggesusers\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("QQQQ;SPY;^VXN",what=yahooQF(c("Bid","Ask"))) standardQuote() yahooQF() } } \keyword{ IO } \keyword{ data } quantmod/man/chobTA-class.Rd0000644000176200001440000000207113253773663015426 0ustar liggesusers\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/chartTheme.Rd0000644000176200001440000000431613253773663015253 0ustar liggesusers\name{chartTheme} \alias{chartTheme} \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{fg.col}{foreground color} \item{bg.col}{background color} \item{grid.col}{grid color} \item{border}{border color} \item{minor.tick}{minor tickmark color} \item{major.tick}{major tickmark color} \item{up.col}{up bar/candle color} \item{dn.col}{down bar/candle color} \item{up.up.col}{up after up bar/candle color} \item{up.dn.col}{up after down bar/candle color} \item{dn.dn.col}{down after down bar/candle color} \item{dn.up.col}{down after up bar/candle color} \item{up.border}{up bar/candle border color} \item{dn.border}{down bar/candle border color} \item{up.up.border}{up after up bar/candle border color} \item{up.dn.border}{up after down bar/candle border color} \item{dn.dn.border}{down after down bar/candle border color} \item{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/addExpiry.Rd0000644000176200001440000000120113253773663015106 0ustar liggesusers\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/getFX.Rd0000644000176200001440000000314013606423034014160 0ustar liggesusers\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, ...) } %- maybe also 'usage' for other objects documented here. \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{ The results of the call will be the data will be assigned automatically to the environment specified (parent by default). Additionally 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") } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ utilities} quantmod/man/addADX.Rd0000644000176200001440000000125713253773663014255 0ustar liggesusers\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/setSymbolLookup.Rd0000644000176200001440000000672513606423034016332 0ustar liggesusers\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(QQQQ='yahoo',DIA='MySQL') getSymbolLookup('QQQQ') getSymbolLookup(c('QQQQ','DIA')) \dontrun{ ## Will download QQQQ from yahoo ## and load DIA from MySQL getSymbols(c('QQQQ','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/setTA.Rd0000644000176200001440000000323113253773663014202 0ustar liggesusers\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/getSplits.Rd0000644000176200001440000000366613762435573015154 0ustar liggesusers\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/peak.Rd0000644000176200001440000000205313253773663014103 0ustar liggesusers\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/DESCRIPTION0000644000176200001440000000222513764105424013617 0ustar liggesusersPackage: quantmod Type: Package Title: Quantitative Financial Modelling Framework Version: 0.4.18 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="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 Suggests: DBI,RMySQL,RSQLite,timeSeries,xml2,downloader,jsonlite(>= 1.1) Description: Specify, build, trade, and analyse quantitative financial trading strategies. LazyLoad: yes License: GPL-3 URL: http://www.quantmod.com https://github.com/joshuaulrich/quantmod BugReports: https://github.com/joshuaulrich/quantmod/issues NeedsCompilation: no Packaged: 2020-12-08 16:05:30 UTC; josh Author: Jeffrey A. Ryan [aut, cph], Joshua M. Ulrich [cre, aut], Wouter Thielen [ctb], Paul Teetor [ctb], Steve Bronder [ctb] Maintainer: Joshua M. Ulrich Repository: CRAN Date/Publication: 2020-12-09 08:30:12 UTC quantmod/build/0000755000176200001440000000000013763722112013205 5ustar liggesusersquantmod/build/partial.rdb0000644000176200001440000000745313763722112015343 0ustar liggesusers‹í]}sÓFw;±ó4P ´Ð­)€c“Àe%¼uÒI uBË´j{kim‹È’«•L†ûónîöß›¹/pÓÐÞ³ÒÊ^ÉrbÙ"ñLœåYKµ¿çeŸ}vWZ¿žL$£‰db,1:ÆŠ§áßH"1Æè™ÖçÑSM&2@OýfcݪÊBËÛ¸B‰ä¨p}¼¨üjá ãÎ&¿V|䤦l’2Ô7Ã>¹u%&8=ËËgßš€o•U°›&Ü¿?,cÏt9PêÕÖó…{¾4ÑeCQõ ØD€/c©5B-\«Ã½O° +¿ÿóßÿZúv*À˜’5L)¿Û¨xãåæêkÙò¤v>ZPú3‡‰¥ã ÀyZ°jõBþýxǰž¬Š%[ÕåέÒââíÒݯî.-<«jX/M”/*ºFw•@-¹(µ¸è= Òî%بKÓøâF‚\)ÉÕ»8úWÀS¼ã“e|cÀ—ü«Ûj}¾=2ÙGrëÙë­0Î ”=ÀˆÐÔÚѵ—3xšÓOx¹'%…Ö:.aMÅ´C½#œ Ú9lã°êÏ ”1'Ýj ‘Œ2Æ ÁèI^>yFã†k~á‡mVýGåGLF™òŒBôˆvIr[0:Ë˳‡`—$·£\$FÛ.¬ú3åGLv™8 €u•‚c’ÓS¼Ü“φ֚–CÞjÔÃú—·DŠ»èHÏnÚ—URÜ=:Û«S:VíÎ8oåGŸZ¹ñk´ª…-u‡ çªŽuYÅZ‡f¬iž¡ç&d»†¹°—L2zƒ—oÄØ¨µæ>^nNøR•Ãv¯ó÷(?ŽÊ}صåGŸZY>Ð}°® -+>WBeÃDŨ"Lrc2ºÌË˱9Ô´¤*›jÝR ½ƒYSGëVSÜ•<ÚŸ[]éÎ4·‡GùÑ£V¼aÛSi“¼­›?™„ÚšE—M%CÀ Yv†E?ïY†¡Ñû÷ïÃp—wn¿>}¶ù¤¸º±µúòÅ\öòbvþ}—¹bæÕæ³âúÊ“âËñf¸¡½ÈË£Šç¦Ö°löÓCÂýîoü‰°ž}TÓ"š‹ÑK‚<—z‘Ç9žïûõžØàø`d6\eÞGG‡i'Ñ©vÉÂ¥ÃS:h¬t¤Ê“dóÐt1 þ9ÎòÞ¡sM£žÆ&CßüP0&¶XV=tN 7P÷c£T×qôßÌ÷ĤÀ=躙¿_¼7ª8ŽÞ9µb[UäŠCÿdµ!yn0 ó Bu†>WX¯/ËsÙoI¹l’F6—]Égçs¨ŒkªÖXÎXÏæih„±aÛ¹^ÍÎÏçC5DƒVm @×}²¼ÒLU® ÒÀ]‰É\¤†Um9û¾›¯åm‡÷Q…ÌËF-;(âÞ ˆ›ýÁ°-bf[bnUU¢‘¦Õ²²Uô ¢ßÀ¶&b'Ä2Ì„~'}Ó";DÀþØ4t…Àö1„æ2Çn1ó”Ô‰®Ða§ô.*¢¹‡ËèV~)¢ð[‹²7ó_-°ï #‡¶¶Šî¹%8S#S(t Uw,½yµV7LkèÍÎt7’móÈf©‡¾€1¹iW*„Ó¹ú5zúx5W\ol~·–+Â?Õ"9ö¼á&1UBsokÚRN1vuÍÀÇäÞ@®£‹½‹ùÅa1(n=ó´µt;ôl /ÐfÈj¹‘CÎ’iY&¸pÎYŽÇ:Ö”¸ CÞôf¹9½iñÕz ‹T !äR£ÇÑÑ'×ð»ÆD£¡—³ÚPƒ óÞAñÍÌš*œ«è›µ…[©‰ã蜩Wŵ¡c]AU˪ß/vwwóÞ£!l>×9OáBEµªv‰*¼q¦Ý™ßÂð9’óééÇv¥H†s ÞÕ›]»pA¥Ô¦ãÉiw]tèÅ숯<¢•¹m<ÊÆq‰kÀ£ñxëÄ~H6±ìFMI±Þ°ªîÃ"ÍŒ/rÿœ#dtŽ—çúOïW-TÅ麦“Ýknr^Û3 ògB‘aFÅŠͰczÍ}$ë¤à¢u‚·‘QÎ#C1“c7*Ø/8@FãË™!Á/ÃðH®b“B˜Åò4Á' À;XÕpI‹Üëg9Àl¬`ç¡Ï!n7 ã¹"{ÊO€a ¨L'*ÜË"£ó¼<ß?\pë?a…Ñ.¤ZuP5øÃ.‹Ì ÃFX3 V"wý_rˆ_Æ ÷‹mðJ§¯× 8ã4,g<­a½‚íJd­ ÃPÑ{ûÍ£B>!A-¶üÕ¦$rÀ~ŒyTä(/´’£|®Ùÿ×ð6¡BØ$˜ªà¥t5cNEE,D÷DŽ—s}#¾Á<z&b©Îü {!»¬cº«¼ˆ‚± [Wz,4•þö°òGÐÀ$'(YÕ-b–¡¥‘—ƒ„©±#è§NãL† ˆe‚¼¾*¢4x”Išàyýµ›ÐZÓ’B,èÃöœæµ-ôS3ãh^™R:®©òsÍÙöw†ßt<=1”£åGƒd¿pØè/#P~ôé=§«íQQ¸Æ M~‡¶OßäU{4ž¾à®¸ÖØý2[Tð‹0£wyùnl rBÂÎÓ%\ŠU¶«Ö"o‰7.ö×Ђ£úLs-&"¬[ w?7Fgyy6Æ8¹MÐU+jáô÷eeÕŸhÏû²†rÃD÷þ¼‰ÏD/.É8f‡Ðøºqg:¶[z’פpôLý|;%Qg?vïö#Ó~Q›ŒîÒv“íDKR"ΆñÏéÀõŒDÞBe{Z¯É” 0MK;moÞö¶€÷ø¦B+Ü.)~ìë0ˆi—ÍÇ3!•ÕŠmíLPÃÞþ¤MŽd›eÈú†t ­÷»C†oYY™>jÙ¢ ·7}TPØáûâ¤TTvÜu„o½jJ¢v‰º+éû˜4))e½„'-QB°F ¿øŽJÅ-#цnÔ!qõKОRI:Ù…n ²]ÑO>iW¾¡[l)vÎHuh”,sÎý¼nBr_ãö«­ý ik¶hî“a\— ŒvÊ×åV·Þ€»ò‡xÞo¢ ƒîØMµ“ Cn nVÚ·yî`1¦¢ÕÛë (’ï ¾¯+@;wlwÀÍR¬$¤YƒYëW/:µê ‰Z¦ácéÐLŠq^´>0&³–l¡]Ü\ÒÃ5v¢-H`³b³­Èu²ÝuÚnÓVÙŒd’®Z¡Eì&7owÕº@ó†mÊûmþ#!bà$˜tÀ^¸NµÁV-RSßxÚ]V˺BĦœmCT5} ‡: V´jì&|Áªƒ—²¨fèZ#œ9Ä5œ­‚Ú6 3Ë9ôFmŸÖ›rô"0̆zúþ±'íkÚ"O{¼5‚¡©C ô  k¾)ûò‘° –Ú½·]Ü’¡B¼RùÎö'íAÄÙ†º/ƒ°#ÿ~ѺCÔfù—ðÅ™P…PöN2ý$ÝeÂs‚û¤Îc§ÃÓ¸»©´À‘ ÕvQyY÷¨ÉvMy3<z8J=Ð}cÓ­.c“ZfëÛÙ6mêì¥*æÉ!ÉZÞ?¢ŒI¾Ü! MRªowÑAu<Ø=/v°uk3l1ƒõª:ßaçOÛü1äUu•·wñK=l4.ä5ÞFãí£¸Ï]°-ór¹5ŠGYì\*(Œø“YãÁ‹ ÷ü«už#+¿ÿgóÍ¡a·?‚• Vpµ`S³@«Ø$…¢GÙ¯[±1c6(ÄèæÏZM¿}Ô?f2 Ý(öä@¥ Ëõ6wñ¹»öëFqîòb¨SˆOd=àå-§»žNèÐ ¯á-òZô\ï‚^áÑfOƒ<æíû=6&ÞÛskxÿþýž[‘q‰ËÅè}^¾›ŒN¶¸=CÅ„ìç­EË{—™¤ð?DÌ{\4F—yy¹W1Æ“âÊ 'ºÆ!á';Üó^Œd÷Î@‹o`7ÌJǵetEuGî‘Å'_×yy=‘!{¡€‚ÄãºÂlú°$ “ê<—„Ñ›¼|³ Êp o¹óAqXõaônË™êÜa‰–ýÈË?ö«‡®R»“ž~VuEuÒê84ô(º†T·þÎ:× áå_b‹mῇ.âù5•v}ˆ«ù!IN÷úðéá„§‡>‡ ¾Ž®w©³ôY.1£/K±ÄÃ$ŒÄÔxäþª{¹ä*î,±¸Ô¹ÆËk}Û{Ö³wk­1ÙŸD·y­ ¡³ÄG”^Vb”ÒaL‚é¶8ò~ 7]7IÆL“ÎXæëÿ%¼¿¶Y6õF N‡Ö‘øóÿ^1ç`yquantmod/tests/0000755000176200001440000000000013763722075013260 5ustar liggesusersquantmod/tests/test_getDividends.R0000644000176200001440000000064013763713636017056 0ustar liggesuserslibrary(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"]) stopifnot(isTRUE(all.equal(cf.div.adj, rep(0.3, 4)))) cf.div.raw <- as.numeric(getDividends("CF", split.adjust = FALSE)["2015"]) stopifnot(isTRUE(all.equal(cf.div.raw, c(1.5, 1.5, 0.3, 0.3)))) } quantmod/tests/test_Defaults.R0000644000176200001440000000645313760466720016220 0ustar liggesuserslibrary(quantmod) 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/tests.R0000644000176200001440000000452713763722075014555 0ustar liggesusersav.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/tests/test_getSplits.R0000644000176200001440000000046413763713636016427 0ustar liggesuserslibrary(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) stopifnot(isTRUE(all.equal(aapl.spl, expected))) } quantmod/tests/test_getSymbols.R0000644000176200001440000000703413763713636016601 0ustar liggesuserslibrary(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) stopifnot(exists("IBM", e)) rm(IBM, pos = e) x <- try({ getSymbols("IBM;WYSIWYG", env = e, src = "rda", dir = td, col.names = cn) }, silent = TRUE) stopifnot(exists("IBM", e)) rm(IBM, pos = e) if (nzchar(test.web.endpoints)) { x <- try({ getSymbols("IBM;WYSIWYG", env = e, src = "yahoo") }, silent = TRUE) stopifnot(exists("IBM", e)) rm(IBM, pos = e) if (nzchar(apikey)) { x <- try({ getSymbols("IBM;WYSIWYG", env = e, src = "av", api.key = apikey) }, silent = TRUE) stopifnot(exists("IBM", e)) rm(IBM, pos = e) } x <- try({ getSymbols("DGS10;WYSIWYG", env = e, src = "FRED") }, silent = TRUE) stopifnot(exists("DGS10", e)) rm(DGS10, pos = e) x <- try({ getSymbols("EUR/USD;WYS/WYG", env = e, src = "oanda") }, silent = TRUE) stopifnot(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) stopifnot(inherits(x, "try-error")) x <- try({ getSymbols("WYSIWYG", env = e, src = "FRED") }, silent = TRUE) stopifnot(inherits(x, "try-error")) if (nzchar(apikey)) { x <- try({ getSymbols("WYSIWYG", env = e, src = "av", api.key = apikey) }, silent = TRUE) stopifnot(inherits(x, "try-error")) } x <- try({ getSymbols("WYS/WYG", env = e, src = "oanda") }, silent = TRUE) stopifnot(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) stopifnot(exists("AAPL", e)) stopifnot(exists("DGS10", e)) } quantmod/R/0000755000176200001440000000000013763713636012322 5ustar liggesusersquantmod/R/adjustOHLC.R0000644000176200001440000000275513253773663014416 0ustar liggesusersadjustOHLC <- 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/Price.transformations.R0000644000176200001440000002261513253773663016745 0ustar liggesusers############################################################################### # 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/getFinancials.R0000644000176200001440000000402713263460400015176 0ustar liggesusers`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/getSymbols.skeleton.R0000644000176200001440000000457313253773663016431 0ustar liggesusers# 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/addTA.R0000644000176200001440000015767013760464726013442 0ustar liggesusers# # 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 col <- 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(class(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/R/getDividends.R0000644000176200001440000000273113760466720015055 0ustar liggesusers`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()) { if(missing(env)) env <- parent.frame(1) 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 <- .yahooURL(Symbol.name, from.posix, to.posix, "1d", "div", handle) conn <- curl::curl(yahoo.URL,handle=handle$ch) fr <- try(read.csv(conn, as.is=TRUE), silent = TRUE) if (inherits(fr, "try-error")) { fr <- retry.yahoo(Symbol.name, from.posix, to.posix, "1d", "div", conn) } fr <- xts(fr[,2],as.Date(fr[,1])) colnames(fr) <- paste(Symbol.name,'div',sep='.') # dividends from Yahoo are not split-adjusted if(src[1] == "yahoo" && split.adjust) { splits <- getSplits(Symbol.name, from="1900-01-01") if(is.xts(splits) && is.xts(fr) && nrow(splits) > 0 && nrow(fr) > 0) { fr <- fr * adjRatios(splits=merge(splits, index(fr)))[,1] } } if(is.xts(Symbol)) { if(auto.update) { xtsAttributes(Symbol) <- list(dividends=fr) assign(Symbol.name,Symbol,envir=env) } } else if(auto.assign) { assign(paste(Symbol.name,'div',sep='.'),fr,envir=env) } else fr } quantmod/R/tradeModel.R0000644000176200001440000000511713760464726014531 0ustar liggesusers"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(class(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(class(fitted.zoo) != "zoo") { 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/tradeLog.R0000644000176200001440000000566313253773663014220 0ustar liggesuserssetOldClass('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/addMFI.R0000644000176200001440000000303713253773663013534 0ustar liggesusers# 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/quantmod.R0000644000176200001440000000571213606423034014264 0ustar liggesusers"is.quantmod" <- function(x) { (class(x) == 'quantmod') } "is.quantmodResults" <- function(x) { (class(x) == 'quantmodResults') } `as.zoo.data.frame`<- function(x,row.date=TRUE,...) { # Registered S3 method overwritten by 'quantmod': # method from # as.zoo.data.frame zoo send.message <- getOption("quantmod.deprecate.as.zoo.data.frame", NULL) if(is.null(send.message)) { # Only message once if user hasn't set an option value send.message <- TRUE options(quantmod.deprecate.as.zoo.data.frame = FALSE) } if(isTRUE(send.message)) { message( "\nNOTE: quantmod::as.zoo.data.frame() is deprecated", "\n Use as.zoo(x, order.by = as.Date(rownames(x))) instead.", "\n This note is printed once. To see it for every call, set", "\n options(quantmod.deprecate.as.zoo.data.frame = TRUE)\n") } # ignore row.date if order.by is specified if(hasArg("order.by")) { zoo(x,...) } #really need to test order - ???how? else 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/zzz.R0000644000176200001440000001766213762213764013312 0ustar liggesusers#".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') } # Loading quantmod produces the following message: # # Registered S3 method overwritten by 'quantmod': # method from # as.zoo.data.frame zoo # # Message users that this method will be deprecated in a future release. options(quantmod.deprecate.as.zoo.data.frame = TRUE) 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/zoomChart.R0000644000176200001440000000263713253773663014423 0ustar liggesusers`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/addCMF.R0000644000176200001440000000464313253773663013532 0ustar liggesusers # 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/getQuote.R0000644000176200001440000003625213763713636014252 0ustar liggesusers# 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,] } `getQuote.yahoo` <- function(Symbols,what=standardQuote(),...) { importDefaults("getQuote.yahoo") length.of.symbols <- length(Symbols) if(length.of.symbols > 200) { # yahoo only works with 200 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,200), function(x) na.omit(Symbols[x:(x+199)])) 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)) } cat("...done\n") return(df) } SymbolsString <- paste(Symbols,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, regularMarketTime, 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?symbols=", SymbolsString, "&fields=",QFc) # The 'response' data.frame has fields in columns and symbols in rows response <- jsonlite::fromJSON(curl::curl(URL)) if (is.null(response$quoteResponse$error)) { sq <- response$quoteResponse$result } else { stop(response$quoteResponse$error) } # Always return symbol and time # 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) { Qposix <- .POSIXct(sq[,"regularMarketTime"], tz=tz[1L]) } else { warning("symbols have different timezones; converting to local time") Qposix <- .POSIXct(sq$regularMarketTime, tz = NULL) # force local timezone } # 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 qflist <- c(list(Symbol = sq$symbol, regularMarketTime = Qposix), 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')) } .yahooQuoteFields <- matrix(c( # quote / symbol "Symbol", "Symbol", "symbol", "Name", "Name", "shortName", "Name (Long)", "NameLong", "longName", "Quote Type", "Quote Type", "quoteType", "Quote Source Name", "Quote Source", "quoteSourceName", "Source Interval", "Source Interval", "sourceInterval", "Currency", "Currency", "currency", "Financial Currency", "Financial Currency", "financialCurrency", # 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", #"Trade Date", "Trade Date", "d2", #"Last Trade Size", "Last Size", "k3", #"Last Trade (Real-time) With Time", "Last Trade (RT) With Time", "k1", #"Last Trade (With Time)", "Last", "l", #"High Limit", "High Limit", "l2", #"Low Limit", "Low Limit", "l3", #"Order Book (Real-time)", "Order Book (RT)", "i5", #"Days Range", "Days Range", "m", #"Days Range (Real-time)", "Days Range (RT)", "m2", #"52-week Range", "52-week Range", "w", # 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", "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", # valuation stats "Market Capitalization", "Market Capitalization", "marketCap", #"Market Cap (Real-time)", "Market Cap (RT)", "j3", "P/E Ratio", "P/E Ratio", "trailingPE", #"P/E Ratio (Real-time)", "P/E Ratio (RT)", "r2", #"Price/EPS Estimate Current Year", "Price/EPS Estimate Current Year", "r6", "Price/EPS Estimate Next Year", "Price/EPS Estimate Next Year", "forwardPE", "Price/Book", "Price/Book", "priceToBook", "Book Value", "Book Value", "bookValue", #"Price/Sales", "Price/Sales", "p5", #"PEG Ratio", "PEG Ratio", "r5", #"EBITDA", "EBITDA", "j4", # share stats "Average Daily Volume", "Ave. Daily Volume", "averageDailyVolume3Month", #"Average Daily Volume", "Ave. Daily Volume", "averageDailyVolume10Day", "Shares Outstanding", "Shares Outstanding", "sharesOutstanding", #"Float Shares", "Float Shares", "f6", #"Short Ratio", "Short Ratio", "s7", # 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", # 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", #"Earnings/Share", "Earnings/Share", "e", #"EPS Estimate Current Year", "EPS Estimate Current Year", "e7", #"EPS Estimate Next Year", "EPS Estimate Next Year", "e8", #"EPS Estimate Next Quarter", "EPS Estimate Next Quarter", "e9", # yahoo / meta "Language", "Language", "language", "Message Board ID", "Message Board ID", "messageBoardId", "Price Hint", "Price Hint", "priceHint" # user portfolio #"Trade Links", "Trade Links", "t6", #"Ticker Trend", "Ticker Trend", "t7", #"1 yr Target Price", "1 yr Target Price", "t8", #"Holdings Value", "Holdings Value", "v1", #"Holdings Value (Real-time)", "Holdings Value (RT)", "v7", #"Days Value Change", "Days Value Change", "w1", #"Days Value Change (Real-time)", "Days Value Change (RT)", "w4", #"Price Paid", "Price Paid", "p1", #"Shares Owned", "Shares Owned", "s1", #"Commission", "Commission", "c3", #"Notes", "Notes", "n4", #"More Info", "More Info", "i", #"Annualized Gain", "Annualized Gain", "g3", #"Holdings Gain", "Holdings Gain", "g4", #"Holdings Gain Percent", "Holdings Gain %", "g1", #"Holdings Gain Percent (Real-time)", "Holdings Gain % (RT)", "g5", #"Holdings Gain (Real-time)", "Holdings Gain (RT)", "g6", #"Error Indication (returned for symbol changed / invalid)", "Error Indication (returned for symbol changed / invalid)", "e1", ), 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/modelSignal.R0000644000176200001440000000026213253773663014703 0ustar liggesusers"modelSignal" <- function(x) { if(!is.quantmodResults(x)) stop(paste(dQuote("x"),"must be of class", dQuote("quantmodResults"))) x@signal } quantmod/R/addEMV.R0000644000176200001440000000330013253773663013541 0ustar liggesusers# 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/add_Last.R0000644000176200001440000001101713760464726014160 0ustar liggesusersadd_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/reChart.R0000644000176200001440000001142013760464726014033 0ustar liggesusers`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/tools.R0000644000176200001440000000536413760466720013611 0ustar liggesusers`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) } } } retry.yahoo <- function(symbol, from, to, interval, type, conn, ..., curl.options = list()) { warning(symbol, " download failed; trying again.", call. = FALSE, immediate. = TRUE) # re-create handle handle <- .getHandle(curl.options, force.new = TRUE) # try again. must rebuild url with crumbs yahoo.URL <- .yahooURL(symbol, from, to, interval, type, handle) close(conn) conn <- curl::curl(yahoo.URL, handle = handle$ch) fr <- try(read.csv(conn, ..., as.is = TRUE), silent = TRUE) # error if second attempt also failed if (inherits(fr, "try-error")) { close(conn) stop(symbol, " download failed after two attempts. Error", " message:\n", attr(fr, "condition")$message, call. = FALSE) } # return data return(fr) } quantmod/R/getSplits.R0000644000176200001440000000263313760466720014423 0ustar liggesusers`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. if(missing(env)) env <- parent.frame(1) 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 <- .yahooURL(Symbol.name, from.posix, to.posix, "1d", "split", handle) conn <- curl::curl(yahoo.URL, handle=handle$ch) fr <- try(read.csv(conn, as.is=TRUE), silent=TRUE) if (inherits(fr, "try-error")) { fr <- retry.yahoo(Symbol.name, from.posix, to.posix, "1d", "split", conn) } if(NROW(fr)==0) { fr <- NA } else { fr[,2] <- gsub(":", "/", fr[,2], fixed = TRUE) fr$V3 <- 1 / vapply(parse(text=fr[,2]), eval, numeric(1)) fr <- xts(fr$V3, as.Date(fr[,1], "%Y-%m-%d")) colnames(fr) <- paste(Symbol.name,'spl',sep='.') } if(is.xts(Symbol)) { if(auto.update) { xtsAttributes(Symbol) <- list(splits=fr) assign(Symbol.name,Symbol,envir=env) } } else if(auto.assign) { assign(paste(Symbol.name,'spl',sep='.'),fr,envir=env) } else fr } quantmod/R/addZigZag.R0000644000176200001440000000322513253773663014313 0ustar liggesusers# 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/periodReturn.R0000644000176200001440000000616213760464726015134 0ustar liggesuserscumReturn <- 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',type=type,leading=FALSE), periodReturn(x,'weekly',type=type), periodReturn(x,'monthly',type=type,indexAt='endof'), periodReturn(x,'quarterly',type=type,indexAt='endof'), periodReturn(x,'yearly',type=type) ) colnames(all.ret) <- c('daily','weekly','monthly','quarterly','yearly') reclass(all.ret, x.orig) } quantmod/R/chartSeries.R0000644000176200001440000005043713760464726014732 0ustar liggesusers# 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/addVolatility.R0000644000176200001440000000304313253773663015256 0ustar liggesusers# 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/axTicksByTime2.R0000644000176200001440000000410713253773663015251 0ustar liggesusersaxTicksByTime2 <- 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/returnBy.R0000644000176200001440000000062413253773663014261 0ustar liggesusers"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/modelData.R0000644000176200001440000000137013253773663014340 0ustar liggesusers"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/attachSymbols.R0000644000176200001440000001316613263432341015253 0ustar liggesusersgetSymbolsDB <- 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/replot.R0000644000176200001440000002153113253773663013754 0ustar liggesusers# 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(x, ...) { print(str(unclass(x))) } # 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/SymbolLookup.R0000644000176200001440000000330013253773663015100 0ustar liggesuserssetSymbolLookup <- 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/addCMO.R0000644000176200001440000000431513253773663013537 0ustar liggesusers # 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/buildModel.methods.R0000644000176200001440000001535613253773663016201 0ustar liggesusers`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/getModelData.R0000644000176200001440000001632313253773663015004 0ustar liggesusersgetModelData <- 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("POSIXt" %in% class(x)) { 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("zoo" %in% class(target.data)) { 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(class(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/gainloss.R0000644000176200001440000000134013253773663014262 0ustar liggesusers"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/peak.R0000644000176200001440000000123513253773663013366 0ustar liggesusersfindPeaks <- 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/symbols.R0000644000176200001440000000071213253773663014135 0ustar liggesusers# # 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/addSMI.R0000644000176200001440000000535613253773663013557 0ustar liggesusers # 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/addKST.R0000644000176200001440000000330713253773663013562 0ustar liggesusers# 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/OHLC.transformations.R0000644000176200001440000002727513253773663016437 0ustar liggesusersseriesAccel <- 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 } `Op` <- function(x) { if(has.Op(x)) return(x[,grep('Open',colnames(x),ignore.case=TRUE)]) stop('subscript out of bounds: no 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('Open',colnames(x),ignore.case=TRUE) if(!identical(loc,integer(0))) { return(if(which) loc else TRUE) } else FALSE } `Hi` <- function(x) { if(has.Hi(x)) return(x[,grep('High',colnames(x),ignore.case=TRUE)]) stop('subscript out of bounds: no 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('High',colnames(x),ignore.case=TRUE) if(!identical(loc,integer(0))) { return(if(which) loc else TRUE) } else FALSE } `Lo` <- function(x) { if(has.Lo(x)) return(x[,grep('Low',colnames(x),ignore.case=TRUE)]) stop('subscript out of bounds: no 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('Low',colnames(x),ignore.case=TRUE) if(!identical(loc,integer(0))) { return(if(which) loc else TRUE) } else FALSE } `Cl` <- function(x) { if(has.Cl(x)) return(x[,grep('Close',colnames(x),ignore.case=TRUE)]) stop('subscript out of bounds: no 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('Close',colnames(x),ignore.case=TRUE) if(!identical(loc,integer(0))) { return(if(which) loc else TRUE) } else FALSE } `Vo` <- function(x) { #vo <- grep('Volume',colnames(x)) #if(!identical(vo,integer(0))) if(has.Vo(x)) return(x[,grep('Volume',colnames(x),ignore.case=TRUE)]) stop('subscript out of bounds: no 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('Volume',colnames(x),ignore.case=TRUE) if(!identical(loc,integer(0))) { return(if(which) loc else TRUE) } else FALSE } `Ad` <- function(x) { if(has.Ad(x)) return(x[,grep('Adjusted',colnames(x),ignore.case=TRUE)]) stop('subscript out of bounds: no 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('Adjusted',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 } `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/loadSymbols.R0000644000176200001440000000406613263432341014725 0ustar liggesusers`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/chob.R0000644000176200001440000000352313263460400013342 0ustar liggesusers.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/getSymbols.R0000644000176200001440000017206013760466720014577 0ustar liggesusers# 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), ...) { if(getOption("getSymbols.warning4.0",TRUE)) { # transition message for 0.4-0 to 0.5-0 message(sQuote('getSymbols'), ' currently uses auto.assign=TRUE by default, but will\n', 'use auto.assign=FALSE in 0.5-0. You will still be able to use\n', sQuote('loadSymbols'), ' to automatically load data. getOption("getSymbols.env")\n', 'and getOption("getSymbols.auto.assign") will still be checked for\n', 'alternate defaults.\n\n', 'This message is shown once per session and may be disabled by setting \n', 'options("getSymbols.warning4.0"=FALSE). See ?getSymbols for details.\n') options("getSymbols.warning4.0"=FALSE) } 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] } ))) # 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 ((class(from)=="Date" && class(to)=="Date") || # (class(from)=="character" && length(from)<=8 && # class(to)=="character" && 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 (class(from)=="character") { # fromStr <- from # } else { # fromStr <- strftime(from,format="%Y%m%d") # } # if (class(to)=="character") { # 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 if (!force.new) { h <- list() } # establish session new.session <- function() { for (i in 1:5) { h <- curl::new_handle() curl::handle_setopt(h, .list = curl.options) # random query to avoid cache ru <- paste(sample(c(letters, 0:9), 4), collapse = "") cu <- paste0("https://finance.yahoo.com?", ru) z <- curl::curl_fetch_memory(cu, handle = h) if (NROW(curl::handle_cookies(h)) > 0) break; Sys.sleep(0.1) } if (NROW(curl::handle_cookies(h)) == 0) stop("Could not establish session after 5 attempts.") return(h) } h$ch <- new.session() n <- if (unclass(Sys.time()) %% 1L >= 0.5) 1L else 2L query.srv <- paste0("https://query", n, ".finance.yahoo.com/", "v1/test/getcrumb") cres <- curl::curl_fetch_memory(query.srv, handle = h$ch) h$cb <- rawToChar(cres$content) assign("_handle_", h, .quantmodEnv) } return(h) } .yahooURL <- function(symbol, from, to, period, type, handle) { p <- match.arg(period, c("1d", "1wk", "1mo")) e <- match.arg(type, c("history", "div", "split")) n <- if (unclass(Sys.time()) %% 1L >= 0.5) 1L else 2L u <- paste0("https://query", n, ".finance.yahoo.com/v7/finance/download/", symbol, sprintf("?period1=%.0f&period2=%.0f", from, to), "&interval=", p, "&events=", e, "&crumb=", handle$cb) 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 intervals <- c(daily = "1d", weekly = "1wk", monthly = "1mo") default.periodicity <- match.arg(periodicity, names(intervals)) if(!hasArg("verbose")) verbose <- FALSE if(!hasArg("auto.assign")) auto.assign <- 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] 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 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 <- .yahooURL(Symbols.name, from.posix, to.posix, interval, "history", handle) conn <- curl::curl(yahoo.URL, handle = handle$ch) fr <- try(read.csv(conn, na.strings="null"), silent = TRUE) if (inherits(fr, "try-error")) { fr <- retry.yahoo(Symbols.name, from.posix, to.posix, interval, "history", curl.options = curl.options, na.strings = NULL) } if(verbose) cat("done.\n") fr <- xts(as.matrix(fr[,-1]), as.Date(fr[,1]), #as.POSIXct(fr[,1], tz=Sys.getenv("TZ")), src='yahoo',updated=Sys.time()) # warn about missing values if (any(is.na(fr))) { 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 cnames <- c("Open", "High", "Low", "Close", "Volume", "Adjusted") 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)) tclass(fr) <- index.class Symbols[[i]] <-toupper(gsub('\\^','',Symbols[[i]])) 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) } 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(!requireNamespace("xml2", quietly=TRUE)) stop("package:",dQuote("xml2"),"cannot be loaded.") yahoo.URL <- "https://info.finance.yahoo.co.jp/history/" 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.y <- as.numeric(strsplit(as.character(as.Date(from,origin='1970-01-01')),'-',)[[1]][1]) from.m <- as.numeric(strsplit(as.character(as.Date(from,origin='1970-01-01')),'-',)[[1]][2]) from.d <- as.numeric(strsplit(as.character(as.Date(from,origin='1970-01-01')),'-',)[[1]][3]) to.y <- as.numeric(strsplit(as.character(as.Date(to,origin='1970-01-01')),'-',)[[1]][1]) to.m <- as.numeric(strsplit(as.character(as.Date(to,origin='1970-01-01')),'-',)[[1]][2]) to.d <- as.numeric(strsplit(as.character(as.Date(to,origin='1970-01-01')),'-',)[[1]][3]) 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 <- paste(yahoo.URL, "?code=",Symbols.name, "&sm=",from.m, "&sd=",sprintf('%.2d',from.d), "&sy=",from.y, "&em=",to.m, "&ed=",sprintf('%.2d',to.d), "&ey=",to.y, "&tm=d", "&p=",page, sep='') fdoc <- xml2::read_html(URL) rows <- xml2::xml_find_all(fdoc, "//table[@class='boardFin yjSt marB6']//tr") if (length(rows) <= 1) 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') firstrow <- totalrows[[1]] cells <- xml2::xml_find_all(firstrow, "th") if (length(cells) == 5) cols <- cols[-(5:6)] # Process from the start, for easier stocksplit management totalrows <- rev(totalrows) mat <- matrix(0, ncol=length(cols) + 1, nrow=0, byrow=TRUE) for(row in totalrows) { cells <- xml2::xml_find_all(row, "td") # 2 cells means it is a stocksplit row # So extract stocksplit data and recalculate the matrix we have so far if (length(cells) == 2 && length(cols) == 6 & nrow(mat) > 1) { ss.data <- as.numeric(na.omit(as.numeric(unlist(strsplit(xml2::xml_text(cells[[2]]), "[^0-9]+"))))) factor <- ss.data[2] / ss.data[1] mat <- rbind(t(apply(mat[-nrow(mat),], 1, function(x) { x * c(1, rep(1/factor, 4), factor, 1) })), mat[nrow(mat),]) } if (length(cells) != length(cols) + 1) next # Parse the Japanese date format using UTF characters # \u5e74 = "year" # \u6708 = "month" # \u65e5 = "day" date <- as.Date(xml2::xml_text(cells[[1]]), format="%Y\u5e74%m\u6708%d\u65e5") entry <- c(date) for(n in 2:length(cells)) { entry <- cbind(entry, as.numeric(gsub(",", "", xml2::xml_text(cells[[n]])))) } mat <- rbind(mat, entry) } fr <- xts(mat[, -1], as.Date(mat[, 1]), 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) } 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(!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) } 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(!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) } 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 FRED.URL <- "https://fred.stlouisfed.org/series" returnSym <- Symbols noDataSym <- NULL for(i in seq_along(Symbols)) { if(verbose) cat("downloading ",Symbols[[i]],".....\n\n") test <- try({ URL <- paste(FRED.URL, "/", Symbols[[i]], "/downloaddata/", Symbols[[i]], ".csv", sep="") fr <- read.csv(curl::curl(URL),na.string=".") 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]])) 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) } 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 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) } 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 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) } 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 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) } 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(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 { 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) } 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(), ...) { if(!requireNamespace("jsonlite", quietly=TRUE)) stop("package:",dQuote("jsonlite"),"cannot be loaded.") 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 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) { 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) { warning("Oanda only provides historical data for the past 180 days.", " Symbol: ", Symbols[[i]]) } oanda.URL <- paste0("https://www.oanda.com/fx-for-business/", "historical-rates/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) } 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 if (!requireNamespace("jsonlite", quietly=TRUE)) { stop("getSymbols.av: Package", dQuote("jsonlite"), "is required but", " cannot be loaded.", call.=FALSE) } # # 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) } 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(), data.type="json", ...) { 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 if (!requireNamespace("jsonlite", quietly=TRUE)) { stop("getSymbols.tiingo: Package", dQuote("jsonlite"), "is required but", " cannot be loaded.", call.=FALSE) } 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") tiingo.names <- c("open", "high", "low", "close", "volume", "adjOpen", "adjHigh", "adjLow", "adjClose", "adjVolume", "divCash", "splitFactor") qm.names <- paste(sym, c("Open", "High", "Low", "Close", "Volume", "Open", "High", "Low", "Close", "Volume", "DivCash", "SplitFactor"), sep=".") if (isTRUE(adjust)) { return.columns <- tiingo.names[6:10] } else { return.columns <- tiingo.names[1:5] } URL <- paste0("https://api.tiingo.com/tiingo/", periodicity, "/", sym.name, "/prices", "?startDate=", from.strftime, "&endDate=", to.strftime, "&format=", data.type, "&columns=", paste0(return.columns, collapse=",")) # If rate limit is hit, the csv API returns HTTP 200 (OK), while json API # returns HTTP 429. The latter caused download.file() to error, but the # contents of 'tmp' still contain the error message. h <- curl::new_handle() curl::handle_setheaders(h, Authorization = paste("Token", api.key)) response <- curl::curl_fetch_memory(URL, h) response.data <- rawToChar(response$content) if (data.type == "json") { stock.data <- jsonlite::fromJSON(response.data) if (verbose) cat("done.\n") } else { stock.data <- read.csv(text=response.data, as.is=TRUE) } # check for error if (!all(return.columns %in% names(stock.data))) { if (data.type == "json") { msg <- stock.data$detail } else { msg <- readLines(response.data, warn=FALSE) } msg <- sub("Error: ", "", msg) stop(msg, call. = FALSE) } tm.stamps <- as.POSIXct(stock.data[, "date"], ...) stock.data[, "date"] <- NULL # adjusted column names adjcols <- grepl("^adj", colnames(stock.data)) # order Tiingo column names before converting to quantmod names stock.data <- OHLCV(stock.data) if (any(adjcols)) { # put adjusted columns last stock.data <- stock.data[, c(which(!adjcols), which(adjcols))] } # now convert to quantmod column names colnames(stock.data) <- qm.names[match(colnames(stock.data), tiingo.names)] # 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) } 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/buildModel.R0000644000176200001440000000401013253773663014520 0ustar liggesusers`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/addAroon.R0000644000176200001440000000520713253773663014200 0ustar liggesusers# 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/chart_Series.R0000644000176200001440000013600313760464726015063 0ustar liggesusersfindOHLC <- 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') } # }}} # range.bars {{{ range.bars <- 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=deparse(substitute(x)), 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) 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 range.bars 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(range.bars(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) && nchar(TA) > 0) { TA <- parse(text=TA, srcfile=NULL) for(ta in seq_along(TA)) { # evaluate TA in environment from which chart_Series was called cs <- eval(TA[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, legend="auto", theme=NULL,...) { lenv <- new.env() lenv$name <- deparse(substitute(x)) lenv$plot_series <- function(x, series, type, ...) { # 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] range.bars(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,legend=legend,...)), list(x=x,type=type,order=order,on=on,legend=legend,...)) 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, legend="auto", yaxis=list(NULL,NULL), col=1, taType=NULL, ...) { lenv <- new.env() lenv$name <- deparse(substitute(x)) lenv$plot_ta <- function(x, ta, on, taType, col=col,...) { 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,legend=legend, taType=taType,col=col,...)), list(x=x,order=order,on=on,legend=legend, 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_VMA {{{ add_VMA <- function(w, ratio=1, on=1, col='green',...) { lenv <- new.env() lenv$add_wma <- function(x, w, ratio, col, ...) { xdata <- x$Env$xdata xsubset <- x$Env$xsubset vma <- VMA(Cl(xdata), w=w, ratio=ratio)[xsubset] lines(1:NROW(xdata[xsubset]), vma, col=col, ...) } mapply(function(name,value) { assign(name,value,envir=lenv) }, names(list(w=w,ratio=ratio,col=col,...)), list(w=w,ratio=ratio,col=col,...)) exp <- parse(text=gsub("list","add_wma",as.expression(substitute(list(x=current.chob(),w=w,ratio=ratio,col=col,...)))), srcfile=NULL) plot_object <- current.chob() lenv$xdata <- VMA(Cl(plot_object$Env$xdata),w=w,ratio=ratio) 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_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/dropTA.R0000644000176200001440000000607113760464726013642 0ustar liggesusers`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/addCLV.R0000644000176200001440000000315013253773663013541 0ustar liggesusers# 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/addTDI.R0000644000176200001440000000305313253773663013537 0ustar liggesusers# 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/addWPR.R0000644000176200001440000000421013253773663013563 0ustar liggesusers # 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/TA.R0000644000176200001440000002515213253773663012756 0ustar liggesusers# 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$length)[which(runs$values)] - runs$length[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.inter=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.inter=.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.inter=.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.inter=.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.inter=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.inter=.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.inter=.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.inter=.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/getOptionChain.R0000644000176200001440000001073113760737357015365 0ustar liggesusers`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, ...) { if(!requireNamespace("jsonlite", quietly=TRUE)) stop("package:",dQuote("jsonlite"),"cannot be loaded.") 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 d <- with(x, data.frame(Strike=strike, Last=lastprice, Chg=change, Bid= if("bid" %in% names(x)) {bid} else {NA}, Ask= if("ask" %in% names(x)) {ask} else {NA}, Vol= if("volume" %in% names(x)) {volume} else {NA}, OI= if("openinterest" %in% names(x)) {openinterest} else {NA}, LastTradeTime= if("lasttradedate" %in% names(x)) {lasttradedate} else {NA}, IV= if("impliedvolatility" %in% names(x)) {impliedvolatility} else {NA}, ITM= if("inthemoney" %in% names(x)) {inthemoney} else {NA}, row.names=contractsymbol, stringsAsFactors=FALSE)) # convert trade time to exchange timezone d$LastTradeTime <- .POSIXct(d$LastTradeTime, tz=tz) d } # 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]) # Add expiry date to URL if(!checkExp) urlExp <- paste0(urlExp, "?&date=", Exp) # Fetch data (jsonlite::fromJSON will handle connection) tbl <- try(jsonlite::fromJSON(urlExp), 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) # 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)) else { out <- lapply(expiry.subset, getOptionChain.yahoo, Symbols=Symbols, .expiry.known=TRUE) # 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/modelReturn.R0000644000176200001440000000642413760464726014753 0ustar liggesusers"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/newTA.R0000644000176200001440000001132213253773663013462 0ustar liggesusers`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/chartSeries.chob.R0000644000176200001440000002457713760464726015652 0ustar liggesusers# 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='') #'1,c(3,rep(1,',x-2,'),1.60),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/saveChart.R0000644000176200001440000000131013253773663014360 0ustar liggesusers`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/Defaults.R0000644000176200001440000002063113760510443014202 0ustar liggesusers"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/addOBV.R0000644000176200001440000000310013253773663013536 0ustar liggesusers# 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/addChaikin.R0000644000176200001440000000603613253773663014471 0ustar liggesusers# 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/months.R0000644000176200001440000000221213606423034013734 0ustar liggesusers`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/saveModels.R0000644000176200001440000000264513253773663014556 0ustar liggesusers"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/addVo.R0000644000176200001440000001145113760464726013504 0ustar liggesusers # 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(class(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/updateModel.R0000644000176200001440000000025413253773663014711 0ustar liggesusers"updateModel" <- function(fitted.model,quantmod) { quantmod@model.inputs <- fitted.model@model.inputs; quantmod@fitted.model <- fitted.model; return(quantmod); } quantmod/R/specifyModel.R0000644000176200001440000000640213253773663015072 0ustar liggesusers`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); } # used potentially for chartSeries parsing - where a model.frame is unecessary `unique.formula.names` <- function(x) { tm <- attr(terms(x),'variables') name.list <- lapply(tm, function(y) paste(make.names(y),collapse=''))[-1] unlist(lapply(name.list, function(x) gsub('\\.+','.',x))) } `make.short.names` <- function(x) { gsub('\\.+','.',make.names(colnames(model.frame(x)))) } quantmod/R/oanda.R0000644000176200001440000001201513253773663013526 0ustar liggesusers`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/NEWS.md0000644000176200001440000004071013762213641013207 0ustar liggesusers### 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/MD50000644000176200001440000001576013764105424012431 0ustar liggesusers9fe953ad02fb4be2290b81f4b5a27b3a *DESCRIPTION ebfb4ac4b0f3308d8d5260e9b442fab0 *NAMESPACE 3fd2f24d9c80da9b698d0fa8b6f470f0 *NEWS.md 02d0bc2c534d9628859ba7bf5a4a1357 *R/Defaults.R fea30b0226f717064ccc77364ffa8c99 *R/OHLC.transformations.R 3eb6c31d57d927394ac1732823b7e519 *R/Price.transformations.R 09a54ce40bdb58e7a9f441568ea9b22e *R/SymbolLookup.R 6206bb77e4fcd8747498b634c9ae220b *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 799b14b92106d05bce34d4992051e703 *R/addTA.R 1924f59377e51122577e642720617c8d *R/addTDI.R 9a43838aa9bb08b7c4829bbce4ada81f *R/addVo.R dd6c35740031d9202898eea236dbd6e1 *R/addVolatility.R ba032b32342f94c409775e032a6c8908 *R/addWPR.R e82fc436823a3ea3bb258832af7796d7 *R/addZigZag.R 74a2d4c04fda69ec3a1a5565685b3507 *R/add_Last.R 6648ca26eb626227900229418a0314fa *R/adjustOHLC.R dd80570b5f18aa4aeab9a3ca6c832e97 *R/attachSymbols.R 4d838787166eed631b194708bd7c2030 *R/axTicksByTime2.R 76afeb22c2c2c41bfdbc99f711329697 *R/buildModel.R 6767384c2917d19a199aa6b287581c7b *R/buildModel.methods.R fc284e92a5bd1685aeb362bd42022e34 *R/chartSeries.R 62597d41261ae3390f0d0ffe6c120738 *R/chartSeries.chob.R 161bbb744479ea0ceed2d16e5a1f173d *R/chart_Series.R 22cdae299dafdc7504d77863a19f7996 *R/chob.R 0ff2ddb2c87969047fab8880c5321d58 *R/dropTA.R cbb6427fefaa0a2579843886ac83d534 *R/gainloss.R 36d92fd0c6c2b929764b8d85eb1dc9db *R/getDividends.R 9da14edfa7993e67759d3c83a24282de *R/getFinancials.R b7d8972d888dbcbb8f7ddd463b286899 *R/getModelData.R 38ebd308ead453f7b55de24b3b6cea56 *R/getOptionChain.R cd3b924a816bbc4c9c320a7a8f700d9a *R/getQuote.R 4abc89c72b46637f6c0b8f6902374d0b *R/getSplits.R a4ff00ea1a6208eeb286ac6fb9c2e9c4 *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 845046d5fe89c3c5612847b90ed30592 *R/periodReturn.R 50b9c0d9e20885cf3e85a8d34a85bab7 *R/quantmod.R 0a09bad2f3dcb6f86445cce8bb54c9e3 *R/reChart.R f77a10724737bd71b34169fafad789c7 *R/replot.R d22629cb2177d29835945d9a7c928fb3 *R/returnBy.R 365f610384311c30deb04c88043dac5a *R/saveChart.R 375a94816b114be4f994f37d1f37dc2f *R/saveModels.R 5867f8a8e18a37cf13055ea99d139bde *R/specifyModel.R bde9f4fb4e0c592b3a4ff1c2a5a243a9 *R/symbols.R 3d81ace19edce9f9f856e291ac903f48 *R/tools.R d278a4eb9201362be8b7475b73cf710b *R/tradeLog.R 44c34d22a499866c49c9d3aa140ecac4 *R/tradeModel.R 0c99badd6fea917d849505328953cc7d *R/updateModel.R efea22ce21431595d7d7f76bd8dfa5ae *R/zoomChart.R 6bd4a0bda6fe3a18a7764308607376d5 *R/zzz.R 22b188123443a3ed6d163ae5527778ef *build/partial.rdb 512fd036a11aafe3d7e82c8b045baf63 *demo/00Index f0f55a8e00e795c94275d57d4cd09aa1 *demo/chartSeries.R 45f126715a150a9cd1198721f2afd1d9 *man/Defaults.Rd e234ab5d06debe9c1ce04fd836f9df92 *man/Delt.Rd e4d807e1a7429aadabe5e101f9938a3f *man/Lag.Rd c9f0ebbedb0634e5a53cb0f9a8b4803c *man/Next.Rd de8e9dc3d96feafdfc9c38750d218cfb *man/OHLC.Transformations.Rd 913ad3d605b9eb5271b329ce4aa3758e *man/TA.Rd a1d9d4bb93ba68b358aba254fdddc943 *man/addADX.Rd 434e56ba51aaf14912695d66fd900c09 *man/addBBands.Rd fd6f5f5021ddb75a300739af985c1a6b *man/addCCI.Rd d32851b5994699fd65cfa6c20a54811e *man/addExpiry.Rd 14cf31dd5aa59920174fe0a5788dcf75 *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 521909d7cc06f40ffe09f5dfa47adcb4 *man/attachSymbols.Rd 208cfabf1b73107d19452c9b39fb39ab *man/buildData.Rd 0b95c00314f7ca1fd72db99a96036318 *man/buildModel.Rd 0ed4c58a7444217434aba47a8f2c370a *man/chartSeries.Rd bcc41e33fb7a920d930fa04fd5fa3ba4 *man/chartTheme.Rd 6c5db640af9682cf1fb22d809387d9ad *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 df9a9535c46def7a8067a3267a4992a3 *man/getFX.Rd f3be40bbda8cc7172c9c05c951f45b5f *man/getFinancials.Rd 87dc4c41dbe292190765c9fc16ba8ff8 *man/getMetals.Rd dffc24b805d53c3e11f0463d6f03716e *man/getModelData.Rd b72e5eaf02872e8da8366b1920d93201 *man/getOptionChain.Rd 8038a985601067835219030fe242e4dc *man/getQuote.Rd 8b78a05483d174fe73bd61cca5408b83 *man/getSplits.Rd 61a9cf999515950bb03cff6fe60fc99f *man/getSymbols.FRED.Rd 4414a58435730a9f65d3ccdcc8e7f951 *man/getSymbols.MySQL.Rd 9441b369999c783ae3e8356876232c99 *man/getSymbols.Rd a7117087413e23ae6b9d4c168969ee8a *man/getSymbols.SQLite.Rd 9057b50d06b9aabc8b1420357a6e3229 *man/getSymbols.av.Rd 1ee6d77ede0a33ef77d16b666e604afb *man/getSymbols.csv.Rd c10790c811d0c5fc2f7766d92f670142 *man/getSymbols.oanda.Rd dbfd3a6b8beda5133ba2ad6edaa1100c *man/getSymbols.rda.Rd 3f3179f80979306c4adac9eff33d6ef8 *man/getSymbols.tiingo.Rd d22737b7a4488697912bbf5280ddb7fa *man/getSymbols.yahoo.Rd 800143de2230ef2dbeee81d6e25a2448 *man/getSymbols.yahooj.Rd 933e9464ab25462138de27d949ebb0e1 *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 bc6581844a8666a1a3e21786dda9e1b8 *man/periodReturn.Rd 1bc893d43208cf1329903928d6df751f *man/quantmod-class.Rd 303df1c3a3d85830b5d4780fae203824 *man/quantmod-defunct.Rd 4520d2a4a632138d42295bf01baed1eb *man/quantmod-package.Rd f93d01b8ea2c1ff138f675e047a382ef *man/quantmod.OHLC.Rd b8c1ada5347961c4591f0be419ab4870 *man/saveChart.Rd 682e6f66ae52c53a08dafd1ea7b931e9 *man/setSymbolLookup.Rd 0228bad7cdd6f00eafc817d6dc8c2244 *man/setTA.Rd ddc4f0fe52165f427bff3a65c7b279c5 *man/specifyModel.Rd 226bb886283249a1840aa3f5823bae6f *man/tradeModel.Rd ba287ea419bb17e7fe24fb33de89ef92 *man/zoomChart.Rd 928cf208eab2c0285dcf9267dce18ba7 *tests/test_Defaults.R 6b37a2972f6c4a34a54d099f12248b59 *tests/test_getDividends.R b3a6c8270077225dfeeaca76ba33f2f8 *tests/test_getSplits.R 9e1fed59d5e95969f14d0604664f4f4c *tests/test_getSymbols.R 88e57b900ffedf3ba9c644e633dc579a *tests/tests.R