estimate.compound <-
function(x, dist="exp", comp1=as.null(), comp2=as.null(),est.var=TRUE)
{
if(!any(dist == c("exp","gamma","lnorm","paretoII","bisa","lomax","beta","kumar","norm","logis","cauchy","gumbel"))) stop("distribution is not recognized")
if(!any(comp1 == c("EXP","EXP2","MO","MO2","SB")) & !is.null(comp1)) stop("distribution is not recognized")
if(!any(comp2 == c("EXP","EXP2","MO","MO2","SB")) & !is.null(comp2)) stop("distribution is not recognized")
if(any(dist == c("exp","gamma","lnorm","paretoII","bisa","lomax")))
{
if(any(x<=0)) stop("x should be positive")
}
if(any(dist == c("beta","kumar"))) 
{
if(any(x<=0) | any(x>=1)) stop("x should be between 0 and 1")
}
if(any(dist==c("exp"))){r=1}
if(any(dist==c("gamma","lnorm","paretoII","bisa","lomax","beta","kumar","norm","logis","cauchy","gumbel"))){r=2}
if(dist=="paretoII"){dist.aux="paretoII";dist="lomax"}
F=get(paste("p",dist,sep=""))
f=get(paste("d",dist,sep=""))
if(!is.null(comp2)){g2=get(paste("d",comp2,sep=""))}
if(!is.null(comp1)){g1=get(paste("d",comp1,sep=""));G1=get(paste("p",comp1,sep=""))}
if(!is.null(comp2))
{
llike.comp<-function(psi, x, dist, comp1, comp2, mod.param=FALSE, r=1)
{
if(r==1)
{
alpha<-exp(psi[1])
theta1<-exp(psi[2])
theta2<-exp(psi[3])
if(comp1=="SB") theta1<-1-2*plogis(psi[2])
if(comp2=="SB") theta2<-1-2*plogis(psi[3])
if(mod.param){alpha<-psi[1];theta1<-psi[2];theta2<-psi[3]}
logf<-g2(G1(F(x, alpha),theta1),theta2,log=TRUE)+g1(F(x,alpha),theta1,log=TRUE)+f(x,alpha,log=TRUE)
}
if(r==2 & !any(dist == c("lnorm","norm","logis","cauchy","gumbel")))
{
alpha<-exp(psi[1])
beta<-exp(psi[2])
theta1<-exp(psi[3])
theta2<-exp(psi[4])
if(comp1=="SB") theta1<-1-2*plogis(psi[3])
if(comp2=="SB") theta2<-1-2*plogis(psi[4])
if(mod.param){alpha<-psi[1];beta<-psi[2];theta1<-psi[3];theta2<-psi[4]}
logf<-g2(G1(F(x, alpha, beta),theta1),theta2,log=TRUE)+g1(F(x,alpha,beta),theta1,log=TRUE)+f(x,alpha,beta,log=TRUE)
}
if(r==2 & any(dist == c("lnorm","norm","logis","cauchy","gumbel")))
{
alpha<-psi[1]
beta<-exp(psi[2])
theta1<-exp(psi[3])
theta2<-exp(psi[4])
if(comp1=="SB") theta1<-1-2*plogis(psi[3])
if(comp2=="SB") theta2<-1-2*plogis(psi[4])
if(mod.param){beta<-psi[2];theta1<-psi[3];theta2<-psi[4]}
logf<-g2(G1(F(x, alpha, beta),theta1),theta2,log=TRUE)+g1(F(x,alpha,beta),theta1,log=TRUE)+f(x,alpha,beta,log=TRUE)
}
-sum(logf)
}
rr=r+ifelse(is.null(comp1), 0,1)+ifelse(is.null(comp2), 0,1)
aux=optim(rep(0, rr), llike.comp, x=x, dist=dist, comp1=comp1, comp2=comp2, 
mod.param=FALSE, r=r, method="BFGS",control=list(maxit=1000))
if(r==1) param=exp(aux$par)
if(r==2) param=exp(aux$par)
if(r==2 & any(dist == c("lnorm","norm","logis","cauchy","gumbel"))){param=exp(aux$par);param[1]=aux$par[1]}
if(comp1=="SB") param[r+1]=1-2*plogis(aux$par[r+1])
if(comp2=="SB") param[r+2]=1-2*plogis(aux$par[r+2])
param=matrix(param, ncol=1)
colnames(param)=c("estimate")
se = c()
if(est.var)
{
test = try(solve(hessian(llike.comp, x0=param, x=x, dist=dist, comp1=comp1, comp2=comp2, 
mod.param=TRUE, r=r)), silent = TRUE)
if(!grepl("Error",test)[1])
{
        if (is.numeric(test) & min(diag(test)) > 0) {
            se = sqrt(diag(test))
            param <- cbind(param, se)
            colnames(param) <- c("estimate", "s.e.")
        }
}
}
rownames(param)=c(1:nrow(param))
if(r==1) rownames(param)[1]=c("gamma")
if(r==2) rownames(param)[1:2]=c("gamma","beta")
if(r==2 & any(dist == c("lnorm","norm","logis","cauchy","gumbel"))) rownames(param)[1:2]=c("mu","sigma")
if(comp1=="EXP" | comp1=="EXP2"){rownames(param)[r+1]="alpha"}
if(comp1=="MO" | comp1=="MO2"){rownames(param)[r+1]="theta"}
if(comp1=="SB") rownames(param)[r+1]="lambda"
if(comp2=="EXP" | comp2=="EXP2") rownames(param)[r+2]="alpha"
if(comp2=="MO" | comp2=="MO2") rownames(param)[r+2]="theta"
if(comp2=="SB") rownames(param)[r+2]="lambda"
logvero <- -aux$value
AIC = -2 * logvero + 2 * (r+2)
BIC = -2 * logvero + log(length(x)) * (r+2)
object.out <- list(coefficients = param, logLik = logvero, AIC = AIC, 
            BIC = BIC)
}
if(is.null(comp2) & !is.null(comp1))
{
llike.comp2<-function(psi, x, dist, comp1, mod.param=FALSE, r=1)
{
if(r==1)
{
alpha<-exp(psi[1])
theta1<-exp(psi[2])
if(comp1=="SB") theta1<-1-2*plogis(psi[2])
if(mod.param){alpha<-psi[1];theta1<-psi[2]}
logf<-g1(F(x,alpha),theta1,log=TRUE)+f(x,alpha,log=TRUE)
}
if(r==2 & !any(dist == c("lnorm","norm","logis","cauchy","gumbel")))
{
alpha<-exp(psi[1])
beta<-exp(psi[2])
theta1<-exp(psi[3])
if(comp1=="SB") theta1<-1-2*plogis(psi[3])
if(mod.param){alpha<-psi[1];beta<-psi[2];theta1<-psi[3]}
logf<-g1(F(x,alpha,beta),theta1,log=TRUE)+f(x,alpha,beta,log=TRUE)
}
if(r==2 & any(dist == c("lnorm","norm","logis","cauchy","gumbel")))
{
alpha<-psi[1]
beta<-exp(psi[2])
theta1<-exp(psi[3])
if(comp1=="SB") theta1<-1-2*plogis(psi[3])
if(mod.param){beta<-psi[2];theta1<-psi[3]}
logf<-g1(F(x,alpha,beta),theta1,log=TRUE)+f(x,alpha,beta,log=TRUE)
}
-sum(logf)
}
rr=r+ifelse(is.null(comp1), 0,1)
aux=optim(rep(0, rr), llike.comp2, x=x, dist=dist, comp1=comp1, 
mod.param=FALSE, r=r, method="BFGS",control=list(maxit=1000))
if(r==1) param=exp(aux$par)
if(r==2) param=exp(aux$par)
if(r==2 & any(dist == c("lnorm","norm","logis","cauchy","gumbel"))){param=exp(aux$par); param[1]=aux$par[1]}
if(comp1=="SB") param[r+1]=1-2*plogis(aux$par[r+1])
param=matrix(param, ncol=1)
colnames(param)=c("estimate")
se = c()
if(est.var)
{
test = try(solve(hessian(llike.comp2, x0=param, x=x, dist=dist, comp1=comp1, 
mod.param=TRUE, r=r)), silent = TRUE)
if(!grepl("Error",test)[1])
{
        if (is.numeric(test) & min(diag(test)) > 0) {
            se = sqrt(diag(test))
            param <- cbind(param, se)
            colnames(param) <- c("estimate", "s.e.")
        }
}
}
rownames(param)=1:nrow(param)
if(r==1) rownames(param)[1]=c("gamma")
if(r==2) rownames(param)[1:2]=c("gamma","beta")
if(r==2 & any(dist == c("lnorm","norm","logis","cauchy","gumbel"))) rownames(param)[1:2]=c("mu","sigma")
if(comp1=="EXP" | comp1=="EXP2") rownames(param)[r+1]="alpha"
if(comp1=="MO" | comp1=="MO2") rownames(param)[r+1]="theta"
if(comp1=="SB") rownames(param)[r+1]="lambda"
logvero <- -aux$value
AIC = -2 * logvero + 2 * (r+2)
BIC = -2 * logvero + log(length(x)) * (r+2)
object.out <- list(coefficients = param, logLik = logvero, AIC = AIC, 
            BIC = BIC)
}
if(is.null(comp2) & is.null(comp1))
{
llike.comp3<-function(psi, x, dist, mod.param=FALSE, r=1)
{
if(r==1)
{
alpha<-exp(psi[1])
if(mod.param){alpha<-psi[1]}
logf<-f(x,alpha,log=TRUE)
}
if(r==2 & !any(dist == c("lnorm","norm","logis","cauchy","gumbel")))
{
alpha<-exp(psi[1])
beta<-exp(psi[2])
if(mod.param){alpha<-psi[1];beta<-psi[2]}
logf<-f(x,alpha,beta,log=TRUE)
}
if(r==2 & any(dist == c("lnorm","norm","logis","cauchy","gumbel")))
{
alpha<-psi[1]
beta<-exp(psi[2])
if(mod.param){beta<-psi[2]}
logf<-f(x,alpha,beta,log=TRUE)
}
-sum(logf)
}
aux=suppressWarnings(optim(rep(0, r), llike.comp3, x=x, dist=dist, 
mod.param=FALSE, r=r, method="BFGS",control=list(maxit=1000)))
if(r==1) param=exp(aux$par)
if(r==2) param=exp(aux$par)
if(r==2 & any(dist == c("lnorm","norm","logis","cauchy","gumbel"))){param=exp(aux$par); param[1]=aux$par[1]}
param=matrix(param, ncol=1)
colnames(param)=c("estimate")
se = c()
if(est.var)
{
test = suppressWarnings(try(solve(hessian(llike.comp3, x0=param, x=x, dist=dist, 
mod.param=TRUE, r=r)), silent = TRUE))
if(!grepl("Error",test)[1])
{
        if (is.numeric(test) & min(diag(test)) > 0) {
            se = sqrt(diag(test))
            param <- cbind(param, se)
            colnames(param) <- c("estimate", "s.e.")
        }
}
}
rownames(param)=1:nrow(param)
if(r==1) rownames(param)[1]=c("gamma")
if(r==2) rownames(param)[1:2]=c("gamma","beta")
if(r==2 & any(dist == c("lnorm","norm","logis","cauchy","gumbel"))) rownames(param)[1:2]=c("mu","sigma")
logvero <- -aux$value
AIC = -2 * logvero + 2 * length(param)
BIC = -2 * logvero + log(length(x)) * length(param)
object.out <- list(coefficients = param, logLik = logvero, AIC = AIC, 
            BIC = BIC)
}
    object.out
}
