#
# Tool selection to translate FACS population data into microscopy data
#
# The main purpose of this tool selection is the calibration of FACS to microscopy data.
# A sample function to combine the calibration with a mathematical model is also included.
#
# The usage of this script is as follows:
#
# First source the file:
# > source("populist.R")
#
# Creat populist object
# > mypopulist <- populist("config.csv")
#
# Calibrate 
# > mycalibration <- calibration.multidox(mypopulist)
#
# Translate a FACS measurement into a microscopy measurement
# > myevaluation <- evaluate.data(mycalibration, mypopulist, 1)
# where 1 refers to the number of the measurement dataset. Suppose you have
# four data sets defined in config.csv then the data sets are labeled by running
# numbers from 1 to 4.
#
# Graphical representation of the computed microscopy intensities
# > hist(myevaluation[[1]])
#
# Graphics representation of the computed microscopy volumes
# > hist(myevaluation[[2]])
#
# IMPORTANT NOTE: THE CODE ASSUMES THAT THE FACS VOLUME CHANNEL
# REPRESENTS SECTION AREAS RATHER THAN VOLUMES. IF YOU ALREADY
# TRANSFORMED YOUR FACS DATA MAKE SURE YOU DELETE THE FACTORS 
# 3/2, 0.66, 2/3 AND SO ON IN THE CODE.




library(gplots)
library(gdata)
library(coda)


#
# calibration.multidox
#
# Calibrate FACS data versus microscopy data. Put together all doxes
#
# Input: populist object, edges where to cut FACS data (see cutfacs())
# Output: Fit objects for intensities and volumes.
#	Write penalized chisquares of optimize()-function into file




calibration.multidox <- function(mypopulist, edges = c(0,0), ...) {
	doxes <- unique(mypopulist$Calibration$Dox)

	AllFits <- list()
	pdf("multidox_calibration.pdf")
	
	for (i in 1:length(doxes)) {
		
		producedata(mypopulist, doxes[i])

		cutfacs(edges)

		margins <- plot.function(200*c(1:60), optimize, type="l", lty=1, xlab = "cut position", ylab = "residual squares sum")
		chisquares <- c()
		for (m in 200*c(1:60)) {
			chisquares <- cbind(chisquares, optimize(m))
		}
		smartlegend(x = "left", y = "top", c("Intensity", "Size"), col = c(1,2), lty = 1)
		print(margins)
		datas <- list(sort(facsI)[-c(1:margins[1])], sort(facsV)[-c(1:margins[2])], sort(log(microI)), sort((microV)^0.66))

		AllFits[[i]] <- quantilefit(datas)
	      
      }
      write.csv(t(rbind(200*c(1:60), chisquares)), "multidox_chisquares.csv")
      dev.off()
      return(AllFits)

}


#
# evaluate.data
#
# Translate a FACS dataset into a microscopy data set using the calibration
#
# Input: Calibration object, Populist object, nr = which of the files in the config file
#	should be evaluated, edges = where to cut FACS data.
# Output: list of Microscopy Intensities, Microscopy Volumes, Populist object, nr.


evaluate.data <- function(mycalibration, mypopulist, nr, edges = c(0,0)) {

      data <- mypopulist$Measurement[nr,]
      facsdata <- read.table(as.character(data$File), head=TRUE)
      facsI <- as.character(data$Intensity)
      facsV <- as.character(data$Volume)
      dox <- data$Dox
      nr2 <- which(dox %in% unique(mypopulist$Calibration$Dox))

      facsI <<- facsdata[,facsI]
      facsG <<- facsdata[,"F1"]
      facsV <<- facsdata[,facsV]

      myfacslist <- cutfacs(edges)

      facsV <- myfacslist[[1]]
      facsG <- myfacslist[[2]]
      facsI <- myfacslist[[3]]

      mI <- coefficients(mycalibration[[nr2]][[1]][[1]])[2]
      cI<- coefficients(mycalibration[[nr2]][[1]][[1]])[1]
      print(cI)
      mV<- coefficients(mycalibration[[nr2]][[1]][[2]])[2]
      cV<- coefficients(mycalibration[[nr2]][[1]][[2]])[1]

      microI <- (facsI - cI)/mI
      microI <- exp(microI)

      microV <- (facsV - cV)/mV
      microV <- microV^(3/2)

      pdf(paste("evaluate_data_nr", nr, ".pdf", sep=""))
      hist(microI, breaks=50, xlab = "Calculated Microscopy Intensities", main=as.character(data$File))
      hist(microV, breaks=50, xlab = "Calculated Microscopy Volumes [fl]", main=as.character(data$File))
      dev.off()

      return(list(microI, microV, mypopulist, nr))
      

}



