# 1. This program has been heavily modified by André GILLIBERT
# from "CP-refining-sinica.r" written by Weizhen Wang (AN 
# ITERATIVE CONSTRUCTION OF CONFIDENC E INTERVALS FOR A PROPORTION, 
# Statistica Sinica, 2013).
# 

#wang(32)

# rprec permet d'obtenir une précision variable selon la proximité de l'intervalle de confiance à zéro
# rprec doit être un vecteur de longueur 2.
# Le 1er élément donne la précision relative de chaque borne de l'IC95.
# Le 2ème élément donne la précision absolue en lambda=np, qui, une fois divisée par n, donne la précision absolue en p
# C'est le plus précis de la précision relative et de la précision absolue qui est utilisée
# rprec conseillé : c(1e-3, 0.1)
pfloor=function(v,prec) {floor(v/prec)*prec}
pceiling=function(v,prec) {ceiling(v/prec)*prec}
wang2017=function(n=100, alpha=0.05, prec1=0.0001,prec2=0.000000001, rprec=NULL, verbose=T, skipround=F) {

	lcp<- function(x,n){   # the lower limit of 1-alpha CP interval
		qbeta(alpha/2, x, n-x+1)
	}
	
	ucp<- function(x,n){ # the upper limit of 1-alpha CP interval
		qbeta(1-alpha/2, x+1, n-x)
	}
	
	lcp1<- function(x,n){   # the lower limit of 1-2alpha CP interval
		qbeta(alpha, x, n-x+1)
	}
	
	ucp1<- function(x,n){ # the upper limit of 1-2alpha CP interval
		qbeta(1-alpha, x+1, n-x)
	}
	
	#indicator fucntion of interval [a,b]
	ind<- function(x,a,b){
		(x>=a)*(x<=b)
	}
	
	xx=0:n
	lcpn=lcp(xx,n)   #the lower limit of CP interval
	ucpn=ucp(xx,n)   #the upper limit of CP interval
	lcp1n=lcp1(xx,n) #the lower limit of one-sided CP interval >=lcpn
	ucp1n=ucp1(xx,n) #the upper limit of one-sided CP interval <=ucpn
	
	ss=n/2+1
	if (!is.null(rprec)) {
		prec1=10**floor(log10(pmin(lcpn[ss+1]*rprec[1], rprec[2]/n)));
	}
	print(prec1)
	if (is.null(rprec) & !skipround) {
		lcpn=floor(lcpn/prec1)*prec1     # make confidence limits in x-digit
		ucpn=ceiling(ucpn/prec1)*prec1
		lcp1n=ceiling(lcp1n/prec1)*prec1
		ucp1n=floor(ucp1n/prec1)*prec1
	}
	
	lcpw=lcpn #the lower limit of CP refinement, should be between lcpn and lcp1n
	ucpw=ucpn #the upper limit of CP refinement, should be between ucpn and ucp1n
	
	
	### compute lcpw and ucpw at X=n/2+1. 
	a0=pfloor(lcpn[ss], prec1)
	a1=pceiling(lcp1n[ss], prec1)# a1>a0. the final lower limit is between a1 and a0.
	afinalss=a0
	bfinalss=1-a0

	aa=seq(a0,a1, by=prec1)
	ii=length(aa)
	i=1
		while (i<ii+0.5) {
		lcpw[ss]=aa[i]
		ucpw[ss]=1-aa[i]
		pp=pmax(c(0,lcpw[2:(n+1)]-prec2),0)
		if (0) {
		cp=0*pp
		kkk=1
		while (kkk<n+1+0.5){
			cp=cp+ind(pp,lcpw[kkk],ucpw[kkk])*dbinom(kkk-1,n,pp)
			kkk=kkk+1
		}
		}
		cp2 = wcover2x(lcpw, ucpw, pp, n)
		if (0) {
		if (any(abs(cp2 - cp)>1e-9)) {
			cp2 <<- cp2;cp<<-cp;
			lcpw<<-lcpw;ucpw<<-ucpw;pp<<-pp;n<<-n;ss<<-ss
			stop("err23")
		}
		}
		minic=min(cp2)
		if (minic>=1-alpha){
			afinalss=aa[i]
			bfinalss=1-aa[i]
		}
		else {i=ii}
		i=i+1
	}
	lcpw[ss]=afinalss
	ucpw[ss]=bfinalss
	if (verbose) {
		print(c(ss-1,lcpw[ss], ucpw[ss]))
	}
	
	#### compute lcpw and ucpw at X=n/2 down to 0
	ss=n/2
	while (ss>.5){# construct the lower and upper limit from X=n/2 to 0

      prng = pmin(1,pmax(0,(qbinom(c(1e-9,1-1e-9), n, pmin((ss+2)/n,0.5))+c(-10,10))/n))

	a0=pfloor(lcpw[ss], prec1)
	a1=pceiling(lcp1n[ss], prec1)# a1>a0. the final lower limit is between a1 and a0.
	b0=pfloor(ucp1n[ss], prec1)
	b1=pceiling(ucpw[ss], prec1) # b1>b0. the final upper limit is between b1 and b0.
	
	if (!is.null(rprec)) {
		prec1=10**floor(log10(pmin(lcpn[ss+1]*rprec[1], rprec[2]/n)));
		if (verbose) {print(prec1)}
	}
	aa=seq(a0,a1,by=prec1)
	bb=seq(b1,b0,by=-prec1)
	iii=length(aa)
	lowef=0
	uppef=1
	lenf=uppef-lowef
	lowe=0
	uppe=1
	len=uppe-lowe
	
	ii=1
	pp3=pmax(c(0,lcpw[2:(n+1)]-prec2),0)
	cv = wcover2x(lcpw,ucpw,pp3,n)
	#prop3=pp3 >= prng[1] & pp3 <= prng[2]
	#pp3b=pp3[prop3]
	#cv3b=cv[prop3]
	#pp_offset=min(which(prop3))-1 # displacement (in x) due to use of prop3

	while (ii<iii+.4){
		jj=1;
		jjj=length(bb);
		while (jj<jjj+0.4){
			ciss = c(aa[ii], bb[jj])
			cirss = c(1-bb[jj], 1-aa[ii])
			#cp3b=wcover3(prec2=prec2, lcpw, ucpw, pp3b, n, ss-1, cv=cv3b, ciss=ciss, cirss=cirss, pp_offset=pp_offset )
			#minic3b = min(cp3b)

			minic3=min(wcover3(prec2=prec2, lcpw, ucpw, pp3, n, ss-1, cv=cv, ciss=ciss, cirss=cirss))
			#minic3b=min(wcover3(prec2=prec2, lcpw, ucpw, pp3, n, ss-1, cv=cv, ciss=ciss, cirss=cirss))

			if (0) {
			if (abs(minic3 - minic3b)>1e-9) {
				lower<<-lower;upper<<-upper;pp3<<-pp3;prop3<<-prop3;n<<-n;ss<<-ss;
				pp3b<<-pp3b;cv3b<<-cv3b;pp_offset<<-pp_offset;ciss<<-ciss;cirss<<-cirss;
				lcpw<<-lcpw;ucpw<<-ucpw;
				cv<<-cv
				minic3 <<- minic3
				minic3b <<- minic3b
				cp3 <<- cp3
				cp3b <<- cp3b
				stop("minic3 and minic3b don't match")
			}
			}
			minic = minic3

			if (0) {
			lower=lcpw
			upper=ucpw
			lower[ss]=aa[ii]
			upper[n+2-ss]=1-aa[ii]
			upper[ss]=bb[jj]
			lower[n+2-ss]=1-bb[jj]

			pp=pmax(c(0,lower[2:(n+1)]-prec2),0)
			cp0=0*pp
			kkk=1
			while (kkk<n+1+0.5){
				cp0=cp0+ind(pp,lower[kkk],upper[kkk])*dbinom(kkk-1,n,pp)
				kkk=kkk+1
			}
			minic0=min(cp0)

			prop=pp >= prng[1] & pp <= prng[2]

			cp2=wcover2(lower, upper, pp, n, ss-1)
			minic2 = min(cp2)

			if (abs(minic0 - minic2)>1e-9 || any(abs(cp0-cp2)>1e-9)) {
				lower<<-lower;upper<<-upper;pp<<-pp;prop<<-prop;n<<-n;ss<<-ss-1
				cp0  <<- cp0;cp2 <<-cp2;cp3 <<- cp3;
				stop("error between minic0 ", minic0, " and minic2 ", minic2)
			}
			if (abs(minic0 - minic3)>1e-9 || any(abs(cp0-cp3)>1e-9)) {
				lower<<-lower;upper<<-upper;pp<<-pp;prop<<-prop;n<<-n;ss<<-ss-1;
				lcpw<<-lcpw;ucpw<<-ucpw;
				cv<<-cv
				cp0  <<- cp0;cp2 <<-cp2;cp3 <<- cp3;
				idx=which(abs(cp0-cp3)>1e-9)
				failed<<-idx-1

				stop("error between cp0 and cp3 at value ", paste(idx-1,collapse=" "), " for ss-1=", ss-1)
			}
			minic = minic0
			} # end if (0) {

			if (minic>=1-alpha){
				len=bb[jj]-aa[ii]
				if (len<lenf){
					lowef=aa[ii]
					uppef=bb[jj]
					lenf=uppef-lowef
				}
				jj=jj+1
			}
			if (minic<1-alpha & jj>1.5) 
				{jj=jjj+1}
			if (minic<1-alpha & jj<1.5)
				{jj=jjj+1
			 	 ii=iii+1}
		}
		ii=ii+1
	}
	
	lcpw[ss]=lowef
	ucpw[ss]=uppef
	lcpw[n+2-ss]=1-uppef
	ucpw[n+2-ss]=1-lowef
	if (verbose) {
		print(c(ss-1,lcpw[ss], ucpw[ss]))
	}
	ss=ss-1
	}
	cbind(lcpw, ucpw)
}
if (0) {
system.time(wk1<<-wang2014(512,prec1=0.0001)) # 740 s
system.time(wk3<<-wang2017(512,prec1=0.0001,skipround=F)) # 8.2 s
#c(pp[failed+1], lower[ss+1],upper[ss+1], lcpw[ss+1],ucpw[ss+1])
all(abs(wk1-wk3) < 1e-9)

system.time(wk4<<-wang2017(2048,prec1=1e-5))

slow=F;system.time(df0<<-wang(256,prec1=0.001))
slow=F;system.time(df0<<-wang(2048,prec1=1e-5))

slow=F;system.time(df1<<-wang(512,prec1=0.001))
dfc=t(sapply(0:512, function(x) {cic(x,512)}))

wcoverslow(lower,upper,pp)-wcover(lower,upper,pp)
system.time(replicate(1000,wcover(lower,upper,pp)))
system.time(replicate(1000,wcoverslow(lower,upper,pp)))
}

