.packageName <- "gcrma"
average.for.PAV <-function(y, wt = rep(1, length(y)))
{
  ## compute a weighted average of a vector, y
  if(any(is.na(wt))) stop("NA's not allowed for wt")
  if(any(wt < 0))
    stop("wt must be a vector of NON-NEGATIVE weights")
  if(length(wt) != length(y)) stop("y and wt must be vectors of the same length")
  ## if any observations have Infinite weight, return the simple
  ## (unweighted) average of only those observations (giving no
  ## weight to observations with finite weight)
  if(any(wt == Inf)) {
    wt[wt < Inf] <- 0
    wt[wt == Inf] <- 1
  }
  ## if all weights are zero, return the simple (unweighted)
  ## average of y
  if(sum(wt) == 0)
    wt <- rep(1, length(wt))
  return(sum((y * wt)/sum(wt)))
}

PAV <- function(y, wt = rep(1,length(y)))
{
  ## This is a modification of Derick's PAV program
  ##
  ## (Weighted) Pool-Adjacent-Violators (PAV) algorithm
  ## for non-parametric monotonic (decreasing) regression of y on x
  n <- length(y)
  if(n != length(wt))
    stop("y, and wt must be vectors of equal length")
  yhat <- y       # initialize while loop
  j <- count <- 1
  k <- 2
  support <- vector("numeric", n)
  support[count] <- j
  while(k <= n) {
    while(yhat[j] < yhat[k]) {
      yhat[j:k] <- average.for.PAV(y[j:k], wt[j:k])
      if(yhat[support[count]] < yhat[k]) {
        j <- support[count]
        if(count > 1)
          count <- count - 1
      }
      else {
        k <- ifelse(k == n, k, k + 1)
      }
    }
    
    count <- count + 1
    support[count] <- j
    j <- k
    k <- k + 1
  }
  return(list(y = yhat, wt))
}

bg.adjust.optical <- function(abatch,minimum=1,verbose=TRUE){
  Index <- unlist(indexProbes(abatch,"both"))

  if(verbose) cat("Adjusting for optical effect")
  for(i in 1:length(abatch)){
    if(verbose) cat(".")
    exprs(abatch)[Index,i] <- exprs(abatch)[Index,i] -
      min(exprs(abatch)[Index,i],na.rm=TRUE) + minimum
  }
  if(verbose) cat("Done.\n")
  
  abatch
}

bg.adjust.mm <- function(pms,mms,k=6*fast+0.25*(1-fast),fast=TRUE){
  mu <- log(mms)
  Index <- which(pms<mms)
  sigma <- sqrt(mean((log(pms)[Index]-mu[Index])^2))

  bhat <- exp(mu+0.5*sigma^2)
  var.y <- exp(2*mu+sigma^2)*(exp(sigma^2)-1)

  if(fast) return(gcrma.bg.transformation.fast(pms,bhat,var.y,k=k))
  else return(gcrma.bg.transformation(pms,bhat,var.y,k=k))
}

bg.adjust.constant <- function(x,k=6*fast+0.25*(1-fast),Q=0.25,fast=TRUE){
  mu <- log(quantile(x,Q))
  sigma <- left.sigma(log(x),mu)
 
  if(fast){
     bhat <- exp(mu+1/2*sigma^2)
     var.y <- rep(exp(2*mu+sigma^2)*(exp(sigma^2)-1),length(x))
     return(gcrma.bg.transformation.fast(x,bhat,var.y,k=k))
   }
  else return(gcrma.bg.transformation(x,mu,sigma,k=k))
}

bg.adjust.affinities <- function(x,affinities,index=seq(along=x),
                                 k=6*fast+0.25*(1-fast),Q=0.25,fast=TRUE){
  parameters <- bg.parameters.ns(x[index],affinities,Q=Q)
  mu <- vector("numeric",length(x))
  sigma <- vector("numeric",length(x))
  mu[index] <- parameters$bg.mu
  sigma[index] <- parameters$bg.sigma
  
  ##fill in the pms for which we dont have affinities
  if(length(index)<length(x)){
    mu[-index] <- median(mu[index])
    sigma[-index] <- median(sigma[index])
  }
  
  if(fast){
      bhat <- exp(mu + 1/2*sigma^2)
      var.y <- exp(2*mu+sigma^2)*(exp(sigma^2)-1)
      return(gcrma.bg.transformation.fast(x,bhat,var.y,k=k))
    }
  else return(gcrma.bg.transformation(x,mu,sigma,k=k))
}

