2
0
Fork 0
CVE/CVE_legacy/function_script_2.R

237 lines
6.2 KiB
R

LV_weight_partial<-function(V,Xl,dtemp,h,q,Y,grad=T){
N<-length(Y)
if(is.vector(V)){k<-1}
else{k<-length(V[1,])}
Xlv<-Xl%*%V
d<-dtemp-((Xlv^2)%*%rep(1,k))
w<-exp(-0.5*(d/h)^2)
w<-matrix(w,N,q)
wn<-apply(w,2,sum)-rep(1,q)#new
w<-apply(w,2,column_normalize)
mY<-t(w)%*%Y
sig<-t(w)%*%(Y^2)-(mY)^2
W<-(kronecker(t(wn),rep(1,N)))##new
if(grad==T){
grad<-mat.or.vec(dim,k)
tmp1<-(kronecker(sig,rep(1,N))-(as.vector(kronecker(rep(1,q),Y))-kronecker(mY,rep(1,N)))^2)
if(k==1){
grad_d<- -2*Xl*as.vector(Xlv)
grad<-(1/h^2)*(1/sum(wn))*t(grad_d*as.vector(d)*as.vector(w)*as.vector(W))%*%tmp1 #new
# wn_grad<-(-1/h^2)*t(grad_d*as.vector(d)*as.vector(w))%*%kronecker(diag(rep(1,q)),rep(1,N))
# grad<- wn_grad%*%(sig-rep(var1[2],q))/(sum(wn))+grad
}
else{
for (j in 1:(k)){
grad_d<- -2*Xl*as.vector(Xlv[,j])
grad[,j]<- (1/h^2)*(1/sum(wn))*t(grad_d*as.vector(d)*as.vector(w)*as.vector(W))%*%tmp1#new
# wn_grad<-(-1/h^2)*t(grad_d*as.vector(d)*as.vector(w))%*%kronecker(diag(rep(1,q)),rep(1,N))
# grad[,j]<- wn_grad%*%(sig-rep(var1[2],q))/(sum(wn))+grad
}
}
ret<-list(t(wn)%*%sig/sum(wn),sig,grad)#new
names(ret)<-c('var','sig','grad')
}
else{
ret<-list(t(wn)%*%sig/sum(wn),sig)#new
names(ret)<-c('var','sig')
}
return(ret)
}
################
stiefl_weight_partial_opt<-function(dat,h=NULL,k,k0=30,p=1,maxit=50,nObs=sqrt(length(dat[,1])),lambda_0=1,tol=10^(-3),sclack_para=0){
Y<-dat[,1]
X<-dat[,-1]
N<-length(Y)
dim<-length(X[1,])
if(p<1){
S<-est_varmat(X)
tmp1<-q_ind(X,S,p)
q<-tmp1$q
ind<-tmp1$ind
}
else{
q<-N
ind<-1:N
}
Xl<-(kronecker(rep(1,q),X)-kronecker(X[ind,],rep(1,N)))
dtemp<-apply(Xl,1,norm2)
if(is.null(h)){
S<-est_varmat(X)
tr<-var_tr(S)
h<-choose_h_2(dim,k,N,nObs,tr)
}
best<-exp(10000)
Vend<-mat.or.vec(dim,k)
sig<-mat.or.vec(q,1)
for(u in 1:k0){
Vnew<-Vold<-stiefl_startval(dim,k)
#print(Vold)
#print(LV(Vold,Xl,dtemp,h,q,Y)$var)
Lnew<-Lold<-exp(10000)
lambda<-lambda_0
err<-10
count<-0
count2<-0
while(err>tol&count<maxit){
#print(Vold)
tmp2<-LV_weight_partial(Vold,Xl,dtemp,h,q,Y)
G<-tmp2$grad
Lold<-tmp2$var
W<-G%*%t(Vold)-Vold%*%t(G)
stepsize<-lambda#/(2*sqrt(count+1))
Vnew<-solve(diag(1,dim)+stepsize*W)%*%(diag(1,dim)-stepsize*W)%*%Vold
# print(Vnew)
tmp3<-LV_weight_partial(Vnew,Xl,dtemp,h,q,Y,grad=F)
Lnew<-tmp3$var
err<-sqrt(sum((Vold%*%t(Vold)-Vnew%*%t(Vnew))^2))/sqrt(2*k)#sqrt(sum(tmp3$grad^2))/(dim*k)#
#print(err)
if(((Lnew-Lold)/Lold) > sclack_para){#/(count+1)^(0.5)
lambda=lambda/2
err<-10
count2<-count2+1
count<-count-1
Vnew<-Vold #!!!!!
}
Vold<-Vnew
count<-count+1
#print(count)
}
if(best>Lnew){
best<-Lnew
Vend<-Vnew
sig<-tmp3$sig
}
}
ret<-list(Vend,best,sig,count,h,count2)
names(ret)<-c('est_base','var','aov_dat','count','h','count2')
return(ret)
}
#################MAVE, OPG, rMAVE, rOPG from Bing Li book
opg=function(x,y,d){
p=dim(x)[2];
n=dim(x)[1]
c0=2.34;
p0=max(p,3);
rn=n^(-1/(2*(p0+6)));
h=c0*n^(-(1/(p0+6)))
sig=diag(var(x));
x=apply(x,2,standvec)
kmat=kern(x,h);
bmat=numeric()
for(i in 1:dim(x)[1]){
wi=kmat[,i];
xi=cbind(1,t(t(x)-x[i,]))
bmat=cbind(bmat,wls(xi,y,wi)$b)}
beta=eigen(bmat%*%t(bmat))$vectors[,1:d]
return(diag(sig^(-1/2))%*%beta)
}
######################
wls=function(x,y,w){
n=dim(x)[1];
p=dim(x)[2]-1
out=c(solve(t(x*w)%*%x/n)%*%apply(x*y*w,2,mean))
return(list(a=out[1],b=out[2:(p+1)]))
}
#################
kern=function(x,h){
x=as.matrix(x);
n=dim(x)[1]
k2=x%*%t(x);
k1=t(matrix(diag(k2),n,n));
k3=t(k1);
k=k1-2*k2+k3
return(exp(-(1/(2*h^2))*(k1-2*k2+k3)))
}
###############
standvec=function(x) return((x-mean(x))/sd(x))
##############
mave2=function(x,y,h,d,nit){
sig=diag(var(x));
n=dim(x)[1];
p=dim(x)[2]
x=apply(x,2,standvec);
beta=opg(x,y,d);#beta=opg(x,y,h,d);
kermat=kern(x,h)
for(iit in 1:nit){
b=numeric();
a=numeric();
for(i in 1:n){
wi=kermat[,i]/(apply(kermat,2,mean)[i])
ui=cbind(1,t(t(x)-x[i,])%*%beta)
out=wls(ui,y,wi);
a=c(a,out$a);b=cbind(b,out$b)}
out=0;out1=0;
for(i in 1:n){
xi=kronecker(t(t(x)-x[i,]),t(b[,i]))
yi=y-a[i];
wi=kermat[,i]/apply(kermat,2,mean)[i]
out=out+apply(xi*yi*wi,2,mean)
out1=out1+t(xi*wi)%*%xi/n}
beta=t(matrix(solve(out1)%*%out,d,p))
}
return(diag(sig^(-1/2))%*%beta)
}
######################
rmave=function(x,y,d,nit){
sig=diag(var(x));
n=dim(x)[1];
p=dim(x)[2]
x=apply(x,2,standvec)
c0=2.34;
p0=max(p,3);
h=c0*n^(-(1/(p0+6)));
rn=n^(-1/(2*(p0+6)))
beta=opg(x,y,d)
for(iit in 1:nit){
kermat=kern(x%*%beta,h);
mkermat=apply(kermat,2,mean)
b=numeric();a=numeric()
for(i in 1:n){
wi=kermat[,i]/mkermat[i];
ui=cbind(1,t(t(x)-x[i,])%*%beta)
out=wls(ui,y,wi);
a=c(a,out$a);b=cbind(b,out$b)
}
out=0;
out1=0
for(i in 1:n) {
xi=kronecker(t(t(x)-x[i,]),t(b[,i]));
yi=y-a[i]
wi=kermat[,i]/mkermat[i]
out=out+apply(xi*yi*wi,2,mean)
out1=out1+t(xi*wi)%*%xi/n}
beta=t(matrix(solve(out1)%*%out,d,p))
h=max(rn*h,c0*n^((-1/(d+4))))
}
return(diag(sig^(-1/2))%*%beta)
}
#########################
ropg=function(x,y,d,nit){
sig=diag(var(x));
x=apply(x,2,standvec);
p=dim(x)[2];
n=dim(x)[1]
c0=2.34;
p0=max(p,3);
rn=n^(-1/(2*(p0+6)));
h=c0*n^(-(1/(p0+6)))
beta=diag(p)
for(iit in 1:nit){
kmat=kern(x%*%beta,h);
bmat=numeric()
for(i in 1:dim(x)[1]){
wi=kmat[,i];
xi=cbind(1,t(t(x)-x[i,]))
bmat=cbind(bmat,wls(xi,y,wi)$b)
}
beta=eigen(bmat%*%t(bmat))$vectors[,1:d]
h=max(rn*h,c0*n^((-1/(d+4))))
}
beta.final=diag(sig^(-1/2))%*%beta
return(beta.final)
}