1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
`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)
}
}
|