wcoverslow=function(lcpw,ucpw,pp,n,ss=NULL) {
	cp=0*pp
	kkk=1
	ind<- function(x,a,b){(x>=a)*(x<=b)}
	while (kkk<n+1+0.5){
		cp=cp+ind(pp,lcpw[kkk],ucpw[kkk])*dbinom(kkk-1,n,pp)
		kkk=kkk+1
	}
	cp
}

wcover=function(lower,upper,pp,n,ss) {
	# Attention : lower et upper doivent être croissants sauf à l'index 1+ ss et à l'index 2+ n-ss
	# Pour l'instant, c'est bogué
	if (any(is.na(pp))) {
		stop("All pp must be well-defined");
	}
	if (any(pp < 0 | pp > 1)) {
		stop("All pp must be between 0 and 1");
	}

	if (length(lower)==0) {
		stop("wcover : empty set");
	}
	if (length(lower)!=length(upper)) {
		stop("wcover : inconsistent set");
	}
	# pp is an ordered list of theoretical proportions
	# lower is a vector of lower boundaries of confidence intervals (starting from x=0 to x=n)
	# upper is a vector of upper boundaries of confidence intervals (starting from x=0 to x=n)
	# Returns a vector of length pp containing the coverage of each theoritical proba
	cp2=sapply(pp, function (ptheo) {
		# Get the acceptance region (list of x for which the interval contains ptheo)
		x1 = min(which(upper >= ptheo))-1
		x2 = max(which(ptheo >= lower))-1
		#pbinom(x2,n,ptheo) - pbinom(x1-1,n,ptheo)
		c(x1,x2)
	})
	pbinom(cp2[2,],n,pp) - pbinom(cp2[1,]-1,n,pp)
}


