.packageName <- "lapmix"
lap.volcanoplot <- function(res, highlight=0, ...)
{
	M <- res$M
	odds <- res$lap.lods
	plot(M, odds, xlab='average log fold change', ylab='log posterior odds', pch=16, cex=0.8, ...)
	if(highlight > 0)
	{
		table <- laptopTable(res, number=highlight)
		points(table$M, table$log.odds, pch=3, col='red')
	}
	invisible()
}
lapmix.Fit <- function(Y, asym=FALSE, fast=TRUE, two.step=TRUE, w=0.1, V=10, beta=0, gamma=1, alpha=0.1)
{
	if(is(Y,"ExpressionSet"))
		Y <- exprs(Y)
	if(is.matrix(Y))
	{
		n_vect <- apply(!is.nan(Y), 1, sum)
		y_bar <- apply(Y, 1, mean, na.rm=TRUE)
		s_sq <- apply(Y, 1, var, na.rm=TRUE)
		sum_sq <- apply(Y^2, 1, sum, na.rm=TRUE)		
	}
	else if(is.list(Y))
	{
		G <- length(Y)
		y_bar <- NULL
		sum_sq <- NULL
		s_sq <- NULL
		n_vect <- NULL
		for(g in 1:G)
		{
			if(sum(is.nan(Y[[g]])))
				stop('No NaN allowed when data is stored in a list')
			s_sq <- c(s_sq, var(Y[[g]]))
			n_vect <- c(n_vect, length(Y[[g]]))
			y_bar <- c(y_bar, mean(Y[[g]]))
			sum_sq <- c(sum_sq, sum(Y[[g]]^2))
		}
	}
	opt <- lap.maxlike(y_bar=y_bar, s_sq=s_sq, sum_sq=sum_sq, n_vect=n_vect, asym=asym, fast=fast, two.step=two.step, w=w, V=V, beta=beta, gamma=gamma, alpha=alpha)
	estimates <- NULL
	estimates$w <- opt$w
	estimates$V <- opt$V
	estimates$beta <- opt$beta
	estimates$gamma <- opt$gamma
	estimates$alpha <- opt$alpha
	diff <- post_odds(w=estimates$w, V=estimates$V, beta=estimates$beta, gamma=estimates$gamma, alpha=estimates$alpha, y_bar=y_bar, s_sq=s_sq, sum_sq=sum_sq, n_vect=n_vect)
	list(lap.lods=log(diff$odds), prob=diff$prob, med.number=diff$med.number, estimates=estimates, code=opt$code, M=y_bar, s_sq=s_sq, nb.rep=n_vect)
}
laptopTable <- function(res, number=res$med.number, sort.by='L')
{
	lap.lods <- res$lap.lods
	prob <- res$prob
	nondiff_prob <- 1-prob
	Im <- res$Im
	Ip <- res$Ip
	V <- res$estimates$V
	w <- res$estimates$w
	gamma <- res$estimates$gamma
	alpha <- res$estimates$alpha
	if(number <= 0)
		stop('Number of displayed genes must be a positive integer!')
	if(sort.by == 'L')
	{
		ix <- sort(lap.lods, decreasing=TRUE, index.return=TRUE)$ix
		diff.genes <- ix[1:number]
	}
	else if(sort.by == 'M')
	{
		ix <- sort(res$M, decreasing=TRUE, index.return=TRUE)$ix
		diff.genes <- ix[1:number]	
	}
	else
		stop('invalid value given to argument sort.by')
	table <- data.frame(gene=diff.genes, M=res$M[diff.genes], log.odds=lap.lods[diff.genes], row.names=NULL)
	table
}

lap.maxlike <- function(y_bar, s_sq, sum_sq, n_vect, w=0.1, V=10, beta=0, gamma=1, alpha=0.1, asym=FALSE, fast=!asym, two.step=TRUE)
{
	out <- list(NULL)
	if(two.step)
	{
		res1 <- nlm(var.loglike, p=c(log(gamma), log(alpha)), s_sq=s_sq, n_vect=n_vect)
		phi_hat <- exp(res1$estimate)
		if(res1$code >= 4)
			print('convergence failed in fisrt stage of hyperparameter estimation')
		if(!asym)
		{
			res <- nlm(marginal.loglike, p=c(log(w/(1-w)), log(V)), phi_hat=phi_hat, y_bar=y_bar, s_sq=s_sq, sum_sq=sum_sq, n_vect=n_vect, fast=fast)
			l_Sigma_hat <- res$estimate
			if(res$code >= 4)
				print('convergence failed in second stage of hyperparameter estimation')
			out <- list(w=exp(l_Sigma_hat[1])/(1+exp(l_Sigma_hat[1])), V=exp(l_Sigma_hat[2]), beta=0, gamma=phi_hat[1], alpha=phi_hat[2], code=c(res1$code, res$code))
		}
		else
		{
			res <- nlm(marginal.loglike, p=c(log(w/(1-w)), log(V), log((1+beta)/(1-beta))), phi_hat=phi_hat, y_bar=y_bar, s_sq=s_sq, sum_sq=sum_sq, n_vect=n_vect, fast=fast)
			l_Sigma_hat <- res$estimate
			if(res$code >= 4)
				print('convergence failed in second stage of hyperparameter estimation')
			out <- list(w=exp(l_Sigma_hat[1])/(1+exp(l_Sigma_hat[1])), V=exp(l_Sigma_hat[2]), beta=2*exp(l_Sigma_hat[3])/(1+exp(l_Sigma_hat[3]))-1, gamma=phi_hat[1], alpha=phi_hat[2], code=c(res1$code, res$code))
		}
	}
	else
	{
		if(!asym)
		{
			res <- nlm(marginal.loglike, p=c(log(w/(1-w)), log(V), log(gamma), log(alpha)), y_bar=y_bar, s_sq=s_sq, sum_sq=sum_sq, n_vect=n_vect, fast=fast)
			l_Sigma_hat <- res$estimate
			if(res$code >= 4)
				print('convergence failed in hyperparameter estimation')
			out <- list(w=exp(l_Sigma_hat[1])/(1+exp(l_Sigma_hat[1])), V=exp(l_Sigma_hat[2]), beta=0, gamma=exp(l_Sigma_hat[3]), alpha=exp(l_Sigma_hat[4]), code=res$code)
		}
		else
		{
			res <- nlm(marginal.loglike, p=c(log(w/(1-w)), log(V), log((1+beta)/(1-beta)), log(gamma), log(alpha)), y_bar=y_bar, s_sq=s_sq, sum_sq=sum_sq, n_vect=n_vect, fast=fast)
			l_Sigma_hat <- res$estimate
			if(res$code >= 4)
				print('convergence failed in hyperparameter estimation')
			out <- list(w=exp(l_Sigma_hat[1])/(1+exp(l_Sigma_hat[1])), V=exp(l_Sigma_hat[2]), beta=2*exp(l_Sigma_hat[3])/(1+exp(l_Sigma_hat[3]))-1, gamma=exp(l_Sigma_hat[4]), alpha=exp(l_Sigma_hat[5]), code=res$code)
		}
	}
	out
}

var.loglike <- function(l_phi, s_sq, n_vect)
{
	gamma <- exp(l_phi[1])
	alpha <- exp(l_phi[2])
	if(gamma < 10e-20)
		loglike <- Inf
	else
		loglike <- -sum(log(alpha*gamma*df(alpha*gamma*s_sq, df1=n_vect-1, df2=2*gamma)))
	loglike
}

