### [SAM and Modified SAM Functions] ###

## install packages
install.packages(c("samr","numDeriv"))
source("http://bioconductor.org/biocLite.R")
biocLite("impute")
library(samr)	# SAM
library(numDeriv)	# used for MSAM1

## functions for calculating test statistics

# SAM
varr <- function (x, meanx = NULL) 
{
    n <- ncol(x)
    p <- nrow(x)
    Y <- matrix(1, nrow = n, ncol = 1)
    if (is.null(meanx)) {
        meanx <- rowMeans(x)
    }
    ans <- rep(1, p)
    xdif <- x - meanx %*% t(Y)
    ans <- (xdif^2) %*% rep(1/(n - 1), n)
    ans <- drop(ans)
    return(ans)
}
ttest.func <- function (x, y, s0 = 0, sd = NULL){

    #this function calculates test statistics of SAM.
    n1 <- sum(y == 1)
    n2 <- sum(y == 2)
    p <- nrow(x)
    m1 <- rowMeans(x[, y == 1, drop = F])
    m2 <- rowMeans(x[, y == 2, drop = F])
    if (is.null(sd)) {
        sd2 <- varr(x[, y == 2], meanx = m2)
        sd1 <- varr(x[, y == 1], meanx = m1)
        sd <- sqrt(((n2 - 1) * sd2 + (n1 - 1) * sd1) * (1/n1 + 
            1/n2)/(n1 + n2 - 2))
    }
    numer <- m2 - m1
    dif.obs <- (numer)/(sd + s0)
    ind.sdis0 <- as.numeric(which(sd1 == 0 | sd2 == 0))
    return(list(tt = dif.obs, numer = numer, sd = sd, ind.sdis0 = ind.sdis0))
}

# Modified SAM 1 (MSAM1) : Normal Weighted SAM
sigmaftn <- function(sigma, w.perc, xdif){
	abs(qnorm(w.perc, 0, sigma, lower.tail = F) - max(xdif))
}
ttest.modified1 <- function (x, y, s0 = 0, sd = NULL, w.perc = w.perc){

	#this function calculates test statistics of MSAM1.
	#argument "w.perc" indicates weight percent of MSAM1.
	n1 <- sum(y == 1)
	n2 <- sum(y == 2)
	p <- nrow(x)
	m1 <- rowMeans(x[, y == 1, drop = F])
	m2 <- rowMeans(x[, y == 2, drop = F])
	med1 <- apply(x[, y == 1, drop = F], 1, median)
	med2 <- apply(x[, y == 2, drop = F], 1, median)
	xdif <- as.vector(abs(cbind(x[, y == 1] - med1, x[, y == 2] - med2)))
	sigma <- optimize(sigmaftn, c(0, 10^5), maximum = F, w.perc = w.perc, xdif = xdif)$minimum

	if (is.null(sd)) {
		w <- matrix(0, p, n1 + n2)
		w[, y == 1] <- dnorm(x[, y == 1], med1, sigma)
		w[, y == 2] <- dnorm(x[, y == 2], med2, sigma)
		sd1 <- rowSums((x[, y == 1] - med1)^2 * w[, y == 1])
		sd2 <- rowSums((x[, y == 2] - med2)^2 * w[, y == 2])
		sd <- sqrt((sd1 + sd2))
	}

	numer <- m2 - m1
	dif.obs <- (numer)/(sd + s0)
	ind.sdis0 <- as.numeric(which(sd1 == 0 | sd2 == 0))
	return(list(tt = dif.obs, numer = numer, sd = sd, ind.sdis0 = ind.sdis0))
}

# Modified SAM 2 (MSAM2) : Distance Weighted SAM
distvec <- function(vec, pow = 1){
	out <- rowSums(as.matrix(dist(vec)^pow))
	return(out)
}
ttest.modified2 <- function (x, y, s0 = 0, sd = NULL, pow = pow){

	#this function calculates test statistics of MSAM2.
	#argument "pow" indicates weight power of MSAM2.
	n1 <- sum(y == 1)
	n2 <- sum(y == 2)
	p <- nrow(x)
	m1 <- rowMeans(x[, y == 1, drop = F])
	m2 <- rowMeans(x[, y == 2, drop = F])
	med1 <- apply(x[, y == 1, drop = F], 1, median)
	med2 <- apply(x[, y == 2, drop = F], 1, median)

	if (is.null(sd)) {
		w <- matrix(0, p, n1 + n2)
		w[, y == 1] <- 1/t(apply(x[, y == 1], 1, distvec, pow = pow))
		w[, y == 2] <- 1/t(apply(x[, y == 2], 1, distvec, pow = pow))
		w[w == Inf] <- 1
		sd1 <- rowSums((x[, y == 1] - med1)^2 * w[, y == 1])
		sd2 <- rowSums((x[, y == 2] - med2)^2 * w[, y == 2])
		sd <- sqrt((sd1 + sd2))
	}

	numer <- m2 - m1
	dif.obs <- (numer)/(sd + s0)
	ind.sdis0 <- as.numeric(which(sd1 == 0 | sd2 == 0))
	return(list(tt = dif.obs, numer = numer, sd = sd, ind.sdis0 = ind.sdis0))
}

