.packageName <- "eigenmodel"
"ULU" <-
function(UL){ 

## computes the reduced rank matrix

  UL$U%*%UL$L%*%t(UL$U)
                      }

"XB" <-
function(X,b) {

## generate sociomatrix of regression effects
  
  tmp<-matrix(0,nrow=dim(X)[1],ncol=dim(X)[2])
  for(k in seq(1,length(b),length=length(b))) { tmp<-tmp+b[k]*X[,,k] }
  tmp
                      }

"Y_impute" <-
function() {

  sd_zq<-1/sqrt(pp_zq)
  zq<-c(-Inf,rep(NA,max(Ranks,na.rm=TRUE)-1),Inf)
  for(ry in 1:(max(Ranks,na.rm=TRUE)-1)){
    ub<-suppressWarnings(min(Z[ Ranks==ry+1 ],na.rm=TRUE ) )
    lb<-suppressWarnings(max(Z[ Ranks==ry ],na.rm=TRUE ) )
    zq[ry+1]<-  qnorm( runif(1,pnorm(lb,0,sd_zq),pnorm(ub,0,sd_zq)),0,sd_zq  )
                                     }

  zhat<- Z[upper.tri(Z) & is.na(Y)]
  lb<-outer(zhat,zq[-1],"<")
  ub<-outer(zhat,zq[-length(zq)],">")
  est<-lb & ub
  yhat<- est%*% sort(unique(c(Y)))

  Y[ upper.tri(Z) & is.na(Y) ] <- yhat  
  Y[ lower.tri(Y) ]<- 0 
  Y+t(Y)             }

"addlines" <-
function(U,Y,col="green",lwd=1,lty=1) {
u1<-U[,1]; u2<-U[,2]
n<-dim(Y)[1]
for(i in 1:(n-1)){
for(j in (i+1):n){
if(!is.na(Y[i,j])) {
if(Y[i,j]!=0) {   segments(u1[i],u2[i],u1[j],u2[j],col=col,lwd=lwd) }
                     }
               }}
                              }

"eigenmodel_mcmc" <-
function(Y,X=NULL,R=2,S=1000,seed=1,Nss=min(S-burn,1000),burn=0) {


if(is.null(X)) { X<-array(dim=c(dim(Y)[1],dim(Y)[1],0)) }

mcmc_env<-new.env()

assign("Y",Y,mcmc_env)
assign("X",X,mcmc_env)
assign("R",R,mcmc_env)

environment(eigenmodel_setup)<-mcmc_env
environment(rZ_fc)<-mcmc_env
environment(rUL_fc)<-mcmc_env
environment(rb_fc)<-mcmc_env
environment(Y_impute)<-mcmc_env


## a simple MCMC routine

  Y_postsum<-Z_postsum<-ULU_postsum<-matrix(0,dim(Y)[1],dim(Y)[1])
  L_postsamp<-b_postsamp<-NULL   

  set.seed(seed)
  eigenmodel_setup(R,em_env=mcmc_env)

  nss<-0
  ss<-round(seq(burn+1,S,length=Nss))
  si<-quantile(1:S,prob=seq(.05,1,length=20),type=1) 

  for(s in 1:S) {

    Z<-rZ_fc() ; assign("Z",Z,mcmc_env)
    UL<-rUL_fc() ;  assign("UL",UL,mcmc_env)
    b<-rb_fc()   ;  assign("b",b,mcmc_env)

    if(is.element(s,si)){ 
      cat(round(100*s/S)," percent done (iteration ",s,") ",date(),"\n",sep="")
                         }

    if(is.element(s,ss)){ 
        nss<-nss+1
        L_postsamp<-rbind(L_postsamp,diag(UL$L))
        b_postsamp<-rbind(b_postsamp,b)
        Z_postsum<-Z_postsum+Z
        ULU_postsum<-ULU_postsum+ULU(UL) 
        Y_postsum<-Y_postsum+Y_impute()
                         }
                  }

eigenmodel_post<-list(Z_postmean=Z_postsum/nss,
                ULU_postmean=ULU_postsum/nss, 
                Y_postmean=Y_postsum/nss,
                L_postsamp=L_postsamp, b_postsamp=b_postsamp,Y=Y,X=X,S=S) 
                   
class(eigenmodel_post)<-"eigenmodel_post"
return(eigenmodel_post)
                                                                         }

