###################################################
### chunk number 1: setup
###################################################
options(width=69)


###################################################
### chunk number 2: packages
###################################################
library(VanillaICE)


###################################################
### chunk number 3: data
###################################################
data(chromosome1)
annotation(chromosome1)
chromosome1


###################################################
### chunk number 4: plotSnp eval=FALSE
###################################################
## gp <- plot(chromosome1)
## show(gp)


###################################################
### chunk number 5: orderingSnps
###################################################
ann <- fData(chromosome1)[, c("chromosome", "position")]
ann[, "chromosome"] <- chromosome2integer(ann[, "chromosome"])
chromosome1 <- chromosome1[order(ann[, "chromosome"], ann[, "position"]), ]


###################################################
### chunk number 6: hiddenStates
###################################################
states <- c("homozygousDeletion", "hemizygousDeletion",
	    "normal", "LOH", "3copyAmp", "4copyAmp")
mu <- c(0.05, 1, 2, 2, 3, 4)


###################################################
### chunk number 7: uncertainty
###################################################
library(genefilter)
CT <- copyNumber(chromosome1)
sample.sd <- matrix(rowSds(t(log2(CT))), nrow(CT), ncol(CT))
##robustSD <- function(X) diff(quantile(X, probs=c(0.16, (1-0.16)), na.rm=TRUE))/2 
##sample.sd <- matrix(robustSD(log2(CT)), nrow(CT), ncol(CT))


###################################################
### chunk number 8: emission
###################################################
logCT <- array(log2(CT), dim=c(nrow(CT), ncol(CT), length(states)))
dimnames(logCT) <- list(rownames(CT), colnames(CT), states)
logMu <- aperm(array(log2(mu), dim=c(length(states), ncol(CT), nrow(CT))))
logSd <- aperm(array(sample.sd, dim=c(length(states), ncol(CT), nrow(CT))))
dimnames(logMu) <- dimnames(logSd) <- dimnames(logCT)
k <- which(!is.na(as.vector(logCT)))
emission.logCT <- dnorm(as.vector(logCT)[k], as.vector(logMu)[k], as.vector(logSd)[k])
emission.logCT <- array(emission.logCT, dim=dim(logCT))
logemission.logCT <- log(emission.logCT)


###################################################
### chunk number 9: copynumberEmission
###################################################
logemission.logCT2 <- copynumberEmission(copynumber=CT,
					 states=states,
					 mu=mu,
					 uncertainty=sample.sd,
					 takeLog=TRUE,
					 verbose=TRUE)
dimnames(logemission.logCT) <- dimnames(logemission.logCT2)
identical(logemission.logCT, logemission.logCT2)
rm(logemission.logCT2); gc()


###################################################
### chunk number 10: epsilon
###################################################
logemission.logCT[logemission.logCT < -10] <- -10


###################################################
### chunk number 11: genotypeEmission
###################################################
probs <- c(0.99, 0.9999, 0.99, 0.9999, 0.99, 0.99)
probMissing <- c(0.999, rep(0.01, 5))
names(probs) <- states
GT <- calls(chromosome1)
genotypeEmission <- function(genotypes, states, probHomCall, probMissing, verbose=TRUE){
	if(!is.numeric(genotypes)) stop("genotypes must be integers (1=AA, 2=AB, 3=BB, 4=missing")
	emissionForGenotypes <- function(probHomGenotype, genotypes){
		isHom <- which(as.vector(genotypes) == 1 | as.vector(genotypes) == 3)
		isHet <- which(as.vector(genotypes) == 2)
		isMissing <- which(as.vector(genotypes) == 4 | is.na(as.vector(genotypes)))
		emission.gt <- rep(NA, length(genotypes))
		emission.gt[isHom] <- probHomGenotype
		emission.gt[isHet] <- 1-probHomGenotype
		emission.gt[isMissing] <- NA
		emission.gt
	}
	emission.gt <- array(NA, dim=c(nrow(GT), ncol(GT), length(states)))
	for(j in 1:ncol(GT)){
		emission.gt[, j, ] <- sapply(probs, emissionForGenotypes, genotypes=GT[, j])
		if(any(is.na(emission.gt[, j, 1]))){
			missing <- is.na(emission.gt[, j, 1])			
			if(!missing(probMissing)){
				if(length(probMissing) != length(states)) stop("probMissing must be a numeric vector equal to the number of states")		
				emission.gt[missing, j, ] <- matrix(probMissing, sum(missing), length(states), byrow=TRUE)
			} else{
				if(verbose) message("Argument probMissing is not specified. Assume that missing genotype calls are independent of the underling hidden state")
				emission.gt[missing, j, ] <- 1
			}
		}
	}
	dimnames(emission.gt) <- list(rownames(genotypes), colnames(genotypes), states)
	return(suppressWarnings(log(emission.gt)))
}
logemission.gt <- genotypeEmission(genotypes=calls(chromosome1), states=states, probHomCall=probs)


###################################################
### chunk number 12: emission
###################################################
logemission <- logemission.gt + logemission.logCT