wcover2x=function(lower,upper,pp,n) {
	# Lower and upper must be monotonous
	if (any(is.na(pp))) {
		stop("All pp must be well-defined");
	}
	if (any(pp < 0 | pp > 1)) {
		stop("All pp must be between 0 and 1");
	}

	if (length(lower)==0) {
		stop("wcover : empty set");
	}
	if (length(lower)!=length(upper)) {
		stop("wcover : inconsistent set");
	}
	if (length(pp)==0) {return(NULL)}
	# pp is a quasi-ordered list of theoretical proportions
	# lower is a vector of lower boundaries of confidence intervals (starting from x=0 to x=n)
	# upper is a vector of upper boundaries of confidence intervals (starting from x=0 to x=n)
	# Returns a vector of length pp containing the coverage of each theoritical proba

	ln = length(upper)

	# Initialize x1 and x2
	ptheo1 = pp[1]
	x1=min(which(upper >= ptheo1))-1;
	x2=max(which(ptheo1 >= lower))-1;
	if (!is.finite(x2)) {
		stop("Empty coverage for first pp not yet supported")
	}

	cp3=mapply(function (ptheo,reduction) {
		# Get the acceptance region (list of x for which the interval contains ptheo)
		if (TRUE) { # order is not respected
			x1=pmax(1,x1-16) # magic constant 16, should always be enough as reductions are always quite small
			x2=pmax(1,x2-16)
		}
		while(x1<ln+1) {
			if (upper[x1] >= ptheo) {break;}
			x1=x1+1;
		}
		while(x2<ln+1) {
			if (ptheo < lower[x2]) {x2=x2-1;break;}
			x2=x2+1;
		}
		x1 <<- x1
		x2 <<- x2
		c(x1-1,x2-1)
	},pp, c(1,diff(pp))<0)
	pbinom(cp3[2,],n,pp) - pbinom(cp3[1,]-1,n,pp)
}

