.packageName <- "LMGene"
"GetLMObj" <-
function (eS, model=NULL) 
{
  mat1 <- as.matrix(exprs(eS))

  # model information 

  if (is.null(model)) {
    model <- ''
    vars <- varLabels(eS)
    for (i in 1:length(vars)){
      model <- paste(model, vars[i], ifelse(i<length(vars), '+', ''), sep='')
    }
  }

  model2 <- paste("y ~",model)
  y <- mat1[1,]
  formobj <- as.formula(model2)
  mod <- lm(formobj, x=TRUE, data=pData(eS))
  return(mod)
}
"LMGene" <-
function (eS, model=NULL, level = 0.05 ) 
{
    pvlist <- genediff(eS, model)
    #Check for overfitting
    if (is.null(pvlist)) {return(NULL)}
    #Otherwise proceed
    apvlist <- pvadjust(pvlist)
    numeff <- ncol(apvlist$Posterior.FDR)
    for (effnum in 1:numeff) {
        tmp <- rowlist(exprs(eS), effnum, apvlist, level)
        if (effnum == 1) {
            if (length(tmp) > 1) {
                lmres <- list(tmp = tmp)
            }
            else if (tmp != -1) {
                lmres <- list(tmp = tmp)
            }
            else {
                lmres <- list(tmp = "No significant genes")
            }
        }
        else {
            if (length(tmp) > 1) {
                lmres <- c(lmres, list(tmp = tmp))
            }
            else if (tmp != -1) {
                lmres <- c(lmres, list(tmp = tmp))
            }
            else {
                lmres <- c(lmres, list(tmp = "No significant genes"))
            }
        }
        effname <- colnames(apvlist$Posterior.FDR)[effnum]
        names(lmres)[effnum] <- effname
    }
    return(lmres)
}
"genediff" <-
function(eS, model=NULL)
#
# computes two vectors of p-values per gene or probe
#   using gene-by-gene anova with individual gene MSE using 
#   both the gene-specific MSE and the posterior mean MSE for
#   each term in the anova. Assumes a fixed effects model and
#   the correct denominator for all comparisons is the MSE
# mat1 is a p by n matrix of expression values
# vlist is a list of the form list(v1=v1,v2=v2,..) of variables, 
#   each of length n, the number of chips
# model is the model for each gene in the form of a character 
#   string with variables from vlist. An example is "v1 + v2"
#
# create variables
#
{ 
  mat1 <- as.matrix(exprs(eS))
  
  if (is.null(model)) {
    model <- ''
    vars <- varLabels(eS)
    for (i in 1:length(vars)){
      model <- paste(model, vars[i], ifelse(i<length(vars), '+', ''), sep='')
    }
  } 

  model2 <- paste("y ~",model)
  mat2 <- as.matrix(mat1)
  p <- dim(mat2)[1]
  n <- dim(mat2)[2]
#
# retrieve effect names
#
  owaov <- function(y)
  {
    formobj <- as.formula(model2)
    tmp <- row.names(anova(lm(formobj, data=pData(eS))))
    return(tmp)
  }
  effnames <- owaov(mat2[1,])
#
# Perform ANOVA's and retrieve mean squares and df's
#
  numeff <- length(effnames)
  tmp1 <- rowaov(eS, model)
  #Check if overfit:
  if (is.null(tmp1)) {return(NULL)}
  #Otherwise proceed
  msmat <- tmp1[1:numeff,]
  dfmat <- tmp1[(numeff+1):(2*numeff),]
  numf <- numeff-1
  nu <- median(dfmat[numeff,])
  dfvec <- dfmat[numeff,]
  msevec <- msmat[numeff,]
#
# compute hyperparameters for prior
#

  mn <- mean(msevec)
  v <- var(msevec)
  alpha <- (mn^2-2*mn^2/nu +2*v)/(v-2*mn^2/nu)
  beta <- 1/(mn*(alpha-1))
  eta <- alpha*beta
  prior <- 1/eta
  df <- 2*alpha
#
# compute adjusted mean square errors
#
  adjdfvec <- dfvec+df
  adjmsevec <- (msevec*dfvec+prior*df)/adjdfvec
#
# compute F statistics and p-values
#
  pmat1 <- matrix(numeric(numf*p),ncol=numf)
  pmat2 <- pmat1
  for (i in 1:numf)
  { 
    pmat1[,i] <- 1-pf(msmat[i,]/msevec,dfmat[i,],dfvec) 
    pmat2[,i] <- 1-pf(msmat[i,]/adjmsevec,dfmat[i,],adjdfvec) 
  }
  colnames(pmat1) <- effnames[-numeff]
  colnames(pmat2) <- effnames[-numeff]

  return(list("Gene.Specific"=pmat1,"Posterior"=pmat2))
}
"glog" <-
function(y,lambda)
{
  yt <- log(y+sqrt(y^2+lambda))
  return(yt)
}
"jggrad2" <-
function(y,lambda,alpha)
{
  ya <- y-alpha
  g <- glog(ya,lambda)
  z <- sqrt(ya^2+lambda)
  za <- -ya/z
  zl <- 1/(2*z)
  ga <- -1/z
  gl <- 2*z*(ya+z)
  gl <- 1/gl
  J <- exp(mean(log(z)))
  Ja <- J*mean(za/z)
  Jl <- J*mean(zl/z)
  jg <- g*J
  jga <- ga*J+g*Ja
  jgl <- gl*J+g*Jl
  return(cbind(jg,jgl,jga))
}
"jglog" <-
function(y,lambda)
{
  z <- sqrt(y^2+lambda)
  gmn <- exp(mean(log(z)))
  y1 <- glog(y,lambda)
  y1 <- y1*gmn
  return(y1)
}
"lnorm" <-
function(mat1,span=.1)
{
  mat2 <- as.matrix(mat1)
  p <- dim(mat2)[1]
  n <- dim(mat2)[2]
  rmeans <- apply(mat2,1,mean)
  rranks <- rank(rmeans,ties.method="first")
  matsort <- mat2[order(rranks),]  
  r0 <- 1:p
  lcol <- function(x)
  {
    lx <- lowess(r0,x,f=span)$y
  }
  lmeans <- apply(matsort,2,lcol)
  lgrand <- apply(lmeans,1,mean)
  lgrand <- matrix(rep(lgrand,n),byrow=FALSE,ncol=n)
  matnorm0 <- matsort-lmeans+lgrand
  matnorm1 <- matnorm0[rranks,]
  return(matnorm1)
}
"lnormeS" <-
function (eS, span=0.1)
{
  normat <- lnorm(exprs(eS), span)
  normed.eS <- neweS(normat, pData(eS))
  return(normed.eS)
}
"mlm2lm" <-
function(lmobj,i)
{
  lmobj2 <- lmobj
  lmobj2$coefficients <- (lmobj$coefficients)[,i]
  lmobj2$residuals <- (lmobj$residuals)[,i]
  lmobj2$effects <- (lmobj$effects)[,i]
  lmobj2$fitted.values <- (lmobj$fitted.values)[,i]
  class(lmobj2) <- "lm"
  return(lmobj2)
}
"msa" <-
function(v)
{
  tmp <- sum(v^2)
  if (tmp==0)tmp <- 1
  return(v/sum(v))
  
}
"msecalc" <- 
function (eS, lam, alpha, lowessnorm, R) 
{
    starttime <- Sys.time()
    mat1 <- as.matrix(exprs(eS))
 #   for (i in 1:length(varLabels(eS))) {
 #       assign(paste("x", i, sep = ""), as.factor(pData(eS)[,i]))
 #   }
 #   fchar <- ""
 #   for (i in 1:length(varLabels(eS))) {
 #       fchar <- paste(fchar, paste("x", i, sep = ""), ifelse(i < 
 #           length(varLabels(eS)), "+", ""), sep = "")
 #   }
    mat2 <- as.matrix(mat1)

    n <- dim(mat2)[2]
    p <- dim(mat2)[1]
    mat2 <- jggrad2(mat2, lam, alpha)
    if (lowessnorm) {
        mat2l <- lnorm(mat2[, (n + 1):(2 * n)])
        mat2a <- lnorm(mat2[, (2 * n + 1):(3 * n)])
        mat2 <- lnorm(mat2[, 1:n])
    }
    else {
        mat2l <- norm(mat2[, (n + 1):(2 * n)])
        mat2a <- norm(mat2[, (2 * n + 1):(3 * n)])
        mat2 <- norm(mat2[, 1:n])
    }

    yres <- R %*% t(mat2)
    ylres <- R %*% t(mat2l)
    yares <- R %*% t(mat2a)
    r1 <- sum(yres^2)
    r2 <- sum(2 * yres * ylres)
    r3 <- sum(2 * yres * yares)

    return(c(r1, r2, r3))
}
"msecalcmult" <-
function (eS, lam, alpha, lowessnorm=FALSE, R, grads=TRUE) 
{
    lambda <- FALSE
    mat1 <- as.matrix(exprs(eS))
    n <- dim(mat1)[2]
    p <- dim(mat1)[1]
    y <- mat1
    r <- dim(y)[1]
    onevec <- matrix(1, nrow=r, ncol=1)

    #This does what jggrad does, but for msecalcmult
    #it has to be done internally. The reason is because
    #making all of the jga matrices would blow the RAM.
    #Instead, we calculate the alpha gradients sequentially.
    ya <- y - onevec%*%alpha
    g <- glog(ya, lam)
    z <- sqrt(ya^2 + lam)
    za <- -ya/z
    zl <- 1/(2 * z)
    ga.cat <- -1/z #Is sum of ga.i's, one per column
    gl <- 2 * z * (ya + z)
    gl <- 1/gl
    J <- exp(mean(log(z)))
    k <- length(alpha) #Will be used several times
    Ja <- J * colMeans(za/z) / k #Is a vector now, not a scalar
    Jl <- J * mean(zl/z)
    jg <- g * J
    jgl <- gl * J + g * Jl

    if (lowessnorm) {
        mat2l <- lnorm(jgl)
        #mat2a <- lnorm(mat2[, (2 * n + 1):(3 * n)])
        mat2 <- lnorm(jg)
    }
    else {
        mat2l <- norm(jgl)
        #mat2a <- norm(mat2[, (2 * n + 1):(3 * n)])
        mat2 <- norm(jg)
    }

    yres <- R %*% t(mat2)
    SSE <- sum(yres^2)

    #Rescaling test
    #SSE <- SSE / lam
    ##
    if (grads) {
      ylres <- R %*% t(mat2l)
      SSEl <- 2 * sum(yres * ylres)

      SSEa <- vector(length=k)
      for (i in 1:k) {
        ga.i <- matrix(0, nrow=r, ncol=k)
        ga.i[,i] <- ga.cat[,i]
        jga.i <- ga.i * J + g * Ja[i]
        if (lowessnorm) {mat2a <- lnorm(jga.i)}
        else {mat2a <- norm(jga.i)}
        yares.i <- R %*% t(mat2a)
        SSEa[i] <- 2 * sum(yres * yares.i)
      }

    #Scaling test
    #SSEl <- SSEl / lam - SSE / lam
    #SSEa <- SSEa / lam
    ##
    return(c(SSE, SSEl, SSEa))
  }
  else { return(SSE) }
}
"neweS" <-
function(mat, vlist, vlabel=as.list(names(vlist))) {
  names(vlabel) <- names(vlist)

  #Must add appropriate names to the variables in vlist for R 2.3 compatibility.
  for (i in 1:length(vlist)) {
    names(vlist[[i]]) <- colnames(mat)
  }

  pdata <- new("AnnotatedDataFrame")
  pData(pdata) <- as.data.frame(vlist)
  varLabels(pdata) <- vlabel
  eset <- new("ExpressionSet", exprs=as.matrix(mat), phenoData=pdata)
  return(eset)
}
"norm" <-
function(mat1)
{
  mat2 <- as.matrix(mat1)
  p <- dim(mat2)[1]
  n <- dim(mat2)[2]
  cmean <- apply(mat2,2,mean)
  cmean <- cmean - mean(cmean)
  mnmat <- matrix(rep(cmean,p),byrow=TRUE,ncol=n)
  return(mat2-mnmat)
}
"psmeans" <-
function (eS, ind)
{
  r <- dim(exprs(eS))[1]
  c <- dim(exprs(eS))[2]

  I <- max(ind)
  outmat <- matrix(0, nrow=I, ncol=c)
  for (i in 1:I) {
    k <- sum(ind==i)
    v <- rep(1/k, k)
    outmat[i,] <- v %*% exprs(eS)[ind==i,]
  }

  meaneS <- neweS(outmat, pData(eS))
  return(meaneS)
}
"pvadjust" <-
function(pvlist)
#
# pvlist is the output from genediff containing p-values from
#   gene-specific MSE's and posterior MSE's. This routine
#   adds FDR adjusted p-values using the multtest routine
#   rawp2adjp
#
{
  library(multtest)
  pv1 <- pvlist$Gene.Specific
  pv2 <- pvlist$Posterior
  nump <- dim(pv1)[2]
  for (i  in 1:nump)
  {
    ap <- mt.rawp2adjp(pv1[,i],"BH")
    pv1[,i] <- ap$adjp[order(ap$index),2]
    ap <- mt.rawp2adjp(pv2[,i],"BH")
    pv2[,i] <- ap$adjp[order(ap$index),2]
  }
  pvlist2 <- c(pvlist,list("Gene.Specific.FDR"=pv1,"Posterior.FDR"=pv2))
  return(pvlist2)
}
"rowaov" <-
function (eS, model=NULL) 
{
    mat1 <- as.matrix(exprs(eS))
    for (i in 1:length(varLabels(eS))) {
        assign(paste("x", i, sep = ""), pData(eS)[, i])
    }
    if (is.null(model)) {
      model <- ""
      for (i in 1:length(varLabels(eS))) {
        model <- paste(model, paste("x", i, sep = ""), ifelse(i < 
            length(varLabels(eS)), "+", ""), sep = "")
      }
    }
    model2 <- paste("y ~", model)
    mat2 <- as.matrix(mat1)
    n <- dim(mat2)[2]
    p <- dim(mat2)[1]
    y <- t(mat2)
    formobj <- as.formula(model2)
    tmp <- lm(formobj, x=TRUE, data=pData(eS))
    if (tmp$df <= 0) {
      print("Error: model is overfit. Try a simpler model.")
      return(NULL)
    }
    for (i in 1:p) {
      tmp2 <- mlm2lm(tmp, i)
      tmp3 <- anova(tmp2)
      tmp4 <- c(tmp3$Mean, tmp3$Df)
      if (i == 1) {
          resmat <- tmp4
      }
      else {
          resmat <- cbind(resmat, tmp4)
      }
    }
    return(resmat)
}
"rowlist" <-
function(genemat,effnum,apvlist,level,posterior=TRUE)
#
# genemat is an n-by-p matrix of expression values 
# effnum is the column number for the effect of interest
# apvlist is a matrix of p-values from pvadjust or genediff
# the routine returns a list of genes whose FDR p-value is 
#   less than level using either individual gene or posterior 
#   MSE's. This is gene names if rownames(genemat) is not null,
#   and gene numbers otherwise.
#
{
  if(posterior)
  {
    ind <- apvlist$Posterior.FDR[,effnum] < level
  }
  else
  {
    ind <- apvlist$Gene.Specific.FDR[,effnum] < level
  }
  numsig <- sum(ind)
  if (is.null(rownames(genemat)))
  {
    p <- dim(genemat)[1]
    if (numsig > 0)
    {
      return((1:p)[ind])
    }
    else
    {
      return(-1)
    }
  }
  else
  {
    if (numsig > 0)
    {
      return(rownames(genemat)[ind])
    }
    else
    {
      return(-1)
    }
  }
}
"tranest" <-
function (eS, ngenes = -1, starting = FALSE, lambda = 1000, alpha = 0,
    gradtol = 1e-3, lowessnorm = FALSE, method=1, mult=FALSE, model=NULL)
{
    mat1 <- as.matrix(exprs(eS))
    n <- dim(mat1)[2]
    p <- dim(mat1)[1]
    if (p > 100000) {ngenes <- 50000}
    if ((ngenes < p) & (ngenes > 0))
        mat2 <- mat1[sample(p, ngenes), ]
    else mat2 <- mat1
    eS2 <- new("ExpressionSet", exprs = mat2, phenoData = phenoData(eS))

    if (mult==FALSE) {
      tranpar <- tranest2(eS2, starting, lambda, alpha, gradtol,
        lowessnorm, method, model)
      return(list(lambda = (tranpar[1]), alpha = tranpar[2:length(tranpar)]))
    }
    else {
      return(tranestmult(eS2, starting, lambda, alpha, gradtol,
        lowessnorm, method, 200, model))
    }
}
"tranest2" <-
function (eS, starting = FALSE, lambda = 1000, alpha = 0, gradtol = 0.001, 
    lowessnorm=FALSE, method=1, model=NULL) 
{
    starttime <- Sys.time()
    mat1 <- as.matrix(exprs(eS))
    like <- function(x) {
        lnlam <- x[1]
        alpha <- x[2]
        lam <- exp(lnlam)
        tmp <- msecalc(eS, lam, alpha, lowessnorm, R)
        tmpv <- tmp[1] / df
        attr(tmpv, "gradient") <- c(tmp[2] * lam, tmp[3]) / df
        return(tmpv)
    }
    if (starting) {
        lamstart <- log(lambda)
        alphastart <- alpha
    }
    else {
        lamstart <- log(median(abs(mat1))^2)
        alphastart <- quantile(abs(as.vector(mat1)), 0.1)
    }
    typsize <- c(lamstart, alphastart)
    startvar <- c(lamstart, alphastart)
    names(startvar) <- NULL
    stepmax <- 3

    #Calculate residuals matrix R (from "hat matrix")
    mod <- GetLMObj(eS, model)
    X <- mod$x
    df <- mod$df * dim(mat1)[1]
    U <- svd(X)$u
    H <- U %*% t(U)
    n <- dim(H)[1]
    R <- diag(rep(1,n)) - H

    if (method==1) {
       opt <- nlm(like, startvar, stepmax=4, typsize=typsize,
         check.analyticals=FALSE, gradtol=gradtol)
       return(c(exp(opt$estimate[1]), opt$estimate[2]))
    } else {
       if (method==2) {optype <- 'Nelder-Mead'}
       if (method==3) {optype <- 'BFGS'}
       if (method==4) {optype <- 'CG'}
       opt <- optim (startvar, like, method=optype) 
       return(c(exp(opt$par[1]), opt$par[2]))
    }
}
"tranestmult" <-
function (eS, starting = FALSE, lambda = 1000, alpha = 0, gradtol = 0.001,
    lowessnorm=FALSE, method=1, max_iter=200, model=NULL)
{
    starttime <- Sys.time()
    mat1 <- as.matrix(exprs(eS))
    like <- function(x) {
        lnlam <- x[1]
        alpha <- x[2:length(x)]
        lam <- exp(lnlam)

        tmp <- msecalcmult(eS, lam, alpha, lowessnorm, R, grads=grads)
        tmpv <- tmp[1] / df
        attr(tmpv, "gradient") <- c(tmp[2] * lam, tmp[3:length(tmp)]) / df

        return(tmpv)
    }
    k <- dim(mat1)[2]
    p <- dim(mat1)[1]
    if (starting) {
        lamstart <- log(lambda)
        if (length(alpha)==1) {alphastart <- rep(alpha, k)}
        else {alphastart <- alpha}
    }
    else {
        lamstart <- log(median(abs(mat1))^2)
        lamstart <- log(1000)
        alphastart <- rep(0, k)
        for (i in 1:k) {
          #alphastart[i] = quantile(abs(as.vector(mat1[,i])), 0.1)
          alphastart[i] = min(abs(as.vector(mat1[,i])))
        }
    }
    typsize <- c(lamstart, alphastart)
    startvar <- c(lamstart, alphastart)
    names(startvar) <- NULL
    stepmax <- 3

    #Calculate residuals matrix R (from "hat matrix")
    mod <- GetLMObj(eS, model)
    X <- mod$x
    df <- p * mod$df

    U <- svd(X)$u
    H <- U %*% t(U)
    n <- dim(H)[1]
    R <- diag(rep(1,n)) - H

    if (method==1) {
       grads <- TRUE
       opt <- nlm(like, startvar, stepmax=4, typsize=typsize,
         check.analyticals=FALSE, gradtol=gradtol, steptol=1e-8, iterlim=max_iter)
       return(list(lambda=exp(opt$estimate[1]), alpha=opt$estimate[2:length(opt$estimate)]))
    }
    else {
       if (method==2) {grads <- FALSE; optype <- 'Nelder-Mead'}
       if (method==3) {grads <- TRUE; optype <- 'BFGS'}
       if (method==4) {grads <- TRUE; optype <- 'CG'}
       if (method==5) {grads <- FALSE; optype <- 'SANN'}
       opt <- optim(startvar, like, method=optype, control=list(maxit=max_iter))
       print (opt)
       return(list(lambda=exp(opt$par[1]), alpha=opt$par[2:length(opt$par)]))
    }
}
"transeS" <-
function (eS, lambda, alpha) 
{
  mat <- exprs(eS)
  if (length(alpha)==1) {
    mat.cor <- mat-alpha
  } else {
    r <- dim(mat)[1]
    onevec <- matrix(1, nrow=r, ncol=1)
    mat.cor <- mat - onevec %*% alpha
  }

  mat.trans <- glog(mat.cor, lambda)
  eS.trans <- eS
  exprs(eS.trans) <- mat.trans
  return(eS.trans)
}
