I have been trying to write my own user defined function in Rpart.I
imitated the anova splitting rule which is given as an example.In the
work I am doing ,I am calculating the concentration index(ci) ,which
is in between -1 and +1.So my deviance is given by
abs(ci)*(1-abs(ci)).Now when I run rpart incorporating this user
defined function i get the following error message:
Error in user.split(yback[1:nback], wback[1:nback], xback[1:nback], parms, :
unused argument(s) ( ...)
Now I am failing to indentify where I am going wrong (In case I am
have made some mistake).So I was wondering if there is anybody who
have written some user defined functions of theirs and maybe if there
is any documentation with regards to user defined functions and
examples.
Regards ,
Luwis Diya
#User
defined function
#
temp.init-function(y,offset,parms,wt){
if (!is.null(offset)) y-y-offset
if (is.matrix(y))stop (response must be a vector)
list(y=y,parms=0,numy=1,numresp=1,
summary=function(yval,dev,wt,ylevel,digits){
paste(mean=,format(signif(yval,digits)),
MSE=,format(signif(dev/wt,digits)),
sep='')
})
}
temp.eval-function(y,wt,parms){
n-length(y)
r-wt
for (i in 1:n-1) {r[i+1]=(sum(wt[1:i])+0.5*wt[i+1])/n} #fractional rank
r[1]-0.5*wt[1]/n
wmean-sum(y*wt)/sum(wt)
ci-2*sum(wt*(y-wmean)*(r-0.5))/sum(wt*y) #concentration index
for
socio-economic inequality
dev-abs(ci)*(1-abs(ci)) #deviance following
the gini impurity approach
list(label=wmean,deviance=dev)
}
temp.split-function(y,wt,parms,continous){
n-length(y)
r-wt
for (i in 1:n-1) {r[i+1]=(sum(wt[1:i])+0.5*wt[i+1])/n}
r[1]-0.5*wt[1]/n
wmean-sum(y*wt)/sum(wt)
ci-2*sum(wt*(y-wmean)*(r-0.5))/sum(wt*y)
devci-abs(ci)*(1-abs(ci))
if(continous){
lss-cumsum(wt*y)[-n]
rss-sum(wt*y)-lss
lw-cumsum(wt)[-n]
rw-sum(wt)-lw
lm-lss/lw
rm-rss/rw
lcss-cumsum(wt[1:length(lm)]*(y[1:length(lm)]-lm)*(r[1:length(lm)]-0.5))
rcss-sum(wt*(y-wmean)*(r-0.5))-lcss
lci-2*lcss/lss #concentration index
for left side
rci-2*rcss/rss #concentration index
for right side
devlci-abs(lci)*(1-abs(lci)) #deviance for left
side
devrci-abs(rci)*(1-abs(rci)) #deviance for right
side
goodness-devci-(lw/sum(wt))*devlci-(rw/sum(wt))*devrci
list(goodness=goodness, direction=sign(lci))
}
else {
ux-sort(unique(x))
wtsum-tapply(wt,x,sum)
ysum-tapply(wt*y,x,sum)
means-ysum/wtsum
ord-order(means)
n-length(ord)
lss-cumsum(ysum[ord])[-n]
rss-sum(ysum)-lss
lw-cumsum(wtsum[ord])[-n]
rw-sum(wtsum)-lw
lm-lss/lw
rm-rss/rw
lysum-tapply(wt*(y-lm)*(r-0.5),x,sum)
lcss-cumsum(lysum[ord])[-n]
rcss-sum(lysum)-lcss
lci-2*lcss/lss
rci-2*rcss/rss
devlci-abs(lci)*(1-abs(lci))
devrci-abs(rci)*(1-abs(rci))
goodness-devci-0.5*(lw/sum(wt))*devlci-0.5*(rw/sum(wt))*devrci
list(goodness=goodness, direction=sign(lci))
}
}
alist-list(eval=temp.eval,split=temp.split,init=temp.init)
tree-rpart(u~pcares+antcare.skilled+riskintb+child.born+married+mage1+mage2,
weights=popweight,method=alist)
__
R-help@stat.math.ethz.ch mailing list
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide! http://www.R-project.org/posting-guide.html