###################################################
### chunk number 13: transitionProb
###################################################
tau <- exp(-2 * diff(ann[, "position"])/(100*1e6))


###################################################
### chunk number 14: transitionProbabilityMatrix
###################################################
epsilon <- 1-tau[1]
M <- matrix(epsilon/(length(states)-1), length(states), length(states))
dimnames(M) <- list(states, states)
diag(M) <- tau[1]
all(rowSums(M) == 1)


###################################################
### chunk number 15: scaleTransitionProbs
###################################################
##Make it harder to transition to LOH
tau.scale <- matrix(1, length(states), length(states)) 
dimnames(tau.scale) <- list(states, states)
tau.scale["normal", "LOH"] <- 1e-4


###################################################
### chunk number 16: redistribute
###################################################
S <- length(states)
scale <- (S-1)/(S-2 + 1e-4)
tau.scale["normal", c("homozygousDeletion", "hemizygousDeletion", "3copyAmp", "4copyAmp")] <- scale
all(round(rowSums(M*tau.scale), 5) == 1)


###################################################
### chunk number 17: initialStateProb
###################################################
initialStateProb <- rep(1e-4, length(states))
initialStateProb[states=="normal"] <- 1-(length(states)-1)*1e-4


###################################################
### chunk number 18: fit
###################################################
fit <- viterbi(initialStateProbs=log(initialStateProb),
	       emission=logemission[, 1, ],
	       tau=tau)
fit2 <- viterbi(initialStateProbs=log(initialStateProb),
	       emission=logemission[, 1, ],
	       tau=tau,
	       tau.scale=tau.scale)


###################################################
### chunk number 19: breaks
###################################################
table(fit)
results <- findBreaks(x=fit, states=states, position=ann[, "position"],
		      chromosome=ann[, "chromosome"],
		      sample=colnames(CT))
results[results$state != "normal", ]


###################################################
### chunk number 20: createOligoSnpSet
###################################################
ann[, "chromosome"] <- integer2chromosome(ann[, "chromosome"])
fD <- new("AnnotatedDataFrame", data=ann, varMetadata=data.frame(labelDescription=colnames(ann)))
pD <- annotatedDataFrameFrom(CT, byrow=FALSE)
GT <- matrix(as.integer(GT), nrow(GT), ncol(GT))
dimnames(GT) <- dimnames(CT)
chromosome1 <- new("oligoSnpSet",
		   copyNumber=CT,
		   calls=GT,
		   featureData=fD,
		   phenoData=pD,
		   annotation="pd.mapping50kHind.240,pd.mapping50kXba.240")
validObject(chromosome1)


###################################################
### chunk number 21: HmmParameters
###################################################
options <- new("HmmOptions",
	       snpset=chromosome1,
	       states=states,
	       copyNumber.location=mu,
	       copyNumber.scale=sample.sd[1],
	       probHomCall=c(0.5, 0.999, 0.7, 0.999, 0.7, 0.7))
params <- new("HmmParameter", 
	      states=states(options),
	      initialStateProbability=0.999)
cn.emission <- copyNumber.emission(options)
gt.emission <- calls.emission(options)
emission(params) <- cn.emission + gt.emission ##log scale
genomicDistance(params) <- exp(-2 * diff(position(chromosome1))/(100*1e6))
transitionScale(params) <- matrix(1, length(states), length(states))
class(params)
hmmpredict <- hmm(options, params)
class(hmmpredict)
breaks <- findBreaks(predictions(hmmpredict), states=states, position=ann[, "position"],
		     chromosome=ann[, "chromosome"], sample=colnames(CT))


###################################################
### chunk number 22: vanillaPlot
###################################################
gp <- plot(snpset(options), hmmpredict)
gp$abline.v <- TRUE ##plots vertical dashed lines
allParameters <- unlist(snpPar(gp))
gp$col.predict[3] <- "white"
gp$hmm.ycoords <- c(0.7,0.9)
show(gp)


###################################################
### chunk number 23: params
###################################################
data(chromosome1)
range(cnConfidence(chromosome1))
options <- new("HmmOptions", 
	       snpset=chromosome1, 
	       states=c("D", "N", "L", "A"), 
	       copyNumber.location=c(1, 2, 2, 3),
	       copyNumber.ICE=TRUE,
	       probHomCall=c(0.99, 0.75, 0.99, 0.75))
params <- new("HmmParameter", 
	      states=states(options),
	      initialStateProbability=0.999)
cn.emission <- copyNumber.emission(options)
gt.emission <- calls.emission(options)
emission(params) <- cn.emission + gt.emission
genomicDistance(params) <- exp(-2*diff(position(chromosome1))/(100*1e6))
transitionScale(params) <- matrix(1, length(states(options)), length(states(options)))
fit.ice <- hmm(options, params)
calculateBreakpoints(fit.ice)


