[Robast-commits] r824 - branches/robast-1.0/pkg/RobLoxBioC/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun May 3 17:53:41 CEST 2015
Author: stamats
Date: 2015-05-03 17:53:41 +0200 (Sun, 03 May 2015)
New Revision: 824
Modified:
branches/robast-1.0/pkg/RobLoxBioC/R/KolmogorovMinDist.R
Log:
now works again with newest version of beadarray
Modified: branches/robast-1.0/pkg/RobLoxBioC/R/KolmogorovMinDist.R
===================================================================
--- branches/robast-1.0/pkg/RobLoxBioC/R/KolmogorovMinDist.R 2015-05-03 15:47:48 UTC (rev 823)
+++ branches/robast-1.0/pkg/RobLoxBioC/R/KolmogorovMinDist.R 2015-05-03 15:53:41 UTC (rev 824)
@@ -88,134 +88,56 @@
list("dist" = kmd.mat, "n" = ns.mat)
})
-setMethod("KolmogorovMinDist", signature(x = "BeadLevelList",
+setMethod("KolmogorovMinDist", signature(x = "beadLevelData",
D = "AbscontDistribution"),
- function(x, D, log = FALSE, imagesPerArray = 1, what = "G", probes = NULL, arrays = NULL){
+ function(x, D, log = FALSE, what = "Grn", probes = NULL, arrays = NULL){
BLData <- x
- arraynms <- arrayNames(BLData)
+ arraynms <- sectionNames(BLData)
if(!is.null(arrays) && !is.character(arrays)) arraynms <- arraynms[arrays]
if(is.character(arrays)) arraynms <- which(arraynms %in% arrays)
len <- length(arraynms)
- what <- match.arg(what, c("G", "R", "RG", "M", "A", "beta"))
- whatelse <- ""
- if(what == "RG"){
- if(BLData at arrayInfo$channels == "two"){
- what <- "G"
- whatelse <- "R"
- }else{
- stop("Need two-channel data to calculate summary R and G values")
- }
- }
- if(imagesPerArray == 1){
- sel <- getArrayData(BLData, what = "ProbeID", array = arraynms[1]) != 0
- pr <- getArrayData(BLData, what = "ProbeID", array = arraynms[1])[sel]
- finten <- getArrayData(BLData, what = what, log = log, array = arraynms[1])[sel]
- nasinf <- !is.finite(finten) | is.na(finten)
- finten <- finten[!nasinf]
- }
- else if(imagesPerArray == 2){
- if(length(arraynms)%%2 != 0)
- stop("Need an even number of arrays when 'imagesPerArray=2'")
- arrayord <- order(arraynms)
- arraynms <- arraynms[arrayord]
- tmp <- unlist(strsplit(arraynms, "_"))
- chipnums <- tmp[seq(1, length(tmp), by = 3)]
- pos <- tmp[seq(2, length(tmp), by = 3)]
- stripnum <- as.numeric(tmp[seq(3, length(tmp), by = 3)])
- check <- ((chipnums[seq(1, len, by = 2)] == chipnums[seq(2, len, by = 2)])
- & (pos[seq(1, len, by = 2)] == pos[seq(2, len, by = 2)])
- & (stripnum[seq(1, len, by = 2)] == stripnum[seq(2, len, by = 2)] - 1))
- if(sum(check) != length(check)) stop("Missing arrays")
- sel1 <- getArrayData(BLData, what = "ProbeID", array = arraynms[1]) != 0
- sel2 <- getArrayData(BLData, what = "ProbeID", array = arraynms[2]) != 0
- pr <- append(getArrayData(BLData, what = "ProbeID", array = arraynms[1])[sel1],
- getArrayData(BLData, what = "ProbeID", array = arraynms[2])[sel2])
- finten <- append(getArrayData(BLData, what = what, log = log, array = arraynms[1])[sel1],
- getArrayData(BLData, what = what, log = log, array = arraynms[2])[sel2])
- nasinf <- !is.finite(finten) | is.na(finten)
- finten <- finten[!nasinf]
- }else{
- stop("You can only specify 1 or 2 images per array")
- }
+
+ tmp <- BLData[[1]]
+ what <- match.arg(what, colnames(tmp))
+ if(is.na(what))
+ stop("Could not find bead data of type ", what, "\n The available choices are: ",
+ paste(colnames(tmp)), "\n")
+
+ pr <- getBeadData(BLData, what = "ProbeID", array = 1)
+ finten <- getBeadData(BLData, what = what, array = 1)
+ if(log) finten <- log2(finten)
+ nasinf <- !is.finite(finten) | is.na(finten)
+ finten <- finten[!nasinf]
+
if(is.null(probes)) probes <- sort(unique(pr))
probes <- probes[probes > 0 & !is.na(probes)]
noprobes <- length(probes)
pr <- pr[!nasinf]
- if (imagesPerArray == 1) {
- G.kmd <- matrix(0, nrow = noprobes, ncol = len)
- G.ns <- matrix(0, nrow = noprobes, ncol = len)
- colnames(G.kmd) <- colnames(G.ns) <- arraynms
- if (BLData at arrayInfo$channels == "two" && !is.null(BLData[[arraynms[1]]]$R) && whatelse == "R")
- R.kmd <- R.ns <- G.kmd
- else R.kmd <- R.ns <- NULL
- }
- else if (imagesPerArray == 2) {
- G.kmd <- matrix(0, nrow = noprobes, ncol = (len/2))
- G.ns <- matrix(0, nrow = noprobes, ncol = (len/2))
- colnames(G.kmd) <- colnames(G.ns) <- arraynms[seq(1, len, by = 2)]
- if (BLData at arrayInfo$channels == "two" && !is.null(BLData[[arraynms[1]]]$R) && whatelse == "R")
- R.kmd <- R.ns <- G.kmd
- else R.kmd <- R.ns <- NULL
- }
- i <- j <- 1
- while (j <= len) {
+ G.kmd <- matrix(0, nrow = noprobes, ncol = len)
+ G.ns <- matrix(0, nrow = noprobes, ncol = len)
+ colnames(G.kmd) <- colnames(G.ns) <- arraynms
+
+ i <- 1
+ while (i <= len) {
probeIDs <- as.integer(pr)
start <- 0
G.res <- kmdBeadLevel(x = finten, D = D, probeIDs = probeIDs, probes = probes)
G.kmd[,i] <- G.res[["dist"]]
G.ns[,i] <- G.res[["n"]]
- if (BLData at arrayInfo$channels == "two" && !is.null(BLData[[arraynms[i]]]$R) && whatelse == "R") {
- if (imagesPerArray == 1) {
- finten <- getArrayData(BLData, what = whatelse, log = log, array = arraynms[i])[sel]
- nasinf <- !is.finite(finten) | is.na(finten)
- finten <- finten[!nasinf]
- binten <- rep(0, length(finten))
- }
- else if (imagesPerArray == 2) {
- finten <- append(getArrayData(BLData, what = whatelse, log = log, array = arraynms[j])[sel1],
- getArrayData(BLData, what = whatelse, log = log, array = arraynms[j + 1])[sel2])
- nasinf <- !is.finite(finten) | is.na(finten)
- finten <- finten[!nasinf]
- binten <- rep(0, length(finten))
- }
- start <- 0
- R.res[,i] <- kmdBeadLevel(x = finten, D = D, probeIDs = probeIDs, probes = probes)
- R.kmd[,i] <- R.res[["dist"]]
- R.ns[,i] <- R.res[["n"]]
- }
- j <- j + imagesPerArray
+
i <- i + 1
rm(probeIDs)
gc()
- if ((imagesPerArray == 1) && (i <= len)) {
- sel <- getArrayData(BLData, what = "ProbeID", array = arraynms[i]) != 0
- pr <- getArrayData(BLData, what = "ProbeID", array = arraynms[i])[sel]
- finten <- getArrayData(BLData, what = what, log = log, array = arraynms[i])[sel]
- nasinf <- !is.finite(finten) | is.na(finten)
- pr <- pr[!nasinf]
- finten <- finten[!nasinf]
- }
- else if ((imagesPerArray == 2) && (j < len)) {
- sel1 <- getArrayData(BLData, what = "ProbeID", array = arraynms[j]) != 0
- sel2 <- getArrayData(BLData, what = "ProbeID", array = arraynms[j + 1]) != 0
- pr <- append(getArrayData(BLData, what = "ProbeID", array = arraynms[j])[sel1],
- getArrayData(BLData, what = "ProbeID", array = arraynms[j + 1])[sel2])
- finten <- append(getArrayData(BLData, what = what, log = log, array = arraynms[j])[sel1],
- getArrayData(BLData, what = what, log = log, array = arraynms[j + 1])[sel2])
- nasinf <- !is.finite(finten) | is.na(finten)
- pr <- pr[!nasinf]
- finten <- finten[!nasinf]
- }
+
+ pr <- getBeadData(BLData, what = "ProbeID", array = i)
+ finten <- getBeadData(BLData, what = what, array = i)
+ if(log) finten <- log2(finten)
+ nasinf <- !is.finite(finten) | is.na(finten)
+ pr <- pr[!nasinf]
+ finten <- finten[!nasinf]
}
- if (whatelse == "R") {
- rownames(G.kmd) <- rownames(G.ns) <- rownames(R.kmd) <- rownames(R.ns) <- probes
- res <- list(G = list("dist" = G.kmd, "n" = G.ns),
- R = list("dist" = R.kmd, "n" = R.ns))
- }
- else {
- rownames(G.kmd) <- rownames(G.ns) <- probes
- res <- list("dist" = G.kmd, "n" = G.ns)
- }
+ rownames(G.kmd) <- rownames(G.ns) <- probes
+ res <- list("dist" = G.kmd, "n" = G.ns)
return(res)
})
kmdBeadLevel <- function(x, D, probeIDs, probes){
More information about the Robast-commits
mailing list