.packageName <- "superpc"
 balanced.folds <- function(y, nfolds = min(min(table(y)), 10)) {
   totals <- table(y)
   fmax <- max(totals)
   nfolds <- min(nfolds, fmax)     
                                        # makes no sense to have more folds than the max class size
   folds <- as.list(seq(nfolds))
   yids <- split(seq(y), y)        
                                        # nice we to get the ids in a list, split by class
###Make a big matrix, with enough rows to get in all the folds per class
   bigmat <- matrix(NA, ceiling(fmax/nfolds) * nfolds, length(totals))
   for(i in seq(totals)) {
     bigmat[seq(totals[i]), i] <- sample(yids[[i]])
   }
   smallmat <- matrix(bigmat, nrow = nfolds)       # reshape the matrix
### Now do a clever sort to mix up the NAs
   smallmat <- permute.rows(t(smallmat))   ### Now a clever unlisting
                                        # the "clever" unlist doesn't work when there are no NAs
                                        #       apply(smallmat, 2, function(x)
                                        #        x[!is.na(x)])
   res <-vector("list", nfolds)
   for(j in 1:nfolds) {
     jj <- !is.na(smallmat[, j])
     res[[j]] <- smallmat[jj, j]
   }
   return(res)
 }
superpc.predict.red.cv <- function(fitred, fitcv, data, threshold, num.reduced.models=30, sign.wt="both"){

 # try reduced predictor on cv folds, via prevalidation

                           
  this.call=match.call()

  type=fitred$type

  n.components=fitred$n.components


  n.fold<-length(fitcv$folds)

  shrinkages<- fitred$shrinkages
  num.reduced.models<-length(shrinkages)
  cur.vall<- array(NA,c(num.reduced.models,ncol(data$x),n.components))

  for(j in 1:n.fold){
    cat(j,fill=TRUE)
    fit.temp<-list(feature.scores=fitcv$featurescores.fold[,j], type=type)
    ii<-fitcv$folds[[j]]
    
    data1<-list(x=data$x[,-ii],y=data$y[-ii],censoring.status=data$censoring.status[-ii])
    data2<-list(x=data$x[,ii],y=data$y[ii],censoring.status=data$censoring.status[ii])
    junk<- superpc.predict.red(fit.temp, data1,data2, threshold, num.reduced.models=num.reduced.models, n.components=n.components,compute.lrtest=FALSE, sign.wt=sign.wt)
    cur.vall[,ii,]<-junk$v.test
  }

  lrtest.reduced<-rep(NA,num.reduced.models)

  for(i in 1:num.reduced.models){
    if(type=="survival"){
      require(survival)
      junk<- coxph(Surv(data$y, data$censoring.status) ~cur.vall[i,,])$loglik
      lrtest.reduced[i]=2*(junk[2]-junk[1])
    }
    else{
      junk<- summary(lm(data$y~cur.vall[i,,]))
      if(!is.null(junk$fstat)){lrtest.reduced[i]<-junk$fstat[1]}
    }

  }

return(list(shrinkages=shrinkages, lrtest.reduced=lrtest.reduced,  n.components=n.components, num.features=fitred$num.features, v.preval.red=cur.vall, sign.wt=sign.wt, type=type,call=this.call))
}
superpc.predict.red <- function(train.obj, data, data.test, threshold, component.number=1, n.components=3, num.reduced.models=20,prediction.type=c("continuous", "discrete"), num.features.desired=NULL, compute.lrtest=TRUE, sign.wt="both", n.class=2){

   # try reduced predictor on test set

# if num.features.desired is non-null, fits a single model with that many features
# works on a single component, indicated by component.number
  
  hard.thresh<- function(x,tt){ sign(x)*(abs(x))*(abs(x)>tt)}


  this.call<- match.call()
  prediction.type <- match.arg(prediction.type)

  
  if(!is.null(num.features.desired)){num.reduced.models=1}

  type=train.obj$type

  lrtest.reduced<- rep(NA,num.reduced.models)
  

  cur.vall<- matrix (NA,nrow=num.reduced.models,ncol=ncol(data$x))
  cur.vall.test<- matrix(NA, nrow=num.reduced.models,ncol=ncol(data.test$x))
                         
  corr.with.full<-rep(NA,num.reduced.models)
  
  which.features <- abs(train.obj$feature.scores) > threshold
  x.sml <- data$x[which.features, ]
  x.svd <- mysvd(x.sml, n.components=n.components)
  xtemp=data$x[which.features, ]
  xtemp=t(scale(t(xtemp),center=x.svd$feature.means, scale=F))

  cur.v <- scale(t(xtemp) %*%x.svd$u, center=FALSE,scale=x.svd$d)

                                        # flip the sign of the latent factors, if a coef is neg

  result<-superpc.fit.to.outcome(train.obj, data, cur.v, print=FALSE)
  if(train.obj$type=="survival"){coef=result$coef}
  if(train.obj$type=="regression"){coef=result$coef[-1]}

  cur.v<-scale(cur.v, center=FALSE,scale= sign(coef))


  ##
ii = component.number
  
  import<-cor(t(data$x), cur.v[,ii, drop=F])
  sc<- data$x%*%cur.v

  # don't shrink all of the way to zero 

                                 

  maxshrink=max(abs(sc))

  if(sign.wt=="positive"){ maxshrink=max(abs(sc[sc>0]))}
  
  if(sign.wt=="negative"){ maxshrink=max(abs(sc[sc<0]))}

  if(is.null(num.features.desired)){
    probs=exp(seq(log(.001),log(.999),length=num.reduced.models))
    shrinkages<- quantile(abs(sc[,ii]), probs=1-probs)
  }
  else{
    shrinkages=sort(abs(sc[,ii]))[nrow(data$x)-num.features.desired]
  }

  num.features<-rep(NA,num.reduced.models)
  
  feature.list<-vector("list", num.reduced.models)


 

  for(i in 1:num.reduced.models){
    cat(i)
    sc2<- hard.thresh(sc[,ii],shrinkages[i])
    if(sign.wt=="positive"){sc2[sc2<0]<-0}
    if(sign.wt=="negative"){sc2[sc2>0]<-0}
    nonzero<-sc2!=0
    

    num.features[i]<- sum(nonzero)
    

    
    feature.list[[i]]=(1:nrow(data$x))[nonzero]


  xtemp= data$x[nonzero,,drop=FALSE]
  feature.means=rowMeans(xtemp)
  xtemp=t(scale(t(xtemp),center=feature.means, scale=F))

  cur.vall[i,]<-apply(t(scale(t(xtemp), center=FALSE,scale=1/sc2[nonzero])),2,sum)

  xtemp2= data.test$x[nonzero,,drop=FALSE]
  xtemp2=t(scale(t(xtemp2),center=feature.means, scale=F))

  cur.vall.test[i,]<-apply(t(scale(t(xtemp2), center=FALSE,scale=1/sc2[nonzero])),2,sum)

  if(prediction.type=="discrete") {
    for(j in 1:ncol(cur.v)){
      cur.vall.test[i,]<-cut(cur.vall.test[i,],n.class,labels=FALSE)
    }}

  }
cat("",fill=TRUE)


if(compute.lrtest){ 
  for(i in 1:num.reduced.models){
    if(type=="survival"){
      require(survival)
      junk<- coxph(Surv(data.test$y, data.test$censoring.status) ~cur.vall.test[i,])$loglik
      lrtest.reduced[i]=2*(junk[2]-junk[1])
    }
    else{
      junk<- summary(lm(data.test$y~cur.vall.test[i,]))
      if(!is.null(junk$fstat)){lrtest.reduced[i]<-junk$fstat[1]}
    }
  }
}

for(ii in component.number){
  if(!is.null(num.features.desired)){
    corr.with.full=cor((cur.vall),cur.v[,ii,drop=F])
  }
  else{
    corr.with.full=cor(t(cur.vall),cur.v[,ii,drop=F])
  }}

return(list(shrinkages=shrinkages, lrtest.reduced=lrtest.reduced, corr.with.full=corr.with.full,
            import=import, wt=sc, v.test=cur.vall.test, num.features=num.features,num.features.desired,
            component.number=component.number, n.components=n.components,, sign.wt=sign.wt, type=type,call=this.call))

}



