SCM

SCM Repository

[quantmod] View of /pkg/R/TA.R
ViewVC logotype

View of /pkg/R/TA.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 594 - (download) (annotate)
Mon Dec 31 05:55:29 2012 UTC (18 months, 1 week ago) by jryan
File size: 10858 byte(s)
o TA.R returned to previous state for legend() definitions within chartTA and chartSetUp
o getSymbols et al now default to env=parent.env(), which is in-line with the behavior
  of load() in base.  This may cause some edge case differences in user-land, but is
  'the right thing to do'  Possible extension to this will involve a new environment
  which is currently being attached via .onAttach called .quantmodEnv and accessible via
  quantmodenv().  The latter may be used now, but isn't (yet) the default. This is pending
  further feedback.
o DESCRIPTION updates
o package docs updates
# 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))

R-Forge@R-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge