#Implementation of the BMIX test for a single marker
#Daniel Shriner
#July 28,2011

#y is the vector of phenotypes
#localanc is the vector of local ancestry estimates at a marker
#globalanc is the vector of global ancestry estimates at a marker
#geno is the vector of recoded genotypes at a marker

posterior <- function(x,prior,lambda) {(dchisq(x,1,lambda)*prior)/((dchisq(x,1,lambda)*prior)+(dchisq(x,1,0)*(1-prior)))}
admixture_burden <- 368.8 #for the HUFS data
association_burden <- 345450.3 #for the HUFS data

result <- summary(glm(y~localanc+globalanc,family=gaussian))
admixture_p <- result$coefficients[2,4]
admixture_lambda <- (qnorm(1-0.05/admixture_burden/2)+qnorm(0.8))^2
admixture_prior <- 1/admixture_burden
admixture_test <- qchisq(admixture_p,1,0,lower.tail=FALSE)
admixture_posterior <- posterior(x=admixture_test,prior=admixture_prior,lambda=admixture_lambda)

#stratified association testing
group0 <- which(localanc==0)
if ((is.element(0,geno[group0]) & is.element(1,geno[group0])) | (is.element(1,geno[group0]) & is.element(2,geno[group0])) | (is.element(0,geno[group0]) & is.element(2,geno[group0]))) {
	result <- summary(glm(y[group0]~geno[group0]+globalanc[group0],family=gaussian))
	tmp1 <- result$coefficients[2,1]
	tmp2 <- result$coefficients[2,2]
} else {
	tmp1 <- NA
	tmp2 <- NA
}
group1 <- which(localanc==1)
if ((is.element(0,geno[group1]) & is.element(1,geno[group1])) | (is.element(1,geno[group1]) & is.element(2,geno[group1])) | (is.element(0,geno[group1]) & is.element(2,geno[group1]))) {
	result <- summary(glm(y[group1]~geno[group1]+globalanc[group1],family=gaussian))
	tmp3 <- result$coefficients[2,1]
	tmp4 <- result$coefficients[2,2]
} else {
	tmp3 <- NA
	tmp4 <- NA
}
group2 <- which(localanc==2)
if ((is.element(0,geno[group2]) & is.element(1,geno[group2])) | (is.element(1,geno[group2]) & is.element(2,geno[group2])) | (is.element(0,geno[group2]) & is.element(2,geno[group2]))) {
	result <- summary(glm(y[group2]~geno[group2]+globalanc[group2],family=gaussian))
	tmp5 <- result$coefficients[2,1]
	tmp6 <- result$coefficients[2,2]
} else {
	tmp5 <- NA
	tmp6 <- NA
}

#inverse variance-weighted fixed effects
pooled.pval <- NA
if (!any(is.na(c(tmp1,tmp2,tmp3,tmp4,tmp5,tmp6)))) {
	pooled.beta <- ((tmp1/(tmp2^2))+(tmp3/(tmp4^2))+(tmp5/(tmp6^2)))/(1/(tmp2^2)+1/(tmp4^2)+1/(tmp6^2))
	pooled.se <- sqrt(1/(1/(tmp2^2)+1/(tmp4^2)+1/(tmp6^2)))
	pooled.pval <- 2*(1-pnorm(abs(pooled.beta/pooled.se)))
}
if (!is.na(tmp1) && !is.na(tmp2) && !is.na(tmp3) && !is.na(tmp4) && is.na(tmp5) && is.na(tmp6)) {
	pooled.beta <- ((tmp1/(tmp2^2))+(tmp3/(tmp4^2)))/(1/(tmp2^2)+1/(tmp4^2))
	pooled.se <- sqrt(1/(1/(tmp2^2)+1/(tmp4^2)))
	pooled.pval <- 2*(1-pnorm(abs(pooled.beta/pooled.se)))
}
if (!is.na(tmp1) && !is.na(tmp2) && is.na(tmp3) && is.na(tmp4) && !is.na(tmp5) && !is.na(tmp6)) {
	pooled.beta <- ((tmp1/(tmp2^2))+(tmp5/(tmp6^2)))/(1/(tmp2^2)+1/(tmp6^2))
	pooled.se <- sqrt(1/(1/(tmp2^2)+1/(tmp6^2)))
	pooled.pval <- 2*(1-pnorm(abs(pooled.beta/pooled.se)))
}
if (is.na(tmp1) && is.na(tmp2) && !is.na(tmp3) && !is.na(tmp4) && !is.na(tmp5) && !is.na(tmp6)) {
	pooled.beta <- ((tmp3/(tmp4^2))+(tmp5/(tmp6^2)))/(1/(tmp4^2)+1/(tmp6^2))
	pooled.se <- sqrt(1/(1/(tmp4^2)+1/(tmp6^2)))
	pooled.pval <- 2*(1-pnorm(abs(pooled.beta/pooled.se)))
}
if (!is.na(tmp1) && !is.na(tmp2) && is.na(tmp3) && is.na(tmp4) && is.na(tmp5) && is.na(tmp6)) {
	pooled.beta <- tmp1
	pooled.se <- tmp2
	pooled.pval <- 2*(1-pnorm(abs(pooled.beta/pooled.se)))
}
if (is.na(tmp1) && is.na(tmp2) && !is.na(tmp3) && !is.na(tmp4) && is.na(tmp5) && is.na(tmp6)) {
	pooled.beta <- tmp3
	pooled.se <- tmp4
	pooled.pval <- 2*(1-pnorm(abs(pooled.beta/pooled.se)))
}
if (is.na(tmp1) && is.na(tmp2) && is.na(tmp3) && is.na(tmp4) && !is.na(tmp5) && !is.na(tmp6)) {
	pooled.beta <- tmp5
	pooled.se <- tmp6
	pooled.pval <- 2*(1-pnorm(abs(pooled.beta/pooled.se)))
}

if (!is.na(pooled.pval)) {
	association_lambda <- (qnorm(1-0.05/association_burden/2)+qnorm(0.8))^2
	association_test <- qchisq(pooled.pval,1,0,lower.tail=FALSE)
	joint_posterior <- posterior(x=association_test,prior=admixture_posterior,lambda=association_lambda)
} else {
	joint_posterior <- NA
}