superpc.predict.red.cv <- function(fitred, fitcv, data, threshold, num.reduced.models=30, sign.wt="both"){

 # try reduced predictor on cv folds, via full cross-validation
  # works on single component, indiaqted by component.number in fitred

                           
  this.call=match.call()

  type=fitred$type

  n.components=fitred$n.components
  component.number=fitred$component.number


  n.fold<-length(fitcv$folds)

  shrinkages<- fitred$shrinkages
  num.reduced.models<-length(shrinkages)
  cur.vall<- array(NA,c(num.reduced.models,ncol(data$x),n.components))

 lrtest.reduced<-matrix(NA,nrow=n.fold,ncol=num.reduced.models)

  for(j in 1:n.fold){
    cat(j,fill=TRUE)
    fit.temp<-list(feature.scores=fitcv$featurescores.fold[,j], type=type)
    ii<-fitcv$folds[[j]]
    
    data1<-list(x=data$x[,-ii],y=data$y[-ii],censoring.status=data$censoring.status[-ii])
    data2<-list(x=data$x[,ii],y=data$y[ii],censoring.status=data$censoring.status[ii])
    junk<- superpc.predict.red(fit.temp, data1,data2, threshold, num.reduced.models=num.reduced.models, n.components=n.components, component.number=component.number, compute.lrtest=TRUE, sign.wt=sign.wt)
 lrtest.reduced[j,]=junk$lrtest.reduced
  }

 mean.na <- function(x) {
            mean(x[!is.na(x)])
        }
        se.na <- function(x) {
            val = NA
            if (sum(!is.na(x)) > 0) {
                val = sqrt(var(x[!is.na(x)])/sum(!is.na(x)))
            }
            return(val)
        }

   llr= apply(log(lrtest.reduced), 2, mean.na)
        se.llr = apply(log(lrtest.reduced), 2, se.na)
        lrtest.reduced.lower = exp(llr - se.llr)
        lrtest.reduced.upper = exp(llr + se.llr)
        lrtest.reduced <- exp(llr)


return(list(shrinkages=shrinkages, lrtest.reduced=lrtest.reduced,  lrtest.reduced.lower= lrtest.reduced.lower, lrtest.reduced.upper=lrtest.reduced.upper,  n.components=n.components,component.number=component.number, num.features=fitred$num.features,  sign.wt=sign.wt, type=type,call=this.call))
}
superpc.predictionplot <- function (train.obj, data, data.test,  threshold, n.components=3,  n.class=2, shrinkage=NULL, call.win.metafile=FALSE)
{
  



BIG=1000
  
this.call=match.call()
  
if(n.components>3){
     stop("n.components cannot be bigger than 3")
}

if(is.null(shrinkage)){ fit.cts=superpc.predict(train.obj, data, data.test, threshold=threshold, n.components=n.components, prediction.type="continuous")


  pred.cts=superpc.fit.to.outcome(train.obj, data.test, fit.cts$v.pred[,1:n.components])$results 


pred.cts.1df=superpc.fit.to.outcome(train.obj, data.test, fit.cts$v.pred.1df)$results

                               }
else  {

     fit.cts=superpc.predict.red(train.obj, data, data.test, threshold=threshold, n.components=n.components,  shrinkage=shrinkage)


pred.cts=superpc.fit.to.outcome(train.obj, data.test,fit.cts$v.test[,,1:n.components])$results


pred.cts.1df=superpc.fit.to.outcome(train.obj, data.test, fit.cts$v.test.1df[1,])$results

   }



if(call.win.metafile){win.metafile()}


if(train.obj$type=="survival"){

if(n.components==1){layout(matrix(c(1,2),1,2, byrow = TRUE),width=c(.70,.30),heights=c(1,1))}

if(n.components==2){layout(matrix(c(1,4,2,5,3,6),3,2, byrow = TRUE),width=c(.70,.30),heights=c(.34,.33,.33))}

if(n.components==3){layout(matrix(c(1,5,2,6,3,7,4,8),4,2, byrow = TRUE),width=c(.70,.30),heights=rep(.25,4))}


if(is.null(shrinkage)){
  fit.groups<- superpc.predict(train.obj, data, data.test, threshold=threshold, n.components=n.components, prediction.type="discrete", n.class=n.class)


pred.groups=superpc.fit.to.outcome(train.obj,  data.test, fit.groups$v.pred)$results


pred.groups.1df=superpc.fit.to.outcome(train.obj,  data.test, fit.groups$v.pred.1df)$results


}
 else{
   
 fit.groups<- superpc.predict.red(train.obj, data, data.test, threshold=threshold, n.components=n.components, shrinkage=shrinkage, prediction.type="discrete", n.class=n.class)


pred.groups=superpc.fit.to.outcome(train.obj,  data.test,fit.groups$v.test[,,1])$results

pred.groups.1df=superpc.fit.to.outcome(train.obj, data.test, fit.groups$v.test.1df[1,])$results


}


lastc=2+(n.class-1)
par(mar=c(5,4,2,0))
for(i in 1:n.components){
if(is.null(shrinkage)){
plot(survfit(Surv(data.test$y,data.test$censoring.status)~fit.groups$v.pred[,i]), col=2:lastc, xlab="time", ylab="Prob survival")
}
else{
 plot(survfit(Surv(data.test$y,data.test$censoring.status)~fit.groups$v.test[1,,i]), col=2:lastc, xlab="time", ylab="Prob survival")
}

if(n.class==2){legend(.7*max(data.test$y), .8,lty=c(1,1),col=2:lastc,c("low score","high score"))}

if(n.class==3){legend(.7*max(data.test$y), .8,lty=c(1,1,1),col=2:lastc,c("low score","medium score", "high score"))}

title(main=paste("Component",as.character(i),sep=" "))
}

# if  number of  components >1, plot combined predictor curves

if(n.components>1){
  if(is.null(shrinkage)){
plot(survfit(Surv(data.test$y,data.test$censoring.status)~fit.groups$v.pred.1df), col=2:lastc, xlab="time", ylab="Prob survival")
}
else{
 plot(survfit(Surv(data.test$y,data.test$censoring.status)~fit.groups$v.test.1df[1,]), col=2:lastc, xlab="time", ylab="Prob survival")
}

if(n.class==2){legend(.7*max(data.test$y), .8,lty=c(1,1),col=2:lastc,c("low score","high score"))}

if(n.class==3){legend(.7*max(data.test$y), .8,lty=c(1,1,1),col=2:lastc,c("low score","medium score", "high score"))}

  title(main=" Combined 1 degree of freedom predictor")
}



coefs=cbind(pred.cts$coef,pred.groups$coef)
se=cbind(sqrt(diag(pred.cts$var)), sqrt(diag(pred.groups$var)))
relrisk=exp(coefs)
relrisk[relrisk>BIG] =1/0
pvalue.univ=2*(1-pnorm(abs(coefs/se)))


lograt.stat=2*c(pred.cts$loglik[2]-pred.cts$loglik[1], pred.groups$loglik[2]-pred.groups$loglik[1])
if(n.components==1) {lograt.stat[2]=2*c(pred.groups$loglik[2]-pred.groups$loglik[1])}

pvalue=c(NA,NA)
pvalue[1]=1-pchisq(lograt.stat[1],1)
pvalue[2]=1-pchisq(lograt.stat[2],n.class-1)



res=NULL
rownames=NULL

for(i in 1:n.components){
temp=rbind(coefs[i,], se[i,],relrisk[i,], pvalue[i,])

#for group column, only p-value is menaingful
temp[1:(nrow(temp)-1),2]=NA

res=rbind(res,temp)
if(n.components==1){rownames=c(rownames,"coef","se","relrisk", "pvalue") }

if(n.components>1){rownames=c(rownames,paste("coef",i,sep=""), ,paste("se",i,sep=""), ,paste("relrisk",i,sep=""), paste("pvalue",i,sep="")) }
}
res=round(rbind(res,lograt.stat, pvalue),2)


browser()

rownames=c(rownames,"LR stat","pvalue")

#par(mar=c(5,1,2,2))
par(mar=c(1,1,1,0))
par(cex=.8)
leftcol= 0
midcol=.3
rightcol=.6
nrows=nrow(res)
plot(0,0,xlim=c(0,1),ylim=c(0,1),type="n",axes=F,xlab="",ylab="")
xc=c(midcol,rightcol)
if(n.components==1){ yinc=.03}
if(n.components==2){ yinc=.07}
if(n.components==3){ yinc=.11}
yc=1-(1:nrows)*yinc
#yc[(length(yc)-1)]= yc[(length(yc)-1)]-yinc/3
#yc[(length(yc))]= yc[(length(yc))]-yinc/3

# write out first block of results
for(j in 1:4){
 text(leftcol,yc[j],rownames[j], pos=4, col=4)
}
text(midcol,1, "Linear", pos=4, col=4)
text(rightcol,1, "Grouped", pos=4, col=4)
for(j in 1:4){
for(i in 1:2){
  text(xc[i],yc[j],labels=as.character(res[j,i]),  pos=4)
}}

if(n.components>1){
# write out 2nd block of results
plot(0,0,xlim=c(0,1),ylim=c(0,1),type="n",axes=F,xlab="",ylab="")  
 for(j in 5:8){
 text(leftcol,yc[j-3],rownames[j], pos=4, col=4)
}
text(midcol,1, "Linear", pos=4, col=4)
text(rightcol,1, "Grouped", pos=4, col=4)
for(j in 5:8){
for(i in 1:2){
  jj=j-3
  text(xc[i],yc[jj],labels=as.character(res[j,i]),  pos=4)
}}}

 if(n.components>2){
# write out 3rd block of results
plot(0,0,xlim=c(0,1),ylim=c(0,1),type="n",axes=F,xlab="",ylab="")  
 for(j in 9:12){
 text(leftcol,yc[j-6],rownames[j], pos=4, col=4)
}
text(midcol,1, "Linear", pos=4, col=4)
text(rightcol,1, "Grouped", pos=4, col=4)
for(j in 9:12){
for(i in 1:2){
  jj=j-6
  text(xc[i],yc[jj],labels=as.character(res[j,i]),  pos=4)
}}}

if(n.components>1){
  # write out combined 1df predictor results
#  for(i in 1:(n.components-1)){
#  plot(0,0,type="n",axes=F,xlab="",ylab="")
#}
 plot(0,0,xlim=c(0,1),ylim=c(0,1),type="n",axes=F,xlab="",ylab="") 
  text(midcol,1, "Linear", pos=4, col=4)
  text(rightcol,1, "Grouped", pos=4, col=4)
  
  lograt.stat=2*c(pred.cts.1df$loglik[2]-pred.cts.1df $loglik[1], pred.groups.1df$loglik[2]-pred.groups.1df$loglik[1])
  pvalue=c(NA,NA)
pvalue[1]=1-pchisq(lograt.stat[1],1)
pvalue[2]=1-pchisq(lograt.stat[2],1)
  res=rbind(lograt.stat, pvalue)
  res=round(res,2)
  rownames=c("LR stat","pvalue")
  nrows=2
  yc=1-(1:nrows)*yinc
  for(j in 1:nrows){
    text(leftcol,yc[j],rownames[j], pos=4, col=4)
  }
  for(j in 1:nrows){
    for(i in 1:2){
  text(xc[i],yc[j],labels=as.character(res[j,i]),  pos=4)
}}
par(cex=1)

}}

if(train.obj$type=="regression"){
layout(matrix(c(1,2),1,2, byrow = TRUE),width=c(.6,.40),heights=c(1,1))

par(mar=c(5,4,2,1))

plot(data.test$y, fit.cts$v.pred.1df, xlab="outcome",ylab="predicted outcome")


res=round(t(summary(pred.cts)$coef),3)

rownames=c("coef", "se","T stat","pvalue")

par(mar=c(5,1,2,1))

par(cex=.7)
leftcol= 0
midcol=.21
midcol2= .42
rightcol=.63
rightcol2=.84
nrows=nrow(res)
plot(0,0,xlim=c(0,1),ylim=c(0,1),type="n",axes=F,xlab="",ylab="")
xc=c(midcol,midcol2,rightcol, rightcol2)
yinc=.05
yc=1-(1:nrows)*yinc

for(j in 1:nrows){
 text(leftcol,yc[j],rownames[j], pos=4, col=4)
}
   
text(midcol,1, "Intcpt", pos=4, col=4)

if(n.components==1){
text(midcol2,1, "Comp", pos=4, col=4)
}
if(n.components==2){
text(midcol2,1, "Comp1", pos=4, col=4)
text(rightcol,1, "Comp2", pos=4, col=4)
}
if(n.components==3){
text(midcol2,1, "Comp1", pos=4, col=4)
text(rightcol,1, "Comp2", pos=4, col=4)
text(rightcol2,1, "Comp3", pos=4, col=4)
}

for(j in 1:nrows){
for(i in 1:ncol(res)){
  text(xc[i],yc[j],labels=as.character(res[j,i]),  pos=4)
}}
ylast=yc[nrows]

 junk=summary(pred.cts.1df)$fstat

fstat=junk[1]
pvalue=1-pf(fstat,junk[2],junk[3])
 

text(leftcol,ylast-2*yinc, "F-stat",pos=4,col=4)
text(midcol2,ylast-2*yinc, round(fstat,5),pos=4)
text(leftcol,ylast-3*yinc, "pvalue",pos=4, col=4)
text(midcol2,ylast-3*yinc, round(pvalue,5),pos=4)
par(cex=1)
}


if(call.win.metafile){dev.off()}


}


permute.rows <-function(x)
{
        dd <- dim(x)
        n <- dd[1]
        p <- dd[2]
        mm <- runif(length(x)) + rep(seq(n) * 10, rep(p, n))
        matrix(t(x)[order(mm)], n, p, byrow = TRUE)
}