## modified samr functions

mysamr <- function(data, s0 = NULL, s0.perc = NULL, nperms = 100, center.arrays = FALSE, 
    testStatistic = c("standard", "wilcoxon", "MSAM1", "MSAM2"), w.perc = 0.001, pow = 1,
    regression.method = c("standard", "ranks"), 
    return.x = FALSE, knn.neighbors = 10, random.seed = NULL, 
    xl.mode = c("regular", "firsttime", "next20", "lasttime"), xl.time = NULL, xl.prevfit = NULL){
	
    #this function is modified version of samr function in "samr" package.
    #it generates SAM object for two class unpaired microarray data.
    #argument "w.perc" is only used for MSAM1.
    #argument "pow" is only used for MSAM2.

    this.call = match.call()
    xl.mode = match.arg(xl.mode)
    if (!is.null(random.seed)) {
        set.seed(random.seed)
    }
	
    if (xl.mode == "regular" | xl.mode == "firsttime") {
        x = NULL
        ttstar0 = NULL
        evo = NULL
        ystar = NULL
        sdstar.keep = NULL
        censoring.status = NULL
        sdstar = NULL
        pi0 = NULL
        stand.contrasts = NULL
        stand.contrasts.star = NULL
        stand.contrasts.95 = NULL
        foldchange = NULL
        foldchange.star = NULL
        perms = NULL
        permsy = NULL
        eigengene = NULL
        eigengene.number = NULL
        testStatistic <- match.arg(testStatistic)
        regression.method <- match.arg(regression.method)
        x = data$x
        y = data$y
        argy = y
        if (!is.null(data$eigengene.number)) {
            eigengene.number = data$eigengene.number
        }
        if (sum(is.na(x)) > 0) {
            require(impute)
            x = impute.knn(x, k = knn.neighbors)
            if (!is.matrix(x)) {
                x = x$data
            }
        }
        are.blocks.specified = FALSE
        if (center.arrays) {
            x <- scale(x, center = apply(x, 2, median), scale = FALSE)
        }
        depth = scaling.factors = rep(NA, ncol(x))
        scaling.factors = (prod(depth)^(1/length(depth)))/depth
        if (substring(y[1], 2, 6) == "Block" | substring(y[1], 
            2, 6) == "block") {
            junk = parse.block.labels.for.2classes(y)
            y = junk$y
            blocky = junk$blocky
            are.blocks.specified = TRUE
        }
        y = as.numeric(y)
        sd.internal = NULL
        stand.contrasts = NULL
        stand.contrasts.95 = NULL
        mycheck.format(y, censoring.status = censoring.status)
        n <- nrow(x)
        ny <- length(y)
        sd <- NULL
        numer <- NULL
        if (testStatistic == "standard") {
            init.fit <- ttest.func(x, y, sd = sd.internal)
            numer <- init.fit$numer
            sd <- init.fit$sd
        }
        if (testStatistic == "wilcoxon") {
            init.fit <- wilcoxon.func(x, y)
            numer <- init.fit$numer
            sd <- init.fit$sd
        }
        if (testStatistic == "MSAM1") {
            init.fit <- ttest.modified1(x, y, sd = sd.internal, w.perc = w.perc)
            numer <- init.fit$numer
            sd <- init.fit$sd
        }
        if (testStatistic == "MSAM2") {
            init.fit <- ttest.modified2(x, y, sd = sd.internal, pow = pow)
            numer <- init.fit$numer
            sd <- init.fit$sd
        }
        if (testStatistic == "wilcoxon" | (nrow(x) < 
            500) & is.null(s0) & is.null(s0.perc)) {
            s0 = quantile(sd, 0.05)
            s0.perc = 0.05
        }
        if (is.null(s0)) {
            if (!is.null(s0.perc)) {
                if ((s0.perc != -1 & s0.perc < 0) | s0.perc > 
                  100) {
                  stop("Illegal value for s0.perc: must be between 0 and 100, or equal\nto (-1) (meaning that s0 should be set to zero)")
                }
                if (s0.perc == -1) {
                  s0 = 0
                }
                if (s0.perc >= 0) {
                  s0 <- quantile(init.fit$sd, s0.perc/100)
                }
            }
            if (is.null(s0.perc)) {
                s0 = est.s0(init.fit$tt, init.fit$sd)$s0.hat
                s0.perc = 100 * sum(init.fit$sd < s0)/length(init.fit$sd)
            }
        }
        if (testStatistic == "standard") {
            tt <- ttest.func(x, y, s0 = s0, sd = sd.internal)$tt
        }
        if (testStatistic == "wilcoxon") {
            tt <- wilcoxon.func(x, y, s0 = s0)$tt
        }
        if (testStatistic == "MSAM1") {
            tt <- ttest.modified1(x, y, s0 = s0, sd = sd.internal, w.perc = w.perc)$tt
        }
        if (testStatistic == "MSAM2") {
            tt <- ttest.modified2(x, y, s0 = s0, sd = sd.internal, pow = pow)$tt
        }
        # Start writing to an output file
        sink("checking data integrity.txt")
        cat("::: checking data integrity :::\n")
        cat("", fill = T)
        cat("If there are any problems, the corresponding gene numbers will be shown below.\n")
        cat("You need to check their expressions since the values are the same in at least one group.\n")
        cat("", fill = T)
        cat("original data:\n")
        if (length(init.fit$ind.sdis0) == 0) {
            cat("No problem.\n")
        }
        else {
            cat("Gene numbers:", init.fit$ind.sdis0, fill = TRUE, append = TRUE)
        }
        # Stop writing to the file
        sink()
        if (are.blocks.specified) {
            junk = compute.block.perms(y, blocky, nperms)
            permsy = matrix(junk$permsy, ncol = length(y))
            all.perms.flag = junk$all.perms.flag
            nperms.act = junk$nperms.act
        }
        else {
            junk <- getperms(y, nperms)
            permsy = matrix(y[junk$perms], ncol = length(y))
            all.perms.flag = junk$all.perms.flag
            nperms.act = junk$nperms.act
        }
        sdstar.keep <- NULL
        sdstar.keep <- matrix(0, ncol = nperms.act, nrow = nrow(x))
        ttstar <- matrix(0, nrow = nrow(x), ncol = nperms.act)
        foldchange.star = NULL
        foldchange.star <- matrix(0, nrow = nrow(x), ncol = nperms.act)
    }
	
    if (xl.mode == "next20" | xl.mode == "lasttime") {
        evo = xl.prevfit$evo
        tt = xl.prevfit$tt
        numer = xl.prevfit$numer
        eigengene = xl.prevfit$eigengene
        eigengene.number = xl.prevfit$eigengene.number
        sd = xl.prevfit$sd - xl.prevfit$s0
        sd.internal = xl.prevfit$sd.internal
        ttstar = xl.prevfit$ttstar
        ttstar0 = xl.prevfit$ttstar0
        n = xl.prevfit$n
        pi0 = xl.prevfit$pi0
        foldchange = xl.prevfit$foldchange
        y = xl.prevfit$y
        x = xl.prevfit$x
        censoring.status = xl.prevfit$censoring.status
        argy = xl.prevfit$argy
        testStatistic = xl.prevfit$testStatistic
        foldchange.star = xl.prevfit$foldchange.star
        s0 = xl.prevfit$s0
        s0.perc = xl.prevfit$s0.perc
        sdstar.keep = xl.prevfit$sdstar.keep
        stand.contrasts = xl.prevfit$stand.contrasts
        stand.contrasts.star = xl.prevfit$stand.contrasts.star
        stand.contrasts.95 = xl.prevfit$stand.contrasts.95
        perms = xl.prevfit$perms
        permsy = xl.prevfit$permsy
        nperms = xl.prevfit$nperms
        nperms.act = xl.prevfit$nperms.act
        all.perms.flag = xl.prevfit$all.perms.flag
        depth = xl.prevfit$depth
        scaling.factors = xl.prevfit$scaling.factors
        # Start writing to an output file
        sink("checking data integrity.txt")
        cat("::: checking data integrity :::\n")
        cat("", fill = T)
        cat("If there are any problems, the corresponding gene numbers will be shown below.\n")
        cat("You need to check their expressions since the values are the same in at least one group.\n")
        # Stop writing to the file
        sink()
    }
    if (xl.mode == "regular") {
        first = 1
        last = nperms.act
    }
    if (xl.mode == "firsttime") {
        first = 1
        last = 1
    }
    if (xl.mode == "next20") {
        first = xl.time
        last = min(xl.time + 19, nperms.act - 1)
    }
    if (xl.mode == "lasttime") {
        first = nperms.act
        last = nperms.act
    }
    # Append to the file
    sink("checking data integrity.txt", append = TRUE)
    cat("", fill = T)
    cat("permuted data:\n")
    # Stop writing to the file
    sink()
    tot.sdis0 <- 0
    for (b in first:last) {
        cat(c("perm=", b), fill = TRUE)
        xstar <- x
        ystar = permsy[b, ]
        if (testStatistic == "standard") {
          junk <- ttest.func(xstar, ystar, s0 = s0, sd = sd.internal)
        }
        if (testStatistic == "wilcoxon") {
          junk <- wilcoxon.func(xstar, ystar, s0 = s0)
        }
        if (testStatistic == "MSAM1") {
          junk <- ttest.modified1(xstar, ystar, s0 = s0, sd = sd.internal, w.perc = w.perc)
        }
        if (testStatistic == "MSAM2") {
          junk <- ttest.modified2(xstar, ystar, s0 = s0, sd = sd.internal, pow = pow)
        }
        ttstar[, b] <- junk$tt
        sdstar.keep[, b] <- junk$sd
        foldchange.star[, b] = foldchange.twoclass(xstar, ystar, data$logged2)
        if (length(junk$ind.sdis0) != 0) {
          # Append to the file
          sink("checking data integrity.txt", append = TRUE)
          cat(sprintf("perms %d : y =", b), ystar, fill = TRUE, append = TRUE)
          cat("Gene numbers:", junk$ind.sdis0, fill = TRUE, append = TRUE)
          # Stop writing to the file
          sink()
        }
        tot.sdis0 <- tot.sdis0 + length(junk$ind.sdis0)
    }
    # Append to the file
    sink("checking data integrity.txt", append = TRUE)
    if (tot.sdis0 == 0) {
        cat(sprintf("No problem over %d permutations.\n", last - first + 1), fill = TRUE, append = TRUE)
    }
    cat("", fill = T)
    cat("file creation time:\n")
    print(Sys.time())
    # Stop writing to the file
    sink()

    if (xl.mode == "regular" | xl.mode == "lasttime") {
        ttstar0 <- ttstar
        for (j in 1:ncol(ttstar)) {
            ttstar[, j] <- -1 * sort(-1 * ttstar[, j])
        }
        for (i in 1:nrow(ttstar)) {
            ttstar[i, ] <- sort(ttstar[i, ])
        }
        evo <- apply(ttstar, 1, mean)
        evo <- evo[length(evo):1]
        sdstar <- sdstar.keep
        pi0 = 1
        qq <- quantile(ttstar, c(0.25, 0.75))
        pi0 <- sum(tt > qq[1] & tt < qq[2])/(0.5 * length(tt))
        foldchange = NULL
        foldchange = foldchange.twoclass(x, y, data$logged2)
        stand.contrasts.95 = NULL
        if (return.x == FALSE) {
            x = NULL
        }
    }
    cat("data integrity is examined automatically...", fill = T)
    cat("find the file 'checking data integrity.txt' on your working directory.", fill = T)

    return(list(n = n, x = x, y = y, argy = argy, 
        censoring.status = censoring.status, testStatistic = testStatistic, 
        nperms = nperms, nperms.act = nperms.act, tt = tt, numer = numer, 
        sd = sd + s0, sd.internal = sd.internal, s0 = s0, s0.perc = s0.perc, 
        evo = evo, perms = perms, permsy = permsy, 
        all.perms.flag = all.perms.flag, 
        ttstar = ttstar, ttstar0 = ttstar0, eigengene = eigengene, 
        eigengene.number = eigengene.number, pi0 = pi0, foldchange = foldchange, 
        foldchange.star = foldchange.star, sdstar.keep = sdstar.keep, 
        stand.contrasts = stand.contrasts, 
        stand.contrasts.star = stand.contrasts.star, stand.contrasts.95 = stand.contrasts.95, 
        depth = depth, call = this.call))
}

