.packageName <- "pamr"
"pamr.knnimpute" <-
  function (data, k = 10,rowmax=0.5,colmax=0.8,maxp=1500) 
{
  x <- data$x
  p<-nrow(x)
  col.nas <- drop(rep(1,p)%*%is.na(x))
  if (any(col.nas>colmax*p)) 
    stop(paste("a column has more than",format(round(colmax*100)),"% missing values!"))
  data$x <- knnimp(x,k,maxmiss=rowmax,maxp=maxp)
  data
}
knnimp<-function(x,k=10,maxmiss=0.5,maxp=1500){
  pn<-dim(x)
  dn<-dimnames(x)
  p<-as.integer(pn[1])
  n<-as.integer(pn[2])
  imiss<-is.na(x)
  x[imiss]<-0
  irmiss<-drop(imiss%*%rep(1,n))
  imax<-trunc(maxmiss*n)
  imax<-irmiss>imax
  simax<-sum(imax)
  if(simax>0){
    warning(paste(simax,"rows with more than", format(round(maxmiss*100,1)),"% entries missing;\n",
                  "mean imputation used for these rows"))
    irmiss<-irmiss[!imax]
    imiss.omit<-imiss[imax,,drop=FALSE]
    imiss<-imiss[!imax,]
    xomit<-x[imax,,drop=FALSE]
    x<-x[!imax,]
    discards<-seq(imax)[imax]
    p<-as.integer(p-simax)
  }
  storage.mode(imiss)<-"integer"
  storage.mode(irmiss)<-"integer"
  storage.mode(x)<-"double"
  if(p<=maxp)
    ximp<-knnimp.internal(x,k,imiss,irmiss,p,n,maxp=maxp)
  else
    ximp<-knnimp.split(x,k,imiss,irmiss,p,n,maxp=maxp)
  imiss.new<-is.na(ximp)
  newmiss<-any(imiss.new)
  if( (simax>0) | newmiss ){
    xbar<-mean.miss(x,imiss=imiss)
    if(newmiss)ximp<-meanimp(ximp,imiss.new,xbar)
    if(simax>0){
      xomit<-meanimp(xomit,imiss.omit,xbar)
      xout<-array(0,dim=pn)
      xout[!imax,]<-ximp
      xout[imax,]<-xomit
      ximp<-xout
    }
  }
  dimnames(ximp)<-dn
  ximp
}
           

knnimp.internal<-function(x,k,imiss,irmiss,p,n,maxp=maxp){
  if(p<=maxp){
    junk<-.Fortran("knnimp",
                   x,
                   ximp=x,
                   p,
                   n,
                   imiss=imiss,
                   irmiss,
                   as.integer(k),
                   double(p),
                   double(n),
                   integer(p),
                   integer(n),
                   PACKAGE="pamr")

    ximp<-junk$ximp
### Should we check or iterate?
    ximp[junk$imiss==2]<-NA
    ximp
  }
  else
    knnimp.split(x,k,imiss,irmiss,p,n,maxp=maxp)
}
"knnimp.split" <-
  function(x,k,imiss,irmiss,p,n,maxp){
    junk<-twomeans.miss(x)
    size<-junk$size
    cat("Cluster size",p,"broken into",size,"\n")
    clus<-junk$cluster
    for(i in seq(size)){
      p<-as.integer(size[i])
      index<-clus==i
      x[index,]<-if(p<k)
        meanimp(x[index,])
      else
        knnimp.internal(x[index,],k,imiss[index,],irmiss[index],p,n,maxp)
      cat("Done cluster",size[i],"\n")
    }
    x
  }
mean.miss<-function(x,index=seq(p),imiss=is.na(x)){
  pn<-dim(x)
  p<-pn[1]
  n<-pn[2]
  storage.mode(index)<-"integer"
  x[imiss]<-0
  storage.mode(x)<-"double"
  storage.mode(imiss)<-"integer"
  junk<-  .Fortran("misave",
           x,
           x0=double(n),
           p,
           n,
           imiss0=as.integer(rep(1,n)),
           imiss,
           index,
           as.integer(length(index)),
           PACKAGE="pamr")

  x0<-junk$x0
  x0[junk$imiss0==2]<-NA
x0
}
           
meanimp<-function(x,imiss=is.na(x),xbar=mean.miss(x,imiss=imiss)){
  nr<-nrow(x)
  if(!is.null(nr)&&(nr>1))x[imiss]<-outer(rep(1,nr),xbar)[imiss]
  x
}
                                         
"twomeans.miss" <-
function(x, imiss=is.na(x),imbalance=.2,maxit=5,eps=0.001){
  ### Compute the two-means cluster solution for data with missing
  ### entries
  pn<-dim(x)
  p<-pn[1];n<-pn[2]
  if(missing(imiss))x[imiss]<-0
  storage.mode(imiss)<-"integer"
  starters<-sample(seq(p),2)
  junk<-.Fortran("twomis",
                 x,
                 as.integer(p),
                 as.integer(n),
                 imiss,
                 double(2*n),
                 integer(2*n),
                 as.integer(maxit),
                 as.double(eps),
                 as.integer(starters),
                 cluster=integer(2*p),
                 nsize=integer(2),
                 double(2*p),
                 ratio=double(1),
                 iter=integer(1),
                 integer(p),
                 integer(n),
                PACKAGE="pamr"
               )

  clus=matrix(junk$cluster,ncol=2)
  cluster<-as.list(1:2)
  for(i in 1:2)cluster[[i]]<-clus[seq(junk$nsize[i]),i]
  clus<-rep(1,p)
  clus[cluster[[2]]]<-2
  list(cluster=clus,ratio=junk$ratio,iter=junk$iter,size=junk$nsize)
}
 balanced.folds <- function(y, nfolds = min(min(table(y)), 10)) {
   totals <- table(y)
   fmax <- max(totals)
   nfolds <- min(nfolds, fmax)     
   nfolds= max(nfolds, 2)
         # 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)) {
cat(i)
     if(length(yids[[i]])>1){bigmat[seq(totals[i]), i] <- sample(yids[[i]])}
     if(length(yids[[i]])==1){bigmat[seq(totals[i]), i] <- 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)
 }
descendants <- function(m,k){
  ## the done object indicates what rows of m were used
  done <- k
  if (m[k,1] < 0)
    left <- -m[k,1]
  else {
    junk <- descendants(m, m[k,1])
    left <- junk[[1]]
    done <- c(done, junk[[2]])
  }
  if (m[k,2] < 0)
    right <- -m[k,2]
  else {
    junk <- descendants(m, m[k,2])
    right <- junk[[1]]
    done <- c(done, junk[[2]])
  } 
  return(list(c(left, right), done))
}
diag.disc <-function(x, centroids, prior, weight) {
### Computes the class discriminant functions assuming scaled x and centroids
  if(! missing(weight)) {
    posid <- (weight > 0)
    if(any(posid)) {
      weight <- sqrt(weight[posid])
      centroids <- centroids[posid,  , drop = FALSE] * weight
      x <- x[posid,  , drop = FALSE] * weight
    }
    else {
      mat <- outer(rep(1, ncol(x)), log(prior), "*")
      dimnames(mat) <- list(NULL, dimnames(centroids)[[2]])
      return(mat)
    }
  }
  dd <- t(x) %*% centroids
  dd0 <- drop(rep(1, nrow(centroids)) %*% (centroids^2))/2 - log(prior)
  names(dd0) <- NULL
  scale(dd, dd0, FALSE)
}
enlist <-function(...) {
  result <- list(...)
  if((nargs() == 1) & is.character(n <- result[[1]])) {
    result <- as.list(seq(n))
    names(result) <- n
    for(i in n)
      result[[i]] <- get(i)
  }
  else {
    junk <- sys.call()
    n <- NULL
    for(i in junk[-1])
      n <- c(n, deparse(i))
    if(!is.null(n2 <- names(result))) {
      which <- n2 != ""
      n[which] <- n2[which]
    }
    names(result) <- n
  }
  result
}
error.nsc <-function(object) {
###Computes the roc curve for a nsc model
  yhat <- object$yhat
  y <- object$y
  ny <- table(y)
  errors <- matrix(0, length(object$threshold), length(ny))
  Y <- data.matrix(yhat) != unclass(y)
  yind <- model.matrix( ~ factor(y) - 1, data = list(y = y))
  errors <- t(t(yind) %*% Y)
  apply(errors, 2, mean)
}
nsc <-
  
  function(x, y = NULL, xtest = NULL, proby = NULL, ytest = NULL, prob.ytest = 
        NULL, threshold = NULL, n.threshold = 30, hetero = NULL, scale.sd = 
        TRUE, threshold.scale = NULL, se.scale = NULL, offset.percent = 50, 
        prior = table(y)/length(y), remove.zeros = TRUE, sign.contrast = "both",
           problem.type=c("class", "surv.km","surv.latent"))
{

# modified aug 2003 to add survival analysis facilities
#
#         problem.type can be "class", "surv.km", or "surv.latent"         
#
#         y= class variable => classification problem (problem.type="class")
#         proby= matrix of class probabilities => "soft classification"
#               from Kaplan-Meier estimate, for survival analysis
#         in this case, nsc computes probability-weighted centroids and
#             training error 

        this.call <- match.call()

        argy <- ytest
        if(is.null(ytest)) {
                argy <- y
        }
        if(!is.null(y) & !is.null(proby) & problem.type!="surv.latent") {
                stop("Can't specify both y and proby")
        }
        if(!is.null(ytest) & !is.null(prob.ytest)) {
                stop("Can't specify both ytest and prob.ytest")
        }
        if(is.null(y)) {
                y <- apply(proby, 1, which.is.max)
        }
        n.class <- table(y)
        if(min(n.class) == 1) {
                cat("Warning: a class contains only 1 sample")
        }
        if(is.null(xtest)) {
                xtest <- x
                ytest <- y
                prob.ytest <- proby
        }
        norm.cent <- NULL
        if(!is.null(hetero)) {
                norm.cent <- apply(x[, y == hetero], 1, mean)
                x <- abs(t(scale(t(x), center = norm.cent, scale = FALSE)))
                if(!missing(xtest)) {
                        xtest <- abs(t(scale(t(xtest), center = norm.cent, 
                                scale = FALSE)))
                }
        }
        n <- sum(n.class)
        ntest <- ncol(xtest)
        K <- length(prior)
        p <- nrow(x)
        if(is.null(proby)) {
                Y <- model.matrix( ~ factor(y) - 1, data = list(y = y))
        }
        if(!is.null(proby)) {
                Y <- proby
        }
        dimnames(Y) <- list(NULL, names(n.class))

        centroids <- scale(x %*% Y, FALSE, n.class)
        sd <- rep(1, p)
        if(scale.sd) {
                xdif <- x - centroids %*% t(Y)
                sd <- (xdif^2) %*% rep(1/(n - K), n)
                sd <- drop(sqrt(sd))
                offset <- quantile(sd, offset.percent/100)
                sd <- sd + offset
        }
        centroid.overall <- drop(x %*% rep(1/n, n))
        if(is.null(threshold.scale)) {
                threshold.scale <- rep(1, K)
                names(threshold.scale) <- names(n.class)
        }
### Now make an adjustment for the sample sizes in the "t" ratios

        if(is.null(se.scale))
                se.scale <- sqrt(1/n.class - 1/n)
        delta <- (centroids - centroid.overall)/sd
        delta <- scale(delta, FALSE, threshold.scale * se.scale)
        if(sign.contrast == "positive") {
                delta <- delta * (delta > 0)
        }
        if(sign.contrast == "negative") {
                delta <- delta * (delta < 0)
        }
#allows differential shrinkage
        if(!is.null(threshold)) {
                n.threshold <- length(threshold)
        }
        else {
                threshold <- seq(0, max(abs(delta)), length = n.threshold)
        }
        nonzero <- seq(n.threshold)
        errors <- threshold
        yhat <- as.list(seq(n.threshold))
        prob <- array(0, c(ntest, K, n.threshold))
        for(ii in 1:n.threshold) {
                cat(ii)
                delta.shrunk <- soft.shrink(delta, threshold[ii])
                delta.shrunk <- scale(delta.shrunk, FALSE, 1/(threshold.scale * 
                        se.scale))
                nonzero[ii] <- attr(delta.shrunk, "nonzero")
                posid <- drop(abs(delta.shrunk) %*% rep(1, K)) > 0
                dd <- diag.disc((xtest - centroid.overall)/sd, delta.shrunk, 
                        prior, weight = posid)
                yhat[[ii]] <- softmax(dd)
                dd <- safe.exp(dd)
                prob[,  , ii] <- dd/drop(dd %*% rep(1, K))
                if(!is.null(ytest)) {
                        errors[ii] <- sum(yhat[[ii]] != ytest)
                }
                if(!is.null(prob.ytest)) {

# use of temp below is to ensure that Yhat doesn;t drop a column
#  when no predictions are made to that class
                        temp <- c(yhat[[ii]], names(table(y)))
                        Yhat <- model.matrix( ~ factor(temp) - 1, data = list(y
                                 = temp))
                        Yhat <- Yhat[1:length(yhat[[ii]]),  ]
                     
                        errors[ii] <- length(yhat[[ii]]) - sum(Yhat * prob.ytest)
                }
               
        }
        thresh.names <- format(round(threshold, 3))
        names(yhat) <- thresh.names
        attr(yhat, "row.names") <- paste(seq(ntest))
        class(yhat) <- "data.frame"
        if(remove.zeros)
                n.threshold <- match(0, nonzero, n.threshold)
        dimnames(prob) <- list(paste(seq(ntest)), names(n.class), thresh.names)
        object <- list(y = argy, proby = prob.ytest, yhat = yhat[, seq(
                n.threshold)], prob = prob[,  , seq(n.threshold)], centroids = 
                centroids, centroid.overall = centroid.overall, sd = sd, 
                threshold = threshold[seq(n.threshold)], nonzero = nonzero[seq(
                n.threshold)], threshold.scale = threshold.scale, se.scale = 
                se.scale, scale.sd=scale.sd, call = this.call, hetero = hetero, norm.cent = 
                norm.cent, prior = prior, offset = offset, sign.contrast = 
                sign.contrast)
        if(!is.null(ytest) | !is.null(prob.ytest))
                object$errors <- errors[seq(n.threshold)]
        class(object) <- "nsc"
        object
}