bg.adjust.fullmodel <- function(pms,mms,pm.affinities,mm.affinities,
                                index.affinities,k=6*fast+0.25*(1-fast),
                                Q=0.25,Qmm=0.5,rho=0.7,fast=TRUE){
  
  parameters <- bg.parameters.ns(pms[index.affinities],pm.affinities,Q=Q)
  mu.pm <- vector("numeric",length(pms))
  sigma <- vector("numeric",length(pms))
  mu.pm[index.affinities] <- parameters$bg.mu
  sigma[index.affinities] <- parameters$bg.sigma

  parameters <- bg.parameters.ns(mms[index.affinities],mm.affinities,Q=Qmm)
  mu.mm <-  vector("numeric",length(pms))
  mu.mm[index.affinities] <- parameters$bg.mu
  
  ##fill in the pms for which we dont have affinities
  if(length(index.affinities)<length(pms)){
    mu.pm[-index.affinities] <- median(mu.pm[index.affinities])
    mu.mm[-index.affinities] <- median(mu.mm[index.affinities])
    sigma[-index.affinities] <- median(sigma[index.affinities])
  } 
  
  ##mu.mm <- mu.mm-mean(mu.mm)+mean(mu.pm) ##correction in case not the same
  ##this is the unbiased
  
  if(fast){
    bhat <- exp(mu.pm + rho*(log(mms)-mu.mm) + 1/2*(1 - rho^2)*sigma^2)
    var.y=exp(2*mu.pm+sigma^2)*(exp(sigma^2)-exp(sigma^2*rho^2))
    return(gcrma.bg.transformation.fast(pms,bhat,var.y,k=k))
  }
  else return(gcrma.bg.transformation(pms,mu.pm + rho*(log(mms)-mu.mm),sqrt(1 - rho^2)*sigma,k=k))
}
left.sigma <- function(x,mu) sqrt(mean((x[x<mu]-mu)^2))


bg.parameters.ns <- function(x,affinities,order.aff=NULL,Q=.25,nbreaks=40,
                             monotonize.mu=TRUE,
                             monotonize.sigma=FALSE){
  ##ns stands for nonspecific
  n <- round(length(x)/nbreaks)
  if(is.null(order.aff)) order.aff=order(affinities)
  ##break up the scatter plot and get "mean" and "sigma"
  qs <- sapply(0:(nbreaks-1),function(k) {
    o1 <- k*n+1;
    o2 <- min((k+1)*n,length(x))
    y <- x[order.aff[o1:o2]]
    y <- log(y)
    mu <- quantile(y,Q)
    sigma <- sqrt(mean((y[y<mu]-mu)^2))
    c(affinities[order.aff[(o1+o2)/2]],mu,sigma)
  })
  if(monotonize.mu) qs[2,] <- -PAV(-qs[2,])$y
  ##fill in the blanks with approx
  bg.mu <- approx(qs[1,],qs[2,],xout=affinities,rule=2)$y 
  
  if(monotonize.sigma){
    qs[3,] <- -PAV(-qs[3,])$y
    bg.sigma <- approx(qs[1,],qs[3,],xout=affinities,rule=2)$y 
  }
  else
    ##bg.sigma <- approx(qs[1,],qs[3,],xout=affinities,rule=2)$y 
    bg.sigma <- rep(median(qs[3,]),length(affinities))
  
  return(list(bg.mu = bg.mu,bg.sigma=bg.sigma))
}
compute.affinities <- function(cdfname,verbose=TRUE){
  
  require(splines,quietly = TRUE)
  require(matchprobes,quietly = TRUE)
  data(affinity.spline.coefs) ###needs to change to data(something)
  affinity.basis.matrix <- ns(1:25,df=length(affinity.spline.coefs)/3)
  
  cleancdf <- cleancdfname(cdfname,addcdf=FALSE)
  cdfpackagename <- paste(cleancdf,"cdf",sep="")
  probepackagename <- paste(cleancdf,"probe",sep="")
  
  library(cdfpackagename,character.only=TRUE)
  library(probepackagename,character.only=TRUE)
  p <- get(probepackagename)
  
  p <- check.probes(p, cdfname)
  
  prlen <- unique(nchar(p$sequence))
  stopifnot(length(prlen)==1)
  
  A13 <- sum(affinity.basis.matrix[13,]*affinity.spline.coefs[1:5])
  T13 <- 0
  C13 <- sum(affinity.basis.matrix[13,]*affinity.spline.coefs[6:10])
  G13 <- sum(affinity.basis.matrix[13,]*affinity.spline.coefs[11:15])
  
  if(verbose) cat(".")
  
  apm <- vector("numeric",length(p$sequence))
  amm <- vector("numeric",length(p$sequence))
  
  for(i in seq(along=apm)) {
    charMtrx <- .Call("gcrma_getSeq", p$sequence[i],
                      PACKAGE="gcrma")
    A <- cbind(charMtrx[1,] %*% affinity.basis.matrix,
               charMtrx[2,] %*% affinity.basis.matrix,
               charMtrx[3,] %*% affinity.basis.matrix)
    
    apm[i] <- A %*% affinity.spline.coefs
    
    if (charMtrx[1,13] == 1) {
      amm[i] <- apm[i] + T13 - A13
    }
    else {
      if (charMtrx[4,13] == 1) {
        amm[i] <- apm[i] + A13 - T13
      }
      else{
        if (charMtrx[3,13]) {
          amm[i] <- apm[i] + C13 - G13
        }
        else {
          amm[i] <- apm[i] + G13 - C13
        }
      }
    }
  }
  
  ##put it in an affybatch
  tmp <- get("xy2i",paste("package:",cdfpackagename,sep=""))
  affinity.info <- new("AffyBatch",cdfName=cdfname)
  pmIndex <-  unlist(indexProbes(affinity.info,"pm"))
  mmIndex <-  unlist(indexProbes(affinity.info,"mm"))
  subIndex <- match(tmp(p$x,p$y),pmIndex)
  tmp.exprs=matrix(NA,nrow=max(cbind(pmIndex,mmIndex)),ncol=1)
  tmp.exprs[pmIndex[subIndex]]=apm
  if(!is.null(amm)){ tmp.exprs[mmIndex[subIndex]]=amm }
  exprs(affinity.info)=tmp.exprs
  return(affinity.info)
}