mySAM <- function (x, y = NULL, censoring.status = NULL,
    geneid = NULL, genenames = NULL, s0 = NULL, s0.perc = NULL, nperms = 100, 
    center.arrays = FALSE, testStatistic = c("standard", "wilcoxon", "MSAM1", "MSAM2"), w.perc = 0.001, pow = 1,
    regression.method = c("standard", "ranks"), return.x = TRUE, knn.neighbors = 10, random.seed = NULL, 
    logged2 = FALSE, fdr.output = 0.2, med = T, eigengene.number = 1){
	
    #this function is modified version of SAM function in "samr" package.	
    this.call <- match.call()
    xl.mode = "regular"
    xl.time = NULL
    xl.prevfit = NULL
	
    if (fdr.output < 0 | fdr.output > 1) {
        stop("Error: fdr.output must be between 0 and 1")
    }
    if (is.null(geneid)) {
        geneid = as.character(1:nrow(x))
    }
    if (is.null(genenames)) {
        genenames = paste("g", as.character(1:nrow(x)), sep = "")
    }
    data = list(x = x, y = y, censoring.status = censoring.status, 
        geneid = geneid, genenames = genenames, logged2 = logged2, 
        eigengene.number = eigengene.number)
    samr.obj = mysamr(data,
        s0 = s0, s0.perc = s0.perc, nperms = nperms, center.arrays = center.arrays, 
        testStatistic = testStatistic, w.perc = w.perc, pow = pow, 
        regression.method = regression.method, return.x = return.x, 
        knn.neighbors = knn.neighbors, random.seed = random.seed)
    delta.table <- mysamr.compute.delta.table.array(samr.obj)
    siggenes.table <- del <- NULL
    delta.table <- delta.table[delta.table[, "# called"] > 0, 
        , drop = FALSE]
    if (nrow(delta.table) > 0) {
	whichFDR <- ifelse(med == T, "median FDR", "mean FDR")
        oo <- which(delta.table[, whichFDR] >= fdr.output)
        if (length(oo) > 0) {
            oo <- oo[length(oo)]
        }
        else {
            oo <- 1
        }
        delta.table <- delta.table[oo:nrow(delta.table), , drop = FALSE]
        del <- delta.table[1, "delta"]
        siggenes.table <- mysamr.compute.siggenes.table(samr.obj, 
            del, data, delta.table)
        rang = 4:8
        siggenes.table$genes.up[, rang] = round(as.numeric(siggenes.table$genes.up[, 
            rang]), 3)
        siggenes.table$genes.lo[, rang] = round(as.numeric(siggenes.table$genes.lo[, 
            rang]), 3)
        siggenes.table$genes.up = siggenes.table$genes.up[, -1]
        siggenes.table$genes.lo = siggenes.table$genes.lo[, -1]
    }
    out = list(samr.obj = samr.obj, del = del, delta.table = delta.table, 
        siggenes.table = siggenes.table)
    out$call = this.call
    class(out) = "SAMoutput"
    return(out)
}

