.packageName <- "brlr"
"add1.brlr" <-
    function (object, scope, scale = 0, test = c("none", "Chisq", 
                                        "F"), x = NULL, k = 2, ...) 
{
    Fstat <- function(table, rdf) {
        dev <- table$Deviance
        df <- table$Df
        diff <- pmax(0, (dev[1] - dev)/df)
        Fs <- (diff/df)/(dev/(rdf - df))
        Fs[df < .Machine$double.eps] <- NA
        P <- Fs
        nnas <- !is.na(Fs)
        P[nnas] <- pf(Fs[nnas], df[nnas], rdf - df[nnas], lower.tail = FALSE)
        list(Fs = Fs, P = P)
    }
    if (!is.character(scope)) 
        scope <- add.scope(object, update.formula(object, scope))
    if (!length(scope)) 
        stop("no terms in scope for adding to object")
    oTerms <- attr(object$terms, "term.labels")
    int <- attr(object$terms, "intercept")
    ns <- length(scope)
    dfs <- dev <- numeric(ns + 1)
    names(dfs) <- names(dev) <- c("<none>", scope)
    dfs[1] <- object$rank
    dev[1] <- object$deviance
    add.rhs <- paste(scope, collapse = "+")
    add.rhs <- eval(parse(text = paste("~ . +", add.rhs)))
    new.form <- update.formula(object, add.rhs)
    Terms <- terms(new.form)
    y <- object$y
    wt <- object$prior.weights
    if (is.null(x)) {
        fc <- object$call
        fc$formula <- Terms
        fob <- list(call = fc)
        class(fob) <- oldClass(object)
        m <- model.frame(fob, xlev = object$xlevels)
        x <- model.matrix(Terms, m, contrasts = object$contrasts)
        oldn <- length(y)
        y <- model.response(m, "numeric")
        if (NCOL(y) == 2) 
            y <- y[, 1]/(y[, 1] + y[, 2])
        newn <- length(y)
        if (newn < oldn) 
            warning(paste("using the", newn, "/", oldn, "rows from a combined fit"))
    }
    n <- nrow(x)
    if (is.null(wt)) 
        wt <- rep.int(1, n)
    y <- cbind(y*wt, (1-y)*wt)
    Terms <- attr(Terms, "term.labels")
    asgn <- attr(x, "assign")
    ousex <- match(asgn, match(oTerms, Terms), 0) > 0
    if (int) 
        ousex[1] <- TRUE
    for (tt in scope) {
        usex <- match(asgn, match(tt, Terms), 0) > 0
        X <- x[, usex | ousex, drop = FALSE]
        z <- brlr(y ~ X,  offset = object$offset, br = object$bias.reduction,
                     control = object$control)
        dfs[tt] <- z$rank
        dev[tt] <- z$deviance
    }
    if (scale == 0) 
        dispersion <- summary(object, dispersion = NULL)$dispersion
    else dispersion <- scale
    fam <- object$family$family
    if (fam == "gaussian") {
        if (scale > 0) 
            loglik <- dev/scale - n
        else loglik <- n * log(dev/n)
    }
    else loglik <- dev/dispersion
    aic <- loglik + k * dfs
    aic <- aic + (extractAIC(object, k = k)[2] - aic[1])
    dfs <- dfs - dfs[1]
    dfs[1] <- NA
    aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic, row.names = names(dfs), 
                      check.names = FALSE)
    if (all(is.na(aic))) 
        aod <- aod[, -3]
    test <- match.arg(test)
    if (test == "Chisq") {
        dev <- pmax(0, loglik[1] - loglik)
        dev[1] <- NA
        LRT <- if (dispersion == 1) 
            "LRT"
        else "scaled dev."
        aod[, LRT] <- dev
        nas <- !is.na(dev)
        dev[nas] <- pchisq(dev[nas], aod$Df[nas], lower.tail = FALSE)
        aod[, "Pr(Chi)"] <- dev
    }
    else if (test == "F") {
        if (fam == "binomial" || fam == "poisson") 
            warning(paste("F test assumes quasi", fam, " family", 
                          sep = ""))
        rdf <- object$df.residual
        aod[, c("F value", "Pr(F)")] <- Fstat(aod, rdf)
    }
    head <- c("Single term additions", "\nModel:", deparse(as.vector(formula(object))), 
              if (scale > 0) paste("\nscale: ", format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}
brlr <-
    function (formula, data = NULL, offset, weights, start, ...,
              subset, dispersion = 1, na.action = na.fail,
              contrasts = NULL, x = FALSE, br = TRUE,
              control = list(maxit = 200)) 
{
    glimlog <- function(y) {  
    # log function as in GLIM
        ifelse(y == 0, 0, log(y))
    }
    fmin <- function(beta) {
        eta <- offset. + drop(x %*% beta)
        pr <- plogis(eta)
        w <- wt * denom * pr * (1 - pr)
        detinfo <- det(t(x) %*% sweep(x, 1, w, "*"))
        if (all(pr > 0) && all(pr < 1) && detinfo > 0) 
            sum(wt * (y * glimlog(y/(denom * pr)) +
                     (denom - y) *
                        glimlog((denom - y)/(denom * (1 - pr))))
                ) - 
                br * 0.5 * log(detinfo)
        else Inf
    }
    gmin <- function(beta) {
        eta <- offset. + drop(x %*% beta)
        pr <- plogis(eta)
        h <- hat(sweep(x, 1, sqrt(wt * denom * pr * (1 - pr)), 
                       "*"), intercept = FALSE)
        -drop((wt * (y + br * h/2 - pr * (denom + br * h))) %*% 
              x)
    }
    if (inherits(formula, "glm")){
        call <- formula$call
        if (is.null(call$family) || call$family != as.name("binomial")) stop(
            "model is not a binomial glm")
        call[[1]] <- as.name("brlr")
        return(eval(call, parent.frame()))}
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, parent.frame()))) 
        m$data <- as.data.frame(data)
    m$start <- m$br <- m$control <- m$... <- NULL
    m[[1]] <- as.name("model.frame")
    m <- eval(m, parent.frame())
    Terms <- attr(m, "terms")
    keep.xmat <- x
    x <- model.matrix(Terms, m, contrasts)
    if (ncol(x) == 0) {  ## no estimation to do
        thecall <- match.call(expand.dots = TRUE)
        thecall[[1]] <- as.name("glm")
        return(eval(thecall, parent.frame()))} 
    xmax <- apply(abs(x), 2, max)
    x.unscaled <- x
    x <- sweep(x, 2, xmax, "/")
    xvars <- as.character(attr(Terms, "variables"))[-1]
    if ((yvar <- attr(Terms, "response")) > 0) 
        xvars <- xvars[-yvar]
    xlev <- if (length(xvars) > 0) {
        xlev <- lapply(m[xvars], levels)
        xlev[!sapply(xlev, is.null)]
    }
    wt <- model.extract(m, weights)
    n <- nrow(x)
    if (!length(wt)) 
        wt <- rep(1, n)
    offset <- model.extract(m, offset)
    if (length(offset) <= 1) 
        offset. <- rep(0, n)
    y <- model.extract(m, response)
    denom.adj <- denom <- rep(1, n)
    if (is.factor(y) && nlevels(y) == 2) 
        y <- as.numeric(y) - 1
    if (is.matrix(y) && ncol(y) == 2 && is.numeric(y)) {
        denom <- as.vector(apply(y, 1, sum))
        denom.adj <- denom + (denom < 0.01)
        y <- as.vector(y[, 1])
    }
    ow <- options("warn")[[1]]
    options(warn = -1)
    fit <- glm.fit(x, y/denom.adj, wt * denom, family = binomial(), 
                   offset = offset.,
                   control = glm.control(maxit = 1))
    pr <- fit$fitted
    eta <- qlogis(pr) - offset.
    w <- wt * denom * pr * (1 - pr)
    leverage <- hat(sweep(x, 1, sqrt(w), "*"), intercept = FALSE)
    z <- eta + (y + leverage/2 - (denom + leverage) * pr)/w
    fit <- lm.wfit(x, z, w)
    options(warn = ow)
    est.start <- fit$coefficients
    resdf <- fit$df.residual
    nulldf <- fit$df.null
    if (missing(start)) start <- est.start
    redundant <- is.na(est.start)
    xstored <- x
    xmax.stored <- xmax
    if (any(redundant)){
        x <- x[, -which(redundant)]
        xmax <- xmax[-which(redundant)]
        start <- start[-which(redundant)]}
    fstart <- fmin(start)
    parscale <- fstart/(1e-8 + abs(fstart -
                     sapply(seq(along = start), function(r) {
                           fmin(start + (seq(along = start) == r))}
                            )))
    control <- c(control, list(parscale = parscale, fnscale = abs(fstart)))
    res <- optim(start, fmin, gmin,
                 method = "BFGS",
                 control = control)
    beta <- res$par/xmax
    x <- sweep(x, 2, xmax, "*")
    penalized.deviance <- NULL
    if (br) {
        penalized.deviance <- 2 * fmin(beta)
        br <- FALSE
        deviance <- 2 * fmin(beta)
        br <- TRUE
    }
    else deviance <- 2 * fmin(beta)
    niter <- c(f.evals = res$counts[1],
               g.evals = res$counts[2])
    names(beta) <- colnames(x)
    eta <- as.vector(x %*% beta)
    lp <- offset. + eta
    pr <- plogis(lp)
    convergence <- if (res$convergence == 0) 
        TRUE
    else res$convergence
    h <- hat(sweep(x, 1, sqrt(wt * denom * pr * (1 - pr)), "*"), 
             intercept = FALSE)
    coefs <- est.start
    coefs[!is.na(coefs)] <- beta
    fit <- list(coefficients = coefs,
                deviance = deviance,
                penalized.deviance = penalized.deviance, 
                fitted.values = pr,
                linear.predictors = lp,
                call = match.call(), 
                formula = formula,
                convergence = convergence, 
                niter = niter,
                df.residual = resdf,
                df.null = nulldf, 
                model = m,
                y = y/denom,
                family = binomial(),
                offset = offset, 
                prior.weights = wt * denom,
                weights = wt * denom * pr * (1 - pr),
                terms = Terms,
                dispersion = dispersion, 
                bias.reduction = br,
                leverages = h,
                control = control)
    class(fit) <- c("brlr", "glm", "lm")
    W <- fit$weights
    fit$qr <- qr(model.matrix(fit) * sqrt(W))
    fit$rank <- fit$qr$rank
    fit$FisherInfo <- t(x) %*% sweep(x, 1, W, "*")
    attr(fit, "na.message") <- attr(m, "na.message")
    if (!is.null(attr(m, "na.action"))) 
        fit$na.action <- attr(m, "na.action")
    fit$contrasts <- attr(x.unscaled, "contrasts")
    fit$xlevels <- xlev
    if (missing(data)) 
        data <- environment(formula)
    fit$data <- data
    fit$boundary <- FALSE
    fit$residuals <- (y - pr*denom)/(denom*pr*(1-pr))
    if (keep.xmat) fit$x <- x.unscaled
    fit
}