check.probes <- function(probepackage, cdfname){
  cdfnames <- names(pmindex(new("AffyBatch", cdfName=cdfname)))
  ppnames <- as.character(probepackage$Probe.Set.Name)
  
  if (sum(!(ppnames %in% cdfnames)) != 0){
    Index <- ppnames %in% cdfnames
    probepackage <- probepackage[Index,]
  }
  return(probepackage)
}


gcrma <- function(object,affinity.info=NULL,
                  type=c("fullmodel","affinities","mm","constant"),
                  k=6*fast+0.5*(1-fast),stretch=1.15*fast+1*(1-fast),
                  correction=1,rho=0.7,
                  optical.correct=TRUE,verbose=TRUE,fast=TRUE){
  
  type <- match.arg(type)
  
  
  pmonly <- (type=="affinities"|type=="constant")
  needaff <- (type=="fullmodel"|type=="affinities")
  if( needaff & is.null(affinity.info)){
    if(verbose) cat("Computing affinities")
    affinity.info <- compute.affinities(cdfName(object),verbose=verbose)
    if(verbose) cat("Done.\n")
  }
  
  if(optical.correct)
    object <- bg.adjust.optical(object,verbose=verbose)
  
  pm(object) <- gcrma.engine(pms=pm(object),
                             mms=mm(object),
                             pm.affinities=pm(affinity.info),
                             mm.affinities=mm(affinity.info),
                             type=type,k=k,
                             stretch=stretch,
                             correction=correction,rho=rho,
                             verbose=verbose,fast=fast)
  
  return(rma(object,background=FALSE,verbose=verbose))
}

