# bug fixes
replaceInNamespace <- (,value) {
# if(exists("asNamespace")) {
# environment(value) = environment(get(name))
# assignInNamespace(name,value,environment(value))
# #assignInNamespace(name,value,env=which.environment(name))
# } else {
# assign(name,value,env=.GlobalEnv)
# }
}
my.tree <- (,,) {
tr = tree(,,)
tr$model = (,)
tr
}
# from library/tree/R/tree
my.print.tree <-
(x, = 0, spaces = 2, digits = ("digits")-3, )
{
(!(x, "tree")) ("Not legitimate tree")
is.prob <- !(ylevels <- (x, "ylevels"))
# minka: omit deviance
(is.prob) ("node), split, n, yval, (yprob)\n")
("node), split, n, yval\n")
(" * denotes terminal node\n\n")
<- x$
node <- (())
<- tree.depth(node)
indent <- ((" ", spaces * 32), collapse = "")
#32 is the maximal depth
((node) > 1) {
indent <- (indent, 1, spaces * ())
indent <- (("", indent[depth]), (node), ")", sep = "")
}
indent <- ((node), ")", sep = "")
(is.prob) {
yval <- (($yval), " (", sep = "")
yprob <- ($yprob, digits = digits)
(i (ylevels)) yval <- (yval, yprob, i])
yval <- (yval, ")")
}
yval <- (($yval, digits = digits))
term <- (" ", ())
term[frame$ == "<leaf>"] <- "*"
z <- labels.tree(x, = )
# minka: omit deviance
z <- (indent, z, (($n,2)),
yval, term)
(z, sep = "\n")
(x)
}
# partition.tree must require cont predictors because split sets on a
# factor can vary
# minka: added digits as argument
my.partition.tree <- (tree, label = "yval", add = , ordvars,
digits=2, = T, main=, )
{
ptXlines <- (x, v, xrange, xcoord = , ycoord = , tvar, i = 1)
{
(v[i] == "<leaf>") {
y1 <- (xrange[1] + xrange[3])/2
y2 <- (xrange[2] + xrange[4])/2
(xcoord, ycoord = (ycoord, y1, y2), i = i)
}
(v[i] == tvar[1]) {
xcoord <- (xcoord, x[i], xrange[2], x[i], xrange[4])
# minka: indent the partitions
#xrange[c(2,4)] = xrange[c(2,4)] + c(1,-1)*inchy(0.05)
xr <- xrange
xr[3] <- x[i]
ll2 <- (x, v, xr, xcoord, ycoord, tvar, i + 1)
xr <- xrange
xr[1] <- x[i]
((x, v, xr, ll2$xcoord, ll2$ycoord, tvar, ll2$i + 1))
} (v[i] == tvar[2]) {
xcoord <- (xcoord, xrange[1], x[i], xrange[3], x[i])
# minka
#xrange[c(1,3)] = xrange[c(1,3)] + c(1,-1)*inchx(0.05)
xr <- xrange
xr[4] <- x[i]
ll2 <- (x, v, xr, xcoord, ycoord, tvar, i + 1)
xr <- xrange
xr[2] <- x[i]
((x, v, xr, ll2$xcoord, ll2$ycoord, tvar, ll2$i + 1))
}
("Wrong variable numbers in tree.")
}
((tree, "singlenode")) {
("Singlenode tree has no partitions")
(())
}
(!(tree, "tree")) ("Not legitimate tree")
<- tree$
leaves <- $ == "<leaf>"
<- (($!leaves]))
(() > 2 || () < 1)
("Tree can only have one or two predictors")
<- (xlevels <- (tree, "xlevels"), )
(([var] > 0))
("Tree can only have continuous predictors")
x <- (, (leaves))
x!leaves] <- (($splits!leaves, "cutleft"], 2, 100))
m <- (tree)
# minka: treat 1 var as if var 2 was yvar
( && (() == 1)) {
[2] <- (tree)
}
(() == 1) {
## one x variable
x <- (((m[var]]), x!leaves]))
(((tree, "ylevels"))) y <- $yval[leaves]
# minka: ??
y <- $yprob[leaves, 2] + 1
# minka: must extend y to match x
y <- (y,y[length(y)])
(add) (x, y, = "s", )
{
# minka: use response.var
resp <- (m)
xo <- m[resp]]
=
#if(is.factor(xo)) ylim <- c(0,1) else ylim <- range(xo)
(x, y, ylab = resp, xlab = , = "s", = ,
xaxs = "i", )
}
((x = x, y = y))
} {
## two x variables
(!(ordvars)) {
ind <- (, ordvars)
(((ind))) ("unmatched names in vars")
<- ordvars[sort(ind)]
}
lab <- $yval[leaves]
resp = (tree)
(($yprob)) lab <- ((lab, digits))
((label, (tree, "ylevels"), nomatch = 0)) {
lab <- (($yprob[leaves, label], digits))
# minka: useful title
((main)) main = ("Pr(",resp," = ",label,")",sep="")
}
# minka: useful title
((main)) main = resp
rx <- (m[var[1]]])
rx <- rx + (-0.025, 0.025) * (rx)
rz <- ((m[var[2]]]))
rz <- rz + (-0.025, 0.025) * (rz)
xrange <- (rx, rz)[c(1, 3, 2, 4)]
xcoord <- # x1lo, x2lo, x1hi, x2hi
ycoord <- # y1, y2
xy <- ptXlines(x, $, xrange, xcoord, ycoord, )
xx <- (xy$xcoord, = 4)
yy <- (xy$ycoord, = 2)
(!add)
(rx, rz, xlab = [1], ylab = [2], = "n",
xaxs = "i", yaxs = "i", main = main, )
# minka: use ...
(xx[1, ], xx[2, ], xx[3, ], xx[4, ], )
(yy[1, ], yy[2, ], (lab), )
}
}
# minka: added newdata,rate options
my.misclass.tree <- (tree, newdata, rate = F, detail = )
{
(!(tree, "tree"))
("Not legitimate tree")
(((tree, "ylevels")))
("Misclassification error rate is appropriate for factor responses only")
(!(newdata)) {
resp <- (tree)
r = (predict.tree(tree, newdata, ="class") != newdata[resp]])
((rate) r/(newdata) r)
}
((y <- tree$y))
y <- ((tree), "response")
((wts <- tree$))
wts <- ((tree))
((wts)) wts <- (1, (y))
<- tree$
(detail) {
<- descendants((()))
tmp <- ((, tree$where] *
($yval, y, "!=")) %*% wts)
(tmp) <- (tree$)
r = tmp
}
r = (wts*($yval[tree$where] != y))
(rate) r/(y) r
}
# minka: added newdata,rate options
my.deviance.tree <- (object, newdata, rate = F, detail = , )
{
(!(object, "tree")) ("Not legitimate tree")
(!(newdata)) {
yvar <- (object)
truth <- (newdata[yvar]])
p <- predict.tree(object, newdata)
# correction used in prune.tree
p[p == 0] <- 1e-3
i <- (1:(p)) + (truth-1)*(p)
dev = -2*((p[i]))
((rate) dev/(truth) dev)
}
<- object$
(detail) dev = $dev
dev = ($dev[frame$ == "<leaf>"])
(rate) dev/($ == "<leaf>") dev
}
my.cv.tree <- (object, rand, FUN = prune.tree, K = 10, )
{
(!(object, "tree")) ("Not legitimate tree")
m <- (object)
extras <- (expand.dots = )$
FUN <- ((FUN))
init <- (FUN, ((object), extras))
((rand)) rand <- (K, (m[1]]), = )
cvdev <- 0
(i (rand)) {
# minka: must build a tree as big as original
# can use object$call to see what controls were used
tlearn <- tree(model = m[rand != i, , = ], mindev=-1)
plearn <- (FUN, ((tlearn, newdata =
m[rand ==i, , = ],
k = init$k), extras))
cvdev <- cvdev + plearn$dev
}
init$dev <- cvdev
init
}
my.model.frame.tree <- (, )
{
m <- $model
(!(m)) (m)
oc <- $
(((oc[1]]), 1, 7) == "predict") {
m <- (oc$newdata)
(((m, "terms"))) {
object <- (oc$object)
m <- (object$, m, )
}
(m)
}
((oc[1]]) != "tree") oc <- (oc[2]])$
oc$ <- ($where)
oc$method <- "model.frame"
# minka: use the environment of terms, not the current env
env = ($)
if ((env)) env<-()
(oc,env)
}
# must do this before minka for bugfixes to apply
#library(tree)
("tree" %in% ()) {
replaceInNamespace("print.tree",my.print.tree)
replaceInNamespace("partition.tree",my.partition.tree)
replaceInNamespace("misclass.tree",my.misclass.tree)
replaceInNamespace("deviance.tree",my.deviance.tree)
replaceInNamespace("cv.tree",my.cv.tree)
replaceInNamespace("model.frame.tree",my.model.frame.tree)
}
# bugfix for ts library
#library(ts,warn=F)
as.data.frame.ts <- (x,optional) {
nam <- ((x))
<- ((x))
() <- nam
((=((x))),)
}
my.ccf <- (x, y, lag.max = ,
= ("correlation", "covariance"),
= , = ,
ylab=("Cross",,sep="-"), )
{
<- ()
((x) || (y))
("univariate time series only")
X <- (((x), (y)))
(X) <- (((x)), ((y)))
acf.out <- (X, lag.max = lag.max, = , = )
<- ((acf.out$-1,2,1]), acf.out$,1,2])
y <- ((acf.out$-1,2,1]), acf.out$,1,2])
acf.out$ <- (y, =((y),1,1))
acf.out$ <- (, =((y),1,1))
acf.out$snames <- (acf.out$snames, collapse = " & ")
if () {
# minka: added ylab
(acf.out, ylab=ylab, )
((acf.out))
} (acf.out)
}
replaceInNamespace("ccf",my.ccf)
# workaround bug in formals()
env = ()
()$ =
() = env
()$ =
() = env
# new functions
# also see cluster.r
# lag.default should really be lag.ts
lag.ts = ("lag.default","stats")
lag.default = (x,k=1) {
((,k),x[1:((x)-k)])
}
make.ar <- (n,a,e,) {
k = (a)
(()) {
x = e*(k)/(k)
} {
x =
}
(i in (k+1):n) {
x[i] = (a*x(i-1):(i-k)]) + e*(1)/(1)
}
x
}
growth.chart <- (y,ref=1,ylab,) {
pct.change = (x,r) (x-r)/r*100
abs.change = (x,r) (x-r)
y = (y)
((ref)) ref = (ref,(y))
nam = ((y))
((ylab)) ylab = ("% change since",nam[1],(y)[ref])
((y)) y = (y)
a = (y)
r = (y,2,(x) pct.change(x,x[ref]))
(r) = a
((r),ylab=ylab,)
}
period.grid <- (,p,lty="dotted",=T,cex=0.6,="blue",) {
v = (,("usr")[2],=p)
(v=v,lty=lty,)
() {
i = (v-)/p + 1
h = ("usr")[4] - (0.03)
n = (v)
# place text in center of each interval, except for last one
x = ((v[1:(n-1)]+v[2:n])/2, v[n]+(0.03))
(x,h,i,adj=(0,1),cex=cex,)
}
}
format.pretty <- (x,digits=2) {
((x,="fg",digits=digits),big.mark=",")
}
cycle.matrix <- (x,p,extended=F) {
# x is a vector
# p is cycle length
n = (x)
inc = p/(p)
((p) != p) {
i = (1,n,=inc)
# linear interpolation
x = (1:n,x,i)$y
n = (x)
p = (p)
}
d = (p,(n/p))
m = (x[1:(d)],d)
(m) = format.pretty((1,(m)*inc,len=(m)))
(m) = 1:(m)
(extended) {
m2 = (m,2:(m)],)
m = (m,m2)
}
((m)) = ("Time","Cycle")
m = (m)
(m)
}
plot.stack <- (x,y,n=2,) {
xyplot(y ~ x | equal.count(x, n=n, overlap=0),
panel = (x, y) {
panel.xyplot(x, y, ="l")
},
strip = F,
= (1,n),
= (x = "free"))
}
plot.stack <- (x,y,n=2,ylab="",=,) {
real.asp = ((,"auto")) (x,y)
opar <- (mfrow=(n,1),mar=auto.mar(xlab="",ylab=ylab))
((opar))
#b <- equal.count(x,num=n,overlap=0)$intervals
b = break.equal(x,n)
b = (my.lag(b),b)[2:(n+1),]
(j ((b))) {
i <- (x >= b[j,1]) & (x <= b[j,2])
(x[i],y[i],ylab=ylab,=real.asp,)
(nx=0)
}
}
spiral <- (object, ) ("spiral")
spiral.formula <- (fmla, =(), , main) {
x = (fmla,,=)
resp = (x)
pred = predictor.vars(x)[1]
((main)) main = resp
spiral.default(x,pred],x,resp],,main=main)
}
spiral.default <- (x,y,p,=0,color.palette=(64),
clockwise=T,
pch.palette=20,bg=(0.5),cex=("cex"),
cex.label=0.8,label=T,interp=T,main=,) {
# time flows clockwise by default, unlike other spiral plots
= (clockwise) -1 1
theta = (x - (x,na.rm=T) + )/p
indent = ((theta,na.rm=T)*0.25)
theta = theta + indent
opar = (bg=bg,mar=auto.mar(main=main,xlab="",ylab="",xaxt="n",yaxt="n"))
((opar))
r = (theta)
# sample uniformly in circumference
res = (("pin"))/inch.symbol(=pch.palette[1],cex=cex)*2.5
theta.g = ((r[1]^2,r[2]^2,len=res*(r)))
r = theta.g
xr = r*(2**theta.g*)
yr = r*(2**theta.g*)
(xr,yr,=1,="l",lwd=0.5,="gray",xaxt="n",yaxt="n",main=main,)
(label) {
spiral.text(theta.g[1],(x[1]),"inside",clockwise,cex=cex.label)
n = (xr)
spiral.text(theta.g[n],(x[length(x)]),"outside",clockwise,cex=cex.label)
}
(interp) {
y.g = (theta,y,theta.g)$y
theta = theta.g
y = y.g
}
nlev = (color.palette)
(nlev > 1) {
= color.palette[as.numeric(cut.quantile(y,nlev))]
= pch.palette[1]
} {
= color.palette[1]
= pch.palette[as.numeric(cut.quantile(y,nlev))]
}
r = theta
xr = r*(2**theta*)
yr = r*(2**theta*)
(xr,yr,=,=,cex=cex,)
}
spiral.text <- (theta,label,=("inside","outside"),clockwise=T,) {
# place text on the spiral
f <- (theta) {
theta = theta %% 1
(theta <= 1/4) theta*4
(theta <= 1/2) 1
(theta <= 3/4) (3/4 - theta)*4
0
}
adj.inside <- (theta) {
(1-f(theta),1-f(theta+1/4))
}
adj.outside <- (theta) {
(f(theta), f(theta+1/4))
}
= ()
adj = ( == "inside") adj.inside(theta) adj.outside(theta)
(!clockwise) adj[2] = 1-adj[2]
= (clockwise) -1 1
spc = (inch.symbol())
spc = spc*(0.5-adj)
r = theta
xr = r*(2**theta*)
yr = r*(2**theta*)
(xr+spc[1], yr+spc[2], label, adj=adj, )
}