safe.exp=function(x){
 xx=sign(x)*pmin(abs(x),500)
 return(exp(xx))
}
nsccv <- function(x, y=NULL, proby=NULL, nfold = min(table(y)), folds = NULL, threshold =
        NULL, threshold.scale = NULL, survival.time=NULL, censoring.status=NULL, ngroup.survival=NULL,prior, object, ...)
{
        this.call <- match.call()

        argy <- y
        
#         if( !is.null(y) & !is.null(proby)){
#           stop("Must have at most one of y and  proby  present in the data object")
#         }

        if(is.null(y)){ y <- as.factor(apply(proby,1,which.is.max))}
        
        n <- length(y)

if(is.null(nfold) & is.null(survival.time)) {nfold <- min(table(y))}
if(is.null(nfold) & !is.null(survival.time)) {nfold <- 10}


 if(is.null(survival.time)){
        if(is.null(folds)) {
                folds <-balanced.folds(y)
        }
       }


        if(!is.null(survival.time)){
        if(is.null(folds)) {
                folds <- split(sample(1:n), rep(1:nfold, length = n))
        }
        }
         
nfold<- length(folds)

        if(missing(prior)) {
                if(missing(object))
                        prior <- table(y)/n
                else prior <- object$prior
        }
    
        if(missing(threshold)) {
                if(missing(object))
                        stop("Must either supply threshold argument, or an nsc object"
                                )
                else {
                        threshold <- object$threshold
                        threshold.scale <- object$threshold.scale
                        se.scale <- object$se.scale
                }
        }
       
        n.threshold <- length(threshold)        ### Set up the data structures
        yhat <- rep(list(y), n.threshold)
        names(yhat) <- paste(seq(n.threshold))
        yhat <- data.frame(yhat)
        n.class <- table(y)
        prob <- array(1, c(n, length(n.class), n.threshold))
        size <- double(n.threshold)
        hetero <-object$hetero
        cv.objects=vector("list",nfold)
        for(ii in 1:nfold) {
                cat("Fold", ii, ":")
                a <- nsc(x[,  - folds[[ii]]], y=argy[ - folds[[ii]]], x[, folds[[ii
                        ]], drop = FALSE], proby=proby[-folds[[ii]],],
                         threshold = threshold, threshold.scale
                         = threshold.scale, se.scale = se.scale, prior = prior,
                          hetero=hetero,
                        ..., remove.zeros = FALSE)
                size <- size + a$nonzero
                prob[folds[[ii]],  ,  ] <- a$prob
                yhat[folds[[ii]],  ] <- a$yhat
                cat("\n")
        cv.objects[[ii]]=a
        }
        if(missing(object))
                size <- round(size/nfold)
        else size <- object$nonzero
        error <- rep(NA, n.threshold)
        loglik <- error
        pvalue.survival <- error
        
        pvalue.survival.func <- function(group, survival.time, censoring.status,ngroup.survival){
            temp <- coxph(Surv(survival.time, censoring.status)~as.factor(group))
            loglik <- 2*(temp$loglik[2]-temp$loglik[1])
            return(1-pchisq(loglik, ngroup.survival-1))
          }
        
        if(!is.null(proby)){proby.temp <-proby}
        else if(!is.null(survival.time)){proby.temp <- pamr.surv.to.class2(survival.time,
                                       censoring.status, n.class=ngroup.survival)$prob
                                       }
        
        for(i in 1:n.threshold) {
      
                if(is.null(survival.time) & is.null(proby)){error[i] <- sum(yhat[, i] != y)/n}
                if(!is.null(survival.time)){
                    
                    temp <- c(yhat[,i],names(table(y)))
                    Yhat <- model.matrix( ~ factor(temp) - 1,
                                       data = list(y = temp))
                     Yhat <- Yhat[1:length(yhat[[ii]]),]
                     error[i] <- (length(yhat[,i])-sum(Yhat*proby.temp))/n
                  }
            
                
                if(is.null(survival.time)){
                  loglik[i] <- sum(log(prob[,  , i][cbind(seq(1, n), unclass(y))]))/                        n}
                
                if(!is.null(survival.time)){
                  pvalue.survival[i]<- pvalue.survival.func(yhat[,i], survival.time,censoring.status, ngroup.survival)
                }
        }

obj<- list(threshold=threshold, error=error, loglik=loglik,size=size, yhat=yhat,y=y,prob=prob,folds=folds, cv.objects=cv.objects, pvalue.survival=pvalue.survival,
                call = this.call)
        class(obj) <- "nsccv"
        obj
}

pamr.adaptthresh <- function(object, ntries = 10, reduction.factor = 0.9, full.out = FALSE) {
  errors <- error.nsc(object)
  threshold <- object$threshold   
### Remove all but the first leading zero errors
  ifirst <- match(TRUE, object$errors > 0, FALSE)
  if (!ifirst)
    stop("Zero training error throughout!")
  else {
    ifirst <- max(ifirst, 1)
    threshold <- threshold[seq(ifirst, length(threshold))]
  }
### initialization
  tscales <- object$threshold.scale
  all.errors <- matrix(0, ntries + 1, length(tscales),
                       dimnames = list(NULL, names(tscales)))
  all.scales <- all.errors
  all.objects <- as.list(seq(ntries + 1))
  rocs <- double(ntries + 1)
  all.scales[1,  ] <- tscales
  all.errors[1,  ] <- errors
  rocs[1] <- roc.nsc(object)      # integrated size^(1/4)*error
  cat("Initial errors:", format(round(errors, 5)), "Roc",
      format(round(rocs[1], 5)), "\n")
  for (i in seq(ntries)) {
    cat("Update", i, "\n")
    j <- rev(order(errors))[1]      # identify the largest error
    tscales[j] <- tscales[j] * reduction.factor     
                                        # and reduce its scale
    all.scales[i + 1,  ] <- tscales/min(tscales)    # and renormalize
    iobject <- update(object, threshold = threshold, 
                      threshold.scale = all.scales[i + 1,  ], remove.zeros = 
                      FALSE)
    all.errors[i + 1,  ] <- errors <- error.nsc(iobject)
    rocs[i + 1] <- roc.nsc(iobject)
    cat("\nErrors", format(round(errors, 5)), "Roc",
        format(round(rocs[i + 1], 5)), "\n")
  }
  j <- order(rocs)[1]     # identify the scales with the smallest "roc"
  opt.scale <- all.scales[j,  ]
  if (full.out)
    list(errors = all.errors, scales = all.scales, rocs = rocs, 
         opt.scale = opt.scale)
  else
    opt.scale
}

pamr.batchadjust <- function(data) {
  if (is.null(data$batchlabels)) {
    stop("batch labels are not in data object")
  }
  lab <- data$batchlabels
  dd <- model.matrix( ~ factor(lab) - 1)
  data$x <- data$x - misreg.simple(dd, data$x)
  data
}


misreg.simple <- function(Y, x) {
###Y is a indicator response matrix
  nax <- is.na(x)
  nsamples <- (!nax)%*%Y
  x[nax] <- 0
  xsum <- x%*%Y
  xbar <- xsum/nsamples
  xbar %*% t(Y)
}
pamr.confusion <- function(fit, threshold, extra = TRUE) {
  ii <- (1:length(fit$threshold))[fit$threshold >= threshold]
  ii <- ii[1]
  predicted <- fit$yhat[, ii]
  
if(!is.null(fit$y)){    true <- fit$y[fit$sample.subset]
                        tt <- table(true, predicted)
                     } 
else{true <- fit$proby[fit$sample.subset,]
  ytemp<- apply(true,1,which.is.max)
 temp <- c(predicted,names(table(ytemp)))
   nams <- names(table(temp))
     
                  Yhat <- model.matrix( ~ factor(temp) - 1,
                                       data = list(y = temp))
                  Yhat <- Yhat[1:length(predicted),]
         tt <- matrix(NA,nrow=length(fit$prior),ncol=length(fit$prior))
  
         for(i in 1:length(fit$prior)){
           for(j in 1:length(fit$prior)){
                 tt[i,j] <- sum(true[,i]*Yhat[,j])
               }}
     dimnames(tt) <- list(names(table(ytemp)),nams)
   }
  if (extra) {
    tt1 <- tt
    diag(tt1) <- 0
    tt <- cbind(tt, apply(tt1, 1, sum)/apply(tt, 1, sum))
    dimnames(tt)[[2]][ncol(tt)] <- "Class Error rate"
    print(tt)
    cat(c("Overall error rate=", round(sum(tt1)/sum(tt), 3)),
        fill= TRUE)
  }
  if (!extra) {
    return(tt)
  }
}
## Cube root transformation for Affy chips
pamr.cube.root  <- function(x) {
  return(sign(x) * abs(x)^{1/3})
}

pamr.cv <-
function(fit, data, nfold = NULL, folds = NULL ,...)
{
        x <- data$x[fit$gene.subset, fit$sample.subset]

        if( !is.null(data$y) & !is.null(data$proby)){
           stop("Must have exactly one of y and  proby  present in the data object")
         }
        
        y <- NULL
        proby <- NULL
        
        if(!is.null(fit$y)){
           y<-  factor(fit$y[fit$sample.subset])
         }
        
        if(!is.null(fit$proby)){
           proby<-  fit$proby[fit$sample.subset,]
         }
        
        this.call <- match.call()
        
# three possibilities, 
# problem.type= class: y are class labels, proby=NULL
#               surv.km: y=NULL, proby are soft class probabilities from KM
#               surv.latent: y are latent class labels,
#                   proby are soft class probabilities from KM
# note; problem type is in fit$problem.type
        
        junk <- nsccv(x, y=y, proby=proby, object = fit, nfold=nfold, folds=folds, 
survival.time=data$survival.time, censoring.status = data$censoring.status, 
ngroup.survival=fit$ngroup.survival, problem.type=fit$problem.type, ...)

        junk$call <- this.call
        
        junk$sample.subset <- fit$sample.subset
        class(junk)="pamrcved"
        junk
}

pamr.decorrelate<-  function (x, adjusting.predictors, xtest=NULL, adjusting.predictors.test=NULL){

foo<- lm(t(x)~., adjusting.predictors)
x.adj=t(foo$res)
xtest.adj=NULL

if(!is.null(adjusting.predictors.test)){
   if(is.null(xtest)){
   stop("xtest must be non-null if adjusting.predictors.test is non-null")
  }
    temp=t(predict(foo,adjusting.predictors.test))
    xtest.adj=xtest-temp
}
return(list(x.adj=x.adj,xtest.adj=xtest.adj))
}
pamr.fdr <- function(trained.obj, data, nperms=100, xl.mode=c("regular","firsttime","onetime","lasttime"),
                        xl.time=NULL, xl.prevfit=NULL){

this.call <- match.call()
 xl.mode=match.arg(xl.mode)


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

  y= data$y
  m=nrow(data$x)
  
 nclass=length(table(y))

  threshold <- trained.obj$threshold
 n.threshold=length(threshold)
  
  tt <- scale((trained.obj$centroids - trained.obj$centroid.overall)/trained.obj$sd, FALSE, 
        trained.obj$threshold.scale * trained.obj$se.scale)


  ttstar <- array(NA,c(m,nperms,nclass))
results=NULL
pi0=NULL
  
}
  if(xl.mode=="onetime" |  xl.mode=="lasttime"){
 y=xl.prevfit$y
 m=xl.prevfit$m
 nclass=xl.prevfit$nclass
 threshold=xl.prevfit$threshold
 n.threshold=xl.prevfit$n.threshold
tt=xl.prevfit$tt
ttstar=xl.prevfit$ttstar
nperms=xl.prevfit$nperms
results=xl.prevfit$results
pi0=xl.prevfit$pi0
  }


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


  for(i in first:last){
    cat("",fill=T)
     cat(c("perm=",i),fill=T)
    ystar <- sample(y)
    data2 <- data
    data2$y <- ystar
    foo<-pamr.train(data2, threshold=0, scale.sd = trained.obj$scale.sd, 
    threshold.scale =  trained.obj$threshold.scale,
    se.scale = trained.obj$se.scale, offset.percent = 50, hetero = trained.obj$hetero, 
prior = trained.obj$prior,  sign.contrast = trained.obj$sign.contrast)

    
   sdstar=foo$sd-foo$offset+trained.obj$offset
    ttstar[,i,] =scale((foo$centroids - foo$centroid.overall)/sdstar, FALSE,
        foo$threshold.scale * foo$se.scale)
}

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

