#install.packages("Hmisc")
library("Hmisc")

# Doses
di <- c(.25, .75, 1, 2.5, 3)
N <- length(di)

# Frequency matrix
freq <- t(matrix(c(				
	2185, 8, 0, 0, 0, 				
	2550, 44, 1, 0, 0, 			
	2231, 54, 2, 0, 0, 						
	1196, 123, 7, 1, 0,		
	1070, 320, 41, 6, 1
	),ncol=N))
NN <- ncol(freq)
dist <- seq(0, NN - 1)
ni <- rowSums(freq)
m <- sum(ni)
yi <- as.vector(t(freq%*%dist))

# Statistics
means <- yi/ni
means
vars <- (rowSums(t(dist*dist*t(freq)))/ni - means*means)*(ni/(ni-1))
dcs <- vars/means
dcs
us <- (dcs - 1)*sqrt((ni - 1)/(2*(1 - 1/yi)))
us

# Test data
y <- c(1712, 96, 3)
nf <- sum(y)
disty <- seq(0, length(y) - 1)
yf <- sum(disty*y)
meany <- yf/nf
vary <- (sum(disty*disty*y)/nf - meany*meany)*(nf/(nf - 1))
dcy <- vary/meany
dcy
uy <- (dcy - 1)*sqrt((nf - 1)/(2*(1 - 1/yf)))
uy

# Minus log-likelihood
loglikh<-function(b){
loglikh<-0
for(j in 1:N){
  m<-b[1]*di[j]^2 + b[2]*di[j]
  if(m<=0) m <- .0000001
  q<-prob(m,b[3])
  if(sum(q==0)==0)
  {q<-log(q);loglikh <- loglikh - sum(q*freq[j,])}
  else
  {loglikh<-1000000}}    
loglikh
}

# NA distribution
prob <- function(m,d){
	p <- numeric(NN)
	p[1] <- exp(m*(exp(-(d-1))-1)/(d-1))
	for(i in 1:(NN-1)){
		s <- 0;
		kr <- i-1
		for(k in 0:kr){ s <- s + ((d - 1)^k)*p[i - k]/factorial(k) }
		p[i+1] <- m*exp(-(d - 1))*s/i
	}
	p
}

# MLE: minimization of minus log-likelihood
MLE <- nlm(loglikh, p=c(.001, .001, 1.001))

# Bayesian Information Criterion
BIC_na <- 2*MLE$minimum + 3*log(sum(ni))

# Herm distribution
prob <- function(m,d){
	lam1<-m*(2-d)
  	lam2<-m*(d-1)/2
  	if(lam1<=0)lam1<-0.00001
  	if(lam2<=0)lam2<-0.00001
  	p<-numeric(NN)
  	p[1]<-exp(-lam1-lam2)
  	p[2]<-p[1]*lam1 
  	for (i in 3:NN){p[i]<-(p[i-1]*lam1+2*p[i-2]*lam2)/(i-1)}  
	p
}

MLE <- nlm(loglikh, p=c(.025, .003, 1.001))
BIC_herm <- 2*MLE$minimum + 3*log(sum(ni))

# NB distribution
prob <- function(m,d){
	a<-m*(2-d)
  	b<-m*(d-1)/2
  	p<-numeric(NN)
  	p[1] <- d^(-m/(d - 1))
  	for(i in 1:(NN-1)){ p[i+1] <- p[i]*(1 - 1/d + (m - d + 1)/(d*i))  }
	p
}

MLE <- nlm(loglikh, p=c(.025, .003, 1.001))
BIC_nb <- 2*MLE$minimum + 3*log(sum(ni))

loglikh<-function(b){
loglikh<-0
for(j in 1:N){
  m<-b[1]*di[j]^2 + b[2]*di[j]
  if(m<=0) m <- .0000001
  q<-prob(m)
  if(sum(q==0)==0)
  {q<-log(q);loglikh <- loglikh - sum(q*freq[j,])}
  else
  {loglikh<-1000000}}    
loglikh
}

# Poisson distribution
prob <- function(m){
	p <- numeric(NN)
	p[1] <- exp(-m)
	for(i in 1:(NN-1)){ p[i+1] <- p[i]*m/i  }
	p
}

MLE <- nlm(loglikh, p=c(.023, .004), hessian=TRUE)
BIC_pois <- 2*MLE$minimum + 2*log(sum(ni))

# BIC values
BIC_nb
BIC_herm
BIC_na
BIC_pois

# Poisson estimated fit coefficients, covariance and standar errors
sigma <- solve(MLE$hessian)
SDs <- sqrt(diag(sigma)) 
MLE$estimate
sigma
SDs

