.packageName <- "HighProbability"
# HighProbability, Copyright (c) 2004 by David R. Bickel. All rights reserved.
# Last modified by David R. Bickel on 3/23/04.
# Created by David R. Bickel on 2/21/04.
# HighProbability is pure S, and has been tested with both R and S-PLUS.
# In publications and web sites that use HighProbability, please cite 'Bickel, D. R. (2004) "HighProbability determines which alternative hypotheses are highly probable: Genomic applications include detection of differential gene expression," arXiv.org e-print ID q-bio.QM/0402049, http://arxiv.org/abs/q-bio.QM/0402049'
# Related articles and any updates are available through www.davidbickel.com .

# The contents of these files are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use these files except in compliance with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/
# Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the specific language governing rights and limitations under the License.

alternative.beneficial <- function(p.values, cost.to.benefit = 1, marginal.probability = NULL, plot.relative.gain = FALSE)
# Returns a boolean vector of length equal to the length of p.values, indicating whether each alternative hypothesis is beneficially considered true, i.e., whether its acceptance is optimal given the cost.to.benefit ratio.
{
  if(!is.finite(cost.to.benefit) || length(cost.to.benefit) != 1 || cost.to.benefit <= 0) stop('cost.to.benefit must be a number greater than 0')
  min.probability <- 1 - 1 / (1 + cost.to.benefit)
  cat(paste('Calling alternative.probable with min.probability =', min.probability), '\n')
  alternative.probable(p.values = p.values, min.probability = min.probability, marginal.probability = marginal.probability, plot.relative.gain = plot.relative.gain)
}

alternative.probable <- function(p.values, min.probability = 0.5, marginal.probability = NULL, plot.relative.gain = FALSE)
# Returns a boolean vector of length equal to the length of p.values, indicating whether each alternative hypothesis is probable, i.e., whether it has a probability (conditional on the p.value) of at least min.probability. marginal.probability is a lower bound on the marginal probability that an alternative hypothesis is true; the default of 0 is conservative.
{
  if(!is.numeric(marginal.probability)) 
  {
	 ap0 <- alternative.probable(p.values = p.values, min.probability = 0.5, marginal.probability = 0, plot.relative.gain = FALSE)
	 pi1 <- sum(ap0) / length(ap0)
	 cat('Using marginal.probability estimate of', pi1, '\n')
	 return(alternative.probable(p.values = p.values, min.probability = min.probability, marginal.probability = pi1, plot.relative.gain = plot.relative.gain))
  }
  if(!is.vector(p.values) || !is.numeric(p.values)) stop('p.values should be a numeric vector')
  if(length(min.probability) != 1 || !is.finite(min.probability)) stop('min.probability should be a single number')
  if(length(marginal.probability) != 1 || !is.finite(marginal.probability)) stop('marginal.probability should be a single number')
  is.probability <- function(prob){is.finite(prob) & prob >= 0 & prob <= 1}
  pvals <- ifelse(is.na(p.values), 1, p.values)
  if(!all(is.probability(pvals))) stop('Each element of p.values must be between 0 and 1')
  if(!is.probability(min.probability)) stop('min.probability must be between 0 and 1')
  if(min.probability >= 1) stop('min.probability must be less than 1')
  if(!is.probability(marginal.probability)) stop('marginal.probability must be between 0 and 1')
  
  p <- 1 - min.probability
  pi0 <- 1 - marginal.probability
  alphas <- unique(pvals) # significance levels (Type I error rates)
  
  relative.gain <- function(.alpha, .pvals, .pi0, .p)
  {
    nrejections <- function(.alpha, .pvals)
    {
		apply(reject.null(.pval = .pvals, .alpha = .alpha), 2, sum)
    }
    nrej <- nrejections(.pvals = .pvals, .alpha = .alpha)

    dFDR <- function(.alpha, .pvals, .pi0, .nrej)
	 # estimate of the decisive false discovery rate
    {
      if(length(.alpha) != length(.nrej)) stop('Please report .alpha-.nrej error to www.davidbicke.com')
      dfdr <- ifelse(.nrej > 0, .pi0 * .alpha / (.nrej / length(.pvals)), 0)
      if(any(!is.finite(dfdr) | dfdr < 0)) stop('Please report dFDR error to www.davidbickel.com')
      ifelse(dfdr <= 1, dfdr, 1)
    }

    .dFDR <- dFDR(.pvals = .pvals, .alpha = .alpha, .pi0 = .pi0, .nrej = nrej)
    nrej * (1 - .dFDR / .p) # nrej * (1 - (.pi0 * .alpha * length(.pvals) / nrej) / .p) == nrej - length(.pvals) * .pi0 * .alpha / .p
  }
  gains <- relative.gain(.alpha = alphas, .pvals = pvals, .pi0 = pi0, .p = p)
  if(!all(is.finite(alphas) & is.finite(gains))) {print('Likely error. Type c to continue or Q to quit.'); browser()}
  max.gain <- max(gains)
  if(plot.relative.gain) plot(alphas, gains, xlab = 'test-wise Type I error', ylab = paste('relative gain (max==', max.gain, ')'))
  if(length(alphas) != length(gains)) stop('Please report alphas-gains error to www.davidbickel.com')
  optimal.alphas <- alphas[max.gain == gains & gains > 0]
  optimal.alpha <- if(length(optimal.alphas) > 0) max(optimal.alphas) else -Inf
  if(optimal.alpha >= 0 && optimal.alpha != min(optimal.alphas)) warning('More than one significance level is optimal.')
  reject.null(.pval = pvals, .alpha = optimal.alpha)
}

reject.null <- function(.alpha, .pval) # For internal use only.
# Return value is a matrix (.pval by rows and .alpha by columns), simplified to a vector if length(.alpha) == 1.
{
	if(length(.alpha) > 1)
	{
		ncol <- length(.alpha)
		boo <- matrix(logical(ncol * length(.pval)), ncol = ncol)
		for(j in 1:length(.alpha))
			boo[, j] <- reject.null(.alpha = .alpha[j], .pval = .pval)
		boo
	}
	else
		.pval <= .alpha
}