#
# compute_currents
#
# Compute currents for STAT5 import/export model using the intensity and volume distributions
#
# Input: Evaluation object, config file with fit parameters for the import/export model, boolean graphics
#	if pdf output should be produced
# Output: List of concentrations and currents

compute_currents <- function(myevaluation, config, graphics = FALSE) {

	myconfig <- read.table(config, head=TRUE)
	fv <- myconfig$V_cyt.V_nuc
	fc <- myconfig$c_cyt.c_nuc
	b1imp <- myconfig$b1imp
	b2imp <- myconfig$b2imp
	b1exp <- myconfig$b1exp
	b2exp <- myconfig$b2exp
 	limp <- as.character(myconfig$NormImp)
	lexp <- as.character(myconfig$NormExp)

	Vnuc <- myevaluation[[2]]/(fv+1)
	Vcyt <- myevaluation[[2]]-Vnuc
	# Umrechnung Anzahl (10^6 Moleküle pro Zelle) in Konzentration (µMol/l) 
	cnuc <- ((1e27*myevaluation[[1]])/6.022e23)/(Vnuc + Vcyt*fc)
	ccyt <- fc * cnuc
	A <- 4*pi*(3*Vnuc/(4*pi))^(2/3)
	
	
	Iimp <- eval(parse(text=limp)) * b1imp*ccyt/(b2imp+ccyt)
	Iexp <- eval(parse(text=lexp)) * b1exp*cnuc/(b2exp+cnuc)

	if (graphics) {
		Measurement <- myevaluation[[3]]$Measurement[myevaluation[[4]],]
		Dox <- Measurement$Dox
		Filename <- Measurement$File
		pdf(paste("Currents_", Dox , ".pdf", sep=""))
		hist(Iimp, xlab = "Import current [µMol/s]", main = paste("Dox", Dox))
		hist(Iexp, xlab = "Export current [µMol/s]", main = paste("Dox", Dox))

		dev.off()
	}

	

	return(list(ccyt, cnuc,Iimp, Iexp))



}




#
# populist
#
# Input: configuration file, further options for read.table(()
# Output: list of data.frames for calibration and measurement

populist <- function(Configfile, ...) {

      data <- read.table(Configfile, header=TRUE)
      
      return(list(Calibration = subset(data, Purpose=="Calibration"), Measurement = subset(data, Purpose == "Measurement")))

}


#
# producedata
#
# Create global variables containg all microscopy and FACS data for a given dox
#
# Input: Populist object, dox value
# Output: datas and dox



producedata <- function(mypopulist, dox, ...) {

      # Read from config file
      facsconfig <- subset(mypopulist$Calibration, mypopulist$Calibration$Method == "FACS" & mypopulist$Calibration$Dox == dox)
      microconfig <- subset(mypopulist$Calibration, mypopulist$Calibration$Method == "Microscopy" & mypopulist$Calibration$Dox == dox)

      # Read the data files
      facsdata <<- read.table(as.character(facsconfig$File), header=TRUE, ...)
      microdata <<- read.table(as.character(microconfig$File), header = TRUE, ...)

      # Get names for chanels
      facsI <- as.character(facsconfig$Intensity)
      facsV <- as.character(facsconfig$Volume)
      microI <- as.character(microconfig$Intensity)
      microV <- as.character(microconfig$Volume)

      facsI <<- (facsdata[,facsI])
      facsV <<- (facsdata[,facsV])
      facsG <<- (facsdata[,"F1"])
      microI <<- (microdata[,microI])
      microV <<- (microdata[,microV])

      datas <<- list(sort(facsdata[,facsI]),   
		     sort(facsdata[,facsV]),
		     sort(microdata[,microI]),
		     sort(microdata[,microV]))

      dox <<- dox

}