superpc.cv <- function (fit, data,  n.threshold = 20, 
                        n.fold = NULL, folds=NULL,  n.components=3,
                        min.features=5, max.features=nrow(data$x),
                        compute.fullcv=TRUE, compute.preval=TRUE, 
                        xl.mode=c("regular","firsttime","onetime","lasttime"),
                        xl.time=NULL, xl.prevfit=NULL)
  
{
                                        # cross-validation for supervised PCs;
                                        # returns both  preval cv and fullcv (if requested)  

  
  
  this.call <- match.call()

  xl.mode=match.arg(xl.mode)  
  
  if(xl.mode=="regular" | xl.mode=="firsttime"){
    type <- fit$type
    if(n.components>5){ cat("Max # of components is 5",fill=TRUE)}

    n.components <- min(5, n.components)

    if(type=="survival" & is.null(n.fold)& is.null(folds)){ n.fold=2}
    if(type=="regression" & is.null(n.fold) & is.null(folds)){ n.fold=10}


    n <- ncol(data$x)
    cur.tt <- fit$feature.scores

    lower <- quantile(abs(cur.tt), 1 - (max.features/nrow(data$x)))
    upper <- quantile(abs(cur.tt), 1 - (min.features/nrow(data$x)))

    if(!is.null(folds)){n.fold=length(folds)}
    
    if(is.null(folds)){
      if(type=="survival" & sum(data$censoring.status==0)>0){
        folds=balanced.folds(data$censoring.status, nfolds=n.fold)
        folds=c(folds,balanced.folds(data$censoring.status, nfolds=n.fold))
        folds=c(folds,balanced.folds(data$censoring.status, nfolds=n.fold))
        folds=c(folds,balanced.folds(data$censoring.status, nfolds=n.fold))
        folds=c(folds,balanced.folds(data$censoring.status, nfolds=n.fold))
        n.fold=length(folds)
      }
        else{
        folds<-vector("list",n.fold)
        breaks <- round(seq(from = 1, to = (n + 1), length = (n.fold +
                              1)))
        cv.order <- sample(1:n)
        for(j in 1:n.fold){
          folds[[j]]<-cv.order[(breaks[j]):(breaks[j + 1] - 1)]
        }
      }
      
    }
    featurescores.folds <- matrix(nrow=nrow(data$x), ncol= n.fold)

    thresholds <- seq(from = lower, to = upper, length = n.threshold)
    nonzero <- rep(0, n.threshold)
    scor <- array(NA, c(n.components, n.threshold, n.fold))
    scor.preval<-matrix(NA,nrow=n.components, ncol=n.threshold)
    scor.lower=NULL
    scor.upper=NULL

    v.preval<-array(NA,c(n,n.components,n.threshold))
  }

                                        # save arguments for subsequent calls from Excel

  if(xl.mode=="onetime" |  xl.mode=="lasttime"){
    type=xl.prevfit$type
    scor=xl.prevfit$scor
    scor.preval=xl.prevfit$scor.preval
    scor.lower=xl.prevfit$scor.lower
    scor.upper=xl.prevfit$scor.upper
    v.preval=xl.prevfit$v.preval
    folds=xl.prevfit$folds
    n.fold=xl.prevfit$n.fold
    nonzero=xl.prevfit$nonzero
    featurescores.folds=xl.prevfit$featurescores.folds
    n.threshold=xl.prevfit$n.threshold
    thresholds=xl.prevfit$thresholds
    compute.fullcv=compute.fullcv
    compute.preval=compute.preval
  }


                                        # note, unlike in superpc.predict, we do not flip the signs of the latent
                                        #factors. I don;t think this will cause a problem!

  if(xl.mode=="regular"){
    first=1;last=n.fold
  }
  if(xl.mode=="firsttime"){
    first=1;last=1
  }
  if(xl.mode=="onetime"){
    first=xl.time;last=xl.time
  }
  if(xl.mode=="lasttime"){
    first=n.fold;last=n.fold
  }

  

  for (j in first:last) {
    cat("",fill=TRUE)
    cat(c("fold=",j),fill=TRUE)
    data.temp=list(x=data$x[,-folds[[j]]], y=data$y[-folds[[j]]], censoring.status=data$censoring.status[-folds[[j]]])
    cur.tt <- superpc.train(data.temp, type=type, s0.perc=fit$s0.perc)$feature.scores
    featurescores.folds[,j]<- cur.tt
    for (i in 1:n.threshold) {
      cat(i)
      cur.features <- (abs(cur.tt) > thresholds[i])
      if(sum(cur.features)>1){
        
        nonzero[i] <-  nonzero[i]+sum(cur.features)/n.fold
        
        

#cat("bef svd",fill=T)
        cur.svd <- mysvd(data$x[cur.features, -folds[[j]]],n.components=n.components)

#cat("aft svd",fill=T)
        xtemp=data$x[cur.features, folds[[j]], drop=FALSE]

        xtemp<- t(scale(t(xtemp),center=cur.svd$feature.means, scale=F))
        cur.v.all <- scale(t(xtemp )%*% cur.svd$u, center=FALSE,scale=cur.svd$d)



        n.components.eff<- min(sum(cur.features),n.components)
        cur.v  <- cur.v.all[,1:n.components.eff]


        v.preval[folds[[j]],1:n.components.eff, i]<-cur.v

        if(compute.fullcv){
          for (k in 1:ncol(cur.v)) {
            if(type=="survival"){
require(survival)
              junk <- coxph(Surv(data$y[folds[[j]]], data$censoring.status[folds[[j]]]) ~cur.v[, 1:k], control=coxph.control(iter.max=10))$loglik

              scor[k,i, j]<-2*(junk[2]-junk[1]) 
            }
            else{
              junk<-summary(lm(data$y[folds[[j]]]~cur.v[, 1:k]))
              scor[k,i,j]<- junk$fstat[1]
            }

          }
        }
      }
    }
  }
  cat("\n")

  if(xl.mode=="regular" | xl.mode=="lasttime"){

    mean.na<- function(x){mean(x[!is.na(x)])}
    se.na<- function(x){
val=NA
if(sum(!is.na(x))>0){val=sqrt(var(x[!is.na(x)])/sum(!is.na(x)) )}
return(val)
}
lscor= apply(log(scor),c(1,2),mean.na)
se.lscor=apply(log(scor),c(1,2),se.na)
scor.lower=exp(lscor-se.lscor)
scor.upper=exp(lscor+se.lscor)

    scor<- exp(lscor)



    if(compute.preval){
      for(i in 1:n.threshold){
        for(j in 1:n.components){
          if(sum(is.na(v.preval[, 1:j, i]))==0){

            if(type=="survival"){
              require(survival)
              junk<-  coxph(Surv(data$y, data$censoring.status) ~v.preval[, 1:j, i])$loglik

              scor.preval[j,i]<- 2*(junk[2]-junk[1])
            }
            else{
              junk<-summary(lm(data$y~v.preval[, 1:j, i]))
              scor.preval[j,i]<- junk$fstat[1]
            }

          }
        }   }}
  }

  junk <- list(thresholds = thresholds, n.threshold=n.threshold, nonzero=nonzero, scor.preval=scor.preval, scor=scor, scor.lower=scor.lower,
scor.upper=scor.upper,
               folds=folds, n.fold=n.fold, featurescores.folds=featurescores.folds,  v.preval=v.preval,compute.fullcv=compute.fullcv, compute.preval=compute.preval,  type=type,  call = this.call)
  class(junk) <- "superpc.cv"
  return(junk)
}



"superpc.decorrelate" <- function (x, competing.predictors) {
foo<- lm(t(x)~., competing.predictors)
return(foo)
}


superpc.fit.to.outcome<- function(fit, data.test,score, competing.predictors=NULL,  print=TRUE, iter.max=5){


type=fit$type

if(type=="survival"){temp.list=makelist(data.test$y, data.test$censoring.status, score)}
if(type=="regression"){temp.list=makelist(data.test$y,NULL,  score)}

if(!is.null(competing.predictors)){
 temp.list=c(temp.list,competing.predictors)
}


 if(type=="survival"){
   require(survival)
   results<-coxph(Surv(y, censoring.status)~., data=temp.list, control=coxph.control(iter.max=iter.max))
}

 else{
   results<-lm(data.test$y~.,  data=temp.list)
}


if(print){print(summary(results))}


ss=summary(results)
if(type=="survival"){ test.stat=ss$logtest[1]
                      df=ss$logtest[2]
                      pvalue=ss$logtest[3]
                     }
if(type=="regression"){ test.stat=ss$fstat[1]
                      df=ss$fstat[2:3]
                      pvalue=1-pf(test.stat,df[1],df[2])
                     }

teststat.table=matrix(c(test.stat, df, pvalue), nrow=1)
if(length(df)==1){dflabel="df"}
if(length(df)==2){dflabel=c("df1", "df2")}

dimnames(teststat.table)=list(NULL,c("test statistic",dflabel,"p-value"))


return(list(results=results, teststat.table=teststat.table,  coeftable=ss$coef))
}

makelist=function (y, censoring.status, predictors)
{
    val = list(y = y)
    if (!is.null(censoring.status)) {
        val$censoring.status = censoring.status
    }
    if (!is.matrix(predictors)) {
        val$score.1 = predictors
    }

    if (is.matrix(predictors)) {
        if (ncol(predictors) > 3) {
            Stop("Can't have > 3 principal components")
        }
predictor.type=dimnames(predictors)[[2]]

if(is.null(dimnames(predictors)[[2]])){
  predictor.type=rep("continuous",ncol(predictors))
 }
        score1 = predictors[, 1]
        if(predictor.type[1]=="factor") {
            score1 = as.factor(score1)
        }
        val$score.1 = score1
        if (ncol(predictors) > 1) {
            score2 = predictors[, 2]
 if(predictor.type[2]=="factor") {
                score2 = as.factor(score2)
            }
            val$score.2 = score2
        }
        if (ncol(predictors) > 2) {
            score3 = predictors[, 3]
 if(predictor.type[3]=="factor") {
                score3 = as.factor(score3)
            }
            val$score.3 = score3
        }
    }
    return(val)
}
superpc.listfeatures<- function(data, train.obj, fit.red,  fitred.cv=NULL,
num.features=NULL, component.number=1){

ii=component.number
total.num=sum(abs(fit.red$import[,ii])>0)

if(is.null(num.features)){ num.features=total.num}

if(num.features< 1 | num.features > total.num){

    stop("Error: num.features   argument out of range")

}

featurenames.short<- substring(data$featurenames,1,40)



oo=rank(abs(fit.red$import[,ii]))> nrow(data$x)-num.features

res<-cbind(round(fit.red$import[oo,ii],3), round(train.obj$feature.scores[oo],3),
#round(fit.red$wt[oo,ii],3),
 featurenames.short[oo])

collabs=c("Importance-score", "Raw-score" , "Name")

if(!is.null(data$featureid)){
  res=cbind(res, data$featureid[oo])
 collabs=c(collabs, "ID")
}

if(!is.null(fitred.cv)){
nfold=ncol(fitred.cv$import.cv)

ind=matrix(F,nrow=nrow(data$x),ncol=nfold)
ranks=NULL
for( j in 1:nfold){
          r <- fitred.cv$import.cv[,j,component.number]
        ranks=cbind(ranks,rank(-abs(r)))

  junk=  fitred.cv$import.cv[,j, component.number]!=0
        ind[junk,j]=T
}

av.rank=apply(ranks,1,median)
av.rank=round(av.rank[oo],2)
prop=apply(ind[oo,,drop=F],1,sum)/nfold
res=cbind(res,av.rank,prop)
collabs=c(collabs,"median-rank-in-CV","prop-selected-in-CV")
}


o<-order(-abs(fit.red$import[oo,ii]))
res<-res[o,]
dimnames(res)<-list(NULL,collabs)

return(res)
}
superpc.lrtest.curv <- function (object, data, newdata, n.components=1, threshold=NULL,  n.threshold=20)
{

  this.call <- match.call()

                                        # compute lrtest statistics based on fit "object", training data "data",
                                        # and test  data "newdata",
                                        # over a set of threshold values

  type=object$type

  if(!is.null(threshold)) {n.threshold=length(threshold)}
  if(is.null(threshold)){
    second.biggest<- -sort(-abs(object$feature.scores))[2]
    threshold<- seq(0,second.biggest, length=n.threshold)
  }

  n.pc <- n.components
  lrtest<-rep(NA, n.threshold)
  num.features<-rep(NA, n.threshold)


  cat("",fill=TRUE)
  for(ii in 1:n.threshold){
    cat(ii)

    object.temp<- superpc.predict(object, data, newdata,threshold=threshold[ii], n.components=n.pc)
    
    num.features[ii]<- sum(object.temp$which.features)
    
    v.pred<-object.temp$v.pred
    
    
    if(type=="survival"){
      require(survival)
      junk<- coxph(Surv(newdata$y, newdata$censoring.status) ~v.pred)$loglik
      lrtest[ii]<-2*(junk[2]-junk[1])
    }
    else{junk<- summary(lm(newdata$y~v.pred))
         lrtest[ii]<-junk$fstat[1]
       }

  }
  cat("",fill=TRUE)

  return(list(lrtest=lrtest,threshold=threshold,num.features=num.features, type=type, call=this.call))
}
cor.func<- 