##for now we need the mms for everything
gcrma.engine <- function(pms,mms,pm.affinities=NULL,mm.affinities=NULL,
                         type=c("fullmodel","affinities","mm","constant"),
                         k=6*fast+0.25*(1-fast),
                         stretch=1.15*fast+1*(1-fast),correction=1,rho=0.7,
                         verbose=TRUE,fast=TRUE){
  
  type <- match.arg(type)
  
  if(!is.null(pm.affinities)){
    index.affinities <- which(!is.na(pm.affinities))
    pm.affinities <- pm.affinities[index.affinities]
    if(!is.null(mm.affinities)){
      mm.affinities <- mm.affinities[index.affinities]
    }
  }
  
  if(type=="fullmodel" | type=="affinities"){
    set.seed(1)
    Subset <- sample(1:length(pms[index.affinities,]),25000)
    y <- log2(pms)[index.affinities,][Subset]
    Subset <- (Subset-1)%%nrow(pms[index.affinities,])+1
    x <- pm.affinities[Subset]
    fit1 <- lm(y~x)
  }
  
  
  if(verbose) cat("Adjusting for non-specific binding")
  for(i in 1:ncol(pms)){
    if(verbose) cat(".")
    if(type=="fullmodel"){
      pms[,i] <- bg.adjust.fullmodel(pms[,i],mms[,i],
                                     pm.affinities,mm.affinities,
                                     index.affinities,k=k,
                                     Q=correction*mean(pms[,i]<mms[,i]),
                                     Qmm=correction*0.5,rho=rho,fast=fast)
      pms[index.affinities,i] <- 2^(log2(pms[index.affinities,i])-
                                    fit1$coef[2]*pm.affinities+mean(fit1$coef[2]*pm.affinities))
    }
    if(type=="affinities"){
      pms[,i] <- bg.adjust.affinities(pms[,i],pm.affinities,
                                      index.affinities, k=k,
                                      Q=correction*mean(pms[,i]<mms[,i]),
                                      fast=fast)
      pms[index.affinities,i] <- 2^(log2(pms[index.affinities,i])-
                                    fit1$coef[2]*pm.affinities + 
                                    mean(fit1$coef[2]*pm.affinities))
    }
    if(type=="mm") pms[,i] <- bg.adjust.mm(pms[,i],correction*mms[,i],k=k,fast=fast)
    if(type=="constant"){
      pms[,i] <- bg.adjust.constant(pms[,i],k=k,Q=correction*mean(pms[,i]<mms[,i]),fast=fast)
    }
    if(stretch!=1){
      mu <- mean(log(pms[,i]))
      pms[,i] <- exp(mu + stretch*(log(pms[,i])-mu))
    }
  }

  if(verbose) cat("Done.\n")

  return(pms)
}


