rm(list=ls(all=TRUE))
#install.packages("CharFun")
#install.packages("VGAM")
#install.packages("pracma")
#require(CharFun)
require(VGAM)
require(pracma)

hypergeom1F1 <- function(z, a, b) {
  sz <- dim(z)

  z <- c(z)

  f <- unlist(lapply(z, function(z) cchg(z, a, b)))

  return(f)
}

cchg <- function (z, a, b) {
  chw <- 0
  pi <- 3.141592653589793
  ci <- 1i
  a0 <- a

  if (b == 0 || b == -trunc(abs(b))) {
    chg <- 1e+300
  } else if (a == 0 || z == 0) {
    chg <- 1
  } else if (a == -1) {
    chg <- 1 - z / b
  } else if (a == b) {
    chg <- exp(z)
  } else if (a - b == 1) {
    chg <- (1 + z / b) * exp(z)
  } else if (a == 1 && b == 2) {
    chg <- (exp(z) - 1) / z
  } else if (a == trunc(a) && a < 0) {
    m   <- trunc(-a)
    cr  <- 1
    chg <- 1
    for (k in (1:m)) {
      cr  <- cr * (a + k - 1) / k / (b + k - 1) * z
      chg <- chg + cr
    }
  } else {
    x0 <- Re(z)
    if (x0 < 0) {
      a  <- b - a
      a0 <- a
      z  <- -z
    }
    if (a < 2) {nl <- 0}
    if (a >= 2) {
      nl <- 1
      la <- trunc(a)
      a  <- a - la - 1
    }
    for (n in (0:nl)) {
      if (a0 >= 2) {a <- a + 1}
      if (abs(z) < 20 + abs(b) || a < 0) {
        chg <- 1
        crg <- 1
        for (j in (1:500)) {
          crg <- crg * (a + j - 1) / (j * (b + j - 1)) * z
          chg <- chg + crg
          if (abs((chg - chw) / chg) < 1e-15) {break}
          chw = chg
        }
      } else {
        g1 <- exp(lgamma(a))
        g2 <- exp(lgamma(b))
        ba <- b - a
        g3 <- exp(lgamma(ba))
        cs1 <- 1
        cs2 <- 1
        cr1 <- 1
        cr2 <- 1
        for (i in (1:8)) {
          cr1 <- -cr1 * (a + i - 1) * (a - b + i) / (z * i)
          cr2 <-  cr2 * (b - a + i - 1) * (i - a) / (z * i)
          cs1 <-  cs1 + cr1
          cs2 <-  cs2 + cr2
        }

        x <- Re(z)
        y <- Im(z)

        if (x == 0 && y >= 0) {phi <- 0.5 * pi
        } else if (x == 0 && y <= 0) {phi <- -0.5 * pi
        } else {phi <- atan(y / x)}

        if (phi > -0.5 * pi && phi < 1.5 * pi) {ns <- 1}
        if (phi > -1.5 * pi && phi <= -0.5 * pi) {ns <- -1}

        cfac = exp(ns * ci * pi * a)

        if (y == 0) {cfac = cos(pi * a)}

        chg1 <- g2 / g3 * z ^ (-a) * cfac * cs1
        chg2 <- g2 / g1 * exp(z) * z ^ (a - b) * cs2
        chg <- chg1 + chg2
      }

      if (n == 0) {cy0 <- chg}
      if (n == 1) {cy1 <- chg}
    }
    if (a0 >= 2) {
      for (i in (1:(la - 1))){
        chg <- ((2 * a - b + z) * cy1 + (b - a) * cy0) / a
        cy0 <- cy1
        cy1 <- chg
        a   <- a + 1
      }
    }
    if (x0 < 0) {chg <- chg * exp(-z)}
  }

  return(chg)
}

GAMMA <- function(x, z) {
  pi = 3.141592653589793
  if (x == trunc(x)) {
    if (x > 0) {
      ga = 1
      m1 = x - 1
      for  (k in seq(2, m1, max(0, length.out = m1-2))) {
        ga = ga * k
      }
    } else {ga = 1e+300}
  } else {
    if (abs(x) > 1) {
      z = abs(x)
      m = trunc(z)
      r = 1
      for  (k in (1:m)) {r = r * (z - k)}
      z = z - m
    } else
      z = x
  }
  g <- c(1.0e0,0.5772156649015329e0,-0.6558780715202538e0,
         -0.420026350340952e-1,0.1665386113822915e0,-0.421977345555443e-1,
         -0.96219715278770e-2,0.72189432466630e-2,-0.11651675918591e-2,
         -0.2152416741149e-3,0.1280502823882e-3,-0.201348547807e-4,
         -0.12504934821e-5,0.11330272320e-5,-0.2056338417e-6,0.61160950e-8,
         0.50020075e-8,-0.11812746e-8,0.1043427e-9,0.77823e-11,-0.36968e-11,
         0.51e-12,-0.206e-13,-0.54e-14,0.14e-14,0.1e-15)

  gr <- g[26]

  for (k in (25:1)) {gr = gr * z + g[k]}

  ga = 1 / (gr * z)

  if (abs(x)> 1) {ga = ga * r
  if(x < 0) {ga = -pi / (x * ga * sin(pi * x))}
  }

  return(ga)
}
aux.log.density<-function(x,p,q,s)
{
	exp((p-1)*log(x)+(q-1)*log1p(-x)-s*x)
}

#hypergeom1F12 <- function(z, a, b) {
#exp(lgamma(b)-lgamma(a)-lgamma(b-a))*integrate(aux.log.density, lower=0.0001, upper=0.9999, p=a, q=b-a, s=-z,abs.tol=1e-15)$value
#}

hypergeom1F1(-0.5,2,3)
#hypergeom1F12(-0.5,2,3)