fdr=rep(NA,n.threshold)
fdr90=rep(NA,n.threshold)
ngenes=rep(NA,n.threshold)

for(j in 1:n.threshold){
  nobs=sum( (abs(tt)-threshold[j])%*%rep(1,ncol(tt)) >0)
 temp=abs(ttstar)-threshold[j] >0
 temp2=rowSums(temp, dim=2)
 nnull=colSums(temp2>0)
  fdr[j]=median(nnull)/nobs
  fdr90[j]=quantile(nnull,.9)/nobs
  ngenes[j]=nobs
}


  q1 <- quantile(ttstar, .25)
  q2 <- quantile(ttstar, .75)
  
  pi0 <- min(sum( tt> q1 & tt< q2 )/(.5*m*nclass) ,1 )
  
  fdr <- fdr*pi0
fdr90=fdr90*pi0
fdr=pmin(fdr,1)
fdr90=pmin(fdr90,1)
  
  results <- cbind(threshold, ngenes, fdr*ngenes, fdr, fdr90)
om=is.na(fdr) 
results=results[!om,]
  

 dimnames(results) <- list(NULL,c("Threshold", "Number of significant genes", "Median number of null genes",
"Median FDR", "90th percentile of FDR"))
# last time through, delete the temp stuff that is used just by Excel interface
y=NULL;x=NULL;m=NULL;threshold=NULL;n.threshold=NULL;tt=NULL;nperms=NULL;ttstar=NULL
}

  return(list(results=results,pi0=pi0, y=y,m=m,threshold=threshold,n.threshold=n.threshold, tt=tt,ttstar=ttstar, nperms=nperms))
}
pamr.from.excel <- function(file, ncols, sample.labels = FALSE, batch.labels = FALSE) {
  d <- scan(file, sep = "\t", what = "")
  dd <- matrix(d, ncol = ncols, byrow = TRUE)
  samplelabels <- NULL
  batchlabels <- NULL
  ii <- 1
  if(sample.labels) {
    samplelabels <- dd[1,  - (1:2)]
    ii <- ii + 1
  }
  if(batch.labels & !sample.labels) {
    batchlabels <- dd[1,  - (1:2)]
    ii <- ii + 1
  }
  if(batch.labels & sample.labels) {
    batchlabels <- dd[2,  - (1:2)]
    ii <- ii + 1
  }
  y <- dd[ii,  - (1:2)]
  geneid <- dd[ - (1:ii), 1]
  genenames <- dd[ - (1:ii), 2]
  x <- matrix(as.numeric(as.character(dd[ - (1:ii),  - (1:2)])), ncol = 
              ncols - 2)
  cat("",fill=TRUE)
  cat(c("Read in ", nrow(x), "genes"),fill=TRUE)
  cat(c("Read in ", ncol(x), "samples"),fill=TRUE)
  if(sample.labels){cat(c("Read in ", length(samplelabels), "sample labels"),fill=TRUE)}
  if(batch.labels){cat(c("Read in ", length(batchlabels), "batch labels"),fill=TRUE)}
  cat("",fill=TRUE)
  cat("Make sure these figures are correct!!", fill=TRUE)
  cat("",fill=TRUE)
  
  return(list(x = x, y = y, genenames = genenames, geneid = geneid, 
              samplelabels = samplelabels, batchlabels = batchlabels))
}

pamr.geneplot <- function(fit, data, threshold) {
  par(pch = 1, col = 1)
  geneid <- data$geneid
  if(is.null(geneid)) {
    geneid <- as.character(1:nrow(data$x))
  }
  if(is.null(fit$newy)) {
    y <- factor(data$y[fit$sample.subset])
  }
  else {
    y <- factor(fit$newy[fit$sample.subset])
  }
  x <- data$x[fit$gene.subset, fit$sample.subset]
  geneid <- geneid[fit$gene.subset]
  nc <- length(unique(y))
  aa <- pamr.predict(fit, x, threshold = threshold, type = "nonzero")
  cen <- pamr.predict(fit, x, threshold = threshold, type = "cen")
  d <- (cen - fit$centroid.overall)[aa,  ]/fit$sd[aa]
  oo <- order( - apply(abs(d), 1, max))
  aa <- aa[oo]
  ngenes <- length(aa)
  o <- order(y)
  xx <- x[aa, o]
  geneid <- geneid[aa]
  nc <- length(unique(y))
  nn <- c(0, cumsum(table(y)))
  nrow <- trunc(sqrt(ngenes)) + 1
  ncol <- trunc(sqrt(ngenes)) + 1
  if(nrow * (ncol - 1) >= ngenes) {
    ncol <- ncol - 1
  }
  par(mfrow = c(nrow, ncol))
  for(i in 1:ngenes) {
    plot(1:ncol(xx), xx[i,  ], type = "n", xlab = "sample", ylab = 
         "expression", axes = FALSE)
    box()
    axis(2)
    for(j in 1:nc) {
      j1 <- nn[j] + 1
      j2 <- nn[j] + table(y)[j]
      points(j1:j2, xx[i, j1:j2], col = j + 1)
    }
    title(main = as.character(geneid[i]))
    for(j in 1:(nc - 1)) {
      abline(v = cumsum(table(y))[j] + 0.5, lty = 2)
    }
    if(i == 1) {
      h <- c(0, table(y))
      for(j in 2:(nc + 1)) {
        text(sum(h[1:(j - 1)]) + 0.5 * h[j], max(xx[i,  
                                                    ]), label = levels(y)[j - 1], col = j)
      }
    }
  }
  par(mfrow = c(1, 1))
}


pamr.indeterminate <-  function(prob, mingap=0){
n=nrow(prob)
yhat=rep(NA,n)
for(i in 1:n){

  r=rank(-prob[i,])
if(sum(r==1)==1){
 pr1=prob[i,r==1]
 pr2=prob[i,r==2]
if(pr1-pr2 >= mingap){ yhat[i]=(1:ncol(prob))[r==1]}
}}
yhat=as.factor(dimnames(prob)[[2]][yhat])
return(yhat)
}
pamr.knnimpute.old <- function(data, k = 10) {
  x <- data$x
  N <- dim(x)
  p <- N[2]
  
  N <- N[1]
        col.nas  <- apply(x, 2, is.na)
  if ((sum(col.nas) == N) > 0) {
    stop("Error: A column has all missing values!")
  }
  nas <- is.na(drop(x %*% rep(1, p)))
  xcomplete <- x[!nas,  ]
  xbad <- x[nas,,drop=FALSE ]
  xnas <- is.na(xbad)
  xbadhat <- xbad
  cat(nrow(xbad), fill = TRUE)
  for(i in seq(nrow(xbad))) {
    cat(i, fill = TRUE)
    xinas <- xnas[i,  ]
    xbadhat[i,  ] <- nnmiss(xcomplete, xbad[i,  ], xinas, K = k)
  }
  x[nas,  ] <- xbadhat
  data2 <-data
  data2$x <-x
  return(data2)
}

nnmiss <- function(x, xmiss, ismiss, K = 1) {
  xd <- scale(x, xmiss, FALSE)[, !ismiss]
  dd <- drop(xd^2 %*% rep(1, ncol(xd)))
  od <- order(dd)[seq(K)]
  xmiss[ismiss] <- drop(rep(1/K, K) %*% x[od, ismiss, drop = FALSE])
  xmiss
}

pamr.listgenes <- function (fit,   data, threshold, fitcv=NULL, genenames = FALSE)  {
  x <- data$x[fit$gene.subset, fit$sample.subset]
if (genenames) {
    gnames <- data$genenames[fit$gene.subset]
  }
  if (!genenames) {
    gnames <- NULL
  }
  geneid <- data$geneid[fit$gene.subset]
  if(!is.null(fit$y)){
       nc <- length(fit$y)
      }
 if(is.null(fit$y)){
       nc <- ncol(fit$proby)
      }
 clabs <- colnames(fit$centroids)

  aa <- pamr.predict(fit, x, threshold = threshold, type = "nonzero")
  cen <- pamr.predict(fit, x, threshold = threshold, type = "centroid")
  d <- (cen - fit$centroid.overall)[aa,, drop=FALSE]/fit$sd[aa]
  
  gene.order <- order(-apply(abs(d), 1, max))
  d <- round(d, 4)
  g <- gnames[aa]
  g1 <- geneid[aa]
  if (is.null(gnames)) {
    gnhdr <- NULL
  }
  if (!is.null(gnames)) {
    gnhdr <- "name"
  }

if(!is.null(fitcv)){
nfold=length(fitcv$cv.objects)

ind=matrix(F,nrow=nrow(x),ncol=nfold)
ranks=NULL
for( ii in 1:nfold){
	cen=pamr.predict(fitcv$cv.objects[[ii]], x[,-fitcv$folds[[ii]]],threshold=0, type="centroid")
	 dtemp <- (cen - fitcv$cv.objects[[ii]]$centroid.overall)[,, drop=FALSE]/fitcv$cv.objects[[ii]]$sd
	  r <- apply(abs(dtemp), 1, max)
	ranks=cbind(ranks,rank(-abs(r)))

	junk=pamr.predict(fitcv$cv.objects[[ii]], x[,-fitcv$folds[[ii]]],threshold=threshold, type="nonzero")
	ind[junk,ii]=T
}

av.rank=apply(ranks,1,mean)
av.rank=round(av.rank[aa],2)
prop=apply(ind[aa,,drop=F],1,sum)/nfold
}

  options(width = 500)
  schdr <- paste(clabs, "score", sep = "-")

if(is.null(fitcv)){
res <- cbind(as.character(g1), g, d)[gene.order, ]
  dimnames(res) <- list(NULL, c("id", gnhdr, schdr))

}
if(!is.null(fitcv)){
  res <- cbind(as.character(g1), g, d, av.rank, prop)[gene.order, ]
  dimnames(res) <- list(NULL, c("id", gnhdr, schdr, "av-rank-in-CV", "prop-selected-in-CV"))
}
  print(res, quote = FALSE)
}

pamr.makeclasses <- function(data,  sort.by.class = FALSE, ...) {
  as.matrix.dist <- function (x)  {
    size <- attr(x, "Size")
    df <- matrix(0, size, size)
    df[row(df) > col(df)] <- x
    df <- df + t(df)
    labels <- attr(x, "Labels")
    dimnames(df) <- if (is.null(labels)) 
      list(1:size, 1:size)
    else list(labels, labels)
    df
  }
  as.dist <- function (m, diag = FALSE, upper = FALSE) {
    m <- as.matrix(m)
    retval <- m[row(m) > col(m)]
    attributes(retval) <- NULL
    if (!is.null(rownames(m))) 
      attr(retval, "Labels") <- rownames(m)
    else if (!is.null(colnames(m))) 
      attr(retval, "Labels") <- colnames(m)
    attr(retval, "Size") <- nrow(m)
    attr(retval, "Diag") <- diag
    attr(retval, "Upper") <- upper
    attr(retval, "call") <- match.call()
    class(retval) <- "dist"
    retval
  }
  
  if(!is.null(data$samplelabels)) {
    labs <- data$samplelabels
  }
  if(!is.null(data$samplelabels) & !is.null(data$y)) {
    labs <- paste(data$y, labs)
  }
  if(is.null(data$samplelabels)) {
    labs <- 1:ncol(data$x)
  }
  par(col = 1, cex = 1)
  d <- dist(t(data$x))
  dd <- as.matrix.dist(d)
  if(sort.by.class) {
    tt <- table(data$y)
    nc <- length(tt)
    for(i in 1:nc) {
      o <- data$y == names(tt[i])
      d1 <- max(dd[o, o])
      d2 <- min(dd[o, !o])
      fac <- ((0.2 + (0.7 * i)/nc) * d2)/d1
      dd[o, o] <- dd[o, o] * fac
    }
  }
  hc <- hclust(as.dist(dd), ...)
  plot.hclust(hc, labels = labs)
  aa <- vector("list", 100)
  go <- TRUE
  i <- 0
  while(go & i < 100) {
    go <- FALSE
    i <- i + 1
    print(c("Identify class", i))
    par(pch = as.character(i), col = 4)
    aa[[i]] <- locator(type = "p")
    if(!is.null(aa[[i]])) {
      go <- TRUE
    }
  }
  nclus <- i - 1
  res <- vector("list", nclus)
  for(i in 1:nclus) {
    res[i] <- aa[i]
  }
  hdelta <- 1
  clus <- vector("list", nclus)
  for(j in 1:nclus) {
    for(jj in 1:length(res[[j]]$x)) {
      r <- c(res[[j]]$x[jj], res[[j]]$y[jj])
      d <- abs(hc$hei - r[2])
      o <- rank(d)
      ncomp <- 5
      oo <- (1:length(o))[o < ncomp + 1 & d < hdelta]
      if(length(oo) == 0) {
        stop(
             "1 Ambigious selection; try pamr.makeclasses again"
             )
      }
      ncomp2 <- length(oo)
      good <- rep(FALSE, ncomp2)
      ordpos <- match(1:length(hc$ord), hc$ord)
      nodes <- vector("list", ncomp2)
      for(ii in 1:ncomp2) {
        ooo <- descendants(hc$mer, oo[ii])[[2]]
        o4 <- as.vector(hc$mer[ooo,  ])
        nodes[[ii]] <- -1 * o4[o4 < 0]
        op <- ordpos[nodes[[ii]]]
        if(r[1] > min(op) & r[1] < max(op)) {
          good[ii] <- TRUE
        }
      }
                                        #browser()
      if(sum(good) != 1) {
        stop(
             "2 Ambigious selection; try pamr.makeclasses again"
             )
      }
                                        #browser()
      ii2 <- (1:ncomp2)[good]
      clus[[j]] <- c(clus[[j]], nodes[[ii2]])
    }
  }
  newy <- rep(NA, ncol(data$x))
  temp <- NULL
  for(i in 1:nclus) {
    clus[[i]] <- unique(clus[[i]])
  }
  for(i in 1:nclus) {
    temp <- c(temp, clus[[i]])
  }
  if(length(unique(temp)) < length(temp)) {
    stop("Clusters overlap; try pamr.makeclasses again")
  }
  for(i in 1:nclus) {
    newy[clus[[i]]] <- i
  }
  labs2 <- as.character(newy)
  labs2[labs2 == "NA"] <- ""
  par(col = 1, cex = 1)
  plot.hclust(hc, labels = labs2)
  return(as.factor(newy))
}