"eigenmodel_setup" <-
function(R=0,seed=1,em_env=.GlobalEnv){


## set up data features
  n<-dim(Y)[1] 
  uRanks<-1:length(unique(c(Y[!is.na(Y)])))  
  Ranks<-matrix(match(Y, sort(unique(c(Y)))),n,n)  

  if(!exists("X") ) {  X<-array(dim=c(n,n,0)) }
  
  p<-dim(X)[3]
  if(p>0) {
    x<-NULL
    for(k in seq(1,dim(X)[3],length=p)) {
      x<-cbind(x,c((X[,,k])[upper.tri(X[,,k])])) 
                                         }
    xtx<-t(x)%*%x
    tx<-t(x)
    assign("xtx",xtx,em_env)
    assign("tx",tx,em_env)

           }

  set.seed(seed)

  RR<-rank(c(Y),ties.method="random",na.last="keep")
  Z<-matrix(qnorm(RR/(sum(!is.na(RR))+1)),n,n)
  Z[is.na(Z)]<-rnorm(sum(is.na(Z)) )
  Z<-Z*upper.tri(Z)+ t(Z)*lower.tri(Z)
  
  E<-Z
  b<-rep(0,p)
  if(p>0) {b<-lm(E[upper.tri(E)]~ -1+t(tx))$coef ; E<- E-XB(X,b) }
  E[is.na(E)]<-Z[is.na(E)]

 
  tmp<-eigen(E)
  L<- diag(tmp$val[order(-abs(tmp$val))[seq(1,R,length=R)] ]/n,nrow=R)
  U<- tmp$vec[,order(-abs(tmp$val))[seq(1,R,length=R)],drop=FALSE ]*sqrt(n)
  UL<-list(U=U,L=L)
 
  assign("Z",Z,em_env)
  assign("b",b,em_env)
  assign("UL",UL,em_env)
  assign("R",R,em_env)

  assign("output",NULL,em_env)
  assign("n",n,em_env)
  assign("uRanks",uRanks,em_env)
  assign("Ranks",Ranks,em_env)
  assign("X",X,em_env)
  assign("p",p,em_env) 

  assign("pp_b",diag(1/100,nrow=p),em_env)
  assign("pm_b",rep(0,p),em_env)

  assign("pp_zq",1/100,em_env)
  assign("pp_l",rep(1/100,R),em_env)

  assign("pp_mu",rep(1/100,R),em_env)
  assign("pm_mu",rep(0,R),em_env)

  assign("var_u",rep(1,R),em_env)   #not seperately identifiable from lambdas, so keep fixed
  assign("mean_u",rep(0,R),em_env)

                  }

"plot.eigenmodel_post" <-
function(x,...) {

  n<-dim(x$Y)[1]
  R<-dim(x$L_postsamp)[2]
  p<-dim(x$b_postsamp)[2]

  np<- 1*(R>0) + 1*(p>0) 
  
  if(np>0) {

    if(np==1) { par(mfrow=c(1,2),mar=c(3,3,1,1),mgp=c(1.75,.75,0)) }
    if(np==2) { par(mfrow=c(2,2),mar=c(3,3,1,1),mgp=c(1.75,.75,0)) }

    
      if(R>0) {
 
      plot(c(1,dim(x$L_postsamp)[1]),range(x$L_postsamp),type="n",
           ylab=expression(lambda),xlab="sample") 
      abline(h=0,col="gray")

      L_ord<-t(apply(x$L_postsamp,1,sort))

      for(j in 1:R) {lines(L_ord[,j],col=j+1) }

      tmp<-eigen(x$ULU_postmean) 
      L<- diag(tmp$val[order(-abs(tmp$val))[seq(1,R,length=R)] ]/n,nrow=R)
      U<- tmp$vec[,order(-abs(tmp$val))[seq(1,R,length=R)],drop=FALSE ]*sqrt(n)
 
      if(R>1) { plot(U,type="n",xlab="",ylab="")  
                  abline(h=0,col="gray") ;  abline(v=0,col="gray") 
                  addlines(U,1*(x$Y>median(x$Y,na.rm=TRUE)))
                  #points(U,pch=16,cex=.8,col="blue")
                  text(U[,1],U[,2],labels=rownames(x$Y),cex=.8,col="blue")
               } 
 

              }

    if(p>0) {
    
      b_psamp<-x$b_postsamp 
      b_psamp<-t(t(b_psamp)*apply( apply(x$X,3,c),2,sd,na.rm=TRUE))
   
      plot(c(1,dim(b_psamp)[1]),range(b_psamp),type="n", 
           ylab=expression(beta),xlab="iteration")
      abline(h=0,col="gray")
      for(j in 1:p) {lines(b_psamp[,j],col=j+1) }

      plot(c(1-1/(p+1),p+1/(p+1)),range(b_psamp),type="n",ylab=expression(beta),
          xlab="",xaxt="n")
      axis(side=1,at=1:p,labels=dimnames(x$X)[[3]])
    
      abline(h=0,col="gray")
      qb<-apply(b_psamp,2,quantile,c(0.025,.5,.975))  
      for(j in 1:p) {
        segments(j,qb[1,j],j,qb[3,j],col=1+j) 
        points(j,qb[2,j]) 
                     } 
               }

             }
                             }