# Poisson response fitted curve
win.graph()
errbar(di, yi/ni, yi/ni - 2*sqrt(vars)/sqrt(ni), yi/ni + 2*sqrt(vars)/sqrt(ni), pch=19, ylab="Aberrations per Cell", xlab="Dose, x, Gy")
lines(d <- seq(0, 3, .001), MLE$estimate[1]*d*d + MLE$estimate[2]*d, col="red")

# Parameters
u <- function(x){ MLE$estimate[1]*x*x + MLE$estimate[2]*x }
v <- function(x){ sigma[1,1]*x^4 + 2*sigma[1,2]*x^3 + sigma[2,2]*x^2 }
b <- function(x){ u(x)/v(x) }
a <- function(x){ u(x)*b(x) }

nf*c(MLE$estimate[1], MLE$estimate[2])
nf*c(0, 0, MLE$estimate[1], MLE$estimate[2]) + nf*nf*c(sigma[1,1], 2*sigma[1,2], sigma[2,2], 0)

# Doses sequence for the calibrative density
x <- seq(1.1, 1.8, .001)
l <- length(x)
np <- numeric(l)
gp <- numeric(l)
ggp <- numeric(l)

# Hermite distribution mass function
dherm <- function(x,u,d){ 
	if(x < 2) p <- exp(u*(-1 + (d - 1)/2))*(u*(2 - d))^x/factorial(x)
	else{
		p_k <- numeric(x + 1)
		p_k[1] <- exp(u*(-1 + (d - 1)/2))
		p_k[2] <- p_k[1]*(u*(2 - d))
		for(k in 2:x){p_k[k + 1] <- u*(p_k[k - 1]*(d - 1) + p_k[k]*(2 - d))/k}
		p <- p_k[x + 1]}	
	p}

# Calibrative density calulation for the Normal mean prior and Uniform dose prior 
for(i in 1:l){
	np[i] <- dherm(yf, nf*u(x[i]), 1 + nf*v(x[i])/u(x[i]))
}

cnorm <- sum(np)*.001
np <- np/cnorm

# Calibrative density statistics
mod_np <- x[which.max(np)]

expect_np <- sum(np*x)*.001
var_np <- sum((x - expect_np)^2*np)*.001

i <- 1
sum <- 0
while(sum < .025){ sum <- sum + np[i]*.001; i <- i + 1 }
lb95_np <- x[i]

i <- 1
sum <- 0
while(sum < .975){ sum <- sum + np[i]*.001; i <- i + 1 }
ub95_np <- x[i]

mod_np
expect_np
sqrt(var_np)
lb95_np
ub95_np

# Calibrative density calulation for the Gamma mean prior and Uniform dose prior 
for(i in 1:l){
	gp[i] <- dnbinom(yf, a(x[i]), b(x[i])/(b(x[i]) + nf))
}

cnorm <- sum(gp)*.001
gp <- gp/cnorm

# Calibrative density statistics
mod_gp <- x[which.max(gp)]

expect_gp <- sum(gp*x)*.001
var_gp <- sum((x - expect_gp)^2*gp)*.001

i <- 1
sum <- 0
while(sum < .025){ sum <- sum + gp[i]*.001; i <- i + 1 }
lb95_gp <- x[i]

i <- 1
sum <- 0
while(sum < .975){ sum <- sum + gp[i]*.001; i <- i + 1 }
ub95_gp <- x[i]

mod_gp
expect_gp
sqrt(var_gp)
lb95_gp
ub95_gp

# Calibrative density calulation for the Gamma mean prior and Gamma dose prior 
ggp <- gp*dgamma(x, 1.75^2/.375^2, 1.75/.375^2)

cnorm <- sum(ggp)*.001
ggp <- ggp/cnorm

# Calibrative density statistics
mod_ggp <- x[which.max(ggp)]

expect_ggp <- sum(ggp*x)*.001
var_ggp <- sum((x - expect_ggp)^2*ggp)*.001

i <- 1
sum <- 0
while(sum < .025){ sum <- sum + ggp[i]*.001; i <- i + 1 }
lb95_ggp <- x[i]

i <- 1
sum <- 0
while(sum < .975){ sum <- sum + ggp[i]*.001; i <- i + 1 }
ub95_ggp <- x[i]

mod_ggp
expect_ggp
sqrt(var_ggp)
lb95_ggp
ub95_ggp

# Calibrative densities plot
win.graph()
plot(x, gp, type="l", ylab=expression(paste("f(x|",tilde(y),")")), xlab="Dose, x, Gy", col= "red", lty=4)
lines(x, np, col="blue", lty=3)
lines(x, ggp, col="green", lty=1)

# Maximum dose for using the Normal posterior
uniroot(function(x) u(x) - nf*v(x), c(1,4))$root

# Minimum value of the Gamma shape parameter (the bigger shape value the better Gamma approximation to Normal)
min(a(x))