pamr.menu <- function(data) {
  done <- FALSE
  junk.train <- NULL
  junk.results <- NULL
  while(!done) {
    cat("", fill = TRUE)
    switch(menu(c("pamr.train", "pamr.cv", "pamr.plotcv", 
                  "pamr.plotcen", "pamr.confusion", 
                  "pamr.plotcvprob", "pamr.geneplot", 
                  "pamr.listgenes", 
                  "pamr.train with heterogeneity analysis", 
                  "Exit")),
           junk.train <- pamr.train(data),
           {
             if(is.null(junk.train)) {
               cat("Error: need to run pamr.train first", 
                   fill = TRUE)
             }
             if(!is.null(junk.train)) {
               junk.results <- pamr.cv(junk.train, data)
             }
           }
           ,
           {
             if(is.null(junk.results)) {
               cat("Error: need to run pamr.cv first", fill
                   = TRUE)
             }
             if(!is.null(junk.results)) {
               pamr.plotcv(junk.results)
             }
           }
           ,
           {
             if(is.null(junk.train)) {
               cat("Error: need to run pamr.train first", 
                   fill = TRUE)
             }
             if(!is.null(junk.train)) {
               cat("threshold?")
               threshold <- scan("", nlines = 1)
               pamr.plotcen(junk.train, data, threshold = 
                            threshold)
             }
           }
           ,
           {
             if(is.null(junk.results)) {
               cat("Error: need to run pamr.cv first", fill
                   = TRUE)
             }
             if(!is.null(junk.results)) {
               cat("threshold?")
               threshold <- scan("", nlines = 1)
               pamr.confusion(junk.results, threshold = 
                              threshold)
             }
           }
           ,
           {
             if(is.null(junk.results)) {
               cat("Error: need to run pamr.cv first", fill
                   = TRUE)
             }
             if(!is.null(junk.results)) {
               cat("threshold?")
               threshold <- scan("", nlines = 1)
               pamr.plotcvprob(junk.results, data, threshold
                               = threshold)
             }
           }
           ,
           {
             if(is.null(junk.train)) {
               cat("Error: need to run pamr.train first", 
                   fill = TRUE)
             }
             if(!is.null(junk.train)) {
               cat("threshold?")
               threshold <- scan("", nlines = 1)
               pamr.geneplot(junk.train, data, threshold = 
                             threshold)
             }
           }
           ,
           {
             if(is.null(junk.train)) {
               cat("Error: need to run pamr.train first", 
                   fill = TRUE)
             }
             if(!is.null(junk.train)) {
               cat("threshold?")
               threshold <- scan("", nlines = 1)
               pamr.listgenes(junk.train, data, threshold = 
                              threshold)
             }
           }
           ,
           {
             junkk.train <- NULL
             cat("Normal class?", fill = TRUE)
             normal <- scan("", nlines = 1, what = "")
             junk.train <- pamr.train(data, hetero = normal)
           }
           ,
           done <- TRUE)
  }
  cat("Done\n")
}

pamr.pairscore <-function(x, pair.ind=NULL) {
}

pamr.plotcen <- function(fit, data, threshold) {
  genenames <- data$genenames[fit$gene.subset]
  x <- data$x[fit$gene.subset, fit$sample.subset]
  clabs <- colnames(fit$centroids)
  scen <- pamr.predict(fit, data$x, threshold = threshold, type = "cent")
  dif <- scen - fit$centroid.overall
  nc <- length(unique(fit$y))
  o <- drop(abs(dif) %*% rep(1, nc)) > 0
  d <- dif[o,  ]
  nd <- sum(o)
  genenames <- genenames[o]
  xx <- x[o,  ]
  oo <- order(apply(abs(d), 1, max))
  d <- d[oo,  ]
  genenames <- genenames[oo]
  par(mar = c(1, 5, 1, 1), col = 1)
  plot(rep(2, nd) + d[, 1], 1:nd, xlim = c(0, 2*nc+1), ylim = c(1, nd + 3), 
       type = "n", xlab = "", ylab = "", axes = FALSE)
  box()
  abline(h = seq(nd), lty = 3, col = 7)
  jj <- rep(0, nd)
  for(j in 1:nc) {
    segments(jj + 2 * j, seq(nd), jj + 2 * j + d[, j], seq(nd), col
             = j + 1, lwd = 4)
    lines(c(2 * j, 2 * j), c(1, nd), col = j + 1)
    text(2 * j, nd + 2, label = clabs[j], col = j + 1)
  }
  g <- substring(genenames, 1, 20)
  text(rep(0, nd), seq(nd), label = g, cex = 0.4, adj = 0, col = 1)
}

pamr.plotcen <- function(fit, data, threshold) {
  genenames <- data$genenames[fit$gene.subset]
  x <- data$x[fit$gene.subset, fit$sample.subset]
  clabs <- colnames(fit$centroids)
  scen <- pamr.predict(fit, data$x, threshold = threshold, type = "cent")
  dif <- (scen - fit$centroid.overall)/fit$sd
  if(!is.null(fit$y)){
       nc <- length(unique(fit$y))
  }
   if(is.null(fit$y)){
      nc <- ncol(fit$proby)
}
  o <- drop(abs(dif) %*% rep(1, nc)) > 0
  d <- dif[o,  ]
  nd <- sum(o)
  genenames <- genenames[o]
  xx <- x[o,  ]
  oo <- order(apply(abs(d), 1, max))
  d <- d[oo,  ]
  genenames <- genenames[oo]
  par(mar = c(1, 5, 1, 1), col = 1)
  plot(rep(2, nd) + d[, 1], 1:nd, xlim = c(0, 2*nc+1), ylim = c(1, nd + 3), 
       type = "n", xlab = "", ylab = "", axes = FALSE)
  box()
  abline(h = seq(nd), lty = 3, col = 7)
  jj <- rep(0, nd)
  for(j in 1:nc) {
    segments(jj + 2 * j, seq(nd), jj + 2 * j + d[, j], seq(nd), col
             = j + 1, lwd = 4)
    lines(c(2 * j, 2 * j), c(1, nd), col = j + 1)
    text(2 * j, nd + 2, label = clabs[j], col = j + 1)
  }
  g <- substring(genenames, 1, 20)
  text(rep(0, nd), seq(nd), label = g, cex = 0.4, adj = 0, col = 1)
}
pamr.plotcv <- function(fit) {
  par(mar = c(5, 5, 5, 1))
  par(mfrow = c(2, 1))
  n <- nrow(fit$yhat)
  y <- fit$y
  if(!is.null(fit$newy)) {
    y <- fit$newy[fit$sample.subset]
  }
  nc <- length(table(y))
  nfolds <- length(fit$folds)
  err <- matrix(NA, ncol = ncol(fit$yhat), nrow = nfolds)
  temp <- matrix(y, ncol = ncol(fit$yhat), nrow = n)
  ni <- rep(NA, nfolds)
  for(i in 1:nfolds) {
    ii <- fit$folds[[i]]
    ni[i] <- length(fit$folds[[i]])
    err[i,  ] <- apply(temp[ii,  ] != fit$yhat[ii,  ], 2, sum)/ni[i]
  }
  se <- sqrt(apply(err, 2, var)/nfolds)
  plot(fit$threshold, fit$error, ylim = c(-0.1, 0.8), xlab = 
       "Value of threshold  ", ylab = "Misclassification Error", type
       = "n", yaxt = "n")
  axis(3, at = fit$threshold, lab = paste(fit$size), srt = 90, adj = 0)
  mtext("Number of genes", 3, 4, cex = 1.2)
  axis(2, at = c(0, 0.2, 0.4, 0.6, 0.8))
  lines(fit$threshold, fit$error, col = 2)
  o <- fit$err == min(fit$err)
  points(fit$threshold[o], fit$error[o], pch = "x")
  error.bars(fit$threshold, fit$err - se, fit$err + se)
  err2 <- matrix(NA, nrow = length(unique(y)), ncol = length(fit$threshold
                                                 ))
  for(i in 1:(length(fit$threshold) - 1)) {
    s <- pamr.confusion(fit, fit$threshold[i], extra = FALSE)
    diag(s) <- 0
    err2[, i] <- apply(s, 1, sum)/table(y)
  }
  plot(fit$threshold, err2[1,  ], ylim = c(-0.1, 1.1), xlab = 
       "Value of threshold ", ylab = "Misclassification Error", type
       = "n", yaxt = "n")
  axis(3, at = fit$threshold, lab = paste(fit$size), srt = 90, adj = 0)     
                                        #       mtext("Number of genes", 3, 4,cex=1.2)
  axis(2, at = c(0, 0.2, 0.4, 0.6, 0.8))
  for(i in 1:nrow(err2)) {
    lines(fit$threshold, err2[i,  ], col = i + 1)
  }
  legend(0, 0.9, dimnames(table(y))[[1]], col = (2:(nc + 1)), lty = 1)
  par(mfrow = c(1, 1))
}

error.bars <-function(x, upper, lower, width = 0.02, ...) {
  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)
}

pamr.plotcvprob <- function(fit, data, threshold) {
  par(pch = 1)
  ii <- (1:length(fit$threshold))[fit$threshold > threshold]
  ii <- ii[1]
  ss <- data$samplelabels
  pp <- fit$prob[,  , ii]
  if(is.null(fit$newy)) {
    y <- fit$y[fit$sample.subset]
  }
  if(!is.null(fit$newy)) {
    y <- fit$newy[fit$sample.subset]
  }
  o <- order(y)
  y <- y[o]
  if(!is.null(ss)) {
    ss <- ss[o]
  }
  ppp <- pp[o,  ]
  n <- nrow(ppp)
  nc <- length(unique(y))
  par(cex = 1)
  plot(1:n, ppp[, 2], type = "n", xlab = "sample", ylab = 
       "cross-validated probabilities", ylim = c(0, 1.2), axes = FALSE)
  axis(1)
  axis(2, at=seq(0, 1.2, by=0.2), labels = c("0.0", "0.2", "0.4", "0.6", "0.8", "1.0", ""))
  axis(4)
  for(j in 1:nc) {
    points(1:n, ppp[, j], col = j + 1)
  }
  for(j in 1:(nc - 1)) {
    abline(v = cumsum(table(y))[j] + 0.5, lty = 2)
  }
  h <- c(0, table(y))
  for(j in 2:(nc + 1)) {
    text(sum(h[1:(j - 1)]) + 0.5 * h[j], 1.02, label = levels(y)[j - 
                                                 1], col = j)
  }
  abline(h = 1)
  if(!is.null(ss)) {
    text(1:length(ss), 1.1, labels = ss, srt = 90, cex = 0.7)
  }
  ##if(!is.null(ss)){axis(3,labels=ss,at=1:length(ss),srt=90)}
}