mycheck.format <- function (y, censoring.status = NULL){

    #this function is modified version of check.format function.
    if (sum(y == 1) + sum(y == 2) != length(y)) {
        stop(paste("Error in input response data: values must be 1 or 2"))
    }
    return()
}

mysamr.compute.siggenes.table <-
function (samr.obj, del, data, delta.table, min.foldchange = 0, 
    all.genes = FALSE, compute.localfdr = FALSE){

    #this function is modified version of samr.compute.siggenes.table function.
    if (is.null(data$geneid)) {
        data$geneid = paste("g", 1:nrow(data$x), sep = "")
    }
    if (is.null(data$genenames)) {
        data$genenames = paste("g", 1:nrow(data$x), sep = "")
    }
    if (!all.genes) {
        sig = detec.slab(samr.obj, del, min.foldchange)
    }
    if (all.genes) {
        p = length(samr.obj$tt)
        pup = (1:p)[samr.obj$tt >= 0]
        plo = (1:p)[samr.obj$tt < 0]
        sig = list(pup = pup, plo = plo)
    }
    if (compute.localfdr) {
        aa = localfdr(samr.obj, min.foldchange)
        if (length(sig$pup) > 0) {
            fdr.up = predictlocalfdr(aa$smooth.object, samr.obj$tt[sig$pup])
        }
        if (length(sig$plo) > 0) {
            fdr.lo = predictlocalfdr(aa$smooth.object, samr.obj$tt[sig$plo])
        }
    }
    qvalues = NULL
    if (length(sig$pup) > 0 | length(sig$plo) > 0) {
        qvalues = qvalue.func(samr.obj, sig, delta.table)
    }
    res.up = NULL
    res.lo = NULL
    done = FALSE
    if (!is.null(sig$pup)) {
        res.up = cbind(sig$pup + 1, data$geneid[sig$pup], 
            data$genenames[sig$pup], samr.obj$tt[sig$pup], samr.obj$numer[sig$pup], 
            samr.obj$sd[sig$pup], samr.obj$foldchange[sig$pup], 
            qvalues$qvalue.up)
        if (compute.localfdr) {
            res.up = cbind(res.up, fdr.up)
        }
        temp.names = list(NULL, c("Row", "Gene ID", "Gene Name", 
            "Score(d)", "Numerator(r)", "Denominator(s+s0)", 
            "Fold Change", "q-value(%)"))
        if (compute.localfdr) {
            temp.names[[2]] = c(temp.names[[2]], "localfdr(%)")
        }
        dimnames(res.up) = temp.names
    }
    if (!is.null(sig$plo)) {
        res.lo = cbind(sig$plo + 1, data$geneid[sig$plo], 
            data$genenames[sig$plo], samr.obj$tt[sig$plo], samr.obj$numer[sig$plo], 
            samr.obj$sd[sig$plo], samr.obj$foldchange[sig$plo], 
            qvalues$qvalue.lo)
        if (compute.localfdr) {
            res.lo = cbind(res.lo, fdr.lo)
        }
        temp.names = list(NULL, c("Row", "Gene ID", "Gene Name", 
            "Score(d)", "Numerator(r)", "Denominator(s+s0)", 
            "Fold Change", "q-value(%)"))
        if (compute.localfdr) {
            temp.names[[2]] = c(temp.names[[2]], "localfdr(%)")
        }
        dimnames(res.lo) = temp.names
    }
    done = TRUE
    if (!done) {
        if (!is.null(sig$pup)) {
            res.up = cbind(sig$pup + 1, data$geneid[sig$pup], 
                data$genenames[sig$pup], samr.obj$tt[sig$pup], samr.obj$numer[sig$pup], 
                samr.obj$sd[sig$pup], samr.obj$foldchange[sig$pup], 
                qvalues$qvalue.up)
            if (compute.localfdr) {
                res.up = cbind(res.up, fdr.up)
            }
            temp.names = list(NULL, c("Row", "Gene ID", "Gene Name", 
                "Score(d)", "Numerator(r)", "Denominator(s+s0)", 
                "q-value(%)"))
            if (compute.localfdr) {
                temp.names[[2]] = c(temp.names[[2]], "localfdr(%)")
            }
            dimnames(res.up) = temp.names
        }
        if (!is.null(sig$plo)) {
            res.lo = cbind(sig$plo + 1, data$geneid[sig$plo], 
                data$genenames[sig$plo], samr.obj$tt[sig$plo], samr.obj$numer[sig$plo], 
                samr.obj$sd[sig$plo], samr.obj$foldchange[sig$plo], 
                qvalues$qvalue.lo)
            if (compute.localfdr) {
                res.lo = cbind(res.lo, fdr.lo)
            }
            temp.names = list(NULL, c("Row", "Gene ID", "Gene Name", 
                "Score(d)", "Numerator(r)", "Denominator(s+s0)", 
                "q-value(%)"))
            if (compute.localfdr) {
                temp.names[[2]] = c(temp.names[[2]], "localfdr(%)")
            }
            dimnames(res.lo) = temp.names
        }
        done = TRUE
    }
    if (!is.null(res.up)) {
        o1 = order(-samr.obj$tt[sig$pup])
        res.up = res.up[o1, , drop = F]
    }
    if (!is.null(res.lo)) {
        o2 = order(samr.obj$tt[sig$plo])
        res.lo = res.lo[o2, , drop = F]
    }
    ngenes.up = nrow(res.up)
    if (is.null(ngenes.up)) {
        ngenes.up = 0
    }
    ngenes.lo = nrow(res.lo)
    if (is.null(ngenes.lo)) {
        ngenes.lo = 0
    }
    return(list(genes.up = res.up, genes.lo = res.lo, 
        ngenes.up = ngenes.up, ngenes.lo = ngenes.lo))
}

