R/print.boot.R

In femiguez/nlraa: Nonlinear Regression for Agricultural Applications

#' @title Print an object of class \code{\link[boot]{boot}}
#' @name print_boot
#' @description This is a copy of boot::print.boot
#' @param x A bootstrap output object of class \code{\link[boot]{boot}} generated by one of the bootstrap functions.
#' @param digits The number of digits to be printed in the summary statistics.
#' @param index Indices indicating for which elements of the bootstrap output summary statistics are required.
#' @param ... further arguments passed to or from other methods.
#' @author Brian Ripley with a bug fix by John Nash

print_boot <- function(x, digits = getOption("digits"),
                          index = 1L:ncol(boot.out$t), ...)
{
#
# Print the output of a bootstrap
#
    boot.out <- x
    sim <- boot.out$sim
    cl <- boot.out$call
    t <- matrix(boot.out$t[, index], nrow = nrow(boot.out$t))
    allNA <- apply(t,2L,function(t) all(is.na(t)))
    ind1 <- index[allNA]
    index <- index[!allNA]
    t <- matrix(t[, !allNA], nrow = nrow(t))
    cat("boot.out$t0:")
    print(boot.out$t0)
    rn <- paste("t",index,"*",sep="")
    rn<-names(boot.out$t0)
    if (length(index) == 0L)
        op <- NULL
    else if (is.null(t0 <- boot.out$t0)) {
        if (is.null(boot.out$call$weights))
            op <- cbind(apply(t,2L,mean,na.rm=TRUE),
                        sqrt(apply(t,2L,function(t.st) var(t.st[!is.na(t.st)]))))
        else {
            op <- NULL
            for (i in index)
                op <- rbind(op, imp.moments(boot.out,index=i)$rat)
            op[,2L] <- sqrt(op[,2])
        }
        dimnames(op) <- list(rn,c("mean", "std. error"))
    }
    else {
        t0 <- boot.out$t0[index]
        if (is.null(boot.out$call$weights)) {
            op <- cbind(t0,apply(t,2L,mean,na.rm=TRUE)-t0,
                        sqrt(apply(t,2L,function(t.st) var(t.st[!is.na(t.st)]))))
            dimnames(op) <- list(rn, c("original"," bias  "," std. error"))
        }
        else {
            op <- NULL
            for (i in index)
                op <- rbind(op, imp.moments(boot.out,index=i)$rat)
            op <- cbind(t0,op[,1L]-t0,sqrt(op[,2L]),
                        apply(t,2L,mean,na.rm=TRUE))
            dimnames(op) <- list(rn,c("original", " bias  ",
                                      " std. error", " mean(t*)"))
        }
    }
    type <- find_type(boot.out)
    if (type == "boot") {
        if (sim == "parametric")
            cat("\nPARAMETRIC BOOTSTRAP\n\n")
        else if (sim == "antithetic") {
            if (is.null(cl$strata))
                cat("\nANTITHETIC BOOTSTRAP\n\n")
            else
                cat("\nSTRATIFIED ANTITHETIC BOOTSTRAP\n\n")
        }
        else if (sim == "permutation") {
            if (is.null(cl$strata))
                cat("\nDATA PERMUTATION\n\n")
            else
                cat("\nSTRATIFIED DATA PERMUTATION\n\n")
        }
        else if (sim == "balanced") {
            if (is.null(cl$strata) && is.null(cl$weights))
                cat("\nBALANCED BOOTSTRAP\n\n")
            else if (is.null(cl$strata))
                cat("\nBALANCED WEIGHTED BOOTSTRAP\n\n")
            else if (is.null(cl$weights))
                cat("\nSTRATIFIED BALANCED BOOTSTRAP\n\n")
            else
                cat("\nSTRATIFIED WEIGHTED BALANCED BOOTSTRAP\n\n")
        }
        else {
            if (is.null(cl$strata) && is.null(cl$weights))
                cat("\nORDINARY NONPARAMETRIC BOOTSTRAP\n\n")
            else if (is.null(cl$strata))
                cat("\nWEIGHTED BOOTSTRAP\n\n")
            else if (is.null(cl$weights))
                cat("\nSTRATIFIED BOOTSTRAP\n\n")
            else
                cat("\nSTRATIFIED WEIGHTED BOOTSTRAP\n\n")
        }
    }
    else if (type == "tilt.boot") {
        R <- boot.out$R
        th <- boot.out$theta
        if (sim == "balanced")
            cat("\nBALANCED TILTED BOOTSTRAP\n\n")
        else	cat("\nTILTED BOOTSTRAP\n\n")
        if ((R[1L] == 0) || is.null(cl$tilt) || eval(cl$tilt))
            cat("Exponential tilting used\n")
        else	cat("Frequency Smoothing used\n")
        i1 <- 1
        if (boot.out$R[1L]>0)
            cat(paste("First",R[1L],"replicates untilted,\n"))
        else {
            cat(paste("First ",R[2L]," replicates tilted to ",
                      signif(th[1L],4),",\n",sep=""))
            i1 <- 2
        }
        if (i1 <= length(th)) {
            for (j in i1:length(th))
                cat(paste("Next ",R[j+1L]," replicates tilted to ",
                          signif(th[j],4L),
                          ifelse(j!=length(th),",\n",".\n"),sep=""))
        }
        op <- op[, 1L:3L]
    }
    else if (type == "tsboot") {
        if (!is.null(cl$indices))
            cat("\nTIME SERIES BOOTSTRAP USING SUPPLIED INDICES\n\n")
        else if (sim == "model")
            cat("\nMODEL BASED BOOTSTRAP FOR TIME SERIES\n\n")
        else if (sim == "scramble") {
            cat("\nPHASE SCRAMBLED BOOTSTRAP FOR TIME SERIES\n\n")
            if (boot.out$norm)
                cat("Normal margins used.\n")
            else
                cat("Observed margins used.\n")
        }
        else if (sim == "geom") {
            if (is.null(cl$ran.gen))
                cat("\nSTATIONARY BOOTSTRAP FOR TIME SERIES\n\n")
            else
                cat(paste("\nPOST-BLACKENED STATIONARY",
                          "BOOTSTRAP FOR TIME SERIES\n\n"))
            cat(paste("Average Block Length of",boot.out$l,"\n"))
        }
        else {
            if (is.null(cl$ran.gen))
                    cat("\nBLOCK BOOTSTRAP FOR TIME SERIES\n\n")
            else
                cat(paste("\nPOST-BLACKENED BLOCK",
                          "BOOTSTRAP FOR TIME SERIES\n\n"))
            cat(paste("Fixed Block Length of",boot.out$l,"\n"))
        }
    }
    else if (type == "censboot") {
        cat("\n")
        if (sim == "weird") {
            if (!is.null(cl$strata)) cat("STRATIFIED ")
            cat("WEIRD BOOTSTRAP FOR CENSORED DATA\n\n")
        }
        else if ((sim == "ordinary") ||
                 ((sim == "model") && is.null(boot.out$cox))) {
            if (!is.null(cl$strata)) cat("STRATIFIED ")
            cat("CASE RESAMPLING BOOTSTRAP FOR CENSORED DATA\n\n")
        }
        else if (sim == "model") {
            if (!is.null(cl$strata)) cat("STRATIFIED ")
            cat("MODEL BASED BOOTSTRAP FOR COX REGRESSION MODEL\n\n")
        }
        else if (sim == "cond") {
            if (!is.null(cl$strata)) cat("STRATIFIED ")
            cat("CONDITIONAL BOOTSTRAP ")
            if (is.null(boot.out$cox))
                cat("FOR CENSORED DATA\n\n")
            else
                cat("FOR COX REGRESSION MODEL\n\n")
        }
    } else warning('unknown type of "boot" object')
    cat("\nCall:\n")
    dput(cl, control=NULL)
    cat("\n\nBootstrap Statistics :\n")
    if (!is.null(op)) print(op,digits=digits)
    if (length(ind1) > 0L)
        for (j in ind1)
            cat(paste("WARNING: All values of t", j, "* are NA\n", sep=""))
    invisible(boot.out)
}

find_type<- function(boot.out)
{
  if(is.null(type <- attr(boot.out, "boot_type")))
    type <- sub("^boot::", "", deparse(boot.out$call[[1L]]))
  type
}