gcrma.bg.transformation.fast <- function(x,bhat,var.y,k){
  
  x <- x - bhat ##this is an unbiased estimate
  Index <- x > 0
  x[!Index] <- 0 ##trick to not get -Inf in log
  
  ##alpha is the weith used to create weighted estimate
  ##its basically  for smoothing edge
  alpha <- rep(0,length(x))
  xplusk <- x[Index]+k  #x plus k
  logxplusk <- log(xplusk)
  alpha[Index] <- (logxplusk - log(k))*(logxplusk - log(k) + k/xplusk) /
    ( ( logxplusk - log(k) + k/xplusk)^2 + var.y[Index]/xplusk^2)
  
  y <- exp(alpha*log(x+k) + (1-alpha)*log(k))
}
### A user friendly wrapper for just.gcrma
justGCRMA <- function(..., filenames=character(0),
                     widget=getOption("BioC")$affy$use.widgets,
                     compress=getOption("BioC")$affy$compress.cel,
                     celfile.path=getwd(),
                     sampleNames=NULL,
                     phenoData=NULL,
                     description=NULL,
                     notes="", normalize=TRUE, 
                     bgversion=2, affinity.info=NULL,
                     type=c("fullmodel","affinities","mm","constant"),
                     k=6*fast+0.5*(1-fast), stretch=1.15*fast+1*(1-fast),
                     correction=1, rho=0.7, optical.correct=TRUE,
                     verbose=TRUE, fast=TRUE, minimum=1,
                     optimize.by = c("speed","memory")){
  ##first figure out filenames
  auxnames <- unlist(as.list(substitute(list(...)))[-1])
  
  if (widget){
    require(tkWidgets)
    widgetfiles <- fileBrowser(textToShow="Choose CEL files",
                               testFun=hasSuffix("[cC][eE][lL]"))
  }
  else
    widgetfiles <- character(0)
  
  filenames <- .Primitive("c")(filenames, auxnames, widgetfiles)
  
  if(length(filenames)==0) filenames <- list.celfiles(celfile.path,full.names=TRUE)
  
  if(length(filenames)==0) stop("No cel filenames specified and no cel files in specified directory:",celfile.path,"\n")
  
  
  ##now assign sampleNames if phenoData not given
  if(is.null(phenoData)){
    if(is.null(sampleNames)){
      if(widget){
        require(tkWidgets)
        tksn <- tkSampleNames(filenames=filenames)
        sampleNames <- tksn[,1]
        ##notice that a description of the files is ingored for now
        ##soon to go into MIAME
      }
      else{
        sampleNames <- sub("^/?([^/]*/)*", "", filenames, extended=TRUE)
      }
    }
    else{
      if(length(sampleNames)!=length(filenames)){
        warning("sampleNames not same length as filenames. Using filenames as sampleNames instead\n")
        sampleNames <- sub("^/?([^/]*/)*", "", filenames, extended=TRUE)
      }
    }
  }
  
  ##now get phenoData
  if(is.character(phenoData)) ##if character read file
    phenoData <- read.phenoData(filename=phenoData)
  else{
    if(class(phenoData)!="phenoData"){
      if(widget){
        require(tkWidgets)
        phenoData <- read.phenoData(sampleNames=sampleNames,widget=TRUE)
      }
      else
        phenoData <- read.phenoData(sampleNames=sampleNames,widget=FALSE)
    }
  }
  
  ##get MIAME information
  if(is.character(description)){
    description <- read.MIAME(filename=description,widget=FALSE)
  }
  else{
    if(class(description)!="MIAME"){
      if(widget){
        require(tkWidgets)
        description <- read.MIAME(widget=TRUE)
      }
      else
        description <- new("MIAME")
    }
  }
  
  ##MIAME stuff
  description@preprocessing$filenames <- filenames
  if(exists("tksn")) description@samples$description <- tksn[,2]
  description@preprocessing$affyversion <- library(help=affy)$info[[2]][[2]][2]

  ##and now we are ready to read cel files
  return(just.gcrma(filenames=filenames,
                    phenoData=phenoData,
                    description=description,
                    notes=notes,
                    compress=compress,
                    verbose=verbose,
                    normalize=normalize,
                    bgversion=bgversion,
                    affinity.info=affinity.info,
                    type=type, k=k, stretch=stretch,
                    correction=correction, rho=rho,
                    optical.correct=optical.correct,
                    fast=fast, minimum=minimum,
                    optimize.by=optimize.by))

}


