
##############################################################################
############## Procedures to compute coverage and interval width #############
##############################################################################


repbind=function(v, times) { # transform a vector v of length A in a matrix of length A x times, where all rows of the matrix are equal to v
	if (times <= 0) {return (matrix(nrow=0, ncol=length(v)))}
	t(sapply(1:times, function(x) v))
}

# Precompute a set of confidence intervals sharing the same sample size and estimator
# It works for binomial CI and Poisson CI.
# rng must contain the interval of x values (numerator) that has to be computed
# The estimator is the parameter control$cinfunc.
# control$cifunc must have two positional arguments (numerator, denominator) and one named argument (conf.level)
# If N is infinite, the Poisson computation is performed
# For Poisson distribution (N == Inf), control$cipois should contain a Poisson estimator function
# If control$cipois is undefined, it will be simulated by the binomial control$cifunc, with sample size 1e15
# For Poisson distribution, control$Npois may be specified to avoid infinite loop when rng[2] == Inf
# A global variable is_parallel[[cifunc]] can be specified in order to describe the capability of cifunc to get a vector of numerators (x == vector)
# precompute() returns a matrix 2xN containing CIs
# if rng is specified, only CI estimates for the numerators in range are computed ; other numerators' CI are set to NaN
precompute=function(N, control, rng=c(0,N)) {
	cifunc=getcontrol(control, "cifunc")
	conf.level=getcontrol(control,"conf.level")
	if (N == Inf) {
		rng[2] = rng[2]+10 # Prévoir un peu de rab
		poisfunc=getcontrol(control, "poisfunc")
		if (is.null(poisfunc)) {
			poisfunc=function(x,conf.level=0.95) {
				t(sapply(x, function (x) {cifunc(x,1e15, conf.level=conf.level)*1e15}))
			}
		}
		Npois=getcontrol(control, "Npois")
		if (!is.finite(rng[2])) {rng=c(0, Npois);}
		poisfunc(rng[1]:rng[2],conf.level=conf.level)
	} else {
		parallel=F
		if (is.character(cifunc)) {
			parallel = is_parallel[[cifunc]]
			cifunc=get(cifunc)
		}
		if (!parallel) {
			t(sapply(0:N, function (n) {
				if (n < rng[1] | n > rng[2]) {return(c(NaN,NaN))}
				cifunc(n,N,conf.level=conf.level)
			}))
		} else {
			if (rng[2] < rng[1]) {cis=matrix(ncol=2,nrow=0)}
			else {cis = cifunc(rng[1]:rng[2], N, conf.level=conf.level)}
			m = rbind(
				repbind(c(NaN, NaN), rng[1]),
				cis,
				repbind(c(NaN, NaN), N-rng[2])
			)
			return(m)
		}
	}
}
precalccond=function(N, control, rng) {
	if (is.null(control$precalc)) {
		control$precalc = precompute(N, control, rng=c(qbinpois(1e-9, N, rng[1]), qbinpois(1e-9, N, rng[2],lower.tail=F)))
	}
	control
}

# couvertureRLM computes the conditional risks of a CI estimator for a contant sample size N
# If N is infinite, the Poisson distribution is used
# control$precalc may be specified. It's a 2xN matrix generated by precompute()
# couvertureRLM() returns a vector that has length 6.
# 1) Underestimation risk (conditional right alpha risk)
# 2) Overestimation riskk (conditional left alpha risk)
# 3) CI average right half-width
# 4) CI average left half-width
# 5) Right and (6) left absolute distance of the (right or left) confidence boundary to the actual proportion when the actual proportion is contained in the confidence interval.
couvertureRLM=function(prob, N, control=control0) {
	if (is.finite(N) & prob < 0) {return(NA)}
	if (is.finite(N) & prob > 1) {return(NA)}
	x = qbinpois(c(1e-6,1-1e-6), size=N, prob=prob)
	if (is.null(control$precalc)) {
		control$precalc = precompute(N, control, rng=x)
	}
	if (is.null(control$precalc)) {
		stop("Échec de précalcul dans couvertureRLM")
	}
	
	xv=(x[1]):(x[2])
	d=dbinpois(xv, size=N, prob=prob)
	if (max(xv)+1 > nrow(control$precalc)) {
		control<<-control
		N <<- N;prob <<- prob
		stop("Erreur : Precalc trop court")
	}
	pc=control$precalc[1+xv,,drop=F]
	# Renvoie un vecteur de longueur 6 :
	# 1) risque de sous-estimation
	# 2) risque de sur-estimation
	# 3) largeur d'intervalle à droite
	# 4) largeur d'intervalle à gauche
	# 5 et 6) Dépassement moyen de couverture conditionnel au fait de couvrir la vraie valeur

	probobs = xv/ifelse(N==Inf,1,N)
	ptoolow=pc[, 2] < prob
	ptoohigh=pc[, 1] > prob
	rwidth=pc[,2]  - probobs
	lwidth=probobs - pc[,1]
	
	alpha1=sum(d[ptoolow])
	alpha2=sum(d[ptoohigh])
	v=c(alpha1,
	  alpha2,
	  sum(d*rwidth),
	  sum(d*lwidth),
	  sum(  d*pmax(0,pc[,2] - prob)  )/(1-alpha1),
	  sum(  d*pmax(0,prob - pc[,1])  )/(1-alpha2)
	)
	names(v)=c("toolow","toohigh","rightwidth","leftwidth","rightadist","leftadist")
	v
}

# Same as couvertureRLM2 but accept a vector of theoretical values rather than a unique theoretical value
# This functions pre-computes, if needed, all CIs once, in order to speed up computation.
couvertureRLM2=function(probs, N, control=control0) {
	if (is.finite(N)) {probs=pmin(1, pmax(0, probs))}
	if (is.null(control$precalc)) {
		control = precalccond(N, control, rng=range(probs))
	}
	m=t(sapply(probs, function(prob) {couvertureRLM(prob,N,control)}))
	m
}

# Appendix 1 coverage example
round(couvertureRLM2(0.10,108,control=list(cifunc=cicmidp)),4)
round(couvertureRLM2(0.10,107,control=list(cifunc=cicmidp)),4)

# This function computes average coverage for a random sample size N and constant theoretical value prob.
# N follows a discrete integer-rounded log-normal distribution
# The expectancy of this variable must be given (parameter N of the function)
# OR is the geometric standard deviation
# Numerical integration is used to estimate the average coverage.
couverture4N0=function(prob, N, OR=NULL, control=control0) {
	# Calcule la couverture en supposant prob=constante et n variable selon une loi log-normale d'écart type géométrique OR
	frame = getcontrol(control, "frame")
	if (is.null(OR)) {OR=getcontrol(control, "OR")}
	k=qnorm(1-1e-4) # Étendue de la loi log-normale analysée
	lmed = log(N2center(N, OR)) # log(median)
	rng = exp(c(-k*log(OR), k*log(OR)) + lmed)
	rng[1] = floor(rng[1]); rng[2] = ceiling(rng[2])
	
	step = pmax(1, floor((rng[2] - rng[1]) / frame ))
	x=seq(rng[1], rng[2], step)
	m = t(sapply(x, function (n) {
		couvertureRLM(prob, n, control=control)
	}))
	# Proba de chaque dénominateur n sous l'hypothèse d'une loi log-normale discrétisée
	logtransform=function(n) {
		(log(n) - lmed)/log(OR)
	}
	d=sapply(x, function (n) {
		pnorm( logtransform(n-step/2) ) - pnorm( logtransform(n+step/2) )
	})
	d = d/sum(d)
	v = colSums(m * d)
	v0 = c(n=prob*N,meanN=sum(d*x), N=N) # meanN and N are almost equal (discrete distribution errors)
	v = c(v0, v)
	v
}

center2N=function(med,OR) {# Gets mean N of a log-normal variable from its median med
	exp(log(med)+log(OR)^2/2)
}
N2center=function(N,OR) { # Gets the median of a log-normal variable from its mean
	exp(log(N)-log(OR)^2/2)
}

# Works like couverture4N but n is the expected numerator (rather than prob, the expected numerator/denominator)
# Moreover, this function accepts vectors for n and N, and computes all combinations of n and N
# OR is the geometric standard deviation
couverture4N=function(n, N, OR, control=control0) {
	dfapply(N, function(N) {
		as.data.frame(t(sapply(n, function (n) {
			cat("Computing couverture4N for n=", n, " and N=", N, "\n")
			couverture4N0(n/N,N,OR, control)
		})))
	})
}