function (x, y, s0.perc ) 
{
    n <- length(y)
    xbar <- x %*% rep(1/n, n)
    sxx <- ((x - as.vector(xbar))^2) %*% rep(1, n)
    sxy <- (x - as.vector(xbar)) %*% (y - mean(y))
    syy <- sum((y - mean(y))^2)
    numer <- sxy/sxx
    sd <- sqrt((syy/sxx - numer^2)/(n - 2))

if(is.null(s0.perc)){ fudge=median(sd)}
if(!is.null(s0.perc)){
 if(s0.perc>=0){
  fudge=quantile(sd,s0.perc)
  }
 if(s0.perc<0){
   fudge=0
  }
}
    tt <- numer/(sd + fudge)

    return(list(tt = tt, numer = numer, sd = sd, fudge=fudge ))
}

coxfunc <- 
function(x, y, censoring.status, s0.perc)
{

        junk <- coxscor(x, y, censoring.status)
        scor<-junk$scor
        sd <- sqrt(coxvar(x, y, censoring.status, coxstuff.obj=junk$coxstuff.obj))

if(is.null(s0.perc)){ fudge=median(sd)}
if(!is.null(s0.perc)){
if(s0.perc>=0){
  fudge=quantile(sd,s0.perc)
  }
 if(s0.perc<0){
   fudge=0
  }


}

        tt <- scor/(sd + fudge)

        return(list(tt = tt, numer = scor, sd = sd, fudge=fudge ))
}


coxscor <- 
function(x, y, ic, offset = rep(0., length(y)))
{
        # computes cox scor function for rows of nx by n matrix  x
 # first put everything in time order
        n <- length(y)
        nx <- nrow(x)
        yy <- y + (ic == 0.) * (1e-05)
        otag <- order(yy)
        y <- y[otag]
        ic <- ic[otag]
        x <- x[, otag, drop = F]
        #compute  unique failure times, d=# of deaths at each failure time, 
        #dd= expanded version of d to length n, s=sum of covariates at each
        # failure time, nn=#obs in each risk set, nno=sum(exp(offset)) at each failure time
        offset <- offset[otag]
        a <- coxstuff(x, y, ic, offset = offset)
        nf <- a$nf
        fail.times <- a$fail.times
        s <- a$s
        d <- a$d
        dd <- a$dd
        nn <- a$nn
        nno <- a$nno
        w <- rep(0., nx)
        for(i in (1.:nf)) {
                w <- w + s[, i]
                oo<- (1.:n)[y >= fail.times[i]]
                r<-rowSums(x[, oo, drop = F] * exp(offset[oo]))
                w<- w - (d[i]/nno[i])*r 
        }
        return(list(scor = w, coxstuff.obj = a))
}



 coxvar <- 
function(x, y, ic, offset = rep(0., length(y)), coxstuff.obj = NULL)
{
        # computes information elements (var) for cox
        # x is nx by n matrix of expression  values
        nx <- nrow(x)
        n <- length(y)
        yy <- y + (ic == 0.) * (1e-06)
        otag <- order(yy)
        y <- y[otag]
        ic <- ic[otag]
        x <- x[, otag, drop = F]
        offset <- offset[otag]
        if(is.null(coxstuff.obj)) {
                coxstuff.obj <- coxstuff(x, y, ic, offset = offset)
        }
        nf <- coxstuff.obj$nf
        fail.times <- coxstuff.obj$fail.times
        s <- coxstuff.obj$s
        d <- coxstuff.obj$d
        dd <- coxstuff.obj$dd
        nn <- coxstuff.obj$nn
        nno <- coxstuff.obj$nno

x2<- x^2
oo <- (1.:n)[y >= fail.times[1] ]
sx<-(1/nno[1])*rowSums(x[, oo] * exp(offset[oo]))
s<-(1/nno[1])*rowSums(x2[, oo] * exp(offset[oo]))
w <-  d[1] * (s - sx * sx)


       for(i in 2.:nf) {
           oo <- (1.:n)[y >= fail.times[i-1] & y < fail.times[i] ]
      sx<-(1/nno[i])*(nno[i-1]*sx-rowSums(x[, oo,drop=F] * exp(offset[oo])))
         s<-(1/nno[i])*(nno[i-1]*s-rowSums(x2[, oo,drop=F] * exp(offset[oo])))
       w <- w + d[i] * (s - sx * sx)
        }
        return(w)
}




coxstuff<-
function(x, y, ic, offset = rep(0., length(y)))
{
        fail.times <- unique(y[ic == 1.])
        nf <- length(fail.times)
        n <- length(y)
        nn <- rep(0., nf)
        nno <- rep(0., nf)
        for(i in 1.:nf) {
                nn[i] <- sum(y >= fail.times[i])
                nno[i] <- sum(exp(offset)[y >= fail.times[i]])
        }
        s <- matrix(0., ncol = nf, nrow = nrow(x))
        d <- rep(0., nf)
        #expand d out to a vector of length n
        for(i in 1.:nf) {
                o <- (1.:n)[(y == fail.times[i]) & (ic == 1.)]
                d[i] <- length(o)
}
         oo <- match(y, fail.times)
         oo[ic==0]<-NA
         oo[is.na(oo)]<- max(oo[!is.na(oo)])+1
         s<-t(rowsum(t(x),oo))
       if(ncol(s)> nf){s<-s[,-ncol(s)]}
        dd <- rep(0., n)
        for(j in 1.:nf) {
                dd[(y == fail.times[j]) & (ic == 1.)] <- d[j]
        }
        return(list(fail.times=fail.times, s=s, d=d, dd=dd, nf=nf, nn=nn, nno=nno))
}


 ocoxvar <-
function(x, y, ic, offset = rep(0., length(y)), coxstuff.obj = NULL)
{
        # computes information elements (var) for cox
        # x is nx by n matrix of expression  values
        nx <- nrow(x)
        n <- length(y)
        yy <- y + (ic == 0.) * (1e-06)
        otag <- order(yy)
        y <- y[otag]
        ic <- ic[otag]
        x <- x[, otag, drop = F]
        offset <- offset[otag]
        if(is.null(coxstuff.obj)) {
                coxstuff.obj <- coxstuff(x, y, ic, offset = offset)
        }
        nf <- coxstuff.obj$nf
        fail.times <- coxstuff.obj$fail.times
        s <- coxstuff.obj$s
        d <- coxstuff.obj$d
        dd <- coxstuff.obj$dd
        nn <- coxstuff.obj$nn
        nno <- coxstuff.obj$nno
        w <- rep(0., nx)
 x2<- x^2
        for(i in 1.:nf) {
                oo <- (1.:n)[y >= fail.times[i]]
      sx<-(1/nno[i])*rowSums(x[, oo] * exp(offset[oo]))
         s<-(1/nno[i])*rowSums(x2[, oo] * exp(offset[oo]))
       w <- w + d[i] * (s - sx * sx)
        }
        return(w)
}


mysvd<-function(x,  n.components=NULL){
# finds PCs of matrix x
  p<-nrow(x)
  n<-ncol(x)

# center the observations (rows)

 feature.means<-rowMeans(x)
x<- t(scale(t(x),center=feature.means,scale=F))


  if(is.null(n.components)){n.components=min(n,p)}
  if(p>n){
    a<-eigen(t(x)%*%x)
    v<-a$vec[,1:n.components,drop=FALSE]
    d<-sqrt(a$val[1: n.components,drop=FALSE])
    
      u<-scale(x%*%v,center=FALSE,scale=d)
 
    
    return(list(u=u,d=d,v=v,  feature.means=feature.means))
  }
  else{

      junk<-svd(x,LINPACK=TRUE)
      nc=min(ncol(junk$u), n.components)
      return(list(u=junk$u[,1:nc],d=junk$d[1:nc],
                  v=junk$v[,1:nc], feature.means=feature.means))
}
}
superpc.plot.lrtest<- function(object.lrtestcurv, call.win.metafile=FALSE){

if(call.win.metafile) {win.metafile()}

  plot(object.lrtestcurv$threshold, object.lrtestcurv$lrtest,xlab="Threshold",ylab="Likelihood ratio statistic",type="b")

if(call.win.metafile) {dev.off()}

}
  