interval_change=function(ic1, ic2) {
	# Computes what intervals are added/removed when going from ic2 to ic1
	if (all(ic1 == ic2)) {return(NULL)} # unmodified
	if (ic1[2] <= ic2[1] | ic1[1] >= ic2[2]) { # don't overlap
		return(list(
			c(F,ic2[1],ic2[2]),
			c(T,ic1[1],ic1[2])
		))
	}
	if (ic1[1] >= ic2[2]) {return(NULL)}
	if (ic1[1] < ic2[1] & ic1[2] > ic2[2]) { # extended on both sides
		return(list(
			c(T,ic1[1],ic2[1]), 
			c(T,ic2[2],ic1[2])
		))
	}
	if (ic1[1] < ic2[1] & ic1[2] <= ic2[2]) { # shifted+/-extended to the left
		return(list(
			c(T,ic1[1],ic2[1]),
			c(F,ic1[2],ic2[2])
		))
	}
	if (ic1[1] >= ic2[1] & ic1[2] > ic2[2]) { # shifted+/-extended to the right
		return(list(
			c(F,ic2[1],ic1[1]),
			c(T,ic2[2],ic1[2])
		))
	}
	# shrinked
	return(list(
		c(F,ic2[1],ic1[1]),
		c(F,ic1[2],ic2[2])
	))
}
if (0) {
interval_change(c(0,10),c(5,15))
interval_change(c(5,15),c(0,10))
interval_change(c(5,15),c(20,30))
interval_change(c(20,30),c(5,15))
interval_change(c(25,27),c(5,50))
interval_change(c(5,50),c(25,27))
interval_change(c(5,50),c(5,75))
interval_change(c(30,50),c(30,50))
interval_change(c(3,50),c(30,50))
}