marginal.loglike <- function(l_Sigma, phi_hat=NULL, y_bar, s_sq, sum_sq, n_vect, fast=TRUE)
{
	full <- FALSE
	if(length(l_Sigma) == 2)   ## symmetric model,  fixed gamma and alpha
	{	
		w <- exp(l_Sigma[1])/(1+exp(l_Sigma[1]))
		V <- exp(l_Sigma[2])
		beta <- 0
		gamma <- phi_hat[1]
		alpha <- phi_hat[2]
	}
	else if(length(l_Sigma) == 3)  ## asymmetric model,  fixed gamma and alpha
	{
		w <- exp(l_Sigma[1])/(1+exp(l_Sigma[1]))
		V <- exp(l_Sigma[2])
		beta <- 2*exp(l_Sigma[3])/(1+exp(l_Sigma[3]))-1
		gamma <- phi_hat[1]
		alpha <- phi_hat[2]
	}
	else if(length(l_Sigma) == 4)  ## symmetric model
	{
		w <- exp(l_Sigma[1])/(1+exp(l_Sigma[1]))
		V <- exp(l_Sigma[2])
		beta <- 0
		gamma <- exp(l_Sigma[3])
		alpha <- exp(l_Sigma[4])
		full <- TRUE
	}
	else if(length(l_Sigma) == 5)  ## asymmetric model
	{
		w <- exp(l_Sigma[1])/(1+exp(l_Sigma[1]))
		V <- exp(l_Sigma[2])
		beta <- 2*exp(l_Sigma[3])/(1+exp(l_Sigma[3]))-1
		gamma <- exp(l_Sigma[4])
		alpha <- exp(l_Sigma[5])
		full <- TRUE
	}
	nu <- 2*gamma+n_vect+1
	Vp <- V*(1+beta)
	Vm <- V*(1-beta)
	Bp <- y_bar-1/(Vp*n_vect)
	Bm <- y_bar+1/(Vm*n_vect)
	Cp <- ((n_vect-1)*s_sq+2*y_bar/Vp-1/(n_vect*Vp^2)+2/alpha)/n_vect
	Cm <- ((n_vect-1)*s_sq-2*y_bar/Vm-1/(n_vect*Vm^2)+2/alpha)/n_vect
	Dp <- sqrt(abs(nu/Cp))
	Dm <- sqrt(abs(nu/Cm))
	E <- sqrt(nu*pi)*gamma(nu/2)/gamma((nu+1)/2)
	Ip <- E*(Cp*n_vect/2)^(-(nu+1)/2)*pt(Dp*Bp, df=nu)/Dp
	Im <- E*(Cm*n_vect/2)^(-(nu+1)/2)*pt(-Dm*Bm, df=nu)/Dm
	negp <- which(Cp < 0)
	negm <- which(Cm < 0)
	if(fast)
	{
		Ip[negp] <- 0
		Im[negm] <- 0
	}
	else
	{
		for(i in negp)
			Ip[i] <- integrate(integrand, y_bar=y_bar[i], s_sq=s_sq[i], n=n_vect[i], V=Vp, gamma=gamma, alpha=alpha, lower=0, upper=Inf)$value
		for(i in negm)
			Im[i] <- integrate(integrand, y_bar=y_bar[i], s_sq=s_sq[i], n=n_vect[i], V=Vm, gamma=gamma, alpha=alpha, lower=-Inf, upper=0)$value
	}
	if(!full)
		loglike <- -mean(log((w/(2*V))*gamma((nu+1)/2)*(Im+Ip)+(1-w)*gamma((nu-1)/2)*(sum_sq/2+1/alpha)^(-(nu-1)/2)))
	else
		loglike <- -mean(log((w/(2*V))*gamma((nu+1)/2)*(Im+Ip)+(1-w)*gamma((nu-1)/2)*(sum_sq/2+1/alpha)^(-(nu-1)/2))-log(alpha^gamma*gamma(gamma)))
	loglike
}

integrand <- function(mu, y_bar, s_sq, n, V, gamma, alpha)
{
(((n-1)*s_sq+n*(y_bar-mu)^2)/2+1/alpha+abs(mu)/V)^(-gamma-n/2-1)
}
post_odds <- function(w, V, beta, gamma, alpha, y_bar, s_sq, sum_sq, n_vect)
{
	G <- length(n_vect)
	nu <- n_vect+2*gamma+1
	Vp <- V*(1+beta)
	Vm <- V*(1-beta)
	Bp <- y_bar-1/(Vp*n_vect)
	Bm <- y_bar+1/(Vm*n_vect)
	Cp <- ((n_vect-1)*s_sq+2*y_bar/Vp-1/(n_vect*Vp^2)+2/alpha)/n_vect
	Cm <- ((n_vect-1)*s_sq-2*y_bar/Vm-1/(n_vect*Vm^2)+2/alpha)/n_vect
	Dp <- sqrt(abs(nu/Cp))
	Dm <- sqrt(abs(nu/Cm))
	negp <- which(Cp<0)
	negm <- which(Cm<0)
	E <- sqrt(nu*pi)*(gamma(nu/2)/gamma((nu+1)/2))*(n_vect/2)^(-(nu+1)/2)
	Ip <- E*(Cp^(-(nu+1)/2)*pt(Dp*Bp, df=nu)/Dp)
	Im <- E*(Cm^(-(nu+1)/2)*pt(-Dm*Bm, df=nu)/Dm)
	for(i in negp)
		Ip[i] <- integrate(integrand, y_bar=y_bar[i], s_sq=s_sq[i], n=n_vect[i], V=Vp, gamma=gamma, alpha=alpha, lower=0, upper=Inf)$value
	for(i in negm)
		Im[i] <- integrate(integrand, y_bar=y_bar[i], s_sq=s_sq[i], n=n_vect[i], V=Vm, gamma=gamma, alpha=alpha, lower=-Inf, upper=0)$value
	odds <- w*((nu-1)/2)*(Ip+Im)*(sum_sq/2+1/alpha)^((nu-1)/2)/((1-w)*2*V)
	prob <- odds/(1+odds)
	l_threshold <- Im*(Im+Ip+2*V*(2*(1-w)/(w*(nu-1)))*(sum_sq/2+1/alpha)^(-(nu-1)/2))^(-1)
	h_threshold <- l_threshold+1-prob
	med.number <- sum(!((l_threshold<1/2)*(h_threshold>1/2)))
	list(odds=odds, prob=prob, med.number=med.number)
}