vcov.brlr <- function (object, ...) 
{
    structure(
        object$dispersion * chol2inv(chol(object$FisherInfo)),
        dimnames = dimnames(object$FisherInfo))
}

print.brlr <-
    function (x, digits = max(3, getOption("digits") - 3),
              na.print = "", 
              ...) 
{
    if (!is.null(cl <- x$call)) {
        cat("Call:  ")
        dput(cl)
    }
    if (length(coef(x))) {
        cat("\nCoefficients:\n")
        print(coef(x), digits = digits, ...)
    }
    else {
        cat("\nNo coefficients\n")
    }
    cat("\nDeviance:",
        format(round(x$deviance, digits), nsmall = 2), 
        "\n")
    if (x$bias.reduction) {
        cat("Penalized deviance:",
            format(round(x$penalized.deviance, digits), nsmall = 2),
            "\n")}
    cat("Residual df:", x$df.residual, "\n")
    invisible(x)
}

summary.brlr <-
function (object, dispersion = NULL,
          digits = max(3, .Options$digits - 3), ...) 
{
    cc <- coef(object)
    object$pc <- pc <- length(coef(object))
    coef <- matrix(0, pc, 3, dimnames = list(names(cc),
                     c("Value", "Std. Error", "t value")))
    coef[, 1] <- cc
    vc <- vcov.brlr(object)
    if (is.null(dispersion)) 
        dispersion <- object$dispersion
    else vc <- vc * dispersion/(object$dispersion)
    sd <- cc
    sd[!is.na(cc)] <- sqrt(diag(vc))
    coef[, 2] <- sd
    coef[, 3] <- coef[, 1]/coef[, 2]
    object$coefficients <- coef
    object$digits <- digits
    class(object) <- "summary.brlr"
    object
}

