"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(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=T),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(confpoints, z0, acc, 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=T)
  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=T)
 e0_e0+ (1/n)*sum(err1[o==0,i])/sum(o==0)
}
err.632_.368*app.err + .632*e0
return(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=T),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=T)
   cat(" Increase nboot and try again",fill=T)
  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(thetastar,func.thetastar,jack.boot.val, jack.boot.se, call=call)

 
}
"boott"<- function(x,theta,...,sdfun=sdfunboot,nbootsd=25,nboott=200,
		   VS=F, 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=T),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=T),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=T),nrow=nboott)}
       else{xstar_matrix(sample(x,n*v.nboott,replace=T),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(confpoints=ans1,theta=thetastar0,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( 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)
}
library.dynam("bootstrap.so")

"ctsub"<-
  function(x, y, z)
{
  junk <- .Fortran("ctsub",
		   length(x),
		   as.double(x),
		   as.double(y),
		   as.double(z),
		   ans=double(length(x)))
  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(jack.se, jack.bias, jack.val = u, call=call)
}
"xinter"<-
function(x, y, z, increasing = T)
{
# for function defined by (x(i),y(i)), i=1,...n, interpolate x value at z
	if(increasing == F) {
		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 == F) {
		result <- -1 * result
	}
	return(result)
}
library.dynam("bootstrap.so")

"xinter"<-
  function(x, y, z, increasing = T)
{
  
  if(increasing == F) {
    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))
  if(increasing == F) {
    zz$result <- -1 * zz$result
  }
  return(zz$result)
}

"yinter"<-
function(x, y, z, increasing = T)
{
# for function defined by (x(i),y(i)), i=1,...n, interpolate y value at z
#
# used by boott
    
	if(increasing == F) {
		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)
}
library.dynam("bootstrap.so")

"yinter"<-
  function(x, y, z, increasing = T)
{
  if(increasing == F) {
    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))
  return(zz$result)
}