just.gcrma <- function(..., filenames=character(0),
                       phenoData=new("phenoData"),
                       description=NULL,
                       notes="", compress=getOption("BioC")$affy$compress.cel,
                       normalize=TRUE, bgversion=2, affinity.info=NULL,
                       type=c("fullmodel","affinities","mm","constant"),
                       k=6*fast+0.5*(1-fast), stretch=1.15*fast+1*(1-fast),
                       correction=1, rho=0.7, optical.correct=TRUE,
                       verbose=TRUE, fast=TRUE, minimum=1,
                       optimize.by = c("speed","memory")) {

  require(affy, quietly=TRUE)

  auxnames <- as.list(substitute(list(...)))[-1]
  filenames <- .Primitive("c")(filenames, auxnames)
  
  n <- length(filenames)
  
  ## error if no file name !
  if (n == 0)
    stop("No file name given !")
  
  pdata <- pData(phenoData)
  ##try to read sample names from phenoData. if not there use CEL filenames
  if(dim(pdata)[1]!=n){#if empty pdata filename are samplenames
    #warning("Incompatible phenoData object. Created a new one.\n")
    
    samplenames <- gsub("^/?([^/]*/)*", "", unlist(filenames), extended=TRUE	)
    pdata <- data.frame(sample=1:n,row.names=samplenames)
    phenoData <- new("phenoData",pData=pdata,varLabels=list(sample="arbitrary numbering"))
  }
  else samplenames <- rownames(pdata)
  

  if (is.null(description))
  {
    description <- new("MIAME")
    description@preprocessing$filenames <- filenames
    description@preprocessing$affyversion <- library(help=affy)$info[[2]][[2]][2]
  }

  ## get information from cdf environment

  headdetails <- .Call("ReadHeader", filenames[[1]], compress,PACKAGE="affy")
  dim.intensity <- headdetails[[2]]
  cdfName <- headdetails[[1]]
 
  type <- match.arg(type)

  pmonly <- (type=="affinities"|type=="constant")
  needaff <- (type=="fullmodel"|type=="affinities")

  if( needaff & is.null(affinity.info)){
    if(verbose) cat("Computing affinities.")
    affinity.info <- compute.affinities(cdfName,verbose=verbose)
    if(verbose) cat("Done.\n")
    
    pm.affinities <- pm(affinity.info)
    mm.affinities <- mm(affinity.info)

    index.affinities <- which(!is.na(pm.affinities))

    pm.affinities <- pm.affinities[index.affinities]
    mm.affinities <- mm.affinities[index.affinities]

    ##Recover memory
    rm(affinity.info)
    gc()
    
  }

  speed <- match.arg(optimize.by)
  if(speed == "speed"){
    pms <- fast.bkg(filenames = filenames, pm.affinities = pm.affinities,
                    mm.affinities = mm.affinities, index.affinities = index.affinities,
                    type = type, minimum = minimum, optical.correct = optical.correct,
                    verbose = verbose, k = k, rho = rho, correction = correction,
                    stretch = stretch, fast = fast)
  }
  if(speed == "memory"){
    pms <- mem.bkg(filenames = filenames, pm.affinities = pm.affinities,
                    mm.affinities = mm.affinities, index.affinities = index.affinities,
                    type = type, minimum = minimum, optical.correct = optical.correct,
                    verbose = verbose, k = k, rho = rho, correction = correction,
                   stretch = stretch, fast = fast)
  }

 
  tmp <- new("AffyBatch",
             cdfName=cdfName,
             annotation=cleancdfname(cdfName, addcdf=FALSE))
  pmIndex <- pmindex(tmp)
  probenames <- rep(names(pmIndex), unlist(lapply(pmIndex,length)))
  pmIndex <- unlist(pmIndex)

  ngenes <- length(geneNames(tmp))
  
  ##background correction - not used, but need to pass to .Call
  
  bg.dens <- function(x){density(x,kernel="epanechnikov",n=2^14)}
  
  exprs <- .Call("rma_c_complete",pms,pms,probenames,ngenes,body(bg.dens),new.env(),normalize,background=FALSE,bgversion,PACKAGE="affy")

  colnames(exprs) <- filenames
  se.exprs <- array(NA, dim(exprs))
  
  annotation <- annotation(tmp)
  
  new("exprSet", exprs = exprs, se.exprs = se.exprs, phenoData = phenoData, 
      annotation = annotation, description = description, notes = notes)
}

## A function to do background correction fast, but taking more RAM

fast.bkg <- function(filenames, pm.affinities, mm.affinities,
                     index.affinities, type, minimum, optical.correct,
                     verbose, k, rho, correction, stretch, fast){
  
  pms <- read.probematrix(filenames=filenames, which="pm")$pm
  mms <- read.probematrix(filenames=filenames, which="mm")$mm

  if(optical.correct){
     if(verbose) cat("Adjusting for optical effect.")
     for (i in 1:ncol(pms)){
       if(verbose) cat(".")
       tmp <- min(c(pms[,i], mms[,i]), na.rm=TRUE)
       pms[,i] <- pms[,i]- tmp + minimum
       mms[,i] <- mms[,i]- tmp + minimum
    }
     if(verbose) cat("Done.\n")
  }
  if(type=="fullmodel" | type=="affinities"){
    set.seed(1)
    Subset <- sample(1:length(pms[index.affinities,]),25000)
    y <- log2(pms)[index.affinities,][Subset]
    Subset <- (Subset-1)%%nrow(pms[index.affinities,])+1
    x <- pm.affinities[Subset]
    fit1 <- lm(y~x)
  }

  if(verbose) cat("Adjusting for non-specific binding")
  for(i in 1:ncol(pms)){
    if(verbose) cat(".")

          
    if(type=="fullmodel"){
      pms[,i] <- bg.adjust.fullmodel(pms[,i],mms[,i],
                                     pm.affinities,mm.affinities,
                                     index.affinities,k=k,
                                     Q=correction*mean(pms[,i]<mms[,i]),
                                     Qmm=correction*0.5,rho=rho,fast=fast)
      pms[index.affinities,i] <- 2^(log2(pms[index.affinities,i])-
                                    fit1$coef[2]*pm.affinities+mean(fit1$coef[2]*pm.affinities))
    }
    if(type=="affinities"){
      pms[,i] <- bg.adjust.affinities(pms[,i],pm.affinities,
                                      index.affinities, k=k,
                                      Q=correction*mean(pms[,i]<mms[,i]),
                                      fast=fast)
      pms[index.affinities,i] <- 2^(log2(pms[index.affinities,i])-
                                    fit1$coef[2]*pm.affinities + 
                                    mean(fit1$coef[2]*pm.affinities))
    }
    if(type=="mm") pms[,i] <- bg.adjust.mm(pms[,i],correction*mms[,i],k=k,fast=fast)
    if(type=="constant"){
      pms[,i] <- bg.adjust.constant(pms[,i],k=k,Q=correction*mean(pms[,i]<mms[,i]),fast=fast)
    }
    if(stretch!=1){
      mu <- mean(log(pms[,i]))
      pms[,i] <- exp(mu + stretch*(log(pms[,i])-mu))
    }
  }
  if(verbose) cat("Done.\n")
  return(pms)
}