ssappend=function(ss, l) {
	lapply(l, function(v) {c(ss,v)})
}
wcover2=function(lower,upper,pp,n,ss,echap=F) {
	# The interval at ss (index ss+1) and at n-ss (index 1+n-ss) may not have montonous neighbors
	# Idea : Compute coverage with 'repaired' confidence set
	# Then, update
	lu = cbind(lower, upper)

	ci_ss=lu[1+ss,]
	ci_rss=lu[1+n-ss,]
	off=ifelse(ss==0,1,-1)

	ci_sso = lu[1+ss+off,]
	ci_rsso = lu[1+n-ss-off,]
	if (ss == 0) {
		ci_sso[1] = 0; ci_rsso[2] = 1;
	}

	lu[1+ss,]=ci_sso
	lu[1+n-ss,]=ci_rsso
	# sum(diff(lu[,1])<0)+ sum(diff(lu[,2])<0) == 0
	# sum(diff(pp)<0) # can be positive

	cv = wcover2x(lu[,1],lu[,2],pp,n)
	#cv = wcover(lu[,1],lu[,2],pp,n)
	if(echap) {return(cv)}
	# Now, fix it
	if (1) {
	for (ci in list(c(ss,ci_sso), c(n-ss,ci_rsso))) { # Removes interval from coverage
		pred = pp >= ci[2] & pp <= ci[3]
		cv[pred] = cv[pred]- dbinom(ci[1],n,pp[pred])
	}
	for (ci in list(c(ss,ci_ss), c(n-ss,ci_rss))) { # Adds interval into coverage
		pred = pp >= ci[2] & pp <= ci[3]
		cv[pred] = cv[pred] + dbinom(ci[1],n,pp[pred])
	}
	} else {
		# Pour l'instant, cette version est plus complexe et plus lente
		l=c(ssappend(ss, interval_change(ci_ss,ci_sso)),
		  ssappend(n-ss, interval_change(ci_rss,ci_rsso)))
		for(ci in l) {
			pred = pp >= ci[3] & pp <= ci[4]
			if (any(pred)) {
				cv[pred] = cv[pred] + ifelse(ci[2],1,-1)*dbinom(ci[1],n,pp[pred])
			}
		}
	}
	cv
}