pamr.plotfdr <- function(fdrfit,  call.win.metafile=FALSE){

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

om=fdrfit$results[,"Number of significant genes"]>0

na.min=function(x){min(x[!is.na(x)])}
na.max=function(x){max(x[!is.na(x)])}
  plot(fdrfit$results[om,"Number of significant genes"],fdrfit$results[om,"Median FDR"],log="x",
xlab="Number of genes called significant",
ylab="False discovery rate (median and 90th percentile)",type="b",  
ylim=c(na.min(fdrfit$results[om,"Median FDR"]), na.max(fdrfit$results[om,"90th percentile of FDR"])))
x=fdrfit$results[om,"Number of significant genes"]
 xlim <- range(x)
  barw <- abs((log(x)))*1.2
 upper=fdrfit$results[om,"90th percentile of FDR"]
lower=fdrfit$results[om,"Median FDR"]
 segments(x, upper, x, lower, lty=2)
 segments(x - barw, upper, x + barw, upper, lty=2)

  axis(3,at=fdrfit$results[om,"Number of significant genes"], labels=round(fdrfit$results[om,"Threshold"],2))
 
 mtext("Threshold", 3, 2, cex = 1.0)

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


  return()
}
pamr.plotstrata <-
function (fit, survival.time, censoring.status)
{
    group <-apply(fit$proby,1,which.is.max)
    n.class <- length(unique(group))
    junk <- survfit(Surv(survival.time, censoring.status) ~ as.factor(group))
    junk2 <- coxph(Surv(survival.time, censoring.status) ~ as.factor(group))
 
  pv <- 1-pchisq(2*(junk2$loglik[2]-junk2$loglik[1]),df=n.class-1)

if(!is.null(fit$cutoffs.survival)){
    labels <- rep(NULL,n.class)
    labels[1] <- paste("(1)   ","<= ", round(fit$cutoffs.survival[1],2),sep="")
    if(n.class>2){
        for(i in 2:(n.class-1)){
          labels[i] <- paste("(",as.character(i),")  ", " > ",
        round(fit$cutoffs.survival[i-1],2), "  & <= ", 
        round(fit$cutoffs.survival[i],2), sep="")
     }}
    labels[n.class] <-  paste("(",as.character(n.class),")  ", " > ",round(fit$cutoffs.survival[n.class-1],2),sep="")
  }

else{labels <- as.character(1:n.class)}

#    win.metafile()
    plot(junk, col = 2:(2 + n.class - 1), xlab = "Time", ylab = "Probability of survival", main="Survival Strata Plot")
 #   legend(0.7 * max(fit$survival.time), 0.9, col = 2:(2 + n.class -
     legend(.01* max(fit$survival.time), 0.2, col = 2:(2 + n.class -
        1), lty = rep(1, n.class), legend = labels)
     text(0.1 * max(fit$survival.time), .25, paste("pvalue=",as.character(round(pv,4))))

#   dev.off()
#   return(TRUE)
  }
pamr.predict <-  function(fit, newx, threshold, type = c("class", "posterior", "centroid", "nonzero"), 
                          prior = fit$prior,  threshold.scale = fit$
                          threshold.scale) {
  norm.cen <- fit$norm.cen
  if(!is.null(norm.cen)) {
    newx <- abs(t(scale(t(newx), center = norm.cen, scale = FALSE)))
  }
  type <- match.arg(type)
  sd <- fit$sd
  centroid.overall <- fit$centroid.overall
  centroids <- fit$centroids
  se.scale <- fit$se.scale
  delta <- scale((centroids - centroid.overall)/sd, FALSE, threshold.scale * 
                 se.scale)

  if(fit$sign.contrast=="positive"){delta <- delta*(delta>0)}
  if(fit$sign.contrast=="negative"){delta <- delta*(delta<0)}


  delta.shrunk <- scale(soft.shrink(delta, threshold), FALSE,
                        1/(  threshold.scale * se.scale))
  posid <- drop(abs(delta.shrunk) %*% rep(1, length(prior))) > 0
                
  if(!match(type, c("centroid", "nonzero"), FALSE))
    dd <- diag.disc((newx - centroid.overall)/sd, delta.shrunk, 
                    prior, posid)
  switch(type,
         class = softmax(dd),
         posterior = {
           dd <- safe.exp(dd)
           dd/drop(dd %*% rep(1, length(prior)))
         }
         ,
         centroid = centroid.overall + delta.shrunk * sd,
         nonzero = {
           nz <- drop(abs(delta.shrunk) %*% rep(1, ncol(centroids)
                                                )) > 0
           seq(nz)[nz]
         }
         )
}

safe.exp=function(x){
 xx=sign(x)*pmin(abs(x),500)
 return(exp(xx))
}

pamr.predictmany <- function(fit, newx, threshold=fit$threshold,
                             prior = fit$prior,  threshold.scale = fit$threshold.scale,
                             ...) {
  prob <-array(NA,c(length(prior),ncol(newx),length(threshold)))
  predclass <-matrix(NA,nrow=ncol(newx),ncol=length(threshold))
  
  for(i in 1:length(threshold)){
    prob[,,i] <-pamr.predict(fit,newx,threshold=threshold[i],type="posterior",...)
    predclass[,i] <-pamr.predict(fit,newx,threshold=threshold[i],type="class",...)
  }
  
  predclass <-matrix(levels(fit$y)[predclass],ncol=length((threshold)))

  return(list(prob=prob,predclass=predclass))
}













pamr.score.to.class1 <- function (x, scores, cutoff=2, n.class=2) 
{
        x.sml <- x[abs(scores)>cutoff,]
        out <- kmeans2(t(x.sml), centers=n.class)$cluster 
        return(out)
}
pamr.score.to.class2 <- function (x, scores, cutoff=2, n.pc=1, n.class=2) 
{
        x.sml <- x[abs(scores)>cutoff,]
        v <- svd(x.sml)$v
        v.sml <- v[,1:n.pc]
        out <- kmeans2(v.sml, centers=n.class)$cluster 
        return(out)
}


pamr.surv.to.class2 <- function (y, icens, cutoffs=NULL, n.class=NULL,  class.names=NULL, newy=y, newic=icens) 
# 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
{
        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)
}

kmeans2 <- function(x, ..., n.rep=10) 
# Performs k-means clustering multiple times from different starting
# points
{
        wss <- Inf
        for (i in 1:n.rep) {
                cur.fit <- kmeans(x, ...)
                if (sum(cur.fit$withinss) < wss) {
                        fit <- cur.fit
                        wss <- sum(fit$withinss)
                }
        }
        return(fit)
}
sam.func <- function (x, y, fudge=median(sd)) 
{
        y.l <- levels(y)
        x.n1 <- sum(y==y.l[1])
        x.n2 <- sum(y==y.l[2])
        x.1 <- x[,(y==y.l[1])]
        x.2 <- x[,(y==y.l[2])]
        x.bar1 <- apply(x.1, 1, mean)
        x.bar2 <- apply(x.2, 1, mean)
        x.var1 <- apply(x.1, 1, var) * (x.n1-1)
        x.var2 <- apply(x.2, 1, var) * (x.n2-1)
        sd <- sqrt(((1/x.n1 + 1/x.n2)/(x.n1+x.n2-2)) * (x.var1+x.var2))
        numer <- (x.bar1 - x.bar2)
        tt <- numer / (sd+fudge)
        return(list(tt=tt, numer=numer, sd=sd))
}
"cox.func"<-
function(x, y, icens, fudge = 0)
{
	scor <- coxscor(x, y, icens)$scor
	sd <- sqrt(coxvar(x, y, icens))
	tt <- scor/(sd + fudge)
	return(tt, numer = scor, sd)
}
"coxscor"<-
function(x, y, ic, offset = rep(0, length(y)))
{
# computes cox scor function for rows of nx by n matrix  x
	n <- length(y)
	nx <- nrow(x)
	yy <- y + (ic == 0) * (1.0000000000000001e-05)
	otag <- order(yy)
	y <- y[otag]
	ic <- ic[otag]
	x <- x[, otag, drop = F]
	offset <- offset[otag]	
	#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
	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]
		for(j in (1:n)[y >= fail.times[i]]) {
			w <- w - (d[i] * x[, j, drop = F] * safe.exp(offset[j]))/nno[
				i]
		}
	}
	return(scor = w, coxstuff.obs = a)
}
"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(safe.exp(offset)[y >= fail.times[i]])
	}
	s <- matrix(0, ncol = nf, nrow = nrow(x))
	d <- rep(0, nf)
	for(i in 1:nf) {
		o <- (1:n)[(y == fail.times[i]) & (ic == 1)]
		d[i] <- length(o)
		s[, i] <- apply(x[, o, drop = F], 1, sum)
	}
#expand d out to a vector of length n
	dd <- rep(0, n)
	for(j in 1:nf) {
		dd[(y == fail.times[j]) & (ic == 1)] <- d[j]
	}
	return(fail.times, s, d, dd, nf, nn, nno)
}
"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) * (9.9999999999999995e-07)
	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)
	for(i in 1:nf) {
		sx <- rep(0, nx)
		s <- rep(0, nx)
		ii <- (1:n)[y >= fail.times[i]]
		for(j in ii) {
			sx <- sx + (x[, j] * safe.exp(offset[j]))/nno[i]
		}
		for(j in ii) {
			s <- s + (x[, j]^2 * safe.exp(offset[j]))/nno[i]
		}
		w <- w + d[i] * (s - sx * sx)
	}
	return(w)
}
cox.func2 <- function (x, y, icens, fudge=median(sd)) 
# A faster version of cox.func.  Requires an external C function.
{
        if (!is.loaded("cox_func")) {
                dyn.load("/home/tibs/pamr/surv/cox_func.so")
        }
        n <- length(y)
        nx <- nrow(x)
        nf <- length(unique(y[icens==1]))
        yy <- y + (icens==0) * (1.0000000000000001e-05)
        otag <- order(yy)
        y <- y[otag]
        icens <- icens[otag]
        x <- x[, otag, drop=F]
        junk <- .C("cox_func", as.double(x), as.double(y),
                as.integer(icens), as.integer(nx), as.integer(n),
                as.integer(nf), scor=double(length=nx),
                sd=double(length=nx),
                PACKAGE="pamr")
        scor <- junk$scor
        sd <- sqrt(junk$sd)
        tt <- scor/(sd + fudge)
        return(list(tt=tt, numer=scor, sd=sd))
}
pamr.confusion.survival <-
  
 function(fit, survival.time,censoring.status, yhat){
   
# computes confusion matrix for (survival.time,censoring) outcome
# based on fit object "fit" and class predictions "yhat"
# soft response probabilities for (survival.time,censoring) are first estimated
#  using Kaplan-Meier method applied to training data
   
  n.class<- fit$ngroup.survival
  
true <- pamr.surv.to.class2(fit$survival.time, fit$censoring.status,newy=survival.time, newic=censoring.status, n.class=n.class)$prob

# use of temp below is to ensure that a categeory is not dropped
temp <- c(yhat, 1:n.class)
Yhat <- model.matrix( ~ factor(temp) - 1,data = list(y = temp))
Yhat <- Yhat[1:length(yhat),]


ytemp<- apply(true,1,which.is.max)
 temp <- c(yhat,names(table(ytemp)))
   nams <- names(table(temp))

      tt <- matrix(NA,nrow=length(fit$prior),ncol=length(fit$prior))
  
         for(i in 1:length(fit$prior)){
           for(j in 1:length(fit$prior)){
                 tt[i,j] <- sum(true[,i]*Yhat[,j])
               }}
     dimnames(tt) <- list(names(table(ytemp)),nams)

   tt1 <- tt
    diag(tt1) <- 0
    tt <- cbind(tt, apply(tt1, 1, sum)/apply(tt, 1, sum))
    dimnames(tt)[[2]][ncol(tt)] <- "Class Error rate"

return(tt)
}
pamr.plotsurvival <- function(group, survival.time, censoring.status){
  # plots Kaplan-Meier curves stratified by "group"
  n.class <- length(unique(group))
  junk <- survfit(Surv(survival.time, censoring.status)~as.factor(group))
  junk2 <- coxph(Surv(survival.time, censoring.status) ~ as.factor(group))      
  pv <- 1-pchisq(2*(junk2$loglik[2]-junk2$loglik[1]),df=n.class-1)

 plot(junk, col=2:(2+n.class-1) ,xlab= "Time", ylab="Probability of survival")
  
 legend(.01*max(survival.time),.2, col=2:(2+n.class-1), lty=rep(1,n.class),
        legend=as.character(1:n.class))
 text(0.01 * max(survival.time), .25, paste("pvalue=",as.character(round(pv,4))))
return()
}
 pamr.pvalue.survival <- function(group, survival.time, censoring.status,
                ngroup.survival)
        {
                temp <- coxph(Surv(survival.time, censoring.status) ~ as.factor(
                        group))
                loglik <- 2 * (temp$loglik[2] - temp$loglik[1])
                return(1 - pchisq(loglik, ngroup.survival - 1))
        }
order.class.survival <- function(a, survival.time, censoring.status){
#orders the classes specified in "a" by median survival time, from
#shortest to longest

med <- rep(NA,length(table(a)))
for(i in 1:length(table(a))){
    o <- a==i
    aa <- survfit(Surv(survival.time[o],censoring.status[o]))
    med[i] <- approx(aa$surv,aa$time, xout=.5, method="constant")$y
    }
aa <- rep(NA,length(a))
for(i in 1:length(table(a))){
  aa[a==i] <- rank(med)[i]
}
return(aa)
}