"rUL_fc" <-
function( E=Z-XB(X,b) ) { 

## sample U, column mean of U, and L from full conditionals 
## needs pp_mu, pm_mu

  U<-UL$U ; L<-UL$L

  if(R>0) {

  mean_u<<-rnorm(R, 
  ( (1/var_u)*apply(UL$U,2,sum)+pp_mu*pm_mu ) / ( n/var_u+pp_mu ),
  1/sqrt(n/var_u + pp_mu ) 
                 )


  for(i in sample(1:n,size=n) ) {
    w<-E[i,-i]
    vr<-  solve( t(L)%*%t(U[-i,])%*%U[-i,]%*%L + diag(1/var_u,nrow=dim(U)[2]) )
    mn<-  vr%*%( t(L)%*%t(U[-i,])%*%w  + mean_u/var_u)
    U[i,]<- rmvnorm(mn,vr)        }

  vr<-solve(  ( (t(U)%*%U)^2 - t(U^2)%*%(U^2)) /2 + diag(pp_l,nrow=dim(U)[2])  )
  E[upper.tri(E,diag=TRUE)]<-0
  mn<-vr%*% diag(t(U)%*%E%*%U)
  L<-diag(c(rmvnorm(mn,vr)),nrow=dim(U)[2])
 
           }

  list(U=U,L=L)
             }

"rZ_fc" <-
function( EZ=XB(X,b)+ULU(UL), MH=TRUE ) {

## sample normal quantiles for probit model
## needs pp_zq, Ranks

  sd_zq<-1/sqrt(pp_zq)
  zq<-c(-Inf,rep(NA,max(Ranks,na.rm=TRUE)-1),Inf)
  for(ry in 1:(max(Ranks,na.rm=TRUE)-1)){
    ub<-suppressWarnings(min(Z[ Ranks==ry+1 ],na.rm=TRUE ) )
    lb<-suppressWarnings(max(Z[ Ranks==ry ],na.rm=TRUE ) )
    zq[ry+1]<-  qnorm( runif(1,pnorm(lb,0,sd_zq),pnorm(ub,0,sd_zq)),0,sd_zq  )
                                     }

## sample Z from fc  
## needs Ranks, uRanks to exist

  for(ry in sample(uRanks)){
    ir<- ( Ranks==ry & !is.na(Ranks) )
    lb<- zq[ry]
    ub<- zq[ry+1]
    z<-qnorm(runif(sum(ir),pnorm(lb,EZ[ir],1),pnorm(ub,EZ[ir],1)),EZ[ir],1)
    z[z== Inf]<-lb
    z[z==-Inf]<-ub
    Z[ir]<-z
                                  }
  ir<-is.na(Ranks)
  Z[ir]<-rnorm(sum(ir),EZ[ir],1)
  Z<-Z*upper.tri(Z)+ t(Z)*lower.tri(Z,diag=TRUE)
  diag(Z)<-NA


## MH proposal to help mixing
   if(MH) {
     del<-rnorm(1,0,1/sqrt(n))
     Zp<-Z+del ; zqp<-zq+del
     lhr<-sum(dnorm(Zp-EZ,0,1,log=TRUE),na.rm=TRUE)/2 -
          sum(dnorm(Z-EZ,0,1,log=TRUE),na.rm=TRUE)/2  +
          sum(dnorm(zqp[-c(1,length(uRanks)+1)],0,1/sqrt(pp_zq),log=TRUE)) -
          sum(dnorm(zq[-c(1,length(uRanks)+1)],0,1/sqrt(pp_zq),log=TRUE))
     if(log(runif(1))<lhr) { Z<-Zp ; zq<-zqp   }
          }

Z                        
                                            }

"rb_fc" <-
function( E=Z-ULU(UL) ) {

## sample b from fc
## needs xtx, tx, pm_b and pp_b 

  if(length(pm_b)>0) {
    vr<- solve(  xtx  +  pp_b   )
    mn<- vr%*%( pp_b%*%pm_b +  tx%*%c(E[upper.tri(E)]) )
    b<-rmvnorm(mn,vr)
                      } 
  b 
                   }

"rmvnorm" <-
function(mu,Sig2){

## sample from multivariate normal distribution

  R<-t(chol(Sig2))
  t(R%*%(rnorm(length(mu),0,1)) +mu)
                           }