wcover3=function(lower, upper, pp, n, ss, cv, ciss, cirss, prec2=1e-8, pp_offset=0) {
	# On part d'une liste de couvertures cv pour pp qui correspond aux intervalles de confiance cbind(lower,upper)=matrix(ncol=2,nrow=n+1)
	# L'intervalle à ss est modifié en ciss (vecteur c(lcl, ucl))
	# L'intervalle à n-ss est modifié en cirss (vecteur c(lcl, ucl))
	# pp_offset sert lorsqu'on ne prends pas tous les pp correspondant aux bornes basses (lower) mais juste un intervalle
	# Il correspond à l'offset d'index entre lower et pp
	if (0) {
	lower<<-lower;upper<<-upper;pp<<-pp;n<<-n;ss<<-ss;cv<<-cv;ciss<<-ciss;cirss<<-cirss;prec2<<-prec2;pp_offset<<-pp_offset
	if (anyNA(pp)) {
		stop("wcover3 : NA in pp")
	}
	if (anyNA(c(ciss, cirss))) {
		stop("wcover3 : NA in ciss or cirss")
	}
	}

	cisso=c(lower[1+ss], upper[1+ss])
	cirsso=c(lower[1+n-ss], upper[1+n-ss])

	# On rajoute un point de mesure juste à la borne inf des intervalles qui ont changé
	idx=c(1+ss,1+n-ss)-pp_offset
	extrapp = pmax(c(ciss[1]-prec2, cirss[1]-prec2),0)

	# Parfois, les bornes à changer sont en dehors de la zone d'intérêt
	if (pp_offset > 0) {
		okidx = idx <= length(pp) & idx >= 0
		extrapp = extrapp[okidx]
		idx = idx[okidx]
	}
	pp[idx] = extrapp
	cv[idx] = wcover2x(lower, upper, extrapp, n)

	for (ci in list(c(ss,cisso), c(n-ss,cirsso))) { # Removes interval from coverage
		pred = pp >= ci[2] & pp <= ci[3]
		cv[pred] = cv[pred] - dbinom(ci[1],n,pp[pred])
	}
	for (ci in list(c(ss,ciss), c(n-ss,cirss))) { # Adds interval into coverage
		pred = pp >= ci[2] & pp <= ci[3]
		cv[pred] = cv[pred] + dbinom(ci[1],n,pp[pred])
	}
	cv
}

if (0) {
summary(as.vector(cp3-cp2))
rng=range(which(cp3[2,]!=cp2[2,]))+c(-2,+2)
cp2[2,rng[1]:rng[2]]
cp3[2,rng[1]:rng[2]]
wcover2(lcpw, ucpw, pp[prop], n)-wcover(lcpw, ucpw, pp[prop], n)
cs=wcoverslow(lcpw, ucpw, pp,n)
summary(wcover2(lcpw, ucpw, pp, n, ss) - cs)

all(round(wcover2(lcpw, ucpw, pp, n, ss-1) - cs,5)==0)
 which(round(wcover2(lcpw, ucpw, pp, n, ss-1) - cs,5)!=0)

#cv=wcover2(lcpw, ucpw, pp[prop], n, ss-1,echap=T)
#slow=T;system.time(replicate(100000,wcover2(lcpw, ucpw, pp[prop], n, ss-1,cv=cv)))
#slow=F;system.time(replicate(100000,wcover2(lcpw, ucpw, pp[prop], n, ss-1,cv=cv)))


cs=wcoverslow(lower, upper, pp,n)
summary(wcover2(lower, upper, pp, n, ss) - cs)

system.time(wk4<<-wang2017(2048,prec1=1e-5,alpha=0.05)) # 164 s


}

creation=F
if (creation) {
	setwd("c:/users/andre/documents/owncloud/Falissard/ztest/precalc")
	system.time(wk2048r<<-wang2017(2048,alpha=0.05,rprec=c(1e-2, 0.1)))
	system.time(wk64r<<-wang2017(64,alpha=0.05,rprec=c(1e-2, 0.1)))
	system.time(wk32r<<-wang2017(32,alpha=0.05,rprec=c(1e-2, 0.1)))
	system.time(wk12r<<-wang2017(12,alpha=0.05,rprec=c(1e-2, 0.1)))

	write.table(wk2048r, "wang_2048_variable_CI95.csv", sep=";",dec=",",row.names=F,col.names=T)
	write.table(wk64r, "wang_64_variable_CI95.csv", sep=";",dec=",",row.names=F,col.names=T)
	write.table(wk32r, "wang_32_variable_CI95.csv", sep=";",dec=",",row.names=F,col.names=T)
	write.table(wk12r, "wang_12_variable_CI95.csv", sep=";",dec=",",row.names=F,col.names=T)
}