mysamr.compute.delta.table.array <- function (samr.obj, min.foldchange = 0, dels = NULL, nvals = 50){

    #this function is modified version of samr.compute.delta.table.array function.
    lmax = sqrt(max(abs(sort(samr.obj$tt) - samr.obj$evo)))
    if (is.null(dels)) {
        dels = (seq(0, lmax, length = nvals)^2)
    }
    col = matrix(1, nrow = length(samr.obj$evo), ncol = nvals)
    ttstar0 <- samr.obj$ttstar0
    tt <- samr.obj$tt
    n <- samr.obj$n
    evo <- samr.obj$evo
    nsim <- ncol(ttstar0)
    res1 <- NULL
    foldchange.cond.up = matrix(T, nrow = nrow(samr.obj$ttstar), 
        ncol = ncol(samr.obj$ttstar))
    foldchange.cond.lo = matrix(T, nrow = nrow(samr.obj$ttstar), 
        ncol = ncol(samr.obj$ttstar))
    if (!is.null(samr.obj$foldchange[1]) & (min.foldchange > 
        0)) {
        foldchange.cond.up = samr.obj$foldchange.star >= min.foldchange
        foldchange.cond.lo = samr.obj$foldchange.star <= 1/min.foldchange
    }
    cutup = rep(NA, length(dels))
    cutlow = rep(NA, length(dels))
    g2 = rep(NA, length(dels))
    errup = matrix(NA, ncol = length(dels), nrow = ncol(samr.obj$ttstar0))
    errlow = matrix(NA, ncol = length(dels), nrow = ncol(samr.obj$ttstar0))
    #cat("", fill = T)
    #cat("Computing delta table", fill = T)
    for (ii in 1:length(dels)) {
        #cat(ii, fill = TRUE)
        ttt <- detec.slab(samr.obj, dels[ii], min.foldchange)
        cutup[ii] <- 1e+10
        if (length(ttt$pup > 0)) {
            cutup[ii] <- min(samr.obj$tt[ttt$pup])
        }
        cutlow[ii] <- -1e+10
        if (length(ttt$plow) > 0) {
            cutlow[ii] <- max(samr.obj$tt[ttt$plow])
        }
        g2[ii] = sumlengths(ttt)
        errup[, ii] = colSums(samr.obj$ttstar0 > cutup[ii] & 
            foldchange.cond.up)
        errlow[, ii] = colSums(samr.obj$ttstar0 < cutlow[ii] & 
            foldchange.cond.lo)
    }
    s <- sqrt(apply(errup, 2, var)/nsim + apply(errlow, 2, var)/nsim)
    gmed <- apply(errup + errlow, 2, median)
    gmean = apply(errup + errlow, 2, mean)
    res1 <- cbind(samr.obj$pi0 * gmed, samr.obj$pi0 * gmean, g2, 
        samr.obj$pi0 * gmed/g2, samr.obj$pi0 * gmean/g2, cutlow, 
        cutup)
    res1 <- cbind(dels, res1)
    dimnames(res1) <- list(NULL, c("delta", "# med false pos", 
        "# mean false pos", "# called", "median FDR", "mean FDR", 
        "cutlo", "cuthi"))
    return(res1)
}

