R/utils.R
6a218440
 stupidSplineBasis <- function(x,knots){
   x <- pmin(x,knots[3])
   x <- pmax(x,knots[1])
   cbind(1, x, x^2, pmax(0, (x-knots[2]))^2)
 }
 
 changeToCrlmmAnnotationName <- function(x){
   pkgDir <- system.file(package=THISPKG)
   wanted <- paste(tolower(gsub("_", "", x)), "crlmm.stuff", sep=".")
   file.path(pkgDir, "extdata", wanted)
 }
 
 getCrlmmAnnotationName <- function(x){
e31c7794
 	paste(tolower(gsub("_", "", x)), "Crlmm", sep="")
6a218440
 }
 
a3b625d4
 ## medianSummaries <- function(mat, grps)
 ##   .Call("R_subColSummarize_median", mat, grps, PACKAGE = "preprocessCore")
 
6a218440
 medianSummaries <- function(mat, grps)
a3b625d4
 .Call("subColSummarizeMedianPP", mat, grps)
6a218440
 
 intMedianSummaries <- function(mat, grps)
10632b3f
   as.integer(medianSummaries(mat, grps))
6a218440
 
82be31d4
 
6a218440
 
 ## .crlmmPkgEnv is an enviroment that will
 ## store all the variables used by the pkg.
 ## it's meant to not overwrite user's variables
 ## and get rid of the NOTES generated by
 ## R CMD check
 
 isLoaded <- function(dataset, environ=.crlmmPkgEnv)
76f72a5a
 	exists(dataset, envir=environ)
 
6a218440
 getVarInEnv <- function(dataset, environ=.crlmmPkgEnv){
453e688a
 	if (!isLoaded(dataset, environ=environ))
cfa9fbbc
 		stop("Variable ", dataset, " not found in supplied environment")
76f72a5a
 	environ[[dataset]]
6a218440
 }
95d22b50
 
 list2SnpSet <- function(x, returnParams=FALSE){
f0da6921
   pd <- data.frame(SNR=x[["SNR"]][], gender=x[["gender"]],
f0f02fc4
                    batchQC=rep(x[["batchQC"]], ncol(x[["calls"]])),
95d22b50
                    row.names=colnames(x[["calls"]]))
   pdv <- data.frame(labelDescription=c("Signal-to-noise Ratio",
685829f7
                       "Gender: Male (1) and Female (2)",
                       "Quality score for batch"),
                     row.names=c("SNR", "gender", "batchQC"))
 
95d22b50
   recall <- length(x[["DD"]]) > 1
   if (returnParams){
     if (recall){
       fd <- data.frame(SNPQC=x[["SNPQC"]],
                        cAA=x[["params"]][["centers"]][,1],
                        cAB=x[["params"]][["centers"]][,2],
                        cBB=x[["params"]][["centers"]][,3],
                        sAA=x[["params"]][["scales"]][,1],
                        sAB=x[["params"]][["scales"]][,2],
                        sBB=x[["params"]][["scales"]][,3],
                        nAA=x[["params"]][["N"]][,1],
                        nAB=x[["params"]][["N"]][,2],
                        nBB=x[["params"]][["N"]][,3],
                        spAA=x[["DD"]][,1],
                        spAB=x[["DD"]][,2],
                        spBB=x[["DD"]][,3],
                        row.names=rownames(x[["calls"]]))
       fdv <- data.frame(labelDescription=c(
                           "SNP Quality Score",
                           "Center AA", "Center AB", "Center BB",
                           "Scale AA", "Scale AB", "Scale BB",
                           "N AA", "N AB", "N BB",
                           "Shift in parameters AA",
                           "Shift in parameters AB",
                           "Shift in parameters BB"),
                         row.names=c(
                           "SNPQC",
                           "cAA", "cAB", "cBB",
                           "sAA", "sAB", "sBB",
                           "nAA", "nAB", "nBB",
                           "spAA", "spAB", "spBB"))
     }else{
       fd <- data.frame(SNPQC=x[["SNPQC"]],
                        cAA=x[["params"]][["centers"]][,1],
                        cAB=x[["params"]][["centers"]][,2],
                        cBB=x[["params"]][["centers"]][,3],
                        sAA=x[["params"]][["scales"]][,1],
                        sAB=x[["params"]][["scales"]][,2],
                        sBB=x[["params"]][["scales"]][,3],
                        nAA=x[["params"]][["N"]][,1],
                        nAB=x[["params"]][["N"]][,2],
                        nBB=x[["params"]][["N"]][,3],
                        row.names=rownames(x[["calls"]]))
       fdv <- data.frame(labelDescription=c(
                           "SNP Quality Score",
                           "Center AA", "Center AB", "Center BB",
                           "Scale AA", "Scale AB", "Scale BB",
cfdeb14b
                           "N AA", "N AB", "N BB"),
95d22b50
                         row.names=c(
                           "SNPQC",
                           "cAA", "cAB", "cBB",
                           "sAA", "sAB", "sBB",
                           "nAA", "nAB", "nBB"))
     }
   }else{
     if (recall){
       fd <- data.frame(SNPQC=x[["SNPQC"]],
                        spAA=x[["DD"]][,1],
                        spAB=x[["DD"]][,2],
                        spBB=x[["DD"]][,3],
                        row.names=rownames(x[["calls"]]))
       fdv <- data.frame(labelDescription=c("SNP Quality Score",
                           "Shift in parameters AA",
                           "Shift in parameters AB",
                           "Shift in parameters BB"),
                         row.names=c("SNPQC", "spAA", "spAB", "spBB"))
     }else{
       fd <- data.frame(SNPQC=x[["SNPQC"]],
                        row.names=rownames(x[["calls"]]))
       fdv <- data.frame(labelDescription=c("SNP Quality Score"),
                         row.names=c("SNPQC"))
     }
   }
   new("SnpSet",
       assayData=assayDataNew("lockedEnvironment",
         call=x[["calls"]], callProbability=x[["confs"]]),
       phenoData=new("AnnotatedDataFrame",
         data=pd, varMetadata=pdv),
       featureData=new("AnnotatedDataFrame",
         data=fd, varMetadata=fdv),
       annotation=x[["pkgname"]])
 }
