.packageName <- "GolubRR"
##copyright R. Gentleman, 2002, All rights reserved

##S language implementation of the results reported in Golub et al, 1999

#their "correlation" function

 P <- function(g, c) {
    twog <- split(g, c)
    mn <- sapply(twog, mean)
    sd <- sapply(twog, sd)
    (mn[1]-mn[2])/(sd[1]+sd[2])
 }

##fixme: how to get the classes right?
##this doesn't get used any more, vstruct and dovote are the real
##implementations

votes <- function (eset, c)
{
    x <- exprs(eset)
    mns <- rep(NA, nrow(x))
    wts <- rep(NA, nrow(x))
    closer <- x
    for (i in 1:nrow(x)) {
        rowv <- x[i, ]
        rmns <- sapply(split(rowv, c), mean)
        closer[i, ] <- ifelse(abs(rowv - rmns[1]) > abs(rowv -
            rmns[2]), "ALL", "AML")
        mns[i] <- (rmns[1] + rmns[2])/2
        wts[i] <- abs(P(rowv, c))
    }
    vote <- abs(x - mns)
    return(list(closer = closer, mns = mns, wts = wts, vote = vote))
}

##to do prediction we need the class means and the weights

vstruct <- function(eset, c) {
    wts <- apply(exprs(eset), 1, function(x) abs(P(x, c)))
    mns <- apply(exprs(eset), 1, function(x) sapply(split(x, c), mean))
    ans <- list(wts=wts, mns=mns)
    class(ans) <- "vstruct"
    return(ans)
}

dovote <- function(x, vstr) {
    if( !inherits(vstr, "vstruct") )
        stop("wrong argument")
    mns <- apply(vstr$mns, 2, mean)
    vote <- abs(x-mns)
    t1 <- abs(vstr$mns-rep(x, rep(2, length(x))))
    wh <- apply(t1, 2, function(x) {if(x[1] > x[2]) "AML" else "ALL"})
    vts <- split(vote, wh)
    wts <- split(vstr$wts, wh)
    vAML <- sum(vts$AML*wts$AML)
    vALL <- sum(vts$ALL*wts$ALL)
    if( is.null(vAML) ) vAML <- 0
    if( is.null(vALL) ) vALL <- 0
    if( vAML > vALL ) wh <- "AML" else wh<-"ALL"
    PS <- abs(vAML-vALL)/(vALL+vAML)
    ans <- list(PS=PS, vAML=vAML, vALL=vALL, wh=wh)
    return(ans)
}


PScv <- function(eset, cov) {
    Xpers <- exprs(eset)
    nS <- ncol(Xpers)
    ans <- vector("list", length=nS)
    for(i in 1:nS) {
        vStr <- vstruct(eset[,-i], cov[-i])
        ans[[i]] <- dovote(Xpers[,i], vStr)
    }
    return(ans)
}



##
 permCor <- function(exprSet, c, seed, nPerm) {
     set.seed(seed)

     ans<-list()
     for(i in 1:nPerm) {
       cstar <- sample(c)
       ##a bug - the cstar below used to be c
       ##found by a reader: A. Stoddard <astoddar@mail.med.upenn.edu>
       ans[[i]] <- esApply(exprSet, 1, function(x) P(x, cstar))
     }

     ans
}


##some layout to get something like Fig 3 b

##  nf <- layout(matrix(c(1,2,3)), c(1,1,1), c(1,9,1))

##PS function -- from old work

## PS <- function(eSet, vec, classes, weights) {
##     exprs <- exprs(eSet)
##     clevs <- levels(classes)
##     if(length(clevs) != 2)
##         stop("class vector must have 2 levels")
##     spFun <- function(x) {
##         sp <- split(x, classes)
##         mns <- sapply(sp, mean)
##         c(mns, sum(mns)/2)
##     }
##     mns <- apply(exprs, 1, spFun)
##     v <- abs(vec - mns[3,])*weights
##     gp <- ifelse(abs(vec - mns[1,])<abs(vec - mns[2,]), clevs[1], clevs[2])
##     return(list(v=v,gp=gp))
## }


##wts <- abs(esApply(gTrPS, 1, function(x) P(x, c)))

##rv<-vector("list", length=38)
##for(i in 1:38)
## rv[[i]] <-PS(gTrPS[,-i], exprs(gTrPS)[,i], gTrPS$ALL[-i], wts)

##gps <- sapply(rv, function(x) table(x$gp))

##PStren <- sapply(rv, function(x) {sp<-split(x$v, x$gp)
##                                  mns <- sapply(sp, mean)
##                                  abs(mns[1]-mns[2])/sum(mns)})