## call internal samr functions

qvalue.func <- function (samr.obj, sig, delta.table) 
{
    LARGE = 1e+10
    qvalue.up = rep(NA, length(sig$pup))
    o1 = sig$pup
    cutup = delta.table[, 8]
    FDR = delta.table[, 5]
    ii = 0
    for (i in o1) {
        o = abs(cutup - samr.obj$tt[i])
        o[is.na(o)] = LARGE
        oo = (1:length(o))[o == min(o)]
        oo = oo[length(oo)]
        ii = ii + 1
        qvalue.up[ii] = FDR[oo]
    }
    qvalue.lo = rep(NA, length(sig$plo))
    o2 = sig$plo
    cutlo = delta.table[, 7]
    ii = 0
    for (i in o2) {
        o = abs(cutlo - samr.obj$tt[i])
        o[is.na(o)] = LARGE
        oo = (1:length(o))[o == min(o)]
        oo = oo[length(oo)]
        ii = ii + 1
        qvalue.lo[ii] = FDR[oo]
    }
    qvalue.lo[is.na(qvalue.lo)] = 1
    qvalue.up[is.na(qvalue.up)] = 1
    o1 = order(samr.obj$tt[sig$plo])
    qv1 = qvalue.lo[o1]
    qv11 = qv1
    if (length(qv1) > 1) {
        for (i in 2:length(qv1)) {
            if (qv11[i] < qv11[i - 1]) {
                qv11[i] = qv11[i - 1]
            }
        }
        qv111 = qv11
        qv111[o1] = qv11
    }
    else {
        qv111 = qv1
    }
    o2 = order(samr.obj$tt[sig$pup])
    qv2 = qvalue.up[o2]
    qv22 = qv2
    if (length(qv2) > 1) {
        for (i in 2:length(qv2)) {
            if (qv22[i] > qv22[i - 1]) {
                qv22[i] = qv22[i - 1]
            }
        }
        qv222 = qv22
        qv222[o2] = qv22
    }
    else {
        qv222 = qv2
    }
    return(list(qvalue.lo = 100 * qv111, qvalue.up = 100 * qv222))
}