superpc.plotcv=
function (object, cv.type=c("full","preval"),smooth = TRUE, smooth.df = 10, call.win.metafile=FALSE, ...)
{

cv.type=match.arg(cv.type)

if(cv.type=="full"){
 scor=object$scor
 smooth=FALSE
 }
else{
    scor = object$scor.preval
}
k=nrow(scor)
    if (smooth) {
        for (j in 1:nrow(scor)) {
         if(is.null(smooth.df)){
               om=!is.na(scor[j, ])
               junk=smooth.spline(object$th[om], scor[j,om ])
               scor[j,om] = predict(junk,object$th[om])$y
              }
            if(!is.null(smooth.df)){
               om=!is.na(scor[j, ])
             junk=smooth.spline(object$th[om], scor[j,om ], df=smooth.df)
            scor[j,om] =predict(junk,object$th[om])$y
             }
        }
    }

if(object$type=="survival"){
if(cv.type=="full"){    ymax = max(object$scor.upper[!is.na(object$scor.upper)], qchisq(0.95, nrow(scor)))}
if(cv.type=="preval"){    ymax = max(scor[!is.na(scor)], qchisq(0.95, nrow(scor)))}
}

if(object$type=="regression"){
  # df of denom for f is average sample size in validation fold

n.mean=0
for(i in 1:object$n.fold){
   n.mean=n.mean+length(object$folds[[i]])/object$n.fold
}
   denom.df=n.mean-1-nrow(scor)
if(cv.type=="full"){    ymax = max(object$scor.upper[!is.na(object$scor.upper)], qf(0.95, nrow(scor), denom.df))}
if(cv.type=="preval"){    ymax = max(scor[!is.na(scor)], qf(0.95, nrow(scor), denom.df))}
}

if(call.win.metafile){win.metafile()}

# if(object$type=="survival"){ ylab="Likelihood ratio test statistic"}
#if(object$type=="regression"){ ylab="F statistic"}

ylab="Likelihood ratio test statistic"

    matplot(object$th, t(scor), xlab = "Threshold", ylab = ylab, ylim = c(0, ymax), lty=rep(1,k))
    matlines(object$th, t(scor), lty=rep(1,k), ...)


    for (j in 1:k) {
      if(object$type=="survival"){  abline(h = qchisq(0.95, j), lty = 2, col = j)}
       if(object$type=="regression"){
         # df of denom for f is average sample size in validation fold
         abline(h = qf(0.95, j, denom.df), lty = 2, col = j)
       }
if(cv.type=="full"){
delta=((-1)^j)*diff(object$th)[1]/4
error.bars(object$th+delta*(j>1),t(object$scor.lower[j,]),
 t(object$scor.upper[j,]),lty=2, col=j)
}
    }


if(call.win.metafile){dev.off()}
return(TRUE)

}

error.bars <-function(x, upper, lower, width = 0.005, ...) {
  xlim <- range(x)
  barw <- diff(xlim) * width
  segments(x, upper, x, lower, ...)
  segments(x - barw, upper, x + barw, upper, ...)
  segments(x - barw, lower, x + barw, lower, ...)
  range(upper, lower)
}
jitter<-
function(x)
{
        x + 0.03 * abs(x) * sign(rnorm(length(x)))
}


superpc.plotred.lrtest<- function(object.lrtestred, call.win.metafile=FALSE){
  
if(call.win.metafile) {win.metafile()}

n.components=object.lrtestred$n.components

na.range=function(x){range(x[!is.na(x)])}

  if(!is.null(object.lrtestred$lrtest.reduced.lower)){
ylim=na.range(c(object.lrtestred$lrtest.reduced.lower, object.lrtestred$lrtest.reduced.upper))
}
else{ylim=na.range(object.lrtestred$lrtest.reduced)}

if(n.components==2){par(mfrow=c(1,2))}
if(n.components==3){par(mfrow=c(2,2))}
par(mar=c(6,4,5,2))

for(j in 1:n.components){
ylab=paste("LR statistic, #Components=",as.character(j),sep="")
plot(object.lrtestred$shrinkages, object.lrtestred$lrtest.reduced[,j],xlab="Shrinkage amount",ylab=ylab, ylim=ylim,type="b")

abline(h = qchisq(0.95, j), lty = 2)

if(!is.null(object.lrtestred$lrtest.reduced.lower)){
error.bars(object.lrtestred$shrinkages, object.lrtestred$lrtest.reduced.lower[,j],
object.lrtestred$lrtest.reduced.upper[,j], lty=2)
}
axis(3,at=object.lrtestred$shrinkages, labels=as.character(object.lrtestred$num.features[,j]), cex=0.7)
mtext("Number of genes", 3, 4, cex = 0.8)
}


  

if(call.win.metafile){dev.off()}
return(TRUE)

}

error.bars <-function(x, upper, lower, width = 0.005, ...) {
  xlim <- range(x)
  barw <- diff(xlim) * width
  segments(x, upper, x, lower, ...)
  segments(x - barw, upper, x + barw, upper, ...)
  segments(x - barw, lower, x + barw, lower, ...)
  range(upper, lower)
}


superpc.predict <- function (object, data, newdata, threshold, n.components=3,  prediction.type=c("continuous", "discrete","nonzero"),  n.class=2)
{
  
#thresholds the feature scores at "threshold", computes svd based on "data", and then predicts based on  "newdata"

  
  this.call <- match.call()

  prediction.type <- match.arg(prediction.type)
  
 if(n.class>3){ stop("Maximum number of survival classes is 3")}
  
  which.features <- (abs(object$feature.scores) >= threshold)
  x.sml <- data$x[which.features, ]
  n.pc <- n.components

  
    x.sml.svd <- mysvd(x.sml, n.components=n.components)
  
  


  
  if (prediction.type=="nonzero") {
    if (!is.null(data$featurenames)) {
      out<- data$featurenames[which.features]
    }
    else {
      out<- (1:nrow(data$x))[which.features]
    }
  }

  if (prediction.type=="continuous" | prediction.type=="discrete") {
      xtemp=newdata$x[which.features,]
xtemp=t(scale(t(xtemp),center=x.sml.svd$feature.means,scale=F))

#new! weights are standardized to make PC more interpretable

scal=apply(scale(abs(x.sml.svd$u),center=F,scale=x.sml.svd$d),2,sum)

      cur.v <-scale( t(xtemp) %*%x.sml.svd$u,  center=FALSE,scale=scal*x.sml.svd$d)

xtemp0=data$x[which.features,]

xtemp0=t(scale(t(xtemp0),center=x.sml.svd$feature.means,scale=F))

      cur.v0 <-scale( t(xtemp0)%*%x.sml.svd$u,  center=FALSE,scale=scal*x.sml.svd$d)


    }

    
 #here we obtain the regression coefs of y on the latent factors
 # and flip the sign of the factors if the coef is negative

  
      result<-superpc.fit.to.outcome(object, data, cur.v0,  print=FALSE)$results

      if(object$type=="survival"){coef=result$coef}
      if(object$type=="regression"){coef=result$coef[-1]}




      if (prediction.type=="continuous") {
        out<-scale(cur.v, center=FALSE,scale= sign(coef))
v.pred.1df=apply(scale(out, center=FALSE,scale= 1/abs(coef)),1,sum)
      }
      else if (prediction.type=="discrete") {
        
        
out0<-scale(cur.v0, center=FALSE,scale= sign(coef))
v.pred0.1df=apply(scale(out0, center=FALSE,scale= 1/abs(coef)),1,sum)
        
        out<-scale(cur.v, center=FALSE,scale= sign(coef))
v.pred.1df=apply(scale(out, center=FALSE,scale= 1/abs(coef)),1,sum)

      # compute quantile cutpoints on training set; apply to test set  

        for(j in 1:ncol(out)){
          br=quantile(cur.v0[,j], (0:n.class)/n.class)
          out[,j]<-cut(out[,j],breaks=br,n.class,labels=FALSE)
          out[is.na(out[,j]),j]<-1
        }
 br=quantile(v.pred0.1df, (0:n.class)/n.class)
v.pred.1df<- cut(v.pred.1df,breaks=br,labels=FALSE)
v.pred.1df[is.na(v.pred.1df)]<-1


}

if(is.matrix(out)){  
   dimnames(out)=list(NULL,rep(prediction.type,ncol(out)))
 }



  junk <- list(v.pred=out, u = x.sml.svd$u, d = x.sml.svd$d, 
               which.features = which.features, v.pred.1df=v.pred.1df,
               n.components = n.pc, coef=result$coef,
               call = this.call, prediction.type=prediction.type)

  return(junk)
}