print.summary.brlr <-
    function (x, digits = x$digits, ...) 
{
    if (!is.null(cl <- x$call)) {
        cat("Call:\n")
        dput(cl)
    }
    coef <- format(round(x$coefficients, digits = digits))
    pc <- x$pc
    if (pc > 0) {
        cat("\nCoefficients:\n")
        print(coef[seq(len = pc), ], quote = FALSE, ...)
    }
    else {
        cat("\nNo coefficients\n")
    }
    cat("\nDeviance:",
        format(round(x$deviance, digits), nsmall = 2), 
        "\n")
    if (x$bias.reduction) {
        cat("Penalized deviance:",
            format(round(x$penalized.deviance, digits), nsmall = 2),
            "\n")}
    cat("Residual df:", x$df.residual, "\n")
    invisible(x)
}

predict.brlr <-
    function (object, newdata = NULL, type = c("link", "response"), 
              dispersion = NULL, terms = NULL, ...) 
{
    type <- match.arg(type)
    na.act <- object$na.action
    object$na.action <- NULL
    if (missing(newdata)) {
        pred <- switch(type, link = object$linear.predictors, 
                       response = object$fitted)
        if (!is.null(na.act)) 
            pred <- napredict(na.act, pred)
    }
    else {
        newdata <- as.data.frame(newdata)
        Terms <- delete.response(object$terms)
        m <- model.frame(Terms, newdata, na.action = function(x) x, 
                         xlev = object$xlevels)
        X <- model.matrix(Terms, m, contrasts = object$contrasts)
        offset <- if (!is.null(off.num <- attr(Terms, "offset"))) 
            eval(attr(Terms, "variables")[[off.num + 1]], newdata)
        else if (!is.null(object$offset)) 
            eval(object$call$offset, newdata)
        pred <- offset + drop(X %*% object$coef)
        switch(type, response = {
            pred <- plogis(pred)
        }, link = )
    }
    pred
}
"drop1.brlr" <-
    function (object, scope, scale = 0, test = c("none", "Chisq", 
                                        "F"), k = 2, ...) 
{
    x <- model.matrix(object)
    n <- nrow(x)
    asgn <- attr(x, "assign")
    tl <- attr(object$terms, "term.labels")
    if (missing(scope)) 
        scope <- drop.scope(object)
    else {
        if (!is.character(scope)) 
            scope <- attr(terms(update.formula(object, scope)), 
                          "term.labels")
        if (!all(match(scope, tl, FALSE))) 
            stop("scope is not a subset of term labels")
    }
    ndrop <- match(scope, tl)
    ns <- length(scope)
    rdf <- object$df.resid
    chisq <- object$deviance
    dfs <- numeric(ns)
    dev <- numeric(ns)
    y <- object$y
    if (is.null(y)) 
        y <- model.response(model.frame(object), "numeric")
    wt <- object$prior.weights
    if (is.null(wt)) 
        wt <- rep.int(1, n)
    y <- cbind(y*wt, (1-y)*wt)
    for (i in 1:ns) {
        ii <- seq(along = asgn)[asgn == ndrop[i]]
        jj <- setdiff(seq(ncol(x)), ii)
        xi <- x[, jj, drop = FALSE]
        z <- brlr(y ~ 0 + xi, offset = object$offset,
                  br = object$bias.reduction,
                  control = object$control)
        dfs[i] <- z$rank
        dev[i] <- z$deviance
    }
    scope <- c("<none>", scope)
    dfs <- c(object$rank, dfs)
    dev <- c(chisq, dev)
    dispersion <- if (is.null(scale) || scale == 0) 
        summary(object, dispersion = NULL)$dispersion
    else scale
    fam <- object$family$family
    loglik <- if (fam == "gaussian") {
        if (scale > 0) 
            dev/scale - n
        else n * log(dev/n)
    }
    else dev/dispersion
    aic <- loglik + k * dfs
    dfs <- dfs[1] - dfs
    dfs[1] <- NA
    aic <- aic + (extractAIC(object, k = k)[2] - aic[1])
    aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic, row.names = scope, 
                      check.names = FALSE)
    if (all(is.na(aic))) 
        aod <- aod[, -3]
    test <- match.arg(test)
    if (test == "Chisq") {
        dev <- pmax(0, loglik - loglik[1])
        dev[1] <- NA
        nas <- !is.na(dev)
        LRT <- if (dispersion == 1) 
            "LRT"
        else "scaled dev."
        aod[, LRT] <- dev
        dev[nas] <- pchisq(dev[nas], aod$Df[nas], lower.tail = FALSE)
        aod[, "Pr(Chi)"] <- dev
    }
    else if (test == "F") {
        if (fam == "binomial" || fam == "poisson") 
            warning(paste("F test assumes quasi", fam, " family", 
                          sep = ""))
        dev <- aod$Deviance
        rms <- dev[1]/rdf
        dev <- pmax(0, dev - dev[1])
        dfs <- aod$Df
        rdf <- object$df.residual
        Fs <- (dev/dfs)/rms
        Fs[dfs < 1e-04] <- NA
        P <- Fs
        nas <- !is.na(Fs)
        P[nas] <- pf(Fs[nas], dfs[nas], rdf, lower.tail = FALSE)
        aod[, c("F value", "Pr(F)")] <- list(Fs, P)
    }
    head <- c("Single term deletions", "\nModel:", deparse(as.vector(formula(object))), 
              if (!is.null(scale) && scale > 0) paste("\nscale: ", 
                                                      format(scale), "\n"))
    class(aod) <- c("anova", "data.frame")
    attr(aod, "heading") <- head
    aod
}