pamr.test.errors.surv.compute <- function(proby, yhat) {
## computes confusion matrix, class-wise error rate and overall error rate
## rows of confusion matrix refer to true classes; columns to predicted classes
##
## yhat is class prediction, proby is matrix of "true" soft class probabilities.
## 
  true <- proby
  ytemp <- apply(true, 1, which.is.max)
  temp <- c(yhat, names(table(ytemp)))
  nams <- names(table(temp))
  Yhat <- model.matrix(~factor(temp) - 1, data = list(y = temp))
  Yhat <- Yhat[1:length(yhat), ]
  nc <- ncol(proby)
  tt <- matrix(NA, nrow = nc, ncol = nc)
  for (i in 1:nc) {
    for (j in 1:nc) {
      tt[i, j] <- sum(true[, i] * Yhat[, j])
    }
  }
  dimnames(tt) <- list(names(table(ytemp)), nams)
  
  tt1 <- tt
  diag(tt1) <- 0
  tt <- cbind(tt, apply(tt1, 1, sum)/apply(tt, 1, sum))
  dimnames(tt)[[2]][ncol(tt)] <- "Class Error rate"
  error <- sum(tt1)/sum(tt)
  return(list(confusion=tt,error=error))
}

safe.exp=function(x){
 xx=sign(x)*pmin(abs(x),500)
 return(exp(xx))
}

pamr.to.excel <- function(data, file, trace = TRUE) {
  if(is.null(data$x) | is.null(data$y) | is.null(data$genenames) | 
     is.null(data$geneid)) {
    stop("Invalid format for input data")
  }
  n <- nrow(data$x)
  p <- ncol(data$x)
  row1 <- paste("", "", sep = "\t")
  if(!is.null(data$samplelabels)) {
    for(j in 1:p) {
      row1 <- paste(row1, data$samplelabels[j], sep = "\t")
    }
    write(row1, file = file, append = FALSE)
  }
  row2 <- paste("", "", sep = "\t")
  if(!is.null(data$batchlabels)) {
    for(j in 1:p) {
      row2 <- paste(row2, data$batchlabels[j], sep = "\t")
    }
    write(row2, file = file, append = TRUE)
  }
  row3 <- paste("", "", sep = "\t")
  for(j in 1:p) {
    row3 <- paste(row3, data$y[j], sep = "\t")
  }
  write(row3, file = file, append = TRUE)
  for(i in 1:n) {
    if(trace) {
      cat(c("writing row number", i), fill = TRUE)
    }
    xx <- paste(data$gene.id[i], data$genenames[i],  sep = "\t")
    for(j in 1:ncol(data$x)) {
      xx <- paste(xx, data$x[i, j], sep = "\t")
    }
    write(xx, file = file, append = TRUE)
  }
  return()
}
pamr.train <-
function(data, gene.subset=NULL, sample.subset=NULL,
         threshold = NULL, n.threshold = 30,
        scale.sd = TRUE, threshold.scale = NULL, se.scale = NULL, offset.percent = 50, hetero=NULL,
         prior = NULL,  remove.zeros = TRUE, sign.contrast="both", ngroup.survival=2)

{
  
# modified aug 2003 to add survival analysis facilities
#
# possibilities for different outcomes in data object "data":
#         y= class variable => classification problem
#         proby= matrix of class probabilities => "soft classification"
#              (not currently used by Excel interface)
#        survival time, censoring status present => survival analysis problem
#
# here is how the two  problem types  are passed to nsc:
#
#       class: y is class label, proby, prob.ytest not used
#       surv.km: proby are soft class labels, computed from kaplan-meier
  
        this.call <- match.call()

 if(!is.null(data$y)){problem.type <- "class"}
  if(!is.null(data$survival.time)) {problem.type <- "surv.km"}

        
          if(!is.null(data$proby) & !is.null(data$y)) {
           stop("Can't have both proby and y present in data object")
         }
        
          if(!is.null(data$y) & !is.null(data$survival.time)) {
    stop("Can't have both class label y and survival.time present in data object")
  }
        
        if(!is.null(data$y) & !is.null(data$censoring.status)) {
           stop("Can't have both class label y and censoring status present in data object")
         }
         if(!is.null(data$survival.time) & is.null(data$censoring.status)) {
           stop("Survival time specified but censoring status missing")
         }
          if(is.null(data$survival.time) & !is.null(data$censoring.status)) {
           stop("Censoring status specified but survival time missing")
         }
  
        
        y <- data$y
        proby <- data$proby
        ytest <- NULL
        xtest <- NULL
        prob.ytest <- NULL
       
        
        cutoffs.survival <- NULL
        
#       estimate class probabilities via Kaplan-Meier
#        use Cox score cutoff of 2.0 or 20th largest score, whichever is smaller
#       this ensures at least 20 genes are used for clustering
        
        if(!is.null(data$survival.time)){
          junk <- pamr.surv.to.class2(data$survival.time, data$censoring.status,
             n.class=ngroup.survival)
                 
            proby <- junk$prob
            cutoffs.survival <- junk$cutoffs
        }

        
# ytemp is just used for computation of the prior

 if(!is.null(y)){ ytemp <- y}
 if(is.null(y) & !is.null(proby)){ ytemp <- apply(proby,1, which.is.max)}
 if(is.null(sample.subset)){sample.subset <-1:ncol(data$x)}
 if(is.null(gene.subset)){gene.subset <-1:nrow(data$x)}

# for survival analysis, make default prior the equal prior

  if(is.null(prior) & !is.null(data$survival.time) ){
         prior <- rep(1/ngroup.survival, ngroup.survival)
}

        if(is.null(prior) & is.null(data$survival.time) )
          {prior <- table(ytemp[sample.subset])/length(ytemp[sample.subset])
           prior <- prior[prior!=0]
        }
      
    if(!is.null(y)){y <-  factor(y[sample.subset])}
        
    if(!is.null(proby)){
        proby <- proby[sample.subset,]}
        junk <- nsc(data$x[gene.subset, sample.subset], y=y, proby=proby,
 xtest=xtest, ytest=ytest, prob.ytest=prob.ytest,
          offset.percent=offset.percent,  threshold = threshold, hetero=hetero,
        n.threshold = n.threshold,  scale.sd= scale.sd,
                    threshold.scale=threshold.scale,
           se.scale= se.scale, prior=prior, remove.zeros=remove.zeros,
            sign.contrast=sign.contrast, problem.type=problem.type)

        junk$call <- this.call
        junk$gene.subset <- gene.subset
        junk$sample.subset <- sample.subset
        junk$survival.time <- data$survival.time
        junk$censoring.status <- data$censoring.status
       junk$cutoffs.survival <- cutoffs.survival
        junk$ngroup.survival <- ngroup.survival
        junk$problem.type <- problem.type
        class(junk)="pamrtrained"
        junk
}
pamr.options <- list(debug=TRUE, #whether to turn on debugging or not
                     err.file=ifelse(.Platform$OS.type=="windows", "C:/pamrtrace.txt", "pamrtrace.txt"),
                     image.file=ifelse(.Platform$OS.type=="windows", "C:/pamrimage.Rdata", "pamrimage.Rdata"),                     
                     reserved.class.label="Unspecified")

##
## Our error handler
##
pamr.xl.error.trace <- function() {
  err.message <- geterrmessage()
  if (!is.null(pamr.options$image.file)) {
    save.image(pamr.options$image.file)
  }
  if (!is.null(pamr.options$err.file)) {
    sink(pamr.options$err.file)
    print(err.message)
    traceback()
    sink()
  }
  winDialog(type="ok", message=err.message)
}

##
## Upon loading, if we are in a windows environment, we use the windows
## dialog mechanism to display errors. Useful for debugging COM apps
##
.onLoad <- function(lib, pkg) {

# Rob changed this next line on  apr 10, 2005, requested by Uwe Ligges

#  if ( .Platform$OS.type == "windows"  ) {
  if ( .Platform$OS.type == "windows" && interactive() ) {
    options(error=pamr.xl.error.trace)
  }

}

##
## Upon unload, we set things back the way they were...
##
.onUnload <- function(libpath){
  if ( .Platform$OS.type == "windows") {
    options(error=NULL)
  }
}


pamr.xl.get.threshold.range  <- function(fit) {
  return(range(fit$threshold))
}

pamr.xl.get.soft.class.labels  <- function(fit, survival.times, censoring.status) {
  proby <-  pamr.surv.to.class2(survival.times, censoring.status,
                                n.class=fit$ngroup.survival)$prob
  group <-apply(proby,1,which.is.max)
  return(group)
}
    

pamr.xl.compute.offset <- function(data, offset.percent=50, prior=prior){
  x <- data$x
  y <- data$y
  n.class <- table(y)
  if(min(n.class)==1){stop("Error: each class must have >1 sample")}
  norm.cent <-NULL
  n <- sum(n.class)
  xtest <- x
  ntest <- ncol(xtest)
  K <- length(prior)
  p <- nrow(x)
  Y <- model.matrix( ~ factor(y) - 1, data = list(y = y))
  dimnames(Y) <- list(NULL, names(n.class))
  centroids <- scale(x %*% Y, FALSE, n.class)
  sd <- rep(1, p)
  xdif <- x - centroids %*% t(Y)
  sd <- (xdif^2) %*% rep(1/(n - K), n)
  sd <- drop(sqrt(sd))
  offset  <- quantile(sd, offset.percent/100)
  return(offset)
}

pamr.xl.get.offset  <- function() {
  if (exists("x.train")) {
    return (x.train$offset)
  } else {
    return (pamr.xl.compute.offset(pamr.xl.data,
                                   offset.percent=pamr.xl.training.parameters$offset.percent,
                                   prior=pamr.xl.training.parameters$prior))
  }
}

pamr.xl.derive.adjusted.prior  <- function(prior, data) {
  ## Check this next code in if statement. For survival setting, it is always uniform
  ## and so the check may not be needed. Anyway, needs cleaning....
  if (pamr.xl.survival.setting) {
    s  <-  pamr.xl.get.uniform.prior(data, nclasses=pamr.xl.training.parameters$ngroup.survival)
    return (list(prior=s, prior.name="Uniform Prior"))
  } else {
    s  <- pamr.xl.get.sample.prior(data)
    temp <- prior - s
    if (sum(temp*temp) < pamr.xl.training.parameters$epsilon) {
      return (list (prior=s, prior.name="Sample Prior"))
    } else {
      s  <-  pamr.xl.get.uniform.prior(data)
      temp  <- prior - s
      if (sum(temp*temp) < pamr.xl.training.parameters$epsilon) {
        return (list (prior=s, prior.name="Uniform Prior"))
      } else {
        return (list (prior=prior, prior.name="Custom Prior"))      
      }
    }
  }
}

#pamr.xl.get.default.training.parameters <- function(data) {
#  if (pamr.xl.survival.setting) {
#    return (list(offset.percent=50,
#                 prior=pamr.xl.get.uniform.prior(data, nclasses=2),
#                 prior.name="Uniform Prior",
#                 sign.contrast="both",
#                 epsilon=1e-7,
#                 ngroup.survival=2,
#                 survival.method="Kaplan Meier"))
#  } else {
#    return (list(offset.percent=50,
#                 prior=pamr.xl.get.sample.prior(data),
#                 prior.name="Sample Prior",
#                 sign.contrast="both",
#                 epsilon=1e-7,
#                 ngroup.survival=2,
#                 survival.method="Kaplan Meier"))
#  }
#}



pamr.xl.get.default.training.parameters <- function(data) {
  if (pamr.xl.survival.setting) {
    return (list(offset.proportion=0.5,
                 offset.percent=50,
                 prior=NULL,
                 prior.name=NULL,
                 sign.contrast="both",
                 epsilon=1e-7,
                 ngroup.survival=2,
                 decorrelate=FALSE,
                 n.components=1))
                }
 if (pamr.xl.regression.setting) {

    return (list(offset.proportion=0.5,
                offset.percent=50,
                 prior=NULL,
                 prior.name=NULL,
                 sign.contrast="both",
                 epsilon=1e-7,
                 ngroup.survival=NULL,
                 decorrelate=FALSE,
                 n.components=1))
 }
if(!pamr.xl.survival.setting & !pamr.xl.regression.setting){
    return (list(offset.percent=50,
                 prior=pamr.xl.get.sample.prior(data),
                 prior.name="Sample Prior",
                 sign.contrast="both",
                 epsilon=1e-7,
                 ngroup.survival=NULL,
                 n.components=NULL))
                 
  }
}

## Return the uniform prior on class labels
pamr.xl.get.uniform.prior  <- function(data, nclasses=NULL) {
  if (is.null(nclasses)) {
    w <- table(data$y)
    n  <- length(w)
  } else {
    n = nclasses
  }
  return(rep(1.0/n, n))
}

## Return the sample proportion prior on class labels
pamr.xl.get.sample.prior  <- function(data) {
  w <- table(data$y)
  return(w/sum(w))
}

pamr.xl.get.class.names  <- function() {
  if (pamr.xl.survival.setting) {
    return(as.character(1:pamr.xl.training.parameters$ngroup.survival))
  } else {
    return(names(table(pamr.xl.data$y)))
  }
}



#pamr.xl.get.class.labels  <- function() {
#  if (pamr.xl.survival.setting) {
#    return(rep(" ", length(pamr.xl.survival.times)))
#  } else {
#    return(pamr.xl.data$y)
#  }
#}

pamr.xl.get.class.labels  <- function() {
    return(pamr.xl.data$y)
}