rCHE<-function(n, lambda, q)
{
	x=rbeta(n, shape1=q, shape2=q)
	z=(-1/(2*lambda*x))*log(runif(n))
	z
}

aux.x.density.CH<-function(x,p,q,s)
{
	x*exp((p-1)*log(x)+(q-1)*log1p(-x)-s*x)
}

mean.CH<-function(p,q,s)
{
	#p*hypergeom1F1(-s,p+1,p+q+1)/((p+q)*hypergeom1F1(-s,p,p+q))
	integrate(aux.x.density.CH, lower=0, upper=1, p=p, q=q, s=s,abs.tol=1e-15)$value/(beta(p,q)*hypergeom1F1(-s,p,p+q))
}


aux.log.density.CH<-function(x,p,q,s)
{
	log(x)*exp((p-1)*log(x)+(q-1)*log1p(-x)-s*x)
}

aux.log1.density.CH<-function(x,p,q,s)
{	
	log1p(-x)*exp((p-1)*log(x)+(q-1)*log1p(-x)-s*x)
}

mean.log.CH<-function(p,q,s)
{
	integrate(aux.log.density.CH, lower=0, upper=1, p=p, q=q, s=s,abs.tol=1e-15)$value/(beta(p,q)*hypergeom1F1(-s,p,p+q))
}

mean.log1.CH<-function(p,q,s)
{
	integrate(aux.log1.density.CH, lower=0, upper=1, p=p, q=q, s=s,abs.tol=1e-15)$value/(beta(p,q)*hypergeom1F1(-s,p,p+q))
}

aux.pasoM<-function(theta,logX,log1X)
{
	a<-exp(theta[1])
	-sum(-lbeta(a,a)+(a-1)*logX+(a-1)*log1X)
}

##Paso E
PasoE<-function(z,lambda,a)
{
	X<-c();logX<-c();log1X<-c()
	for(i in 1:length(z))
	{
		X[i]<-mean.CH(a+1,a,2*lambda*z[i])
		logX[i]<-mean.log.CH(a+1,a,2*lambda*z[i])
		log1X[i]<-mean.log1.CH(a+1,a,2*lambda*z[i])
	}	
	if(any(is.nan(X))) X[which(is.nan(X))]=0
	if(any(is.nan(logX))) logX[which(is.nan(logX))]=0
	if(any(is.nan(log1X))) log1X[which(is.nan(log1X))]=0
	return(list(X=X, logX=logX, log1X=log1X))
}

##Paso M
PasoM<-function(z,X,logX,log1X,a.last)
{
	lambda<-length(z)/(2*sum(X*z))
	aux<-nlminb(log(c(a.last)),aux.pasoM, logX=logX, log1X=log1X)
	a<-exp(aux$par[1])
	return(list(lambda=lambda,a=a))
}

EM<-function(z,lambda.last,a.last,max.iter=1000,prec=1e-3)
{
	dif=1
	i=1
	while(i<=max.iter && dif>prec)
	{
		aux<-PasoE(z,lambda.last,a.last)
		X<-aux$X;logX<-aux$logX;log1X<-aux$log1X
		aux<-PasoM(z,X,logX,log1X,a.last)
		lambda.new<-aux$lambda
		a.new<-aux$a
		dif<-max(abs(c(lambda.new-lambda.last,a.new-a.last)))
		lambda.last<-lambda.new
		a.last<-a.new
		i<-i+1
	}
	return(list(lambda=lambda.last,a=a.last, max.prec=dif, iter=i))
}


aux.log.density<-function(x,p,q,s)
{
	exp((p-1)*log(x)+(q-1)*log1p(-x)-s*x)
}
log.llike.CHEx<-function(theta,z)
{
	lambda<-theta[1];a<-theta[2]
	ll<-c()
	for(i in 1:length(z))
	{
		ll[i]<-log(2*lambda)-2*lambda*z[i]-lbeta(a,a)+log(integrate(aux.log.density, lower=0, upper=1, p=(a+1), q=a, s=2*lambda*z[i],abs.tol=1e-15)$value)
	}
	-sum(ll)
}
log2.llike.CHEx<-function(theta,z)
{
	lambda<-exp(theta[1]);a<-exp(theta[2])
	ll<-c()
	for(i in 1:length(z))
	{
		ll[i]<-log(2*lambda)-2*lambda*z[i]-lbeta(a,a)+log(integrate(aux.log.density, lower=0, upper=1, p=(a+1), q=a, s=2*lambda*z[i],abs.tol=1e-15)$value)
	}
	-sum(ll)
}


n=100
lambda=1
q=2
replicas=1000
set.seed(2022)
n.seq=c(50,100,200)
lambda.seq=c(3,5,10,20)
q.seq=c(3,5,10)
for(i in 3:length(n.seq))
{
for(j in 3:length(lambda.seq))
{
for(k in 1:length(q.seq))
{
n=n.seq[i]
lambda=lambda.seq[j]
q=q.seq[k]
resultados=c()
ii=1
while(ii<=replicas)
{
t=rCHE(n, lambda, q)

est=try(EM(t,lambda,q),silent=TRUE)
if(!grepl("Error", est)[1])
{
	para=c(est$lambda, est$a)
	vari=try(solve(hessian(log.llike.CHEx, x0=para, z=t)),silent=TRUE)
	if(!grepl("Error", vari)[1])
	{
		if(min(diag(vari))>0)
		{
			resultados=rbind(resultados, c(para, sqrt(diag(vari))))
			ii=ii+1
			plot(1, main=paste(i, j, k, ii))
		}
	}
}

}
nombre=paste("casolambda",lambda,"q",q,"n",n,".txt",sep="")
write(t(resultados),ncolumns=ncol(resultados),file=nombre)
}
}
}