detec.slab <- function (samr.obj, del, min.foldchange) 
{
    n <- length(samr.obj$tt)
    tt <- samr.obj$tt
    evo <- samr.obj$evo
    numer <- samr.obj$tt * (samr.obj$sd + samr.obj$s0)
    tag <- order(tt)
    pup <- NULL
    foldchange.cond.up = rep(T, length(evo))
    foldchange.cond.lo = rep(T, length(evo))
    if (!is.null(samr.obj$foldchange[1]) & (min.foldchange > 
        0)) {
        foldchange.cond.up = samr.obj$foldchange >= min.foldchange
        foldchange.cond.lo = samr.obj$foldchange <= 1/min.foldchange
    }
    o1 <- (1:n)[(tt[tag] - evo > del) & evo > 0]
    if (length(o1) > 0) {
        o1 <- o1[1]
        o11 <- o1:n
        o111 <- rep(F, n)
        o111[tag][o11] <- T
        pup <- (1:n)[o111 & foldchange.cond.up]
    }
    plow <- NULL
    o2 <- (1:n)[(evo - tt[tag] > del) & evo < 0]
    if (length(o2) > 0) {
        o2 <- o2[length(o2)]
        o22 <- 1:o2
        o222 <- rep(F, n)
        o222[tag][o22] <- T
        plow <- (1:n)[o222 & foldchange.cond.lo]
    }
    return(list(plow = plow, pup = pup))
}