67e99be3
 
 loader <- function(theFile, envir, pkgname){
bc16b510
 	theFile <- file.path(system.file(package=pkgname),
 			     "extdata", theFile)
 	if (!file.exists(theFile))
 		stop("File ", theFile, " does not exist in ", pkgname)
 	load(theFile, envir=envir)
67e99be3
 }
 
82be31d4
 celDates <- function(celfiles){
 	if(!all(file.exists(celfiles))) stop("1 or more cel file does not exist")
4c729c33
 	celdates <- celtimes <- vector("character", length(celfiles))
82be31d4
 	for(i in seq(along=celfiles)){
 		if(i %% 100 == 0) cat(".")
 		tmp <- read.celfile.header(celfiles[i], info="full")$DatHeader
 		tmp <- strsplit(tmp, "\ +")
 		celdates[i] <- tmp[[1]][6]
 		celtimes[i] <- tmp[[1]][7]
bf8acd05
 	}
82be31d4
 	tmp <- paste(celdates, celtimes)
 	celdts <- strptime(tmp, "%m/%d/%y %H:%M:%S")
 	return(celdts)
bf8acd05
 }
 
063b3d14
 illuminaCdfNames <- function(){
 	c("human1mv1c",# 1M
 	  "human370v1c",            # 370CNV
 	  "human650v3a",            # 650Y
 	  "human610quadv1b",        # 610 quad
 	  "human660quadv1a",        # 660 quad
 	  "human370quadv3c",        # 370CNV quad
 	  "human550v3b",            # 550K
 	  "human1mduov3b",          # 1M Duo
 	  "humanomni1quadv1b",      # Omni1 quad
 	  "humanomni25quadv1b",     # Omni2.5 quad
808cfecc
 	  "humanomni258v1a",        # Omni2.5 8
           "humanomni5quadv1b",      # Omni5 quad          
063b3d14
 	  "humanomniexpress12v1b",  # Omni express 12
 	  "humanimmuno12v1b",       # Immuno chip 12
808cfecc
 	  "humancytosnp12v2p1h",    # CytoSNP 12
           "humanomniexpexome8v1p1b")
063b3d14
 }
 
 affyCdfNames <- function(){
e272e5d6
 	c("genomewidesnp6",
063b3d14
 	  "genomewidesnp5")
e272e5d6
 }
063b3d14
 
 validCdfNames <- function(){
 	c(affyCdfNames(),
 	  illuminaCdfNames())
 }
 
 cleancdfname <- function(x) strsplit(x, "Crlmm")[[1]][[1]]
 
e272e5d6
 isValidCdfName <- function(cdfName){
453e688a
 	chipList <- validCdfNames()
063b3d14
 	match.arg(cleancdfname(cdfName), chipList)
 	return(TRUE)
453e688a
 }
 
 isPackageLoaded <- function(pkg){
 	stopifnot(is.character(pkg))
 	pkg <- paste("package:", pkg, sep="")
 	pkg %in% search()
e272e5d6
 }
a13f66d1
 
e1909d6b
 paramNames <- function(){
d5bc779e
 	c("tau2A",
 	  "tau2B", "sig2A", "sig2B",
 	  "nuA", ##"nuA.se",
 	  "nuB",  ##"nuB.se",
 	  "phiA",
 	  "phiB",
 	  "phiPrimeA",
 	  "phiPrimeB",
 	  ##"phiA.se", "phiB.se",
 	  "corrAB",
 	  "corrBB",
 	  "corrAA")
 }
 
 loadObject <- function(filename, load.it){
 	fname <- paste(filename, ".rda", sep="")
 	if(load.it & file.exists(file.path(ldPath(), fname))){
 		message("load.it is TRUE, loading previously saved ff object")
 		return(TRUE)
 	} else return(FALSE)
e1909d6b
 }
 
97e84a80
 
e1909d6b
 
a4ece851
 setMethod("annotatedDataFrameFrom", "ff_matrix", Biobase:::annotatedDataFrameFromMatrix)
 setMethod("annotatedDataFrameFrom", "ffdf", Biobase:::annotatedDataFrameFromMatrix)
b6f0c388
 
 ## Document this...
 getBAF <- function(theta, canonicalTheta)
ad3cc706
     .Call('normalizeBAF', theta, canonicalTheta)
af08b5d6
 
7c0c9ac5
 
 validCEL <- function(celfiles){
 	for(i in seq_along(celfiles)){
 		res <- tryCatch(read.celfile(celfiles[i], intensity.means.only=TRUE), error=function(e) NULL)
 		if(is.null(res)) {
 			msg <- message("Problem reading ", celfiles[i])
 			stop(msg)
 		}
 	}
 	return("Successfully read all cel files")
 }