is_parallel=list(
	ciasinbartlett=TRUE
)


# AKONTI
# In oder to work with both binomial and Poisson distributions,
# these functions perform transformations, knowning the denominator (finite value for binomial -> logit, infinite value for Poisson -> log)

logitINF=function(n, N) {
	if (N == Inf) {log(n)} else {logit(n/N)}
}
expitINF=function(n, N) {
	if (N == Inf) {exp(n)} else {expit(n)}
}
# Works like colMeans but gives a weight to each row of the input matrix (weighted average)
weightedColMeans=function(m, v) {
	v = v / sum(v)
	colSums(m * v)
}
# Computes maximum value of each column and add a ".worst" suffix to all column names
colMaxes=function(m, v) {
	v=apply(m, 2, max)
	names(v)=paste0(names(v), ".worst")
	v
}

# This couverture4P() function is the most important function of this script
# It computes the local average risks and widths for a random proportion P (or expected Poisson value lambda) and a constant sample size N.
couverture4P=function(start=0.1, end=N-0.1,OR=NULL, N=100, overlap=NULL, frame=NULL, control=control0,cvret=F,unif=NULL) {
	# unif=FALSE si on veut que la V.A. suive une loi logit-uniforme
	# unif=TRUE si on veut que la V.A. suive une loi logit-normale
	if (is.null(overlap)) {overlap=getcontrol(control, "overlap")}
	if (is.null(frame)) {frame=getcontrol(control, "frame")}
	if (is.null(OR)) {OR=getcontrol(control, "OR")}
	if (is.null(unif)) {unif=getcontrol(control, "unif")}

	if (!unif) {OR = OR^4}
	hoverlap=overlap/2
	#start=logitINF(start, N);end=logitINF(end, N);
	#npoints=round((end-start)/log(OR)*hoverlap)
	#frame = frame / overlap
	#logit_probs = seq(start, end, length.out=frame*npoints)

	logit_probs=seq(logitINF(start, N)-log(OR)/2, logitINF(end, N)+log(OR)/2, log(OR)/frame)
	frame = frame / overlap
	probs=expitINF(logit_probs,N)

	cv=couvertureRLM2(probs, N, control=control)
	if (cvret) {return(cbind(probs,cv))}

	x=seq(hoverlap*frame, length(probs)-hoverlap*frame, frame)

	m=t(sapply(x, function(i) {
		iitems = seq.int((i-frame*hoverlap+1),(i+frame*hoverlap))

		# On va trouver une loi logit-normale dont l'essentiel des points est situé dans cet intervalle
		mm=expitINF(mean(logit_probs[iitems]),N)
		density = dnorm(logit_probs[iitems],mean=mean(logit_probs[iitems]),sd=log(OR)/4)
		proba   = density *(logit_probs[2]-logit_probs[1])
		proba   = proba/sum(proba)
		if (!unif) {
		c(sum(proba * probs[iitems])*ifelse(N==Inf,1,N),
			probs[iitems[1]],
			probs[iitems[length(iitems)]],
			weightedColMeans(cv[iitems,], proba),
			colMaxes(cv[iitems,]))
		} else {
		c(mean(probs[iitems])*ifelse(N==Inf,1,N),
			probs[iitems[1]],
			probs[iitems[length(iitems)]],
			colMeans(cv[iitems,]),
			colMaxes(cv[iitems,]))
		}
	}))
	colnames(m)[1:3]=c("n","pmin","pmax")
	as.data.frame(m)
}

if (0) {
computedf2=function(...) {
	df1=computedf(...,right=F);df1$right=F;df1$largeur=NA
	df2=computedf(...,right=T);df2$right=T;df2$largeur=NA
	df3=computedf(...,right=2);df3$right=NA;df3$largeur=df3$alpha;df3$alpha=NA;
	rbind(df1,df2,df3)
}
}

