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 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) } ####################### stiefl_opt_momentum<-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,momentum_para=0.8){ 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){ 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 Lnew<-LV(Vold,Xl,dtemp,h,q,Y)$var #print(Lnew) if(best>Lnew){ best<-Lnew Vend<-Vold #sig<-tmp3$sig } } Vnew<-Vold<-Vend G<-matrix(rep(0,dim*k),dim,k) while(err>tol&count sclack_para){#/(count+1)^(0.5) lambda=lambda/2 err<-10 count2<-count2+1 count<-count-1 Vnew<-Vold #!!!!! Lnew<-Lold } Vold<-Vnew count<-count+1 #print(count) } ret<-list(Vnew,Lnew,count,h,count2) names(ret)<-c('est_base','var','count','h','count2') return(ret) } ###################### 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) }