.packageName <- "bootstrap"
"abcnon" <-
function(x, tt,  epsilon = 0.001, alpha = c(.025,.05,.1,.16,.84,.9,.95,.975))
{
call <- match.call()
#abc confidence intervals for nonparametric problems

#tt(P ,x) is statistic in resampling form, where P[i] is weight on x[i]

        if(is.matrix(x)) {n <- nrow(x)} else {n <- length(x)}

	ep <- epsilon/n; I<- diag(n); P0<- rep(1/n,n)
	t0 <- tt(P0,x)	
#calculate t. and t..  .................................................
	t. <- t.. <- numeric(n)
	for(i in 1:n) {  di <- I[i,  ] - P0
			 tp <- tt(P0 + ep * di,x)
			 tm <- tt(P0 - ep * di,x)
			 t.[i] <- (tp - tm)/(2 * ep)
			 t..[i] <- (tp - 2 * t0 + tm)/ep^2}
#calculate sighat,a,z0,and cq ..........................................
	sighat <- sqrt(sum(t.^2))/n
	a <- (sum(t.^3))/(6 * n^3 * sighat^3)	
	delta <- t./(n^2 * sighat)
	cq <- (tt(P0+ep*delta,x) -2*t0 + tt(P0-ep*delta,x))/(2*sighat*ep^2)
	bhat <- sum(t..)/(2 * n^2)
	curv <- bhat/sighat - cq
	z0 <- qnorm(2 * pnorm(a) * pnorm( - curv))	
#calculate interval endpoints............................................
	Z <- z0 + qnorm(alpha)
	za <- Z/(1 - a * Z)^2
	stan <- t0 + sighat * qnorm(alpha)
	abc <- seq(alpha)
        pp <- matrix(0,nrow=n,ncol=length(alpha))
	for(i in seq(alpha)) {abc[i] <- tt(P0 + za[i] * delta,x)
                              pp[,i] <- P0 + za[i] * delta
       }
	limits <- cbind(alpha, abc, stan)
        dimnames(limits)[[2]] <- c("alpha", "abc", "stan")
#output in list form.....................................................
        return(list(limits=limits, 
                    stats=list(t0=t0,sighat=sighat,bhat=bhat), 
                    constants=list(a=a,z0=z0,cq=cq), 
                    tt.inf=t., 
                    pp=pp, 
                    call=call))
}
"abcpar" <- function(y, tt, S, etahat, mu, n=rep(1,length(y)), lambda =
                     0.001, alpha = c(0.025, 0.05, 0.1, 0.16))
{
    call <- match.call()
    syscall <- sys.call()
    p <- length(y)
    I <- diag(p)
    ## calculate thetahat,ehat,dhat, and sighat
    thetahat <- tt(y)
    ehat <- numeric()
    for(j in 1:p) {
        lam <- lambda * S[j, j]^0.5
        delta <- I[, j]
        ehat[j] <- (tt(y + lam * delta) - tt(y - lam * delta))/(2 * lam)
    }
    dhat <- as.vector(S %*% ehat)
    sighat <- sqrt(ehat %*% S %*% ehat)
    ##  calculate acceleration a
    lam <- lambda/sighat
    a0 <- sum(ehat * mu(etahat,n))
    a1 <- sum(ehat * mu(etahat + lam * ehat,n))
    a2 <- sum(ehat * mu(etahat - lam * ehat,n))
    a <- (a1 - 2 * a0 + a2)/(lam^2 * 6 * sighat^3)
    ## calculate bias bhat
    bvec <- numeric(p)
    eig <- eigen(S)
    evals <- (eig$values)^0.5
    evecs <- (eig$vectors)
    for(j in 1:p) {
        b1 <- tt(y + lambda * evals[j] * evecs[, j])
        b2 <- tt(y - lambda * evals[j] * evecs[, j])
        bvec[j] <- (b1 - 2 * thetahat + b2)/lambda^2
    }
    bhat <- sum(bvec)/2
    ## calculate quadratic coefficient cq
    delta <- dhat/sighat
    cq <- (tt(y + lambda * delta) - 2 * thetahat
           + tt(y - lambda * delta)) / (2 * sighat * lambda^2)
    ## calculate bias-correction constant z0
    curv <- bhat/sighat - cq
    z0 <- qnorm(2 * pnorm(a) * pnorm( - curv))	
    ## calculate Standard,ABC, and ABCq limits
    al <- c(alpha, rev(1 - alpha))
    za <- qnorm(al)
    z0a <- (z0 + za)/(1 - a * (z0 + za))
    z1a <- z0a + a * z0a^2	#   calculate endpoints
    standard <- thetahat + sighat * za
    ABC <- numeric(length(za))
    for(j in 1:length(za))
        ABC[j] <- tt(y + delta * z1a[j])
    ABCquad <- thetahat + sighat * (z1a + cq * z1a^2)
    limits <- cbind(al, ABC, ABCquad, standard)
    dimnames(limits) <- list(NULL, c("alpha", "ABC", "ABCquad",
                                     "Standard"))
    ## output in list form
    vl <- list(sys = syscall, 
              limits = limits, 
              stats =
                   list(thetahat=thetahat, sighat=sighat, bhat=bhat),
              constants = list(a=a, z0=z0, cq=cq),
              asym.05 = c(2 * a * 1.645, z0/1.645, cq * 1.645),
              call=call)
    vl$dhat <- dhat
    vl$ehat <- ehat
    return(vl)
}
"bcanon" <- function(x,nboot,theta,...,alpha =
                     c(.025,.05,.1,.16,.84,.9,.95,.975)) { 

    call <- match.call()
    n <- length(x)
    thetahat <- theta(x,...)
    bootsam<- matrix(sample(x,size=n*nboot,replace=TRUE),nrow=nboot)

    thetastar <- apply(bootsam,1,theta,...)
    z0 <- qnorm(sum(thetastar<thetahat)/nboot)
    
    u <- rep(0,n)
    for(i in 1:n){
        u[i] <- theta(x[-i],...)
    }
    uu <- mean(u)-u
    acc <- sum(uu*uu*uu)/(6*(sum(uu*uu))^1.5)
    
    zalpha <- qnorm(alpha)
    
    tt <- pnorm(z0+ (z0+zalpha)/(1-acc*(z0+zalpha)))
    ooo <- trunc(tt*nboot)
    confpoints <- sort(thetastar)[ooo]
    confpoints <- cbind(alpha,confpoints)
    dimnames(confpoints)[[2]] <- c("alpha","bca point")
    return(list(confpoints=confpoints, 
                z0=z0, 
                acc=acc, 
                u=u, 
                call=call))
}
"bootpred" <- function(x,y,nboot,theta.fit,theta.predict,err.meas,...) {
    call <- match.call()
    x <- as.matrix(x)
    n <- length(y)
    saveii <- NULL
    fit0 <- theta.fit(x,y,...)
    yhat0 <- theta.predict(fit0,x)
    app.err <- mean(err.meas(y,yhat0))
    err1 <- matrix(0,nrow=nboot,ncol=n)
    err2 <- rep(0,nboot)
    for(b in 1:nboot){
        ii <- sample(1:n,replace = TRUE)
        saveii <- cbind(saveii,ii)
        fit <- theta.fit(x[ii,],y[ii],...)
        yhat1 <- theta.predict(fit,x[ii,])
        yhat2 <- theta.predict(fit,x)  
        err1[b,] <- err.meas(y,yhat2)
        err2[b] <- mean(err.meas(y[ii],yhat1))
    }

    optim <- mean( apply(err1,1,mean)-err2)

    junk <- function(x,i){sum(x==i)}
    e0 <- 0
    for(i in 1:n){
        o <- apply(saveii,2,junk,i)
        if( sum(o==0)==0)
            cat("increase nboot for computation of the .632 estimator",
                fill = TRUE)
        e0 <- e0+ (1/n)*sum(err1[o==0,i])/sum(o==0)
    }
    err.632 <- .368*app.err + .632*e0
    return(list(app.err, 
                optim, 
                err.632, 
                call=call))
}
"bootstrap"<- function(x,nboot,theta,...,func=NULL) {
    call <- match.call()

    n <- length(x)
    bootsam<- matrix(sample(x,size=n*nboot,replace=TRUE),nrow=nboot)
    thetastar <- apply(bootsam,1,theta,...)
    func.thetastar <- NULL; jack.boot.val <- NULL; jack.boot.se <- NULL;
    if(!is.null(func)){
        match1 <- function(bootx,x){
            duplicated(c(bootx,x))[(length(x)+1) : (2*length(x))]
        } 
        matchs <- t(apply(bootsam,1,match1,x))
        func.thetastar <- func(thetastar)
        jack.boot <- function(inout,thetastar,func){
            func(thetastar[!inout])
        }
        jack.boot.val <- apply(matchs,2,jack.boot,thetastar,func)

        if(sum(is.na(jack.boot.val)>0)) {
            cat("At least one jackknife influence value for func(theta) is   undefined", 
                                   fill=TRUE)
            cat(" Increase nboot and try again",fill=TRUE)
            return()
        }

        if( sum(is.na(jack.boot.val))==0) {
            jack.boot.se <- sqrt( ((n-1)/n)*sum( (jack.boot.val-mean(jack.boot.val))^2 )  )

        }
    }

    return(list(thetastar=thetastar, func.thetastar=func.thetastar,
               jack.boot.val=jack.boot.val, jack.boot.se=jack.boot.se,
               call=call))
}
"boott"<- function(x,theta,...,sdfun=sdfunboot,nbootsd=25,nboott=200,
		   VS=FALSE, v.nbootg=100,v.nbootsd=25,v.nboott=200,
		   perc=c(.001,.01,.025,.05,.10,.50,.90,.95,.975,.99,.999)){

    call <- match.call()
    sdfunboot <- function(x,nboot,theta,...){
        n <- length(x)
        junk <- matrix(sample(x,size=n*nboot,replace=TRUE),nrow=nboot)
        return(sqrt(var(apply(junk,1,theta,...))))
    }

    thetahat<- theta(x,...)
    n <- length(x)
    if(!VS) {sd <- sdfun(x,nbootsd,theta,...)} else {sd <- 1}
    
    if(VS){
        xstar <- matrix(sample(x,size=n*v.nbootg,replace=TRUE),
                        nrow=v.nbootg)
        thetastar0 <- apply(xstar,1,theta,...)
        sdstar0 <- apply(xstar,1,sdfun,v.nbootsd,theta,...)
        o <- order(thetastar0)
        thetastar0 <- thetastar0[o]
        sdstar0 <- sdstar0[o]
        
        temp <- lowess(thetastar0,log(sdstar0))$y
        
        sdstar0 <- exp(temp)
        invsdstar0 <- 1/sdstar0
        g <- ctsub(thetastar0,invsdstar0,thetastar0)
        g <- (g-mean(g))/sqrt(var(g))
        g <- g*sqrt(var(thetastar0))+mean(thetastar0)
    }

    if(!VS) { thetastar0 <- NULL; g  <-  NULL}

    if(!VS) {
        xstar <- matrix(sample(x,n*nboott,replace=TRUE),nrow=nboott)
    } else {
        xstar <- matrix(sample(x,n*v.nboott,replace=TRUE),nrow=v.nboott)
    }
    thetastar <- apply(xstar,1,theta,...)
    gthetastar <- rep(0,length(thetastar))
    
    if(VS) {
        gthetahat <- yinter(thetastar0,g,thetahat)
    } else {
        gthetahat <- thetahat
    }
    
    if(VS){
        for(i in 1:length(thetastar)){
            gthetastar[i] <- yinter(thetastar0,g,thetastar[i])
        }
    }
    else {
        gthetastar <- thetastar
    }
  
    if(!VS) {
        sdstar <- apply(xstar,1,sdfun,nbootsd,theta,...)
    } else {
        sdstar <- 1
    }
  
    tstar <- sort( (gthetastar-gthetahat)/sdstar)[length(gthetastar):1]

    ans <-  gthetahat-sd*tstar

    if(VS){
        for(i in 1:length(ans)) {
            ans[i] <- xinter(thetastar0,g,ans[i])
        }
    }

    o <- trunc(length(ans)* perc)+1
  
    ans1 <- matrix(ans[o],nrow=1)

    dimnames(ans1) <- list(NULL,perc)

    return(list(confpoints=ans1,
                theta=thetastar0,
                g=g,
                call=call))
}
"crossval"<- function(x,y,theta.fit,theta.predict,...,ngroup=n){
    call <- match.call()
    x <- as.matrix(x)
    n <- length(y)
    ngroup <- trunc(ngroup)
    if( ngroup < 2){
        stop ("ngroup should be greater than or equal to 2")
    }
    if(ngroup > n){
        stop ("ngroup should be less than or equal to the number of observations")
    }
  
    if(ngroup==n) {groups <- 1:n; leave.out <- 1}
    if(ngroup<n){
        leave.out <- trunc(n/ngroup);
        o <- sample(1:n)
        groups <- vector("list",ngroup)
        for(j in 1:(ngroup-1)){
            jj <- (1+(j-1)*leave.out)
            groups[[j]] <- (o[jj:(jj+leave.out-1)])
        }
        groups[[ngroup]] <- o[(1+(ngroup-1)*leave.out):n]
    }
    u <- vector("list",ngroup)
    cv.fit <- rep(NA,n)
    for(j in 1:ngroup){
        u <- theta.fit(x[-groups[[j]], ],y[-groups[[j]]],...)
        cv.fit[groups[[j]]] <-  theta.predict(u,x[groups[[j]],])
        
    }
  
    if(leave.out==1) groups <- NULL
    return(list(cv.fit=cv.fit, 
                ngroup=ngroup, 
                leave.out=leave.out,
                groups=groups, 
                call=call)) 
}
"ctsub"<-
function(x, y, z)
{
    ##
    ## for function defined by (x(1),y(1))...(x(n),y(n)), compute
    ## integral from 0 to z(i) and put it in ans(i), for i=1,2,..n
    ## uses the trapezoid rule
    ##
    ## used by boott
    
    n <- length(z)
    ans <- rep(0,n)
    for(i in 1:n)
    {
        if(z[i]<= x[1]) {ans[i] <- (z[i]-x[1])*y[1]}
        else {
            j <- 1
            ans[i] <- 0
            while((j<=n) & (z[i]>x[j]) ){
                if(j > 1){
                    ans[i] <- ans[i]+(x[j]-x[j-1])*(y[j]+y[j-1])/2
                }
                j <- j+1
            }
            if(z[i] <= x[n]){
                ans[i] <-
                    ans[i]+.5*(z[i]-x[j-1])*(2*y[j-1]+(z[i]-x[j-1])*(y[j]-y[j-1])/(x[j]-x[j-1])) 
            }
            else { ans[i] <- ans[i]+(z[i]-x[n])*y[n] }
        }
    }
    
    return(ans)
}
"ctsub"<-
  function(x, y, z)
{
  junk <- .Fortran("ctsub",
		   length(x),
		   as.double(x),
		   as.double(y),
		   as.double(z),
		   ans=double(length(x)),
                   PACKAGE = "bootstrap")
  return(junk$ans)
}
"jackknife"<-
function(x, theta, ...)
{
    call <- match.call()
    n <- length(x)
    u <- rep(0, n)
    for(i in 1:n) {
        u[i] <- theta(x[ - i], ...)
    }
    thetahat <- theta(x, ...)
    jack.bias <- (n - 1) * (mean(u) - thetahat)
    jack.se <- sqrt(((n - 1)/n) * sum((u - mean(u))^2))
    return(list(jack.se=jack.se, 
                jack.bias=jack.bias, 
                jack.values = u, 
                call=call))
}
"xinter"<-
function(x, y, z, increasing = TRUE)
{
    ## for function defined by (x(i),y(i)), i=1,...n, interpolate x
    ## value at z
    if(increasing == FALSE) {
        x <- -1 * x
        x <- x[length(x):1]
        y <- y[length(y):1]
    }
    
    n <- length(x)

    if (z <= y[1]) {
        ii <- 1;jj <- 2;while(x[jj]==x[ii]) {jj <- jj+1;}}
    else if (z >= y[n]) {
        jj <- n;ii <- n-1;while(x[ii]==x[jj]) {ii <- ii-1;}}
    else {
        ii <- 1;                                                             
        while( (!((y[ii] <= z) & (z <= y[ii+1])))                
              &
              (!((y[ii]>= z) & (z>= y[ii+1])))  )   
        {ii <- ii+1;}                                             
        jj <- ii+1;                                                           
    }                                                                   
    if (x[ii]==x[jj]) {result <- (x[ii])}  else 
    if ((y[ii]==y[jj]) & (z <= y[1]))
    {result <- x[1];} else 
    if ((y[ii]==y[jj]) & (z >= y[n]))
    {result <- x[n];} else 
     if (y[ii]==y[jj]) {result <- (x[ii]+x[jj])/2;} else 
         {slope <- (y[jj]-y[ii])/(x[jj]-x[ii]);
          result <- x[ii]+(z-y[ii])/slope;
      }
    
    if(increasing == FALSE) {
        result <- -1 * result
    }
    return(result)
}
"xinter"<-
  function(x, y, z, increasing = TRUE)
{
    
    if(increasing == FALSE) {
        x <- -1 * x
        x <- x[length(x):1]
        y <- y[length(y):1]
    }
    zz <- .Fortran("xinter",
                   as.double(x),
                   as.double(y),
                   length(x),
                   as.double(z),
                   result = double(1),
                   PACKAGE = "bootstrap")
    if(increasing == FALSE) {
        zz$result <- -1 * zz$result
    }
    return(zz$result)
}