## A function to do background correction using less RAM

mem.bkg <- function(filenames, pm.affinities, mm.affinities,
                     index.affinities, type, minimum, optical.correct,
                     verbose, k, rho, correction, stretch, fast){
  
  pms <- read.probematrix(filenames=filenames, which="pm")$pm

  ## tmps used to carry optical correct value to bkg correction loop
   if(optical.correct){
     if(verbose) cat("Adjusting for optical effect.")
     tmps <- NULL
     for (i in 1:ncol(pms)){
       if(verbose) cat(".")
       mm <- read.probematrix(filenames=filenames[i], which="mm")$mm[,1]
       tmp <-  min(c(pms[,i], mm), na.rm=TRUE)
       pms[,i] <- pms[,i]- tmp + minimum
       tmps <- c(tmps, tmp)
    }
   }
  if(verbose) cat("Done.\n")

  
  if(type=="fullmodel" | type=="affinities"){
    set.seed(1)
    Subset <- sample(1:length(pms[index.affinities,]),25000)
    y <- log2(pms)[index.affinities,][Subset]
    Subset <- (Subset-1)%%nrow(pms[index.affinities,])+1
    x <- pm.affinities[Subset]
    fit1 <- lm(y~x)
  }

  if(verbose) cat("Adjusting for non-specific binding")
  for(i in 1:ncol(pms)){
    if(verbose) cat(".")

    mm <- read.probematrix(filenames=filenames[i], which="mm")$mm[,1]
    
    if(optical.correct)
      mm <- mm - tmps[i] + minimum
          
    if(type=="fullmodel"){
      pms[,i] <- bg.adjust.fullmodel(pms[,i],mm,
                                     pm.affinities,mm.affinities,
                                     index.affinities,k=k,
                                     Q=correction*mean(pms[,i]<mm),
                                     Qmm=correction*0.5,rho=rho,fast=fast)
      pms[index.affinities,i] <- 2^(log2(pms[index.affinities,i])-
                                    fit1$coef[2]*pm.affinities+mean(fit1$coef[2]*pm.affinities))
    }
    if(type=="affinities"){
      pms[,i] <- bg.adjust.affinities(pms[,i],pm.affinities,
                                      index.affinities, k=k,
                                      Q=correction*mean(pms[,i]<mm),
                                      fast=fast)
      pms[index.affinities,i] <- 2^(log2(pms[index.affinities,i])-
                                    fit1$coef[2]*pm.affinities + 
                                    mean(fit1$coef[2]*pm.affinities))
    }
    if(type=="mm") pms[,i] <- bg.adjust.mm(pms[,i],correction*mm,k=k,fast=fast)
    if(type=="constant"){
      pms[,i] <- bg.adjust.constant(pms[,i],k=k,Q=correction*mean(pms[,i]<mm),fast=fast)
    }
    if(stretch!=1){
      mu <- mean(log(pms[,i]))
      pms[,i] <- exp(mu + stretch*(log(pms[,i])-mu))
    }
  }
  if(verbose) cat("Done.\n")
  return(pms)
}


  




.First.lib <- function(libname, pkgname, where) {
  library.dynam("gcrma", pkgname, libname)  

  where <- match(paste("package:", pkgname, sep=""), search())

  require(affy, quietly=TRUE) ##Biobase uses methods

  cacheMetaData(as.environment(where))

}
