[Quantmod-commits] r593 - in pkg: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Dec 27 18:22:39 CET 2012
Author: jryan
Date: 2012-12-27 18:22:39 +0100 (Thu, 27 Dec 2012)
New Revision: 593
Modified:
pkg/DESCRIPTION
pkg/R/TA.R
pkg/R/add_Last.R
pkg/R/chart_Series.R
pkg/R/getSymbols.R
Log:
TA.R updates to fix CRAN check warnings. chartSetUp is now deprecated, and users are directed to use layout() and chart_Series
o add_Last updates, though this is still not widely used anyway (check)
o MySQL binding issue resolved even when not checking against suggests
o increased version to 0.3.23
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2012-12-27 14:59:02 UTC (rev 592)
+++ pkg/DESCRIPTION 2012-12-27 17:22:39 UTC (rev 593)
@@ -1,8 +1,8 @@
Package: quantmod
Type: Package
Title: Quantitative Financial Modelling Framework
-Version: 0.3-22
-Date: 2012-10-23
+Version: 0.3-23
+Date: 2012-12-27
Author: Jeffrey A. Ryan
Depends: Defaults, xts(>= 0.9-0), zoo, TTR(>= 0.2), methods
Suggests: DBI,RMySQL,RSQLite,timeSeries,its
Modified: pkg/R/TA.R
===================================================================
--- pkg/R/TA.R 2012-12-27 14:59:02 UTC (rev 592)
+++ pkg/R/TA.R 2012-12-27 17:22:39 UTC (rev 593)
@@ -125,16 +125,21 @@
1:NCOL(tav)
} else x at params$order
- if(is.null(x at params$legend)) legend <- function(...) {}
+ if(is.null(x at params$legend))
+ #legend <- function(...) {}
+ body(legend) <- {}
if(is.character(x at params$legend) && x at params$legend != "auto") {
legend("topleft", legend=x at params$legend, bty='n', y.inter=0.95)
- legend <- function(...) { }
+ #legend <- function(...) { }
+ body(legend) <- {}
}
if(!x at new) {
- legend <- function(legend,text.col,...) { list(legend=legend,text.col=text.col) }
+ #legend <- function(legend,text.col,...) { list(legend=legend,text.col=text.col) }
formals(legend) <- formals(graphics::legend)
+ text.col <- NULL # make check happy, this function is going away anyway, so..
+ body(legend) <- { list(legend=legend, text.col=text.col) }
}
legend.text <- list()
@@ -186,88 +191,89 @@
# chartSetUp {{{
`chartSetUp` <-
function(x) {
- spacing <- x at params$spacing
- width <- x at params$width
-
- x.range <- x at params$xrange
- x.range <- seq(x.range[1],x.range[2]*spacing)
-
- tav <- x at TA.values
-
- if(x at new) {
- y.range <- if(is.null(x at params$yrange) || length(x at 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 at params$yrange[1],x at 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 at params$colors$area)
- grid(NA,NULL,col=x at params$colors$grid.col)
- }
-
- pars <- x at 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 at params$pars#[[1]]
-# pars <- lapply(pars, function(x) rep(x, length.out=NCOL(tav)))
-
- col.order <- if(is.null(x at params$order)) {
- 1:NCOL(tav)
- } else x at params$order
-
- if(is.null(x at params$legend)) legend <- function(...) {}
- if(is.character(x at params$legend) && x at params$legend != "auto") {
- legend("topleft", legend=x at params$legend, bty='n', y.inter=0.95)
- legend <- function(...) { }
- }
-
- if(!x at new) {
- legend <- function(legend,text.col) { list(legend=legend,text.col=text.col) }
- formals(legend) <- formals(graphics::legend)
- }
-
- legend.text <- list()
-
- # possibly able to handle newTA functionality
- if(is.null(x at params$legend.name)) x at params$legend.name <- deparse(x at call[-1][[1]])
-
- if(NCOL(tav) == 1) {
- tmp.pars <- lapply(pars,function(x) x[[1]][[1]])
-# if(x at 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 at params$legend.name,":"),sprintf("%.3f",last(na.omit(tav)))),
- text.col=c(x at 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 at params$legend.name,":")),
- text.col=c(x at 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 at params$colors$fg.col)
- invisible(legend.text)
+ .Deprecated("layout",msg="For multiple charts on one device, use chart_Series and the R layout() function")
+# spacing <- x at params$spacing
+# width <- x at params$width
+#
+# x.range <- x at params$xrange
+# x.range <- seq(x.range[1],x.range[2]*spacing)
+#
+# tav <- x at TA.values
+#
+# if(x at new) {
+# y.range <- if(is.null(x at params$yrange) || length(x at 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 at params$yrange[1],x at 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 at params$colors$area)
+# grid(NA,NULL,col=x at params$colors$grid.col)
+# }
+#
+# pars <- x at 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 at params$pars#[[1]]
+## pars <- lapply(pars, function(x) rep(x, length.out=NCOL(tav)))
+#
+# col.order <- if(is.null(x at params$order)) {
+# 1:NCOL(tav)
+# } else x at params$order
+#
+# if(is.null(x at params$legend)) legend <- function(...) {}
+# if(is.character(x at params$legend) && x at params$legend != "auto") {
+# legend("topleft", legend=x at params$legend, bty='n', y.inter=0.95)
+# legend <- function(...) { }
+# }
+#
+# if(!x at new) {
+# legend <- function(legend,text.col) { list(legend=legend,text.col=text.col) }
+# formals(legend) <- formals(graphics::legend)
+# }
+#
+# legend.text <- list()
+#
+# # possibly able to handle newTA functionality
+# if(is.null(x at params$legend.name)) x at params$legend.name <- deparse(x at call[-1][[1]])
+#
+# if(NCOL(tav) == 1) {
+# tmp.pars <- lapply(pars,function(x) x[[1]][[1]])
+## if(x at 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 at params$legend.name,":"),sprintf("%.3f",last(na.omit(tav)))),
+# text.col=c(x at 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 at params$legend.name,":")),
+# text.col=c(x at 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 at params$colors$fg.col)
+# invisible(legend.text)
} # }}}
# setTA {{{
Modified: pkg/R/add_Last.R
===================================================================
--- pkg/R/add_Last.R 2012-12-27 14:59:02 UTC (rev 592)
+++ pkg/R/add_Last.R 2012-12-27 17:22:39 UTC (rev 593)
@@ -83,7 +83,7 @@
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) {
+ lenv$plot_title <- function(x,main,sub,xlab,ylab,line,side,font,pos) {
xdata <- x$Env$xdata
if(is.OHLC(xdata))
xdata <- OHLC(xdata)
@@ -110,7 +110,7 @@
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_axis", as.expression(substitute(list(x = current.chob(),
+ 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 <- quantmod:::current.chob()
lenv$xdata <- plot_object$Env$xdata
Modified: pkg/R/chart_Series.R
===================================================================
--- pkg/R/chart_Series.R 2012-12-27 14:59:02 UTC (rev 592)
+++ pkg/R/chart_Series.R 2012-12-27 17:22:39 UTC (rev 593)
@@ -875,7 +875,8 @@
plot_object
} # }}}
-skeleton_TA <- function(on) {
+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
Modified: pkg/R/getSymbols.R
===================================================================
--- pkg/R/getSymbols.R 2012-12-27 14:59:02 UTC (rev 592)
+++ pkg/R/getSymbols.R 2012-12-27 17:22:39 UTC (rev 593)
@@ -443,7 +443,7 @@
sQuote('password'),sQuote('dbname'),
") is not set"))
}
- con <- dbConnect(MySQL(),user=user,password=password,dbname=dbname,host=host,port=port)
+ con <- dbConnect("MySQL",user=user,password=password,dbname=dbname,host=host,port=port)
db.Symbols <- dbListTables(con)
if(length(Symbols) != sum(Symbols %in% db.Symbols)) {
missing.db.symbol <- Symbols[!Symbols %in% db.Symbols]
More information about the Quantmod-commits
mailing list