pamr.xl.get.number.of.classes  <- function() {
  if (pamr.xl.survival.setting) {
    return(pamr.xl.training.parameters$ngroup.survival)
  } else {
    return(length(names(table(pamr.xl.data$y))))
  }
}

#pamr.xl.process.data <- function(use.old.version=FALSE) {
#
#  res <- list(x=pamr.xl.raw.data, y=pamr.xl.class.labels, genenames=pamr.xl.gene.names, 
#              geneid=pamr.xl.gene.ids, samplelabels=pamr.xl.sample.labels,
#              batchlabels=pamr.xl.batch.labels, survival.time=pamr.xl.survival.times,
#              censoring.status=pamr.xl.censoring.status)
#  
#  if (pamr.xl.data.has.missing.values) {
#    if (use.old.version) {
#      res <- pamr.knnimpute.old(res, k = pamr.xl.knn.neighbors)      
#    } else {
#      res <- pamr.knnimpute(res, k = pamr.xl.knn.neighbors)
#    }
#  }
#  return(res)
#}

pamr.xl.process.data <- function(use.old.version=FALSE) {

# in this new version, the outcome is always stored in y
# the survival times component  is no longer used. Superpc now handles
# both the surival and regression problems

 if(!is.null(pamr.xl.class.labels)){
    y=pamr.xl.class.labels
   }
  if(is.null(pamr.xl.class.labels)){
    y=pamr.xl.survival.times
   }

  res <- list(x=pamr.xl.raw.data, y=y, genenames=pamr.xl.gene.names,
              geneid=pamr.xl.gene.ids, samplelabels=pamr.xl.sample.labels,
              batchlabels=pamr.xl.batch.labels, 
              censoring.status=pamr.xl.censoring.status)
  
  if (pamr.xl.data.has.missing.values) {
    if (use.old.version) {
      res <- pamr.knnimpute.old(res, k = pamr.xl.knn.neighbors)
    } else {
      res <- pamr.knnimpute(res, k = pamr.xl.knn.neighbors)
    }
  }
  return(res)
}   


pamr.xl.compute.cv.confusion  <- function (fit, cv.results, threshold) {
  threshold.rank  <- which(rank(abs(cv.results$threshold - threshold))==1)
  t.threshold  <- cv.results$threshold[threshold.rank]
  true  <- cv.results$y
  predicted  <- cv.results$yhat[, threshold.rank]
  tt <- table(true, predicted)
  tt1 <- tt
   diag(tt1) <- 0
  tt <- cbind(tt, apply(tt1, 1, sum)/apply(tt, 1, sum))
  dimnames(tt)[[2]][ncol(tt)] <- "Class Error rate"
  overall.err  <- round(sum(tt1)/sum(tt), 3)
  return(list(confusion.matrix=tt, overall.error=overall.err, threshold=round(t.threshold, 5)))
 }
pamr.xl.compute.confusion  <- function (fit, threshold) {
  ii <- (1:length(fit$threshold))[fit$threshold >= threshold]
  ii <- ii[1]
  predicted <- fit$yhat[, ii]
  if(!is.null(fit$y)){
    true <- fit$y[fit$sample.subset]
    tt <- table(true, predicted)
  } else {
    true <- fit$proby[fit$sample.subset,]
    ytemp<- apply(true,1,which.is.max)
    temp <- c(predicted,names(table(ytemp)))
    nams <- names(table(temp))
    Yhat <- model.matrix( ~ factor(temp) - 1,
                         data = list(y = temp))
    Yhat <- Yhat[1:length(predicted),]
    tt <- matrix(NA,nrow=length(fit$prior),ncol=length(fit$prior))
    for(i in 1:length(fit$prior)){
      for(j in 1:length(fit$prior)){
        tt[i,j] <- sum(true[,i]*Yhat[,j])
      }
    }
    dimnames(tt) <- list(names(table(ytemp)),nams)
  }
  tt1 <- tt
  diag(tt1) <- 0
  tt <- cbind(tt, apply(tt1, 1, sum)/apply(tt, 1, sum))
  dimnames(tt)[[2]][ncol(tt)] <- "Class Error rate"
  overall.err  <- round(sum(tt1)/sum(tt), 3)
  return(list(confusion.matrix=tt, overall.error=overall.err))
}

pamr.xl.is.a.subset  <- function(a, y) {
  if (pamr.xl.survival.setting) {
    x  <- as.character(1:pamr.xl.training.parameters$ngroup.survival)
  } else {
    x  <- a$y
  }
  if (nlevels(factor(x)) == nlevels(factor(c(x, y[!is.na(y)])))) {
    return (1)  # True
  } else {
    return (0)  # False
  }
}

pamr.xl.listgenes.compute  <- function (fit, data, threshold, fitcv=NULL,  genenames = FALSE) {
  x <- data$x[fit$gene.subset, fit$sample.subset]
  if (genenames) {
    gnames <- data$genenames[fit$gene.subset]
  }
  if (!genenames) {
    gnames <- NULL
  }
  geneid <- data$geneid[fit$gene.subset]
  if(!is.null(fit$y)){
       nc <- length(fit$y)
      }
 if(is.null(fit$y)){
       nc <- ncol(fit$proby)
      }
 clabs <- colnames(fit$centroids)

  aa <- pamr.predict(fit, x, threshold = threshold, type = "nonzero")
  cen <- pamr.predict(fit, x, threshold = threshold, type = "cen")
  d <- (cen - fit$centroid.overall)[aa, ]/fit$sd[aa]
  
  gene.order <- order(-apply(abs(d), 1, max))
  d <- round(d, 4)
  g <- gnames[aa]
  g1 <- geneid[aa]
  if (is.null(gnames)) {
    gnhdr <- NULL
  }
  if (!is.null(gnames)) {
    gnhdr <- "name"
  }

if(!is.null(fitcv)){
nfold=length(fitcv$cv.objects)

ind=matrix(F,nrow=nrow(x),ncol=nfold)
ranks=NULL
for( ii in 1:nfold){
        cen=pamr.predict(fitcv$cv.objects[[ii]], x[,-fitcv$folds[[ii]]],threshold=0, type="centroid")
         dtemp <- (cen - fitcv$cv.objects[[ii]]$centroid.overall)[,, drop=FALSE]/fitcv$cv.objects[[ii]]$sd
          r <- apply(abs(dtemp), 1, max)
        ranks=cbind(ranks,rank(-abs(r)))

        junk=pamr.predict(fitcv$cv.objects[[ii]], x[,-fitcv$folds[[ii]]],threshold=threshold, type="nonzero")
        ind[junk,ii]=T
}

av.rank=apply(ranks,1,mean)
av.rank=round(av.rank[aa],2)
prop=apply(ind[aa,,drop=F],1,sum)/nfold
}

  options(width = 500)
  schdr <- paste(clabs, "score", sep = " ")


if(is.null(fitcv)){
res <- cbind(as.character(g1), g, d)[gene.order, ]
  dimnames(res) <- list(NULL, c("id", gnhdr, schdr))

}
if(!is.null(fitcv)){
  res <- cbind(as.character(g1), g, d, av.rank, prop)[gene.order, ]
  dimnames(res) <- list(NULL, c("id", gnhdr, schdr, "av-rank-in-CV", "prop-selected-in-CV"))
}


  return(list(gene.headings = dimnames(res)[[2]],
              gene.ids = res[ , 2],   # This was switched with gene.names.
              gene.names = res[ , 1],
              gene.scores = res[ , -(1:2)]))
  ##print(res, quote = FALSE)
}
pamr.xl.plot.test.probs.compute  <- function(fit, new.x, newx.classes, missing.class.label, 
	threshold, sample.labels=NULL) {
  predicted.probs  <- pamr.xl.predict.test.probs(fit, new.x, threshold=threshold)
  py  <- pamr.xl.predict.test.class.only(fit, new.x, threshold=threshold)

  if (pamr.xl.survival.setting & !is.null(pamr.xl.test.survival.times) ) {
    proby <-  pamr.surv.to.class2(pamr.xl.test.survival.times, pamr.xl.test.censoring.status,
                                  n.class=fit$ngroup.survival)$prob
    group <-apply(proby,1,which.is.max)
    order.classes  <- order(group)
    actual.classes  <- group[order.classes]
  } else {
    order.classes  <- order(newx.classes)
    actual.classes <- newx.classes[order.classes]
    actual.classes[is.na(actual.classes)] <- missing.class.label
  }
  pp  <- predicted.probs[, order.classes]
  ny  <- py$predicted[order.classes]
  n  <- length(ny)
  ss  <- sample.labels
  if (!is.null(ss)) {
    ss  <- ss[order.classes]
  }
  if (pamr.xl.survival.setting) {
    training.classes <- levels(factor(as.character(1:pamr.xl.training.parameters$ngroup.survival)))
  } else {
    training.classes  <- levels(factor(fit$y))
  }
  
  return (list(x = 1:n,
               y = t(pp),
               x.label = "Sample",
               y.label = "Predicted Test Probabilities",
               y.names = training.classes,
               y.lines = cumsum(table(actual.classes)) + 0.5,
               x.dummy = vector(length=2, mode="numeric"),
               y.dummy = vector(length=2, mode="numeric"),
               panel.names = levels(factor(actual.classes)),
               x.names = ss))
}  



pamr.xl.plot.training.error.compute  <- function(trained.object) {
  if (pamr.xl.survival.setting) {
    n  <- length(trained.object$survival.time)
  } else {
    n  <- length(trained.object$y)
  }
  return (list(x = trained.object$threshold,
               y = trained.object$errors/n,
               y.ytop = trained.object$nonzero,
               x.label = "Threshold",
               y.label = "Training Error"))
}
pamr.xl.plotcen.compute  <- function(fit, data, threshold) {
  genenames <- data$genenames[fit$gene.subset]
  x <- data$x[fit$gene.subset, fit$sample.subset]
  clabs <- colnames(fit$centroids)
  scen <- pamr.predict(fit, data$x, threshold = threshold, type = "cent")
  dif <- (scen - fit$centroid.overall)/fit$sd
  if(!is.null(fit$y)){
       nc <- length(unique(fit$y))
  }
   if(is.null(fit$y)){
      nc <- ncol(fit$proby)
}
  o <- drop(abs(dif) %*% rep(1, nc)) > 0
  d <- dif[o,  ]
  nd <- sum(o)
  genenames <- genenames[o]  
  xx <- x[o,  ]
  oo <- order(apply(abs(d), 1, max))
  d <- d[oo,  ]
  genenames <- genenames[oo]
  win.metafile()
  par(mar = c(1, 5, 1, 1), col = 1)
  plot(rep(2, nd) + d[, 1], 1:nd, xlim = c(0, 2*nc+1), ylim = c(1, nd + 3), 
       type = "n", xlab = "", ylab = "", axes = FALSE)
  box()
  abline(h = seq(nd), lty = 3, col = 7)
  jj <- rep(0, nd)
  for(j in 1:nc) {
    segments(jj + 2 * j, seq(nd), jj + 2 * j + d[, j], seq(nd), col
             = j + 1, lwd = 4)
    lines(c(2 * j, 2 * j), c(1, nd), col = j + 1)
    text(2 * j, nd + 2, label = clabs[j], col = j + 1)
  }
  g <- substring(genenames, 1, 20)
  text(rep(0, nd), seq(nd), label = g, cex = 0.4, adj = 0, col = 1)
  dev.off()
#  pamr.plot.y <<- matrix(d, nrow=dim(d)[1])
#  pamr.plot.x <<- seq(nd)
#  pamr.plot.seriesnames <<- dimnames(d)[[2]]
#  pamr.plot.genenames <<- genenames

  return(TRUE)
}
pamr.xl.plotcv.compute  <- function(aa) {
  n <- nrow(aa$yhat)
  y <- aa$y
  if(!is.null(aa$newy)) {
    y <- aa$newy[aa$sample.subset]
  }
  nc <- length(table(y))
  nfolds <- length(aa$folds)
  err <- matrix(NA, ncol = ncol(aa$yhat), nrow = nfolds)
  temp <- matrix(y, ncol = ncol(aa$yhat), nrow = n)
  ni <- rep(NA, nfolds)
  for(i in 1:nfolds) {
    ii <- aa$folds[[i]]
    ni[i] <- length(aa$folds[[i]])
    err[i,  ] <- apply(temp[ii,  ] != aa$yhat[ii,  ], 2, sum)/ni[i]
  }
  se <- sqrt(apply(err, 2, var)/nfolds)

  err2 <- matrix(NA, nrow = length(unique(y)), ncol = length(aa$threshold)-1)
  for(i in 1:(length(aa$threshold) - 1)) {
    s <- pamr.confusion(aa, aa$threshold[i], extra = FALSE)
    diag(s) <- 0
    err2[, i] <- apply(s, 1, sum)/table(y)
  }
  if (pamr.xl.survival.setting) {
    p.values <- aa$pvalue.survival
  } else {
    p.values  <- NULL
  }
  
  return (list(x = aa$threshold,
               y = aa$error,
               x.label = "Threshold",
               y.label = "Misclassification Error",
               y.se = se,
               p.values = p.values,
               y.ytop = aa$size,
               cv.err = t(err2),
               cv.legend = dimnames(table(y))[[1]]))
               
}
pamr.xl.plotcvprob.compute  <- function(fit, data, threshold) {
  ii <- (1:length(fit$threshold))[fit$threshold > threshold]
  ii <- ii[1]
  ss <- data$samplelabels
  pp <- fit$prob[,  , ii]
  if(is.null(fit$newy)) {
    y <- fit$y[fit$sample.subset]
  }
  if(!is.null(fit$newy)) {
    y <- fit$newy[aa$sample.subset]
  }
  o <- order(y)
  y <- y[o]
  if(!is.null(ss)) {
    ss <- ss[o]
  }
  ppp <- pp[o,  ]
  n <- nrow(ppp)
  nc <- length(unique(y))


#  axis(2, labels = c("0.0", "0.2", "0.4", "0.6", "0.8", "1.0", ""))
#  if (!is.null(ss)) {
#    pamr.plot.x.names <<- ss
#  }

  return (list(x = 1:n,
               y = ppp,
               x.label = "Sample",
               y.label = "CV Probabilities",
               y.names = levels(y),
               y.lines = cumsum(table(fit$y)),
               x.dummy = vector(length=2, mode="numeric"),
               y.dummy = vector(length=2, mode="numeric"),
               x.names = ss))
  
#   for(j in 1:nc) {
#     points(1:n, ppp[, j], col = j + 1)
#   }
#   for(j in 1:(nc - 1)) {
#     abline(v = cumsum(table(y))[j] + 0.5, lty = 2)
#   }
#   h <- c(0, table(y))
#   for(j in 2:(nc + 1)) {
#     text(sum(h[1:(j - 1)]) + 0.5 * h[j], 1.02, label = levels(y)[j - 
#                                                  1], col = j)
#   }
#   abline(h = 1)
#   if(!is.null(ss)) {
#     text(1:length(ss), 1.1, labels = ss, srt = 90, cex = 0.7)
#   }
  ##if(!is.null(ss)){axis(3,labels=ss,at=1:length(ss),srt=90)}
}
pamr.xl.predict.test.class<- function(fit, newx, threshold, test.class.labels) {
  predicted  <- pamr.predict(fit, newx, threshold, type="class")
  return(list(confusion.matrix=table(test.class.labels, predicted), predicted=as.vector(predicted)))
}