superpc.predict.red <- function(fit, data, data.test, threshold, n.components=3, n.shrinkage=20, shrinkages=NULL, compute.lrtest=TRUE, sign.wt="both", prediction.type=c("continuous","discrete"), n.class=2){
# try reduced predictor on test set

  
  soft.thresh<- function(x,tt){ sign(x)*(abs(x)-tt)*(abs(x)>tt)}


  this.call<- match.call()
  
  prediction.type=match.arg(prediction.type)

  type=fit$type

  if(!is.null(shrinkages)){ n.shrinkage=length(shrinkages)}

  lrtest.reduced<- matrix(NA,ncol=n.components,nrow=n.shrinkage)
  
  cur.vall<- array(NA,c(n.shrinkage,ncol(data$x),n.components))
  cur.vall.test<- array(NA, c(n.shrinkage,ncol(data.test$x),n.components))
  cur.vall.test.groups<- array(NA, c(n.shrinkage,ncol(data.test$x),n.components))
  cur.vall.1df<- matrix(NA, nrow=n.shrinkage,ncol=ncol(data$x))
  cur.vall.test.1df<- matrix(NA, nrow=n.shrinkage,ncol=ncol(data.test$x))

  corr.with.full<-matrix(NA,nrow=n.shrinkage, ncol=n.components)
  which.features <- abs(fit$feature.scores) > threshold
  x.sml <- data$x[which.features, ]
  x.svd <- mysvd(x.sml, n.components=n.components)
scal=apply(scale(abs(x.svd$u),center=F,scale=x.svd$d),2,sum)

  cur.v <- scale(t(data$x[which.features, ]) %*%x.svd$u, center=FALSE,scale=scal*x.svd$d)

  # flip the sign of the latent factors, if a coef is neg

  junk<-superpc.fit.to.outcome(fit,data, cur.v,  print=FALSE)
  if(fit$type=="survival"){coef=junk$coeftable[,1]}
  if(fit$type=="regression"){coef=junk$coeftable[-1,1]}

  cur.v<-scale(cur.v, center=FALSE,scale= sign(coef))
  ##

  train.means=apply(data$x,1,mean)
  xcen=t(scale(t(data$x), center=train.means,scale=F))
  xtest.cen=t(scale(t(data.test$x), center=train.means,scale=F))
  
#  import<-cor(t(data$x), cur.v)

  sc= xcen%*%cur.v
sc[abs(fit$feature.scores)< threshold]=0

import=sc



                                        # don't shrink all of the way to zero 
  maxshrink=max(abs(sc))

  if(sign.wt=="positive"){ maxshrink=max(abs(sc[sc>0]))}
  
  if(sign.wt=="negative"){ maxshrink=max(abs(sc[sc<0]))}

  
  if(is.null(shrinkages)){
    shrinkages<- seq(0,maxshrink,length=n.shrinkage+1)
    shrinkages= shrinkages[-(n.shrinkage+1)]
  }

  num.features<-matrix(NA,nrow=n.shrinkage, ncol=n.components)
  
  feature.list<-vector("list", n.shrinkage)


  for(i in 1:n.shrinkage){
    cat(i)
    sc2<- soft.thresh(sc,shrinkages[i])
    if(sign.wt=="positive"){sc2[sc2<0]<-0}
    if(sign.wt=="negative"){sc2[sc2>0]<-0}
    nonzero<-sc2!=0
    

    num.features[i,]<- apply(nonzero,2,sum)
    
    junk=vector("list",n.components)
    for(ii in 1:n.components){
      junk[[ii]]<- (1:nrow(xcen))[nonzero[,ii]]
    }
    feature.list[[i]]=junk

    for(ii in 1:n.components){
      cur.vall[i,,ii]<-apply(t(scale(t(xcen[nonzero[,ii],,drop=FALSE]), center=FALSE,scale=1/sc2[nonzero[,ii],ii])),2,mean)
      cur.vall.test[i,,ii]<-apply(t(scale(t(xtest.cen[nonzero[,ii],,drop=FALSE]), center=FALSE,scale=1/sc2[nonzero[,ii],ii])),2,mean)

                                        # find quantile break points on training data; apply to test data
      if(prediction.type=="discrete") {
        if(sum(is.na(cur.vall.test[i,,ii]))==0){
          br=quantile(cur.vall[i,,ii], (0:n.class)/n.class)
          cur.vall.test.groups[i,,ii]<-cut(cur.vall.test[i,,ii],breaks=br,labels=FALSE)
          o=is.na(cur.vall.test.groups[i,,ii])
          cur.vall.test.groups[i,o,ii]<-1
        }
        else{ cur.vall.test.groups[i,,ii]<-1}
      }
    }   
    
    cur.vall.1df[i,]=apply( scale(cur.vall[i,,],center=F,scale=1/coef),1,mean)
    cur.vall.test.1df[i,]=apply( scale(cur.vall.test[i,,],center=F,scale=1/coef),1,mean)
    

    if(prediction.type=="discrete") {
      if(sum(is.na(cur.vall.1df[i,]))==0){
        br=quantile(cur.vall.1df[i,], (0:n.class)/n.class)
        cur.vall.test.1df[i,]<- cut( cur.vall.test.1df[i,], breaks=br,labels=FALSE)
        o=is.na(cur.vall.test.1df[i,])
        cur.vall.test.1df[i,o]<-1
      }
  else{cur.vall.test.1df[i,]<-1}
     
   
       }

  }


 if(prediction.type=="continuous"){
   dimnames(cur.vall.test)=list(NULL,NULL,rep("continuous", dim(cur.vall.test)[3]))
 }

 if(prediction.type=="discrete"){
   cur.vall.test<- cur.vall.test.groups
   dimnames(cur.vall.test)=list(NULL,NULL, rep("factor", dim(cur.vall.test)[3]))
 }

  cat("",fill=TRUE)


  if(compute.lrtest){ 
for(ii in 1:n.components){
    for(i in 1:n.shrinkage){
      if(type=="survival"){
        require(survival)
        
# with too much shrinkage,
# all predictors may be shrunk to zero and Cox model bombs. I check for this first

         if(sum(is.na(cur.vall.test[i, , 1:ii]))==0){
junk=superpc.fit.to.outcome(fit, data.test, cur.vall.test[i,,1:ii], print=FALSE)$results$loglik
        lrtest.reduced[i,ii]=2*(junk[2]-junk[1])
        }
      }
      else{
         if(sum(is.na(cur.vall.test[i, , 1:ii]))==0){
junk=superpc.fit.to.outcome(fit, data.test, cur.vall.test[i,,1:ii], print=FALSE)
        if(!is.null(junk$fstat)){lrtest.reduced[i,ii]<-junk$results$fstat[1]}
      }
      }
    }
  }
}
  

  return(list(shrinkages=shrinkages, lrtest.reduced=lrtest.reduced, 
num.features=num.features, feature.list=feature.list, import=import,  v.test=cur.vall.test, coef=coef, v.test.1df= cur.vall.test.1df,
              n.components=n.components, sign.wt=sign.wt, type=type,call=this.call))
  
}



superpc.predict.red.cv <- function(fitred, fitcv, data, threshold,  sign.wt="both"){

 # try reduced predictor on cv folds, via full cross-validation

                           
  this.call=match.call()

  type=fitred$type

  n.components=fitred$n.components


  n.fold<-length(fitcv$folds)

  shrinkages<- fitred$shrinkages
  n.shrinkages<- length(shrinkages)
  cur.vall<- array(NA,c(n.shrinkages,ncol(data$x),n.components))

import.cv=array(NA,c(nrow(data$x), n.fold,n.components))

 lrtest.reduced<-array(NA,c(n.fold,n.shrinkages, n.components))

  for(j in 1:n.fold){
    cat(j,fill=TRUE)
    fit.temp<-list(feature.scores=fitcv$featurescores.fold[,j], type=type)
    ii<-fitcv$folds[[j]]
    
    data1<-list(x=data$x[,-ii],y=data$y[-ii],censoring.status=data$censoring.status[-ii])
    data2<-list(x=data$x[,ii],y=data$y[ii],censoring.status=data$censoring.status[ii])
    junk<- superpc.predict.red(fit.temp, data1,data2, threshold, shrinkages=shrinkages, n.components=n.components,  compute.lrtest=TRUE, sign.wt=sign.wt)
 lrtest.reduced[j,,]=junk$lrtest.reduced
import.cv[,j,]=junk$import
  }

 mean.na <- function(x) {
            mean(x[!is.na(x)])
        }
        se.na <- function(x) {
            val = NA
            if (sum(!is.na(x)) > 0) {
                val = sqrt(var(x[!is.na(x)])/sum(!is.na(x)))
            }
            return(val)
        }

   llr= apply(log(lrtest.reduced), c(2,3), mean.na)
        se.llr = apply(log(lrtest.reduced), c(2,3), se.na)
        lrtest.reduced.lower = exp(llr - se.llr)
        lrtest.reduced.upper = exp(llr + se.llr)
        lrtest.reduced <- exp(llr)


return(list(shrinkages=shrinkages, lrtest.reduced=lrtest.reduced,  lrtest.reduced.lower= lrtest.reduced.lower, lrtest.reduced.upper=lrtest.reduced.upper,  n.components=n.components, num.features=fitred$num.features,  sign.wt=sign.wt,import.cv=import.cv, type=type,call=this.call))
}
superpc.predictionplot <- function (train.obj, data, data.test,  threshold, n.components=3,  n.class=2, shrinkage=NULL, call.win.metafile=FALSE)
{
  



BIG=1000
  
this.call=match.call()
  
if(n.components>3){
     stop("n.components cannot be bigger than 3")
}

if(is.null(shrinkage)){ fit.cts=superpc.predict(train.obj, data, data.test, threshold=threshold, n.components=n.components, prediction.type="continuous")


  pred.cts=superpc.fit.to.outcome(train.obj, data.test, fit.cts$v.pred[,1:n.components], print=FALSE)$results 


pred.cts.1df=superpc.fit.to.outcome(train.obj, data.test, fit.cts$v.pred.1df, print=FALSE)$results

                               }
else  {

     fit.cts=superpc.predict.red(train.obj, data, data.test, threshold=threshold, n.components=n.components,  shrinkage=shrinkage)


pred.cts=superpc.fit.to.outcome(train.obj, data.test,fit.cts$v.test[,,1:n.components], print=FALSE)$results


pred.cts.1df=superpc.fit.to.outcome(train.obj, data.test, fit.cts$v.test.1df[1,], print=FALSE)$results

   }



if(call.win.metafile){win.metafile()}


if(train.obj$type=="survival"){

if(n.components==1){layout(matrix(c(1,2),1,2, byrow = TRUE),width=c(.80,.20),heights=c(1,1))}

if(n.components==2){layout(matrix(c(1,4,2,5,3,6),3,2, byrow = TRUE),width=c(.80,.20),heights=c(.34,.33,.33))}

if(n.components==3){layout(matrix(c(1,5,2,6,3,7,4,8),4,2, byrow = TRUE),width=c(.80,.20),heights=rep(.25,4))}


if(is.null(shrinkage)){
  fit.groups<- superpc.predict(train.obj, data, data.test, threshold=threshold, n.components=n.components, prediction.type="discrete", n.class=n.class)


pred.groups=superpc.fit.to.outcome(train.obj,  data.test, fit.groups$v.pred, print=FALSE)$results


pred.groups.1df=superpc.fit.to.outcome(train.obj,  data.test, fit.groups$v.pred.1df, print=FALSE)$results


}
 else{
   
 fit.groups<- superpc.predict.red(train.obj, data, data.test, threshold=threshold, n.components=n.components, shrinkage=shrinkage, prediction.type="discrete", n.class=n.class)


pred.groups=superpc.fit.to.outcome(train.obj,  data.test,fit.groups$v.test[,,1], print=FALSE)$results

pred.groups.1df=superpc.fit.to.outcome(train.obj, data.test, fit.groups$v.test.1df[1,], print=FALSE)$results


}

#plot survival curves

lastc=2+(n.class-1)
par(mar=c(5,4,2,1))
xmax=max(data.test$y)*1.5

for(i in 1:n.components){
if(is.null(shrinkage)){

plot(survfit(Surv(data.test$y,data.test$censoring.status)~fit.groups$v.pred[,i]), col=2:lastc, xlab="time", ylab="Prob survival", xlim=c(0,xmax))
}
else{
 plot(survfit(Surv(data.test$y,data.test$censoring.status)~fit.groups$v.test[1,,i]), col=2:lastc, xlab="time", ylab="Prob survival", xlim=c(0,xmax))
}


if(i==1 & n.class==2){legend(1.05*max(data.test$y), .8,lty=c(1,1),col=2:lastc,c("low score","high score"), cex=.8)}

if(i==1 & n.class==3){legend(1.05*max(data.test$y), .8, lty=c(1,1,1),col=2:lastc,c("low score","med score", "high score"), cex=.8)}


title(main=paste("Component",as.character(i),sep=" "))
}

# if  number of  components >1, plot combined predictor curves

if(n.components>1){
  if(is.null(shrinkage)){
plot(survfit(Surv(data.test$y,data.test$censoring.status)~fit.groups$v.pred.1df), col=2:lastc, xlab="time", ylab="Prob survival" , xlim=c(0,xmax))
}
else{
 plot(survfit(Surv(data.test$y,data.test$censoring.status)~fit.groups$v.test.1df[1,]), col=2:lastc, xlab="time", ylab="Prob survival" , xlim=c(0,xmax))
}


  title(main=" Combined predictor")
}

# output results on right ride of plot

res=NULL
rownames=NULL

for( ii in 1:n.components){
if(is.null(shrinkage)){
junk=superpc.fit.to.outcome(train.obj,  data.test, fit.groups$v.pred[,ii], print=FALSE)$results
}
else{
 junk=superpc.fit.to.outcome(train.obj,  data.test,fit.groups$v.test[,,ii], print=FALSE)$results
}

lr=round(2*(junk$loglik[2]-junk$loglik[1]),4)
likrat=c(lr, n.class-1,round(1-pchisq(lr,df=n.class),5))
res=c(res,likrat)
rownames=c(rownames,"LR stat", "df", "pvalue")
}





lr=round(2*(pred.groups.1df$loglik[2]-pred.groups.1df$loglik[1]),4)
likrat=c(lr, n.class-1,round(1-pchisq(lr,df=n.class),5))
res=c(res,likrat)
rownames=c(rownames,"LR stat", "df", "pvalue")



par(mar=c(1,1,1,0))
par(cex=.8)
leftcol= 0
midcol=.5
nrows=length(res)
plot(0,0,xlim=c(0,1),ylim=c(0,1),type="n",axes=F,xlab="",ylab="")
xc=c(midcol)
if(n.components==1){ yinc=.03}
if(n.components==2){ yinc=.07}
if(n.components==3){ yinc=.11}
yc=1-(1:nrows)*yinc

# write out first block of results
for(j in 1:3){
 text(leftcol,yc[j],rownames[j], pos=4, col=4)
}
#text(midcol,1, "Linear", pos=4, col=4)
for(j in 1:3){
  text(xc[1],yc[j],labels=as.character(res[j]),  pos=4)
}

if(n.components>1){
# write out 2nd block of results
plot(0,0,xlim=c(0,1),ylim=c(0,1),type="n",axes=F,xlab="",ylab="")  
 for(j in 4:6){
 text(leftcol,yc[j-3],rownames[j], pos=4, col=4)
}
for(j in 4:6){
  jj=j-3
  text(xc[1],yc[jj],labels=as.character(res[j]),  pos=4)
}}

 if(n.components>2){
# write out 3rd block of results
plot(0,0,xlim=c(0,1),ylim=c(0,1),type="n",axes=F,xlab="",ylab="")  
 for(j in 7:9){
 text(leftcol,yc[j-6],rownames[j], pos=4, col=4)
}
for(j in 7:9){
  jj=j-6
  text(xc[1],yc[jj],labels=as.character(res[j]),  pos=4)
}}

if(n.components>1){
  # write out combined 1df predictor results
#  for(i in 1:(n.components-1)){
#  plot(0,0,type="n",axes=F,xlab="",ylab="")
#}
 plot(0,0,xlim=c(0,1),ylim=c(0,1),type="n",axes=F,xlab="",ylab="") 
  
  nrows=3
  yc=1-(1:nrows)*yinc
  for(j in 1:nrows){
jj=length(res)-3+j
    text(leftcol,yc[j],rownames[jj], pos=4, col=4)
  }
  for(j in 1:nrows){
jj=length(res)-3+j
  text(xc[1],yc[j],labels=as.character(res[jj]),  pos=4)
}
}
}

if(train.obj$type=="regression"){
layout(matrix(c(1,2),1,2, byrow = TRUE),width=c(.6,.40),heights=c(1,1))

par(mar=c(5,4,2,1))

plot(data.test$y, fit.cts$v.pred.1df, xlab="outcome",ylab="predicted outcome")


res=round(t(summary(pred.cts)$coef),3)

rownames=c("coef", "se","T stat","pvalue")

par(mar=c(5,1,2,1))

par(cex=.7)
leftcol= 0
midcol=.21
midcol2= .42
rightcol=.63
rightcol2=.84
nrows=nrow(res)
plot(0,0,xlim=c(0,1),ylim=c(0,1),type="n",axes=F,xlab="",ylab="")
xc=c(midcol,midcol2,rightcol, rightcol2)
yinc=.05
yc=1-(1:nrows)*yinc

for(j in 1:nrows){
 text(leftcol,yc[j],rownames[j], pos=4, col=4)
}
   
text(midcol,1, "Intcpt", pos=4, col=4)

if(n.components==1){
text(midcol2,1, "Comp", pos=4, col=4)
}
if(n.components==2){
text(midcol2,1, "Comp1", pos=4, col=4)
text(rightcol,1, "Comp2", pos=4, col=4)
}
if(n.components==3){
text(midcol2,1, "Comp1", pos=4, col=4)
text(rightcol,1, "Comp2", pos=4, col=4)
text(rightcol2,1, "Comp3", pos=4, col=4)
}

for(j in 1:nrows){
for(i in 1:ncol(res)){
  text(xc[i],yc[j],labels=as.character(res[j,i]),  pos=4)
}}
ylast=yc[nrows]

 junk=summary(pred.cts.1df)$fstat

fstat=junk[1]
pvalue=1-pf(fstat,junk[2],junk[3])
 

text(leftcol,ylast-2*yinc, "F-stat",pos=4,col=4)
text(midcol2,ylast-2*yinc, round(fstat,5),pos=4)
text(leftcol,ylast-3*yinc, "pvalue",pos=4, col=4)
text(midcol2,ylast-3*yinc, round(pvalue,5),pos=4)
par(cex=1)
}


if(call.win.metafile){dev.off()}


}


