R/rcModel.R

In preprocessCore: A collection of pre-processing functions

rcModelPLM <- function(y,row.effects=NULL, input.scale=NULL){
  if (!is.matrix(y))
    stop("argument should be matrix")
  PsiCode <- 0
  PsiK <- 1.345
  if (is.null(row.effects)){
    .Call("R_rlm_rma_default_model",y,PsiCode,PsiK,input.scale,PACKAGE="preprocessCore")
  } else {
    if (length(row.effects) != nrow(y)){
       stop("row.effects parameter should be same length as number of rows")
    }  
    if (abs(sum(row.effects)) > length(row.effects)*.Machine$double.eps){
       stop("row.effects should sum to zero")
    }
    .Call("R_rlm_rma_given_probe_effects",y,as.double(row.effects),PsiCode,PsiK,input.scale,PACKAGE="preprocessCore") 
  }	
}



rcModelWPLM <- function(y, w, row.effects=NULL, input.scale=NULL){
  if (!is.matrix(y))
    stop("argument should be matrix")
  if (is.vector(w)){
    if (length(w) != prod(dim(y))){
      stop("weights are not correct length")
    }
  } else if (is.matrix(w)){
    if (!all(dim(w) == dim(y))){
      stop("weights should be same dimension as input matrix")
    }

  }
  if (any(w < 0)){
    stop("weights should be no negative")
  }

  
    
  PsiCode <- 0
  PsiK <- 1.345 
  if (is.null(row.effects)){
     .Call("R_wrlm_rma_default_model",y,PsiCode,PsiK,as.double(w),input.scale,PACKAGE="preprocessCore")
  } else {
    if (length(row.effects) != nrow(y)){
       stop("row.effects parameter should be same length as number of rows")
    }  
    if (abs(sum(row.effects)) > length(row.effects)*.Machine$double.eps){
       stop("row.effects should sum to zero")
    }
    .Call("R_wrlm_rma_given_probe_effects",y,as.double(row.effects),PsiCode,PsiK,as.double(w),input.scale,PACKAGE="preprocessCore") 
  }	

}



rcModelMedianPolish <- function(y){
  if (!is.matrix(y))
    stop("argument should be matrix")
  PsiCode <- 0
  PsiK <- 1.345
  .Call("R_medianpolish_rma_default_model",y,PACKAGE="preprocessCore")
}




subrcModelMedianPolish <- function(y,group.labels){

  if (!is.matrix(y))
    stop("argument should be matrix")

  if (!is.double(y) & is.numeric(y))
    y <- matrix(as.double(y),dim(y)[1],dim(y)[2])
  else if (!is.numeric(y))
    stop("argument should be numeric matrix")

  rowIndexList <- convert.group.labels(group.labels)
  
  x <- .Call("R_sub_rcModelSummarize_medianpolish", y, rowIndexList,PACKAGE="preprocessCore")

  names(x) <- names(rowIndexList)
  x
}





subrcModelPLM <- function(y,group.labels,row.effects=NULL, input.scale=NULL){

  if (!is.matrix(y))
    stop("argument should be matrix")  

  if (!is.double(y) & is.numeric(y))
    y <- matrix(as.double(y),dim(y)[1],dim(y)[2])
  else if (!is.numeric(y))
    stop("argument should be numeric matrix")
   
  rowIndexList <- convert.group.labels(group.labels)
 
  PsiCode <- 0
  PsiK <- 1.345

  if (is.null(row.effects)){
    x <- .Call("R_sub_rcModelSummarize_plm", y, rowIndexList, PsiCode, PsiK, input.scale,PACKAGE="preprocessCore")
    names(x) <- names(rowIndexList)
    x

  } else {
    stop("row.effects not yet implemented for subrcModelPLM")
    if (length(row.effects) != nrow(y)){
       stop("row.effects parameter should be same length as number of rows")
    }  
    if (abs(sum(row.effects)) > 10*.Machine$double.eps){
       stop("row.effects should sum to zero")
    }
    .Call("R_rlm_rma_given_probe_effects",y,as.double(row.effects),PsiCode,PsiK,input.scale,PACKAGE="preprocessCore") 
  }	
}