fit.RBP<-function (formula = formula(data), sigma.formula = ~1, data, 
    param = "AM") 
{
    if (!inherits(formula, "formula")) {
        if (inherits(formula, "data.frame")) 
            warning("You gave a data.frame instead of a formula.")
        stop("formula is not an object of type formula")
    }
    if (!inherits(sigma.formula, "formula")) {
        if (inherits(sigma.formula, "data.frame")) 
            warning("You gave a data.frame instead of a formula for sigma.")
        stop("sigma.formula is not an object of type formula")
    }
    if (missing(formula)) 
        stop("Missing formula")
    if (missing(data)) 
        stop("Missing data")
    y <- model.frame(formula, data)[[1]]
    x <- model.matrix(formula, data)
    z <- matrix(1, nrow = length(y))
    colnames(z) <- "(Intercept)"
    if (sigma.formula != ~1) {
        z <- model.matrix(sigma.formula, data)
    }
    data = list(y = y, x = x, z = z)
    if (!any(param == c("AM", "GM", "HM", "MO", "MD"))) 
        stop("param is not recognized")
    quiet <- function(x) {
        sink(tempfile())
        on.exit(sink())
        invisible(force(x))
    }
    E.step <- function(zeta, data, param = "AM") {
        tau1 = switch(param, AM = 0, GM = 0.5, HM = 1, MO = 1, 
            MD = 1/3)
        tau2 = switch(param, AM = 0, GM = 0.5, HM = 1, MO = 2, 
            MD = 2/3)
        p = ncol(x)
        q = ncol(z)
        beta <- zeta[1:p]
        nu <- zeta[(p + 1):(p + q)]
        mu <- exp(x %*% beta)
        sigma <- max(0, tau2 - 1) + exp(z %*% nu)
        a <- mu * sigma + tau1
        b <- sigma - tau2 + 1
        logw = log1p(y) - digamma(a + b)
        w1 = (a + b)/(1 + y)
        list(w1 = w1, logw = logw)
    }
    aux.M.step <- function(zeta, data, w1, logw, param) {
        tau1 = switch(param, AM = 0, GM = 0.5, HM = 1, MO = 1, 
            MD = 1/3)
        tau2 = switch(param, AM = 0, GM = 0.5, HM = 1, MO = 2, 
            MD = 2/3)
        y = data$y
        x = data$x
        z = data$z
        p = ncol(x)
        q = ncol(z)
        beta <- zeta[1:p]
        nu <- zeta[(p + 1):(p + q)]
        mu <- exp(x %*% beta)
        sigma <- max(0, tau2 - 1) + exp(z %*% nu)
        a <- mu * sigma + tau1
        b <- sigma - tau2 + 1
        -sum(-lgamma(a) - lgamma(b) - (a + b) * logw - w1 * (y + 
            1) + (a - 1) * log(y))
    }
    M.step <- function(zeta, data, w1 = w1, logw = logw, param = param) nlminb(zeta, 
        aux.M.step, data = data, w1 = w1, logw = logw, param = param)$par
    llike.BP <- function(zeta, data, param) {
        y = data$y
        x = data$x
        z = data$z
        if (!any(param == c("AM", "GM", "HM", "MO", "MD"))) 
            stop("param is not recognized")
        tau1 = switch(param, AM = 0, GM = 0.5, HM = 1, MO = 1, 
            MD = 1/3)
        tau2 = switch(param, AM = 0, GM = 0.5, HM = 1, MO = 2, 
            MD = 2/3)
        p = ncol(x)
        q = ncol(z)
        beta <- zeta[1:p]
        nu <- zeta[p + 1:q]
        mu <- exp(x %*% beta)
        sigma <- max(0, tau2 - 1) + exp(z %*% nu)
        -sum(dRBP(y, mu, sigma, param, log = TRUE))
    }
    data.aux = list(y = y, x = x, z = z)
    p = ncol(x)
    q = ncol(z)
    aa = lm(log(y) ~ 1)
	if(ncol(x)>1) aa = lm(log(y) ~ x[, -1, drop = FALSE])
    zeta = c(coef(aa), log(sigma(aa)), rep(0, ncol(z) - 1))
    i = 1
    dif = 1
    prec = 1e-04
    max.iter = 1000
    while (dif > prec && i <= max.iter) {
        aux <- E.step(zeta, data.aux, param)
        w1 = aux$w1
        logw = aux$logw
        zeta.new <- M.step(zeta, data.aux, w1 = w1, logw = logw, 
            param = param)
        dif <- max(abs(zeta.new - zeta))
        zeta <- zeta.new
        i = i + 1
    }
    convergence = ifelse(dif > prec || i > max.iter, FALSE, TRUE)
    se = sqrt(diag(solve(hessian(llike.BP, x0 = zeta, data = data.aux, 
        param = param))))
    aa = cbind(zeta, se)
    llike = -llike.BP(zeta, data.aux, param)
    rownames(aa) <- c(paste("beta_", colnames(x), sep = ""), 
        paste("nu_", colnames(z), sep = ""))
    colnames(aa) = c("Estimate", "Std. Error")
    tau1 = switch(param, AM = 0, GM = 0.5, HM = 1, MO = 1, MD = 1/3)
    tau2 = switch(param, AM = 0, GM = 0.5, HM = 1, MO = 2, MD = 2/3)
    mu <- exp(x %*% aa[1:p, 1])
    sigma <- max(0, tau2 - 1) + exp(z %*% aa[p + 1:q, 1])
    alpha = mu * sigma + tau1
    beta = sigma - tau2 + 1
    pearson = NULL
    if (all(beta > 2)) {
        mean.y = alpha/(beta - 1)
        sd.y = sqrt(alpha * (alpha + beta - 1)/((beta - 2) * 
            (beta - 1)^2))
        pearson = (y - mean.y)/sd.y
    }
    mean.log = digamma(alpha) - digamma(alpha + beta)
    sd.log = sqrt(trigamma(alpha) - trigamma(alpha + beta))
    mod.pearson = (log(y/(1 + y)) - mean.log)/sd.log
    quant = qnorm(pRBP(y, mu = mu, sigma = sigma, param = param))
    val = list(estimate = aa, logLik = llike, AIC = -2 * llike + 
        2 * (p + q), BIC = -2 * llike + log(length(y)) * (p + 
        q), tau1 = tau1, tau2 = tau2, pearson.res = as.vector(pearson), 
        mod.pearson.res = as.vector(mod.pearson), quant.res = c(quant), 
        convergence = convergence, dist = "BP", param = param, 
        mu.x = x, sigma.x = z)
    class(val) <- "rregm"
    val
}