superpc.rainbowplot=function(data, pred, sample.labels,  competing.predictors, call.win.metafile=FALSE){



extrapolate.surv<- function(y,ic,ncat=100){
cut<-seq(min(y),max(y),length=ncat)
b<-surv.to.class2(y,ic,cutoff=cut)
yhat<-b$prob[,-1]%*%cut
return(yhat)
}





yhat= extrapolate.surv(data$y,data$censoring.status)
yhat[data$censoring.status==1]=data$y[data$censoring.status==1]


ncomp.predictors=length(competing.predictors)

 if (call.win.metafile) {
        win.metafile(width=10,height=2+ncomp.predictors)
    }


npanels=2*(ncomp.predictors+4)
layout(matrix(1:npanels,ncomp.predictors+4,2, byrow = TRUE),width=c(.8,.2),heights=c(.2,rep(.1, (ncomp.predictors+2)), .05))
#layout.show(14)
par(mar=c(2,0,1,0))
par(cex=.8)
o=order(pred)
n=length(pred)
plot(0,0, xlim=c(0,1),ylim=c(0,1),type="n",axes=F)
for(i in 1:n){
  text(i/n,.5,labels=sample.labels[i],srt=90,cex=.5)
}

cols=rep(c("green","blue"),ncomp.predictors)
plot(0,0, xlim=c(0,1),ylim=c(0,1),type="n",axes=F)
my.barplot(yhat[o], label="survival", type="continuous", col="gray")
my.barplot(pred[o],label="supervised PC", type="continuous", col="red")
for(ii in 1:length(competing.predictors)){
if(!is.factor(competing.predictors[[ii]])){type="continuous"}
if(is.factor(competing.predictors[[ii]])){type="discrete"}

my.barplot(competing.predictors[[ii]][o], label=names(competing.predictors)[[ii]], type=type, col=cols[ii])
}

if (call.win.metafile) {
        dev.off()
    }

return()
}

my.barplot=function(x,label, type=c("continuous", "discrete"), col=c("red","green","blue", "gray")){
n=length(x)
 reds <- rgb(r=(0:n)/n, g=0,b=0, names=paste("red",0:n,sep="."))
 greens <- rgb(g=(0:n)/n, r=0,b=0, names=paste("green",0:n,sep="."))
 blues <- rgb(b=(0:n)/n, g=0,r=0, names=paste("blue",0:n,sep="."))

if(type=="continuous"){
if(col=="gray"){
 palette(gray(seq(0,.9,len=n)))
 cols=rank(x)
 }

if(col=="red"){cols=reds[rank(x)]}
if(col=="green"){cols=greens[rank(x)]}
if(col=="blue"){cols=blues[rank(x)]}
 nc=4 
 temp=quantile(x,c(0.25, .5, .75, 1))
 values.legend=paste("<",round(temp,2),sep="")
 cols.legend=sort(cols[trunc(n*c(0.25,.5,.75,1))])

 if(length(unique(x))<6){
# we guess that x is an ordered discrete variable
   nc= length(unique(x))
   values.legend=sort(unique(x))
  }
  
}

if(type=="discrete"){
 palette("default") 
dd=sort(names(table(x)))
nc=length(dd)
cols=match(x,dd)
values.legend=dd
cols.legend=1:nc
}

par(mar=c(0,0,0,0))
 
plot(0,0,xlim=c(0,1),ylim=c(0,1/n),type="n",axes=F,xlab="",ylab="")
xval=c(0,1/n,1/n,0)
yval=c(0,0,1/n,1/n)
for(i in 1:n){
  polygon(xval,yval,col=cols[i])
  xval=xval+1/n
}
plot(0,0,xlim=c(0,1.25),ylim=c(0,1),type="n",axes=F,xlab="",ylab="")


h=.25

text(.5,.7,label=label, cex=.8)
xval=c(0,1/nc,1/nc,0)
yval=c(0,0,h,h)+h
for(i in 1:nc){
   polygon(xval,yval,col=cols.legend[i])
   text((xval[1]+xval[2])/2,yval[1]-.2, labels=values.legend[i], cex=.5)
  xval=xval+1/nc
}

return()
}




surv.to.class2 <- function (y, icens, cutoffs=NULL, n.class=NULL,  class.names=NULL, newy=y, newic=icens) 

# this is the function "pamr.surv.to.class2" from the pamr libarary
# the auxiliary functions below are also from pamr

# Splits patients into classes based on their survival times
# The user can either specify the number of classes or the survival
# time cutoffs.
#
# y - vector of survival times
# icens - censoring indicator
# cutoffs - survival time cutoffs
# n.class - number of classes to create
# class.names - optional vector of names for each class
{
        require(survival)
        if (is.null(cutoffs) & is.null(n.class)) {
                stop("Must specify either cutoffs or n.class")
        }
        if (!is.null(cutoffs) & !is.null(n.class)) {
                stop("Can't have both cutoffs and n.class specified")
        }
        data.sfit <- survfit(Surv(y,icens))
        if (!is.null(cutoffs)) {
                if (is.null(class.names)) {
                        class.names <- 1:(length(cutoffs)+1)
                }
                cur.mat <- gen.y.mat2(Surv(y, icens), cutoffs, class.names,                                              newdata=Surv(newy, newic))
        }
        else {
                if (n.class==1) {
                        stop("Must have at least two classes")
                }
                if (is.null(class.names)) {
                        class.names <- 1:n.class
                }
                cur.quantiles <- seq(from=0, to=1, length=n.class+1)
                cur.quantiles <- cur.quantiles[2:n.class]
                cutoffs <- quantile(y[icens==1], cur.quantiles)
                cur.mat <- gen.y.mat2(Surv(y, icens), cutoffs, class.names,
                                newdata=Surv(newy, newic))
        }
        mle.classes <- apply(cur.mat, 1, get.mle.class)
         return(list(class=as.numeric(mle.classes), prob=cur.mat, cutoffs=cutoffs))
}
gen.y.mat2 <- function(surv.data, cutoffs, class.names=NULL, newdata=surv.data)
# Calculates the probability that a given patient belongs to a given
# class.  Returns a matrix where entry (i,j) is the probability that
# patient i belongs to class j.  The function calculates the
# probability that a given patient dies between two given cutoffs,
# and uses this information to calculate the probability that
# a patient with a censored survival time died in a given interval.
{
         data.sfit <- survfit(surv.data)
         surv.ndx <- find.surv.ndx(cutoffs, data.sfit$time)
         surv.probs <- c(0, 1-data.sfit$surv[surv.ndx],1)
         surv.probs <- c(rep(0, sum((surv.ndx==0))), surv.probs)
         cutoffs <- c((min(surv.data[,1])-1), cutoffs, (max(surv.data[,1])+1))
         y.size <- length(cutoffs)
         y.mat <- matrix(0,nrow=length(newdata[,1]), ncol=(y.size-1))
         for (i in 2:y.size) {
                 cur.int.prob <- surv.probs[i] - surv.probs[i-1]
                 y.mat[((newdata[,1]<=cutoffs[i])&(newdata[,1]>cutoffs[i-1])&
                         (newdata[,2]==1)),i-1] <- 1
                 which.x <- ((newdata[,2]==0)&(newdata[,1]<=cutoffs[i-1]))
                 if (sum(which.x)>0) {
                         which.x.vals <- newdata[which.x,1]
                         surv.ndx <- find.surv.ndx(which.x.vals,
                                 data.sfit$time)
                         y.mat[which.x,i-1][surv.ndx==0] <- cur.int.prob
                         y.mat[which.x,i-1][surv.ndx!=0] <- cur.int.prob /
                                 data.sfit$surv[surv.ndx]
                 }
                 which.x <- ((newdata[,2]==0)&(newdata[,1]>cutoffs[i-1])&
                         (newdata[,1]<=cutoffs[i]))
                 if (sum(which.x>0)) {
                         which.x.vals <- newdata[which.x,1]
                         surv.ndx <- find.surv.ndx(which.x.vals,
                                 data.sfit$time)
                         y.mat[which.x,i-1][surv.ndx==0] <- surv.probs[i]
                         y.mat[which.x,i-1][surv.ndx!=0] <- 1 -
                                 (1 - surv.probs[i]) / data.sfit$surv[surv.ndx]
                 }
         }
         if (!is.null(class.names)) {
                 y.mat <- as.data.frame(y.mat)
                 names(y.mat) <- class.names
                 y.mat <- as.matrix(y.mat)
         }
         y.mat
}