#
# cutfacs
#
# Choose the living cells from the set of all cells
#
# Input: vector edges of cut positions. Depends on "producedata".
# Output: list of vectors containing intensity (I), granularity (G) and volume (V) channel




cutfacs <- function(edges=c(0,0)) {

	      zufrieden <- FALSE
	      left <- 1
	      right <- length(facsV)
	      if (sum(abs(edges)) != 0) {
		      left <- edges[1]
			right <- edges[2]
			zufrieden <- TRUE
		}	
		

		# Rotate the data and cut "wrong" cells
		myfit <- glm(facsG ~ facsV + 0)
		phi <- atan(coefficients(myfit))
		X <- cos(phi) * facsV + sin(phi)*facsG
		Y <- - sin(phi) * facsV + cos(phi)*facsG
		myrange <- which(X > left & X < right)
		mybreaks <- seq(0,max(X)+10, length.out = 100)
		x11()
		while(!zufrieden) {
		
			myhist <- hist(X, breaks=mybreaks)
			left <- read.and.check("Left cut:", what = numeric(), lower = 0, upper = max(X))
			right <- read.and.check("Right cut:", what = numeric(), lower = 0, upper = max(X))
			myrange <- which(X > left & X < right)

			hist(X[myrange],breaks=mybreaks, add=TRUE, col=2)

			answer <- read.and.check("Ok? [y,n]", what = character())
			if (answer == "y") zufrieden <- TRUE
		}	

			range1 <- resample(c(1:length(facsV)), 20000)
			range2 <- myrange[which(myrange %in% range1)] #resample(myrange, 1000*length(myrange)/length(facsV))
			range3 <- range1[which(!(range1 %in% range2))]
			
			dev.off()
			
			par(mfcol=c(1,1))
			plot(facsV[range3], facsG[range3], xlab = "FACS Forward Scatter", ylab = "FACS Granularity")
			matplot(facsV[range2], facsG[range2], pch = 1, col=2, add=TRUE)

			
			write.csv(cbind(facsV[range3], facsG[range3]),"FACS_not.csv")
			write.csv(cbind(facsV[range2], facsG[range2]),"FACS_selected.csv")

			facsV <<- facsV[myrange]
			facsG <<- facsG[myrange]
			facsI <<- facsI[myrange]


			return(list(facsV, facsG, facsI))


}


#
# pophistos
#
# Creates histogram output (screen or pdf) of intensities and volumes (assuming that the volume channel must
# be taken to the power of 3/2 to get really volumes).
#
# Input: Boolean pdf for pdf output. Depends on "producedata"
# Output: Screen or pdf histogram output

pophistos <- function(pdf = FALSE) {
	
	if (pdf) pdf(paste("pophistos_dox", dox, ".pdf", sep="")) else 	x11()
	par(mfcol = c(2,1))
	hist(facsI, main = "FACS Intensity Channel", breaks=30)
	hist(microI, main = "Microscopy Intensity Channel", breaks=30)
	
	if (!pdf) x11()
	par(mfcol = c(2,1))
	hist(facsV^1.5, main = "FACS Volume Channel", breaks=30)
	hist(microV, main = "Microscopy Volume Channel", breaks=30)

	if (pdf) dev.off()
}


#
# optimize
#
# the objective function in dependence of the cut position m
#
# Input: cut position m in [1, length(facsdata)]
# Output: penalized chi square value.


optimize <- function(m) {
	mylenI <- length(facsI)
	mylenV <- length(facsV)
	quotI <- m/mylenI
	quotV <- m/mylenV
	n <- 2 
	punishI <- (n+1)*quotI^n
	punishV <- (n+1)*quotV^n

	datas <- list(sort(facsI)[-c(1:m)], sort(facsV)[-c(1:m)], sort(log(microI)), sort(microV)^0.66)
	chisquares <- c(quantilefit(datas, graphics=FALSE)[[2]][[1]],quantilefit(datas, graphics=FALSE)[[2]][[2]])
	return(chisquares + chisquares*c(punishI,punishV))

}