sumlengths <- function (aa) 
{
    length(aa$pl) + length(aa$pu)
}

est.s0 <- function (tt, sd, s0.perc = seq(0, 1, by = 0.05)) 
{
    br = unique(quantile(sd, seq(0, 1, len = 101)))
    nbr = length(br)
    a <- cut(sd, br, labels = F)
    a[is.na(a)] <- 1
    cv.sd <- rep(0, length(s0.perc))
    for (j in 1:length(s0.perc)) {
        w <- quantile(sd, s0.perc[j])
        w[j == 1] <- 0
        tt2 <- tt * sd/(sd + w)
        tt2[tt2 == Inf] = NA
        sds <- rep(0, nbr - 1)
        for (i in 1:(nbr - 1)) {
            sds[i] <- mad(tt2[a == i], na.rm = TRUE)
        }
        cv.sd[j] <- sqrt(var(sds))/mean(sds)
    }
    o = (1:length(s0.perc))[cv.sd == min(cv.sd)]
    s0.hat = quantile(sd[sd != 0], s0.perc[o])
    return(list(s0.perc = s0.perc, cv.sd = cv.sd, s0.hat = s0.hat))
}

getperms <- function (y, nperms) 
{
    total.perms = factorial(length(y))
    if (total.perms <= nperms) {
        perms = permute(1:length(y))
        all.perms.flag = 1
        nperms.act = total.perms
    }
    if (total.perms > nperms) {
        perms = matrix(NA, nrow = nperms, ncol = length(y))
        for (i in 1:nperms) {
            perms[i, ] = sample(1:length(y), size = length(y))
        }
        all.perms.flag = 0
        nperms.act = nperms
    }
    return(list(perms = perms, all.perms.flag = all.perms.flag, 
        nperms.act = nperms.act))
}

foldchange.twoclass <- function (x, y, logged2) 
{
    m1 <- rowMeans(x[, y == 1, drop = F])
    m2 <- rowMeans(x[, y == 2, drop = F])
    if (!logged2) {
        fc = m2/m1
    }
    if (logged2) {
        fc = 2^{
            m2 - m1
        }
    }
    return(fc)
}