问题描述
我尝试了很多方法让我的rpart代码使用新的损失函数。在用户代码文章中，我们应该更改eval代码和拆分代码。如果我的数据的y是矩阵，则在eval中导入y function 是 y 的一种奇怪形式。split 函数中 y 的导入是一样的吗？
如何在这段代码中使用损失函数？如果我使用父节点损失函数-子节点损失函数作为优点，应该使用哪一个作为偏差？ 我的代码无法得到好的结果。
library(rpart)
library(partykit)
library(plyr)
library(tibble)
i<-300
n1<-5
m<-i*n1
c<-(i-1)/i/(n1/m*(1-n1/m)*i)
d2<-1.6487
x1<-matrix(sample(1:100,i,replace=T),1)
x2<-matrix(sample(1:100,1)
x3<-matrix(sample(1:100,1)
x4<-matrix(sample(1:100,1)
x5<-matrix(sample(1:100,1)
f<-matrix(i,1)
y<-matrix(i,1)
e<-matrix(rexp(i*n1,1/d2),n1)
f<-0.01*(x1+2*x2-x3+2*sqrt(x1*x3)-sqrt(x2*x4))
ex<-exp(f)
y<-cbind(ex,ex,ex)+e
w<-matrix(1,n1)
mystate <- data.frame(y,x1,x2,x3,x4,x5)
d20<-sum((y-rowMeans(y))^2)/i/(n1-1)
ta0<-c*(1/(i-1)*sum((rowMeans(y)- sum(y*w)/sum(w))^2)-i*d20/m)
if(ta0<0){ta0=0}
al0<-n1*ta0/(n1*ta0+d20)
p<-al0*rowMeans(y)+(1-al0)*sum(y*w)/sum(w)
p0<-(sum((p-ex-1.65)^2))/i
itemp <- function(y,offset,parms,wt) {
if (length(offset)) y <- y - offset
sfun <- function(yval,dev,wt,ylevel,digits ) {
paste(" mean=",format(signif(yval,digits)),",MSE=",format(signif(dev/wt,sep = '')
}
environment(sfun) <- .GlobalEnv
list(y = c(y),parms = NULL,numresp = 1,numy = n1,summary = sfun)
}
etemp1<- function(y,parms) {
wmean <- mean(y)
n2<-nrow(y)
y1<-matrix(0,nrow=1,ncol=(n2*n1))
y2<-matrix(0,nrow=n2,ncol=n1)
for(i in 1:n2){
for(j in 1:n1){
y1[n1*i+j-n1]<-y[i,j]
}
}
for(i in 1:n2){
for(j in 1:n1){
y2[i,j]<-y1[n2*j+i-n2]
}
}
d2a<-sum((y2-rowMeans(y2))^2)/(n1-1)/n2
y3<- (rowMeans(y2)- mean(y2))^2
ta<-(sum(y3)/(n2-1)-i*d2a/m)
RSS <-n2*d2a/(n1+d2a/ta)
list(label = wmean,deviance = RSS)
}
stemp1 <- function(y,x,continuous)
{
n2<-nrow(y)
y1<-matrix(0,j]<-y1[n2*j+i-n2]
}
}
y0<-rowSums((y2-rowMeans(y2))^2)
templ<-matrix(0,(n2-1),1)
for(z1 in 1:(n2-1)){
templ[z1]<-sum(y0[1:z1])
}
tempr<-sum((y2-rowMeans(y2))^2)-templ
left.wt <- t(matrix(1:(n2-1),1))
right.wt <- t(matrix((n2-1):1,1))
d2l<-templ/(n1-1)/left.wt
d2r<-tempr/(n1-1)/right.wt
left.wt1<-left.wt-1
right.wt1<-right.wt-1
left.wt1[1]<-1
right.wt1[n2-1]<-1
c0<-1
y3<-(rowMeans(y2)- mean(y2))^2
templeft <- cumsum(y3)[-n2]
tempright<-sum(y3)-templeft
tl<- c0*(templeft/left.wt1-left.wt*d2l/m)
tr<- c0*(tempright/right.wt1-right.wt*d2r/m)
for(z in 1:(n2-1))
{if(tl[z]<0){tl[z]=0}
if(tr[z]<0){tr[z]=0}
}
tl[1]<-0
tr[n2-1]<-0
ll<-d2l/(n1+d2l/tl)
lr<-d2r/(n1+d2r/tr)
d2a<-sum((y2-rowMeans(y2))^2)/(n1-1)/n2
ta<-(sum(y3)/(n2-1)-i*d2a/m)
RSS <-n2*d2a/(n1+d2a/ta)
goodness <-RSS-ll*left.wt-lr*right.wt
list(goodness = goodness,direction = rep(-1,length(goodness)))
}
xgroup1 <- rep(1:5,length = nrow(mystate))
xgroup2 <-sample(xgroup1,length(xgroup1))
ulist1 <- list(eval = etemp1,split = stemp1,init = itemp)
tree1<-rpart(y~x1+x2+x3+x4+x5,data=mystate,weights=w,method=ulist1,xval=xgroup2,control = rpart.control(minbucket=3,cp=0.01))
解决方法
暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！
如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。
小编邮箱:dio#foxmail.com (将#修改为@）