steigung <- function(m) {

	datas <- list(facsI[-c(1:m)], facsV[-c(1:m)], microI, microV^0.66)
	return(quantilefit(datas, graphics=FALSE)[[1]][[2]]$coefficients[2])

}
achsenabschnitt <- function(m) {

	datas <- list(facsI[-c(1:m)], facsV[-c(1:m)], microI, microV^0.66)
	return(quantilefit(datas, graphics=FALSE)[[1]][[2]]$coefficients[1])

}



#
# quantilefit 
#
# Perform the quantile-quantile fits
# 
# Input: datas produced with produce_data, boolean graphics if graphics output should be added to existing device (pdf or x11)
# Output: List of fit object and penalized chisquare value from optimize()

quantilefit <- function(datas, graphics = TRUE) {
	

	# Quantiles

	n <- 200 # Number of quantiles
	
	quant <- list(
		quantfI = quantile(datas[[1]], probs = seq(0,1,length.out=n)),
		quantfV = quantile(datas[[2]], probs = seq(0,1,length.out=n)),
		quantmI = quantile(datas[[3]], probs = seq(0,1,length.out=n)),
		quantmV = quantile(datas[[4]], probs = seq(0,1,length.out=n))
	)	

	#
	# (50% around mean value)-method for calibration
	#

	
	# Select the 50% "internal" points	
	redquant <- quant
	for (i in 1:(length(quant)/2)) {
		
		mymean <- mean(quant[[i+2]])
		myindex <- median(which(abs(quant[[i+2]]-mymean) == min(abs(quant[[i+2]]-mymean))))
		redquant[[i]] <- quant[[i]][(myindex-(n/3)):(myindex+(n/3))]
		redquant[[i+2]] <- quant[[i+2]][(myindex-(n/3)):(myindex+(n/3))]
	
	}

	#Linear fit of the internal region and chi^2
	fit <- list()
	chiquadrat <- list()
	sigmafacs <- list()
	sigmamicro <- list()
	totalvariance <- list()
	for (i in 1:(length(quant)/2)) {
		
		fit[[i]] <- glm(redquant[[i]] ~ redquant[[i+2]])
		chiquadrat[[i]] <- mean((fit[[i]]$coefficients[1] + fit[[i]]$coefficients[2]*quant[[i+2]] - quant[[i]])^2) #/totalvariance[[i]], na.rm=TRUE)
		
	}

	

	if (graphics) {
    
    	   plot(quant[[3]],quant[[1]], xlab = "log(microI)", ylab="facsI")
    	   abline(coef(fit[[1]])[1], coef(fit[[1]])[2])
    	   title(paste("Intensities for dox =", dox))
    	   plot(quant[[4]],quant[[2]], xlab= "microV^0.66", ylab="facsV")
    	   abline(coef(fit[[2]])[1], coef(fit[[2]])[2])
    	   title(paste("Volumes for dox =", dox))
	}

	return(list(fit, chiquadrat))



}




plot.function <- function(x, f, ...) {
	
	y <- c()
	for (i in 1:length(x)) {
		y <- rbind(y, f(x[i]))
	}
	nrcols <- dim(y)[2]
	xx <- t(t(x))
	T <- seq(1,1,len=nrcols)
	xx <- xx%*%T
	matplot(xx,y,...)
	
	mymin <- function(v) return(which(v == min(v))) 

	return(x[apply(y,2,mymin)])

}

derivative.vector <- function(x, k) {
	n <- length(x)
	M <- diag(1,n)
	M <- cbind(0,M)
	M <- M[,1:n]
	M <- diag(-1,n)+M

	Deltax <- M%*%x 
	Deltax[n] <- NA

	Estimate <- c()
	for (i in (k+1):(n-k)) {
		Estimate[i] <- mean(Deltax[(i-k):(i+k)], na.rm=TRUE)
	}

	return(Estimate)
		

}