get.surv.q <- function(surv.obj, quantile) 
{
    ndx <- sum(surv.obj$surv > quantile)
    if (ndx==0)
        return(0)
    else
        return(surv.obj$time[ndx])
}
find.surv.ndx <- function(newtimes, oldtimes) 
{
	first <- apply(as.matrix(newtimes), 1, function(e1,e2) (e1>=e2), e2=oldtimes)
	as.vector(apply(first, 2, sum))
}
get.mle.class <- function(y.row) 
{
	i <- 1+sum((max(y.row)>cummax(y.row)))
	if (!is.null(names(y.row)[i])) {
		return(names(y.row)[i])
	}
	else return(i)
}

superpc.train<-
  function (data, type=c("survival","regression"), s0.perc=NULL){
    
# computes feature scores for supervised pc analysis
    
  this.call <- match.call()
 type <- match.arg(type)

  
  if (is.null(data$censoring.status) & type=="survival") {
 stop("Error: survival specified but  censoring.status is null")
  }
  
 if (!is.null(data$censoring.status) & type=="regression") {
 stop("Error: regression specified but  censoring.status is  non-null")
  }

  if (type=="survival") {
junk<- coxfunc(data$x, data$y, data$censoring.status, s0.perc=s0.perc)
feature.scores<-junk$tt
   }
  else {
junk<- cor.func(data$x, data$y, s0.perc=s0.perc)
feature.scores<-junk$tt
  }

  
  junk <- list( feature.scores=feature.scores, 
               type=type, s0.perc=s0.perc, 
               call = this.call)

  
  class(junk) <- "superpc"
  return(junk)

}

superpc.xl.get.threshold.range  <- function(train.obj) {


  cur.tt <- train.obj$feature.scores
p<-length(cur.tt)

min.features=5
max.features=p


  lower <- quantile(abs(cur.tt), 1 - (max.features/p))
  upper <- quantile(abs(cur.tt), 1 - (min.features/p))

  return(c(lower,upper))
}


superpc.xl.listgenes.compute<- function(data, train.obj, fit.red, fitred.cv=NULL,
num.genes=NULL, component.number=1){

ii=component.number
total.num=sum(abs(fit.red$import[,ii])>0)
if(is.null(num.genes)){num.genes=total.num}

if(num.genes< 1 | num.genes > total.num){
    stop("Error: num.genes   argument out of range")

}

genenames.short<- substring(data$geneid,1,40)


oo=rank(abs(fit.red$import[,ii]))> nrow(data$x)-num.genes

res<-cbind(data$genenames[oo], genenames.short[oo], round(fit.red$import[oo,ii],3), round(train.obj$feature.scores[oo],3))

collabs=c("GeneID", "Genename","Importance-score", "Raw-score" )


if(!is.null(fitred.cv)){
nfold=ncol(fitred.cv$import.cv)

ind=matrix(F,nrow=nrow(data$x),ncol=nfold)
ranks=NULL
for( j in 1:nfold){
          r <- fitred.cv$import.cv[,j,component.number]
        ranks=cbind(ranks,rank(-abs(r)))

  junk=  fitred.cv$import.cv[,j, component.number]!=0
        ind[junk,j]=T
}

av.rank=apply(ranks,1,mean)
av.rank=round(av.rank[oo],2)
prop=apply(ind[oo,,drop=F],1,sum)/nfold
res=cbind(res,av.rank,prop)
collabs=c(collabs,"av-rank-in-CV","prop-selected-in-CV")
}


o<-order(-abs(fit.red$import[oo,ii]))
res<-res[o,]
dimnames(res)<-list(NULL,collabs)

if(is.null(fitred.cv)){foo=list(gene.ids=res[,1],gene.names=res[,2],gene.scores=res[,3:4],
    gene.headings=c("ID", "Name"," Importance score", "Raw score"))
}
if(!is.null(fitred.cv)){foo=list(gene.ids=res[,1],gene.names=res[,2],gene.scores=res[,3:6],
    gene.headings=c("ID", "Name"," Importance score", "Raw score","av-rank-in-CV", "prop-selected-in-CV"))
}

return(foo)
}



superpc.xl.fit.to.clin<- function(fit, data.test,score, pamr.xl.test.sample.labels, pamr.xl.clindata, pamr.xl.clinsamplabels, pamr.xl.clinprednames, pamr.xl.clinpredtype ){

# strip off extra first element, row, col that rServer seems to include
# put everything in same order as test expression data

errorflag=FALSE
temp= pamr.xl.clindata[-1,-1,drop=F]
clinsamplabels=pamr.xl.clinsamplabels[-1]
clinpredtype=pamr.xl.clinpredtype[-1]
clinprednames=pamr.xl.clinprednames[-1]

o=match(pamr.xl.test.sample.labels, clinsamplabels)
if(sum(is.na(o))>0){ errorflag=TRUE
 return(list(errorflag=errorflag))
}
clindata=temp[,o,drop=F]
npreds=nrow(clindata)
clinlist=vector("list",npreds)
for(i in 1:npreds){
  if(clinpredtype[[i]]=="continuous") {clinlist[[i]]=clindata[i,]}
  if(clinpredtype[[i]]=="discrete") {clinlist[[i]]=as.factor(clindata[i,])}
}

names(clinlist)= clinprednames

foo=superpc.fit.to.outcome(fit, data.test,score, competing.predictors=clinlist, print=FALSE)

return(list(results=foo$coeftable, teststat.table=foo$teststat.table,  errorflag=errorflag))
}


superpc.xl.decorrelate<- function(data, pamr.xl.train.sample.labels, pamr.xl.clindata, pamr.xl.clinsamplabels, pamr.xl.clinprednames, pamr.xl.clinpredtype ){

# strip off extra first element, row, col that rServer seems to include
# put everything in same order as training expression data
errorflag=FALSE

temp= pamr.xl.clindata[-1,-1]
clinsamplabels=pamr.xl.clinsamplabels[-1]
clinpredtype=pamr.xl.clinpredtype[-1]
clinprednames=pamr.xl.clinprednames[-1]

o=match(pamr.xl.train.sample.labels, clinsamplabels)
if(sum(is.na(o))>0){ errorflag=TRUE
 return(list(errorflag=errorflag))
}

clindata=temp[,o]
npreds=nrow(clindata)
clinlist=vector("list",npreds)
for(i in 1:npreds){
  if(clinpredtype[[i]]=="continuous") {clinlist[[i]]=clindata[i,]}
  if(clinpredtype[[i]]=="discrete") {clinlist[[i]]=as.factor(clindata[i,])}
}

names(clinlist)= clinprednames

foo=superpc.decorrelate(data$x, competing.predictors=clinlist)

return(list(results=foo, errorflag=errorflag))

}

superpc.xl.decorrelate.test<- function(object.decorr, xtest, pamr.xl.train.sample.labels, pamr.xl.clindata, pamr.xl.clinsamplabels, pamr.xl.clinprednames, pamr.xl.clinpredtype ){

# strip off extra first element, row, col that rServer seems to include
# put everything in same order as training expression data

errorflag=FALSE
temp= pamr.xl.clindata[-1,-1]
clinsamplabels=pamr.xl.clinsamplabels[-1]
clinpredtype=pamr.xl.clinpredtype[-1]
clinprednames=pamr.xl.clinprednames[-1]

o=match(pamr.xl.train.sample.labels, clinsamplabels)
if(sum(is.na(o))>0){ errorflag=TRUE
 return(list(errorflag=errorflag))
}

clindata=temp[,o]
npreds=nrow(clindata)
clinlist=vector("list",npreds)
for(i in 1:npreds){
  if(clinpredtype[[i]]=="continuous") {clinlist[[i]]=clindata[i,]}
  if(clinpredtype[[i]]=="discrete") {clinlist[[i]]=as.factor(clindata[i,])}
}

names(clinlist)= clinprednames

xtest<- xtest-t(predict(object.decorr, clinlist))

return(list(results=xtest, errorflag=errorflag))

}



superpc.xl.rainbowplot=function(data, pred,  pamr.xl.test.sample.labels, 
    pamr.xl.clindata, pamr.xl.clinsamplabels, pamr.xl.clinprednames, 
    pamr.xl.clinpredtype, call.win.metafile=FALSE){


 temp = pamr.xl.clindata[-1, -1, drop = F]
    clinsamplabels = pamr.xl.clinsamplabels[-1]
    clinpredtype = pamr.xl.clinpredtype[-1]
    clinprednames = pamr.xl.clinprednames[-1]
    o = match(pamr.xl.test.sample.labels, clinsamplabels)
    if (sum(is.na(o)) > 0) {
        errorflag = TRUE
        return(list(errorflag = errorflag))
    }
    clindata = temp[, o, drop = F]
    npreds = nrow(clindata)
    clinlist = vector("list", npreds)
    for (i in 1:npreds) {
        if (clinpredtype[[i]] == "continuous") {
            clinlist[[i]] = clindata[i, ]
        }
        if (clinpredtype[[i]] == "discrete") {
            clinlist[[i]] = as.factor(clindata[i, ])
        }
    }
    names(clinlist) = clinprednames



junk<- superpc.rainbowplot(data, pred, pamr.xl.test.sample.labels,  clinlist, call.win.metafile=call.win.metafile)
return()
}

  