"yinter"<-
function(x, y, z, increasing = TRUE)
{
    ## for function defined by (x(i),y(i)), i=1,...n, interpolate y
    ## value at z
    ##
    ## used by boott
    
    if(increasing == FALSE) {
        x <- -1 * x
        x <- x[length(x):1]
        y <- y[length(y):1]
        z <- -1 * z
    }
    n <- length(x)
    if (z <= x[1]) {
        ii <- 1;jj <- 2;while ( y[jj]==y[ii]) {jj <- jj+1;}
    }
    else if (z>=x[n]) {
        jj <- n;ii <- n-1;while ( y[ii]==y[jj]) {ii <- ii-1;}
    }
    else {ii <- 1;
          while  (!((x[ii] <= z) & (z <= x[ii+1])))
          {ii <- ii+1;}
          jj <- ii+1;
      }
    if (x[ii]==x[jj]) {result <- (y[ii]+y[jj])/2;}
    else {slope <- (y[jj]-y[ii])/(x[jj]-x[ii]);
          result <- y[ii]+slope*(z-x[ii]);
      }
    
    return(result)
}
"yinter"<-
  function(x, y, z, increasing = TRUE)
{
    if(increasing == FALSE) {
        x <- -1 * x
        x <- x[length(x):1]
        y <- y[length(y):1]
        z <- -1 * z
    }
    zz <- .Fortran("yinter",
                   as.double(x),
                   as.double(y),
                   length(x),
                   as.double(z),
                   result = double(1),
                   PACKAGE = "bootstrap")
    return(zz$result)
}
.First.lib <- function(lib, pkg)
{
    library.dynam("bootstrap", pkg, lib)
}