pamr.xl.predict.test.surv.class <- function(fit, newx, threshold, survival.times, censoring.status) {
  predicted  <- pamr.predict(fit, newx, threshold, type="class")
  soft.probs  <- pamr.surv.to.class2(survival.times, censoring.status,
                                     n.class=pamr.xl.training.parameters$ngroup.survival)$prob
  w  <- pamr.test.errors.surv.compute(soft.probs, predicted)
  return(list(confusion.matrix=w$confusion, predicted=as.vector(predicted)))
}

pamr.xl.predict.test.class.only  <- function(fit, newx, threshold) {
  return(list(predicted=as.vector(pamr.predict(fit, newx, threshold, type="class"))))
}

pamr.xl.predict.test.probs  <- function(fit, newx, threshold) {
  predicted  <- pamr.predict(fit, newx, threshold, type="posterior")
  return(t(predicted))
}

pamr.xl.test.data.impute  <- function(x, k, use.old.version=FALSE) {
  if (use.old.version) {
    res <- pamr.knnimpute.old(list(x=x), k = pamr.xl.knn.neighbors) 
  } else {
    res  <- pamr.knnimpute(list(x=x), k = pamr.xl.knn.neighbors)
  }
  return(res$x)
}

pamr.xl.test.errors.surv.compute <- function(fit, newx, threshold=fit$threshold, survival.times, censoring.status) {
  prediction.errs  <- vector(mode="numeric", length=length(threshold))
  soft.probs  <- pamr.surv.to.class2(survival.times, censoring.status,
                                     n.class=pamr.xl.training.parameters$ngroup.survival)$prob
  for (i in 1:length(threshold)) {
    predicted  <- pamr.predict(fit, newx, threshold=threshold[i], type="class")
    w  <- pamr.test.errors.surv.compute(soft.probs, predicted)
    prediction.errs[i]  <- w$error
  }
  return(list(x=threshold, y=prediction.errs, x.label="Threshold", y.label="Test Error", ))  
}



pamr.xl.test.errors.compute  <- function(fit, newx, newx.classes, threshold=fit$threshold,
                                         prior = fit$prior,  threshold.scale = fit$threshold.scale,
                                         ...) {
  n  <- length(which(!is.na(newx.classes)))
## Note: n is assumed to be nonzero! Check before calling!
  actual.classes  <- newx.classes
  prediction.errs  <- vector(mode="numeric", length=length(threshold))
  
  for(i in 1:length(threshold)){
    t <- pamr.predict(fit,newx,threshold=threshold[i],type="class",...)
    prediction.errs[i]  <- length(which(t != actual.classes)) / n
  }
  
  return(list(x=threshold, y=prediction.errs, x.label="Threshold", y.label="Test Error", ))
  
}

pamr.xl.transform.class.labels  <- function(x) {
  y  <- x
  y[is.na(y)]  <- " "
  return(y)
}

pamr.xl.transform.data <- function(data) {

  if (pamr.xl.take.cube.root) {
    data$x = pamr.cube.root(data$x)
  }

  if (pamr.xl.batch.labels.present) {
    data <- pamr.batchadjust(data)
  }

  if (pamr.xl.center.columns && pamr.xl.scale.columns) {
    data$x = scale(data$x, center=TRUE, scale=TRUE)
  } else if (pamr.xl.center.columns) {
    data$x = scale(data$x, center=TRUE, scale=FALSE)
  } else if (pamr.xl.scale.columns) {
    data$x = scale(data$x, center=FALSE, scale=TRUE)
  }

  return (data)
}

pamr.xl.transform.test.data <- function(test.x) {
  res <- test.x
  if (pamr.xl.take.cube.root) {
    res = pamr.cube.root(res)
  }

  if (pamr.xl.center.columns && pamr.xl.scale.columns) {
    res = scale(res, center=TRUE, scale=TRUE)
  } else if (pamr.xl.center.columns) {
    res = scale(res, center=TRUE, scale=FALSE)
  } else if (pamr.xl.scale.columns) {
    res = scale(res, center=FALSE, scale=TRUE)
  }

  return (res)
}

pamr.xl.plotsurvival<- function(fit, data, threshold) {
  group  <- pamr.predict(fit, data$x, threshold=threshold)
  ## plots Kaplan-Meier curves stratified by "group"
  n.class <- length(unique(group))
  junk <- survfit(Surv(fit$survival.time, fit$censoring.status)~as.factor(group))
  win.metafile()
  plot(junk, col=2:(2+n.class-1) ,xlab= "Time", ylab="Probability of survival", main="Survival Plot")
  legend(.8*max(fit$survival.time),.9, col=2:(2+n.class-1), lty=rep(1,n.class),
         legend=as.character(1:n.class))
  dev.off()
  return(TRUE)
}

pamr.xl.plotsurvival.test <- function(fit, newx, survival.time, censoring.status, threshold) {
  group  <- pamr.predict(fit, newx, threshold=threshold)
  ## plots Kaplan-Meier curves stratified by "group"
  n.class <- length(unique(group))
  junk <- survfit(Surv(survival.time, censoring.status)~as.factor(group))
  win.metafile()
  plot(junk, col=2:(2+n.class-1) ,xlab= "Time", ylab="Probability of survival", main="Test Survival Plot")
  legend(.8*max(survival.time),.9, col=2:(2+n.class-1), lty=rep(1,n.class),
         legend=as.character(1:n.class))
  dev.off()
  return(TRUE)
}

pamr.xl.plotsurvival.strata <- function(fit, data) {
  group <-apply(fit$proby,1,which.is.max)
  n.class <- length(unique(group))
  junk <- survfit(Surv(data$survival.time, data$censoring.status) ~ as.factor(group))
  junk2 <- coxph(Surv(data$survival.time, data$censoring.status) ~ as.factor(group))
  
  pv <- 1-pchisq(2*(junk2$loglik[2]-junk2$loglik[1]),df=n.class-1)
  
  if(!is.null(fit$cutoffs.survival)){
    labels <- rep(NULL,n.class)
    labels[1] <- paste("(1)   ","<= ", round(fit$cutoffs.survival[1],2),sep="")
    if(n.class>2){
      for(i in 2:(n.class-1)){
        labels[i] <- paste("(",as.character(i),")  ", " > ",
                           round(fit$cutoffs.survival[i-1],2), "  & <= ", 
                           round(fit$cutoffs.survival[i],2), sep="")
      }}
    labels[n.class] <-  paste("(",as.character(n.class),")  ", " > ",round(fit$cutoffs.survival[n.class-1],2),sep="")
  }
  
  else{labels <- as.character(1:n.class)}
  
  win.metafile()
  plot(junk, col = 2:(2 + n.class - 1), xlab = "Time", ylab = "Probability of survival",
       main="Survival Strata Plot")
  legend(.01* max(fit$survival.time), 0.2, col = 2:(2 + n.class -
                                             1), lty = rep(1, n.class), legend = labels)
  text(0.1 * max(fit$survival.time), .25, paste("pvalue=",as.character(round(pv,4))))
  
  dev.off()
  return(TRUE)
}

pamr.xl.test.get.soft.classes  <- function(fit, survival.times, censoring.status) {
  proby <-  pamr.surv.to.class2(survival.times, censoring.status,
                                n.class=fit$ngroup.survival)$prob
  soft.classes  <- apply(proby,1,which.is.max)
  return(list(classes=soft.classes, probs = t(proby)))
}
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)
}

print.nsc <- function(x, ...) {
  cat("Call:\n")
  dput(x$call)
  mat <- rbind(threshold = format(round(x$threshold, 3)), nonzero = 
               format(trunc(x$nonzero)), errors = x$errors)
  dimnames(mat) <- list(dimnames(mat)[[1]], paste(1:ncol(mat)))
  print(t(mat), quote = FALSE)
  invisible()
}
 print.nsccv <-function(x, ...) {
   cat("Call:\n")
   dput(x$call)
  
   mat <- rbind(threshold = format(round(x$threshold, 3)), nonzero = 
                format(trunc(x$size)), errors = trunc(x$error * nrow(
                                              x$yhat)))
   if(!is.na(x$pvalue.survival[1])){
     mat <- rbind(mat, pvalue=round(x$pvalue.survival,6))
   }
   dimnames(mat) <- list(dimnames(mat)[[1]], paste(1:ncol(mat)))
 
   print(t(mat), quote = FALSE)
   invisible()
 }
 print.pamrcved <-function(x, ...) {
   cat("Call:\n")
   dput(x$call)
  
   mat <- rbind(threshold = format(round(x$threshold, 3)), nonzero = 
                format(trunc(x$size)), errors = trunc(x$error * nrow(
                                              x$yhat)))
   if(!is.na(x$pvalue.survival[1])){
     mat <- rbind(mat, pvalue=round(x$pvalue.survival,6))
   }
   dimnames(mat) <- list(dimnames(mat)[[1]], paste(1:ncol(mat)))
 
   print(t(mat), quote = FALSE)
   invisible()
 }
print.pamrtrained <- function(x, ...) {
  cat("Call:\n")
  dput(x$call)
  mat <- rbind(threshold = format(round(x$threshold, 3)), nonzero = 
               format(trunc(x$nonzero)), errors = x$errors)
  dimnames(mat) <- list(dimnames(mat)[[1]], paste(1:ncol(mat)))
  print(t(mat), quote = FALSE)
  invisible()
}
roc.nsc <-function(object) {
###Computes the roc curve for a nsc model
  nonzero <- object$nonzero^(1/4)
  errors <- object$errors
  if(is.null(errors))
    stop("No errors component")
  n <- length(errors)
  heights <- (errors[1:(n - 1)] + errors[2:n])/2
  bases <- diff(nonzero)
  area <- sum((nonzero[-1] + nonzero[-n]) * heights * bases) /
    (-2 * diff(range(nonzero)))
  area
}
softmax <-function(x, gap = FALSE) {
  d <- dim(x)
  maxdist <- x[, 1]
  pclass <- rep(1, d[1])
  for(i in seq(2, d[2])) {
    l <- x[, i] > maxdist
    pclass[l] <- i
    maxdist[l] <- x[l, i]
  }
  dd <- dimnames(x)[[2]]
  if(gap) {
    x <- abs(maxdist - x)
    x[cbind(seq(d[1]), pclass)] <- drop(x %*% rep(1, d[2]))
    gaps <- do.call("pmin", data.frame(x))
  }
  pclass <- if(is.null(dd) || !length(dd))
    pclass
  else
    factor(pclass, levels = seq(d[2]), labels = dd)
  if(gap)
    list(class = pclass, gaps = gaps)
  else
    pclass
}
soft.shrink <-function(delta, threshold) {
  dif <- abs(delta) - threshold
  delta <- sign(delta) * dif * (dif > 0)
  nonzero <- sum(drop((dif > 0) %*% rep(1, ncol(delta))) > 0)
  attr(delta, "nonzero") <- nonzero
  delta
}
which.is.max <- function(x)
{
        y <- seq(length(x))[x == max(x)]
        if(length(y) > 1)
                y <- sample(y, 1)
        y
}