dfapply=function(x,func) {
	do.call(rbind,lapply(x, func))
}
computedf3=function(N=1000, cinames=cinames0[unlist(groups)], end=64, OR=NULL, conf.level=0.95) {
	if (anyNA(names(cinames))) {
		stop("All names must be defined\n");
	}
	df0=
	dfapply(conf.level, function(conf.level) {
	dfapply(N, function(denom) {
	print(denom)
	dfapply(names(cinames), function(ci) {
		cat("Calcul de moyenne locale de couverture : interval ", ci, "N=", denom, "\n");
		df=couverture4P(control=list(cifunc=get(ci), conf.level=conf.level),N=denom,end=pmin(denom-0.1,end),OR=OR)
		cbind(df, interval=ci, Intervalle=cinames[[ci]], N=denom, conf.level=conf.level, stringsAsFactors=FALSE)
	})
	})
	})
}
reshapevar=function(df,var1,var2,varout,bvarselect) {
	df1=df
	df1[,varout]=df[,var1]
	df1[,bvarselect]=FALSE

	df2=df
	df2[,varout]=df[,var2]
	df2[,bvarselect]=TRUE

	df3=df
	df3[,varout]=df[,var1] + df[,var2]
	df3[,bvarselect]=2

	df = rbind(df1, df2, df3)
	df[,var1]=NULL
	df[,var2]=NULL
	df
}
canondf=function(df3, compute_width=T) {
	dfa=reshapevar(df3, "toohigh","toolow","alpha","right")
	dfw=reshapevar(df3, "leftwidth","rightwidth","width","right")
	dfad=reshapevar(df3, "leftadist","rightadist","adist","right")
	dfz = (cbind(dfa, dfw[,"width",drop=F], dfad[,"adist",drop=F]))
	if (compute_width) {
		dfclopper=subset(dfz, interval=="cicmidp")
		#wclopper=as.list(dfclopper$width)
		#names(wclopper)=paste(dfclopper$N, round(dfclopper$n,4), dfclopper$right)
		dfz$cic.width = dfclopper$width[
			match(
				paste(dfz$N, round(dfz$n,4), dfz$right),
				paste(dfclopper$N, round(dfclopper$n,4), dfclopper$right)
		)]
		dfz$width2 = dfz$width / dfz$cic.width
		#dfz$width3 = dfz$width * sqrt(dfz$N^3/((dfz$n)*(dfz$N-dfz$n)))
	}
	dfz
}



couverture4C=function(start=0, end=N, N=32, control=control, hotepsilon=NULL) { # Conditional coverage
	end = pmin(end, N)
	if (is.null(hotepsilon)) {hotepsilon = getcontrol(control, "hotepsilon")}
	conditionnalStep = getcontrol(control, "conditionnalStep")
	
	p2n = ifelse(N==Inf,1,N)
	x=seq(0,min(end,N),by=conditionnalStep) / p2n
	# On va rajouter les points chauds (points juste avant et après les discontinuités, c.à.d. bornes d'intervalles)
	control = precalccond(N, control, c(start, end)/p2n)
	hotpoints = na.omit(as.vector(control$precalc))*p2n
	hotpoints = c(hotpoints-hotepsilon, hotpoints+hotepsilon)
	hotpoints = hotpoints[hotpoints > 0 & hotpoints <= end]/p2n
	x=sort(unique(c(x, hotpoints)))

	control$Npois = end+32
	df1=as.data.frame(couvertureRLM2(x, N=N, control=control))
	df1$n=x*ifelse(N==Inf,1,N)
	df1$N=N;
	interval = getcontrol(control, "cifunc")
	df1
}
#dfx=couverture4C(0,12,Inf, control=list(cifunc=ciinvp))
#ciinvp(3,1e15)

computedf3C=function(N=32, start=0, end=32, cinames=cinames0[unlist(groups)], conf.levels=0.95) {
	dfapply(conf.levels, function(conf.level) {
	dfapply(N, function(denom) {
	cat("Calcul couvertures conditionnelles pour N =",denom, " et conf.level=",conf.level, "\n")
	dfapply(names(cinames), function(ci) {
		cat("Calcul couverture conditionnelle ",denom, ci, conf.level, "\n")
		df=couverture4C(control=list(cifunc=get(ci), conf.level=conf.level),N=denom,start=start,end=end)
		cbind(df, interval=ci, Intervalle=cinames[[ci]], N=denom, conf.level=conf.level, stringsAsFactors=FALSE)
	})
	})
	})
}