###################################################
### chunk number 24: params2 eval=FALSE
###################################################
## ##FIXME
## options <- new("HmmOptions", 
## 	       snpset=chromosome1, 
## 	       states=c("D", "N", "L", "A"), 
## 	       copyNumber.location=c(1, 2, 2, 3),
## 	       copyNumber.ICE=TRUE, 
## 	       calls.ICE=TRUE,
## 	       probHomCall=c(0.99, 0.75))
## params <- new("HmmParameter", 
## 	      states=states(options),
## 	      initialStateProbability=0.99)
## cn.emission <- copyNumber.emission(options)
## genomicDistance(params) <- exp(-2 * physicalDistance(options)/(100*1e6))
## transitionScale(params) <- scaleTransitionProbability(states(options))
## gt.emit <- calls.emission(options)
## gt.emission <- array(NA, dim(cn.emission))
## gt.emission[, , 1:2] <- gt.emit
## gt.emission[, , 3:4] <- gt.emit
## emission(params) <- cn.emission + gt.emission
## fit.ice <- hmm(options, params)


###################################################
### chunk number 25: icePlot
###################################################
##gp <- plot(snpset(options), fit.ice)
##gp$abline.v <- TRUE ##plots vertical dashed lines
##gp$col.predict[2] <- "white"
##show(gp)
gp <- plot(snpset(options), fit.ice)
gp$abline.v <- TRUE
gp$col.predict <- c("darkblue", "white", "yellow", "orange")
gp$hmm.coords
show(gp)
legend(-0.05, 10, fill=gp$col.predict[c(1, 3, 4)],
       legend=c("< 2 copies", "copy-neutral LOH", "> 2 copies"),
       bty="n", title="predicted states")
legend(0, 0.8, legend="predictions", bty="n", cex=0.8, adj=0)


###################################################
### chunk number 26: hmmParameters eval=FALSE
###################################################
## new("HmmParameter")


###################################################
### chunk number 27: 
###################################################
params[5, 1, ]


###################################################
### chunk number 28: tau.scale
###################################################
transitionScale(params)


###################################################
### chunk number 29:  eval=FALSE
###################################################
## ##FIXME
## transitionScale(params) <- scaleTransitionProbability(states(params), SCALE=10)
## transitionScale(params)


###################################################
### chunk number 30: hmmOutput
###################################################
fit.ice


###################################################
### chunk number 31: breaks
###################################################
breaks <- breakpoints(fit.ice)
predict <- predictions(fit.ice)
breaks <- findBreaks(x=predict, states=states(fit.ice),
		     position=position(fit.ice), 
		     chromosome=chromosome(fit.ice), sample=sampleNames(fit.ice))
breaks <- calculateBreakpoints(fit.ice)


###################################################
### chunk number 32: summary eval=FALSE
###################################################
## ##FIXME
## summary(fit.ice)


###################################################
### chunk number 33: copyNumberHmm
###################################################
chr1.cn <- as(chromosome1, "SnpCopyNumberSet")
options <- new("HmmOptions",
	       snpset=chr1.cn,
	       states=c("D", "N", "A"),
	       copyNumber.location=1:3)
params.cn <- new("HmmParameter",  
		 states=c("D", "N", "A"))
emission(params.cn) <- copyNumber.emission(options)
transitionScale(params.cn) <- scaleTransitionProbability(states=c("D", "N", "A"), normalLabel="N")
genomicDistance(params.cn) <- exp(-2*physicalDistance(options)/(100*1e6))
fit.cn <- hmm(options, params.cn)
breakpoints(fit.cn)
graph.par <- plot(snpset(options), fit.cn)
graph.par$abline.v <- FALSE


###################################################
### chunk number 34: copyNumberFigure
###################################################
print(graph.par)
legend(0, 0.8, fill=graph.par$col.predict[c(1, 3)], 
       legend=c("< 2 copes", "> 2 copies"),
       bty="n", cex=0.8)


###################################################
### chunk number 35: 
###################################################
rm(chr1.cn, fit.cn, params.cn)


###################################################
### chunk number 36: chr1Calls
###################################################
chr1.calls <- as(chromosome1, "SnpCallSet")
options.calls <- new("HmmOptions",
	       snpset=chr1.calls,
	       states=c("L", "N"),
	       probHomCall=c(0.99, 0.7))
params.calls <- new("HmmParameter", 
		    states=states(options.calls))
transitionScale(params.calls) <- scaleTransitionProbability(states(options.calls))
genomicDistance(params.calls) <- exp(-2*physicalDistance(options.calls)/(100*1e6))
emission(params.calls) <- calls.emission(options.calls)
fit.calls <- hmm(options.calls, params.calls)
breakpoints(fit.calls)
gp <- plot(snpset(options.calls), fit.calls)
gp$col.predict <- c("black", "white")
gp$ylim <- c(-0.5, 1)
gp$add.centromere <- FALSE
gp$abline.v <- TRUE
gp$cytoband.ycoords <- c(-0.45, -0.4)
gp$hmm.ycoords <- c(-0.2, -0.05)


###################################################
### chunk number 37: callsFigure
###################################################
print(gp)
legend(0, -0.1, legend="LOH", fill="black", 
       title="predictions", bty="o", cex=0.8)


###################################################
### chunk number 38: 
###################################################
toLatex(sessionInfo())


