.packageName <- "survey"
regTermTest<-function(model,test.terms, null=NULL){

        if(inherits(test.terms,"formula"))
            test.terms<-attr(terms(test.terms),"term.labels")
        
	tt<-attr(terms(model),"term.labels")
	aa<-attr(model.matrix(model),"assign")
        if(inherits(model,"coxph") && attr(terms(model),"intercept"))
          aa<-aa[-1]
	index<-which(aa %in% match(test.terms,tt))
        
	beta<-coef(model)[index]
        if (!is.null(NULL))
            beta<-beta-null
	V<-vcov(model)[index,index]

	chisq<-beta%*%solve(V)%*%beta
        rval<-list(call=sys.call(),mcall=model$call,chisq=chisq,
                   df=length(index),test.terms=test.terms,
                   p=pchisq(chisq,length(index),lower=FALSE))
        class(rval)<-"regTermTest"
        rval
}

print.regTermTest<-function(x,...){
       cat("Wald test for ")
       cat(x$test.terms)
       cat("\n in ")
       print(x$mcall)
       cat("Chisq = ",x$chisq," on ",x$df," df: p=",format.pval(x$p),"\n")
       invisible(NULL)
}
svydesign<-function(ids,probs=NULL,strata=NULL,variables=NULL, fpc=NULL,
                    data=NULL, nest=FALSE, check.strata=!nest,weights=NULL){

    ## less memory-hungry version for sparse tables
    interaction<-function (..., drop = TRUE) {
        args <- list(...)
        narg <- length(args)
        if (narg == 1 && is.list(args[[1]])) {
            args <- args[[1]]
            narg <- length(args)
        }
        
        ls<-sapply(args,function(a) length(levels(a)))
        ans<-do.call("paste",c(lapply(args,as.character),sep="."))
        ans<-factor(ans)
        return(ans)
        
    }


    na.failsafe<-function(object,...){
      if (NCOL(object)==0)
        object
      else na.fail(object)
    }
    
     if(inherits(ids,"formula")) {
	 mf<-substitute(model.frame(ids,data=data,na.action=na.failsafe))   
	 ids<-eval.parent(mf)
	} else if (!is.null(ids))
            ids<-na.fail(data.frame(ids))

     if(inherits(probs,"formula")){
	mf<-substitute(model.frame(probs,data=data,na.action=na.failsafe))
	probs<-eval.parent(mf)
	}
     
     if(inherits(weights,"formula")){
       mf<-substitute(model.frame(weights,data=data,na.action=na.failsafe))
       weights<-eval.parent(mf)
     } else if (!is.null(weights))
         weights<-na.fail(data.frame(weights))
     
     if(!is.null(weights)){
       if (!is.null(probs))
         stop("Can't specify both sampling weights and probabilities")
       else
         probs<-1/weights
     }

      

    if (!is.null(strata)){
      if(inherits(strata,"formula")){
        mf<-substitute(model.frame(strata,data=data, na.action=na.failsafe))
        strata<-eval.parent(mf)
      }
      if(is.list(strata))
        strata<-na.fail(do.call("interaction", strata))
      if (!is.factor(strata))
        strata<-factor(strata)
      has.strata<-TRUE
    } else {
      strata<-factor(rep(1,NROW(ids)))
      has.strata <-FALSE
    }
    
    if (inherits(variables,"formula")){
        mf<-substitute(model.frame(variables,data=data))
        variables <- eval.parent(mf)
    } else if (is.null(variables)){
        variables<-data
    } else
        variables<-data.frame(variables)

    
     if (inherits(fpc,"formula")){
       mf<-substitute(model.frame(fpc,data=data,na.action=na.failsafe))
       fpc<-eval.parent(mf)
       if (length(fpc))
         fpc<-fpc[,1]
     }
     
    if (is.null(ids) || NCOL(ids)==0)
	ids<-data.frame(.id=seq(length=NROW(variables)))

     ## force subclusters nested in clusters
     if (nest && NCOL(ids)>1){
      N<-ncol(ids)
      for(i in 2:(N)){
          ids[,i]<-do.call("interaction", ids[,1:i,drop=TRUE])
      }
    }
     ## force clusters nested in strata
     if (nest && has.strata && NCOL(ids)){
       N<-NCOL(ids)
       for(i in 1:N)
         ids[,i]<-do.call("interaction", list(strata, ids[,i]))
     }

    ## check if clusters nested in strata 
     if (check.strata && nest)
      warning("No point in check.strata=TRUE if nest=TRUE")
    if(check.strata && !is.null(strata) && NCOL(ids)){
       sc<-rowSums(table(ids[,1],strata)>0)
       if(any(sc>1)) stop("Clusters not nested in strata")
    }

    ## Put degrees of freedom (# of PSUs in each stratum) in object, to 
    ## allow subpopulations
    if (NCOL(ids)){
        nPSU<-table(strata[!duplicated(ids[,1])])
    }


     if (!is.null(fpc)){

       if (NCOL(ids)>1){
         if (all(fpc<1))
           warning("FPC is not currently supported for multi-stage sampling")
         else
           stop("Can't compute FPC from population size for multi-stage sampling")
       }
       
       ## Finite population correction: specified per observation
       if (is.numeric(fpc) && length(fpc)==NROW(variables)){
         tbl<-by(fpc,list(strata),unique)
         if (any(sapply(tbl,length)!=1))
           stop("fpc not constant within strata")
         fpc<-data.frame(strata=factor(rownames(tbl),levels=levels(strata)),
                         N=as.vector(tbl))
       }
       ## Now reduced to fpc per stratum
       nstr<-table(strata[!duplicated(ids[[1]])])
       
       if (all(fpc[,2]<=1)){
         fpc[,2]<- nstr[match(as.character(fpc[,1]), names(nstr))]/fpc[,2]
       } else if (any(fpc[,2]<nstr[match(as.character(fpc[,1]), names(nstr))]))
         stop("Over 100% sampling in some strata")
       
     }

    ## if FPC specified, but no weights, use it for weights
    if (is.null(probs) && is.null(weights) && !is.null(fpc)){
      pstr<-nstr[match(as.character(fpc[,1]), names(nstr))]/fpc[,2]
      probs<-pstr[match(as.character(strata),as.character(fpc[,1]))]
      probs<-as.vector(probs)
    }

    
    if (is.numeric(probs) && length(probs)==1)
        probs<-rep(probs, NROW(variables))
    
    if (length(probs)==0) probs<-rep(1,NROW(variables))
    
    if (NCOL(probs)==1) probs<-data.frame(probs)

    rval<-list(cluster=ids)
    rval$strata<-strata
    rval$has.strata<-has.strata
    rval$prob<- apply(probs,1,prod) 
    rval$allprob<-probs
    rval$call<-match.call()
    rval$variables<-variables
    rval$fpc<-fpc
    rval$call<-sys.call()
    rval$nPSU<-nPSU
    class(rval)<-"survey.design"
    rval
  }

print.survey.design<-function(x,varnames=FALSE,design.summaries=FALSE,...){
  n<-NROW(x$cluster)
  if (x$has.strata) cat("Stratified ")
  un<-length(unique(x$cluster[,1]))
  if(n==un){
    cat("Independent Sampling design\n")
    is.independent<-TRUE
  } else {
    cat(NCOL(x$cluster),"- level Cluster Sampling design\n")
    nn<-lapply(x$cluster,function(i) length(unique(i)))
    cat(paste("With (",paste(unlist(nn),collapse=","),") clusters.\n"))
    is.independent<-FALSE
  }
  print(x$call)
  if (design.summaries){
    cat("Probabilities:\n")
    print(summary(x$prob))
    if(x$has.strata){
      cat("Stratum sizes: \n")
      a<-rbind(obs=table(x$strata),
	       design.PSU=x$nPSU,
               actual.PSU=if(!is.independent || !is.null(x$fpc))
               table(x$strata[!duplicated(x$cluster[,1])]))
      print(a)
    }
    if (!is.null(x$fpc)){
      if (x$has.strata) {
        cat("Population stratum sizes (PSUs): \n")
        print(x$fpc)
      } else {
        cat("Population size (PSUs):",x$fpc[,2],"\n")
      }
    }
  }
  if (varnames){
    cat("Data variables:\n")
    print(names(x$variables))
  }
  invisible(x)
}

"[.survey.design"<-function (x,i, ...){
  
  if (!missing(i)){ 
    x$variables<-"[.data.frame"(x$variables,i,...,drop=FALSE)
    x$cluster<-x$cluster[i,,drop=FALSE]
    x$prob<-x$prob[i]
    x$allprob<-x$allprob[i,,drop=FALSE]
    x$strata<-x$strata[i]
  } else {
    x$variables<-x$variables[,...]
  }
  
  x
}

"[<-.survey.design"<-function(x, ...,value){
  if (inherits(value, "survey.design"))
    value<-value$variables
  x$variables[...]<-value
  x
}

dim.survey.design<-function(x,...){
	dim(x$variables)
}

na.fail.survey.design<-function(object,...){
	tmp<-na.fail(object$variables,...)
	object
}

na.omit.survey.design<-function(object,...){
  tmp<-na.omit(object$variables,...)
  omit<-attr(tmp,"na.action")
  if (length(omit)){
    object$cluster<-object$cluster[-omit,,drop=FALSE]
    object$prob<-object$prob[-omit]
    object$allprob<-object$allprob[-omit,,drop=FALSE]
    object$variables<-tmp
    attr(object,"na.action")<-omit
  }
  object
}

na.exclude.survey.design<-function(object,...){
	tmp<-na.exclude(object$variables,...)
	exclude<-attr(tmp,"na.action")
	if (length(exclude)){
	   object$cluster<-object$cluster[-exclude,,drop=FALSE]
	   object$prob<-object$prob[-exclude]
	   object$allprob<-object$allprob[-exclude,,drop=FALSE]
	   object$variables<-tmp
	   attr(object,"na.action")<-exclude
	}
	object
}


update.survey.design<-function(object,...){

  dots<-substitute(list(...))[-1]
  newnames<-names(dots)
  
  for(j in seq(along=dots)){
    object$variables[,newnames[j]]<-eval(dots[[j]],object$variables, parent.frame())
  }
  
  object$call<-sys.call()
  object 
}

subset.survey.design<-function(x,subset,...){
        e <- substitute(subset)
        r <- eval(e, x$variables, parent.frame())
        r <- r & !is.na(r) 
        x<-x[r,]
	x$call<-sys.call()
	x
}

summary.survey.design<-function(object,...){
  class(object)<-"summary.survey.design"
  object
}

print.summary.survey.design<-function(x,...){
  y<-x
  class(y)<-"survey.design"
  print(y,varnames=TRUE,design.summaries=TRUE,...)
}	
     
svyCprod<-function(x, strata, psu, fpc, nPSU,
                   lonely.psu=getOption("survey.lonely.psu")){

  x<-as.matrix(x)
  n<-NROW(x)

  ##First collapse over PSUs

  if (is.null(strata)){
    strata<-rep("1",n)
    if (!is.null(nPSU))
        names(nPSU)<-"1"
  }
  else
    strata<-as.character(strata) ##can't use factors as indices in for()'

  if (!is.null(psu)){
    x<-rowsum(x, psu, reorder=FALSE)
    strata<-strata[!duplicated(psu)]
    n<-NROW(x)
  }
  
  if (!is.null(nPSU)){
      obsn<-table(strata)
      dropped<-nPSU[match(names(obsn),names(nPSU))]-obsn
      if(sum(dropped)){
        xtra<-matrix(0,ncol=NCOL(x),nrow=sum(dropped))
        strata<-c(strata,rep(names(dropped),dropped))
      	if(is.matrix(x))
	   x<-rbind(x,xtra)
        else
	   x<-c(x,xtra)
        n<-NROW(x)
      }
  }

  if(is.null(strata)){
      x<-t(t(x)-colMeans(x))
  } else {
      strata.means<-drop(rowsum(x,strata, reorder=FALSE))/drop(rowsum(rep(1,n),strata, reorder=FALSE))
      if (!is.matrix(strata.means))
          strata.means<-matrix(strata.means, ncol=NCOL(x))
      x<- x- strata.means[ match(strata, unique(strata)),,drop=FALSE]
  }
  
  p<-NCOL(x)
  v<-matrix(0,p,p)
  
  ss<-unique(strata)
  for(s in ss){
      this.stratum <- strata %in% s
      
      ## original number of PSUs in this stratum 
      ## before missing data/subsetting
      this.n <-nPSU[match(s,names(nPSU))]
      
      this.df <- this.n/(this.n-1)	
      
      if (is.null(fpc))
          this.fpc <- 1
      else{
          this.fpc <- fpc[,2][ fpc[,1]==as.character(s)]
          this.fpc <- (this.fpc - this.n)/this.fpc
      }
      
      xs<-x[this.stratum,,drop=FALSE]
      
      ## stratum with only 1 cluster leads to undefined variance
      if (this.n==1){
          this.df<-1
          lonely.psu<-match.arg(lonely.psu, c("remove","adjust","fail","certainty"))
          if (lonely.psu=="fail")
              stop("Stratum ",s, " has only one sampling unit.")
          else if (lonely.psu!="certainty")
              warning("Stratum ",s, " has only one sampling unit.")
          if (lonely.psu=="adjust")
            xs<-strata.means[match(s,ss),,drop=FALSE]
      }
      
      ## add it up
      v<-v+crossprod(xs)*this.df*this.fpc
  }
  v
}


svymean<-function(x,design, na.rm=FALSE,deff=FALSE){

  if (!inherits(design,"survey.design"))
    stop("design is not a survey design")
  
  if (inherits(x,"formula"))
    x<-model.frame(x,design$variables,na.action=na.pass)
  else if(typeof(x) %in% c("expression","symbol"))
    x<-eval(x, design$variables)
  
  x<-as.matrix(x)
  
  if (na.rm){
    nas<-rowSums(is.na(x))
            design<-design[nas==0,]
    x<-x[nas==0,,drop=FALSE]
  }
  
  pweights<-1/design$prob
  psum<-sum(pweights)
  average<-colSums(x*pweights/psum)
  x<-sweep(x,2,average)
  v<-svyCprod(x*pweights/psum,design$strata,design$cluster[[1]], design$fpc, design$nPSU)
  attr(average,"var")<-v
  attr(average,"statistic")<-"mean"
  class(average)<-"svystat"
  if (deff){
    vsrs<-svyvar(x,design,na.rm=na.rm)/NROW(design$cluster)
    attr(average, "deff")<-v/vsrs
  }
  
  return(average)
}


print.svystat<-function(x,...){
  m<-cbind(x,sqrt(diag(attr(x,"var"))))
  deff<-attr(x,"deff")
  if (is.null(deff)){
    colnames(m)<-c(attr(x,"statistic"),"SE")
  } else {
    m<-cbind(m,diag(as.matrix(deff)))
    colnames(m)<-c(attr(x,"statistic"),"SE","DEff")
  }
  printCoefmat(m)
}

svytotal<-function(x,design, na.rm=FALSE, deff=FALSE){

  if (!inherits(design,"survey.design"))
    stop("design is not a survey design")
  
  if (inherits(x,"formula"))
      x<-model.frame(x,design$variables,na.action=na.pass)
  else if(typeof(x) %in% c("expression","symbol"))
      x<-eval(x, design$variables)

  x<-as.matrix(x)
  
  if (na.rm){
    nas<-rowSums(is.na(x))
    design<-design[nas==0,]
    x<-x[nas==0,,drop=FALSE]
  }

  N<-sum(1/design$prob)
  m <- svymean(x, design, na.rm=na.rm)
  total<-m*N
  attr(total, "var")<-v<-svyCprod(x/design$prob,design$strata, design$cluster[[1]], design$fpc, design$nPSU)
  attr(total,"statistic")<-"total"
  if (deff){
    vsrs<-svyvar(x,design)*sum(weights(design)^2)
    attr(total,"deff")<-v/vsrs
  }
  return(total)
}

svyvar<-function(x, design, na.rm=FALSE){
    
	if (inherits(x,"formula"))
            x<-model.frame(x,design$variables,na.action=na.pass)
	else if(typeof(x) %in% c("expression","symbol"))
            x<-eval(x, design$variables)
        
	xbar<-svymean(x,design, na.rm=na.rm)
	if(NCOL(x)==1) {
            x<-x-xbar
            v<-svymean(x*x,design, na.rm=na.rm)
            attr(v,"statistic")<-"variance"
            return(v)
	}
	x<-t(t(x)-xbar)
	p<-NCOL(x)
	n<-NROW(x)
	a<-matrix(rep(x,p),ncol=p*p)
	b<-x[,rep(1:p,each=p)]
	v<-svymean(a*b,design, na.rm=na.rm)
	v<-matrix(v,ncol=p)
        attr(v,"statistic")<-"variance"
    }

svyquantile<-function(x,design,quantiles,alpha=0.05,ci=FALSE, method="linear",f=1){
    if (inherits(x,"formula"))
		x<-model.frame(x,design$variables)
    else if(typeof(x) %in% c("expression","symbol"))
        x<-eval(x, design$variables)
    
    w<-weights(design)
    
    computeQuantiles<-function(xx){
      oo<-order(xx)
      cum.w<-cumsum(w[oo])/sum(w)
      cdf<-approxfun(cum.w,xx[oo],method="linear",f=1,
                     yleft=min(xx),yright=max(xx)) 
      cdf(quantiles)
    }
      
    computeCI<-function(xx,p){
    
      U<-function(theta){ ((xx>theta)-(1-p))}
      
      scoretest<-function(theta,qlimit){
        umean<-svymean(U(theta),design)
        umean/sqrt(attr(umean,"var"))-qlimit
      }

      iqr<-IQR(xx)
      lower<-min(xx)+iqr/100
      upper<-max(xx)-iqr/100
      tol<-1/(100*sqrt(nrow(design)))
      c(uniroot(scoretest,interval=c(lower,upper),qlimit=qnorm(alpha/2,lower.tail=FALSE),tol=tol)$root,
        uniroot(scoretest,interval=c(lower,upper),qlimit=qnorm(alpha/2,lower.tail=TRUE),tol=tol)$root)
    }

    if (!is.null(dim(x)))
      rval<-t(matrix(apply(x,2,computeQuantiles),nrow=length(quantiles),
                   dimnames=list(as.character(round(quantiles,2)),colnames(x))))
    else
      rval<-computeQuantiles(x)

    if (!ci) return(rval)

    if (!is.null(dim(x)))
      cis<-array(apply(x,2,function(xx) sapply(quantiles,function(qq) computeCI(xx,qq))),
                 dim=c(2,length(quantiles),ncol(x)),
                 dimnames=list(c("(lower","upper)"),
                   as.character(round(quantiles,2)),
                   colnames(x)))
    else
      cis<-sapply(quantiles, function(qq) computeCI(x,qq))

    
    list(quantiles=rval,CIs=cis)
  
    
  }

svyratio<-function(numerator, denominator, design){

    if (inherits(numerator,"formula"))
		numerator<-model.frame(numerator,design$variables)
    else if(typeof(numerator) %in% c("expression","symbol"))
        numerator<-eval(numerator, design$variables)
    if (inherits(denominator,"formula"))
		denominator<-model.frame(denominator,design$variables)
    else if(typeof(denominator) %in% c("expression","symbol"))
        denominator<-eval(denominator, design$variables)

    nn<-NCOL(numerator)
    nd<-NCOL(denominator)

    all<-cbind(numerator,denominator)
    allstats<-svytotal(all,design) 
    rval<-list(ratio=outer(allstats[1:nn],allstats[nn+1:nd],"/"))


    vars<-matrix(ncol=nd,nrow=nn)
    for(i in 1:nn){
      for(j in 1:nd){
        r<-(numerator[,i]-rval$ratio[i,j]*denominator[,j])/sum(denominator[,j]/design$prob)
        vars[i,j]<-svyCprod(r*1/design$prob, design$strata, design$cluster[[1]], design$fpc, design$nPSU)
      }
    }
    colnames(vars)<-names(denominator)
    rownames(vars)<-names(numerator)
    rval$var<-vars
    rval$call<-sys.call()
    class(rval)<-"svyratio"
    rval
    
  }

print.svyratio<-function(x,...){
  cat("Ratio estimator: ")
  print(x$call)
  cat("Ratios=\n")
  print(x$ratio)
  cat("SEs=\n")
  print(sqrt(x$var))
  invisible(NULL)
}

predict.svyratio<-function(object, total, se=TRUE,...){
  if (se)
    return(list(total=object$ratio*total,se=sqrt(object$var)*total))
  else
    return(object$ratio*total)
}

svytable<-function(formula, design, Ntotal=design$fpc, round=FALSE){

  if (!inherits(design,"survey.design")) stop("design must be a survey design")
    weights<-1/design$prob
  
   ## unstratified or unadjusted.
   if (is.null(Ntotal) || length(Ntotal)==1){
       if (length(formula)==3)
           tblcall<-bquote(xtabs(I(weights*.(formula[[2]]))~.(formula[[3]]), data=design$variables))
        else
           tblcall<-bquote(xtabs(weights~.(formula[[2]]), data=design$variables))
       tbl<-eval(tblcall)
       if (!is.null(Ntotal)) {
         if(length(formula)==3)
           tbl<-tbl/sum(Ntotal)
         else
           tbl<-tbl*sum(Ntotal)/sum(tbl)
       }
       if (round)
           tbl<-round(tbl)
       return(tbl)
   }
   ## adjusted and stratified
   if (length(formula)==3)
           tblcall<-bquote(xtabs(I(weights*.(formula[[2]]))~design$strata+.(formula[[3]]), data=design$variables))
   else
           tblcall<-bquote(xtabs(weights~design$strata+.(formula[[2]]), data=design$variables))
   tbl<-eval(tblcall)

   ss<-match(sort(unique(design$strata)), Ntotal[,1])
   dm<-dim(tbl)
   layer<-prod(dm[-1])
      tbl<-sweep(tbl,1,Ntotal[ss, 2]/apply(tbl,1,sum),"*")
   tbl<-apply(tbl, 2:length(dm), sum)
   if (round)
       tbl<-round(tbl)
   class(tbl)<-c("svytable","xtabs", "table")
   attr(tbl, "call")<-match.call()
   tbl
}

svycoxph<-function(formula,design,subset=NULL,...){
    subset<-substitute(subset)
    subset<-eval(subset,design$variables,parent.frame())
    if (!is.null(subset))
        design<-design[subset,]
    
    require(survival) || stop("Needs the survival package")
    data<-design$variables 
    
    g<-match.call()
    g$design<-NULL
    g$var<-NULL
    g$weights<-quote(.survey.prob.weights)
    g[[1]]<-quote(coxph)      
    
    ##need to rescale weights for stability 
    data$.survey.prob.weights<-(1/design$prob)/sum(1/design$prob)
    if (!all(all.vars(formula) %in% names(data))) 
        stop("all variables must be in design= argument")
    g<-with(data,eval(g))
    
    nas<-attr(model.frame(g), "na.action")
    if (length(nas))
        design<-design[-nas,]
    
    
    g$var<-svyCprod(resid(g,"dfbeta",weighted=TRUE), design$strata,
                    design$cluster[[1]], design$fpc,design$nPSU)
    
    g$naive.var<-NULL
    g$wald.test<-coef(g)%*%solve(g$var,coef(g))
    g$loglik<-c(NA,NA)
    g$rscore<-NULL
    g$score<-NA
    
    class(g)<-c("svycoxph",class(g))
    g$call<-match.call()
    g$survey.design<-design
    g
}

print.svycoxph<-function(x,...){
    print(x$survey.design, varnames=FALSE, design.summaries=FALSE,...)
    NextMethod()
}

summary.svycoxph<-function(object,...){
    print(object$survey.design,varnames=FALSE, design.summaries=FALSE,...)
    NextMethod()
}

survfit.svycoxph<-function(object,...){
    stop("No survfit method for survey models")
}
extractAIC.svycoxph<-function(fit,...){
    stop("No AIC for survey models")
}

anova.svycoxph<-function(object,...){
    stop("No anova method for survey models")
}

svyglm<-function(formula,design,subset=NULL,...){

      subset<-substitute(subset)
      subset<-eval(subset, design$variables, parent.frame())
      if (!is.null(subset))
        design<-design[subset,]
      
      data<-design$variables

      g<-match.call()
      g$design<-NULL
      g$var<-NULL
      g$weights<-quote(.survey.prob.weights)
      g[[1]]<-quote(glm)      

      ##need to rescale weights for stability in binomial
      data$.survey.prob.weights<-(1/design$prob)/sum(1/design$prob)
      if (!all(all.vars(formula) %in% names(data))) 
	stop("all variables must be in design= argument")
      g<-with(data, eval(g))

      nas<-attr(model.frame(g), "na.action")
      if (length(nas))
	design<-design[-nas,]

      g$cov.unscaled<-svy.varcoef(g,design)
      
      class(g)<-c("svyglm",class(g))
      g$call<-match.call()
      g$survey.design<-design 
      g
}

print.svyglm<-function(x,...){
  print(x$survey.design, varnames=FALSE, design.summaries=FALSE,...)
  NextMethod()

}

vcov.svyglm<-function(object,...)  object$cov.unscaled


svy.varcoef<-function(glm.object,design){
    Ainv<-summary(glm.object)$cov.unscaled
    estfun<-model.matrix(glm.object)*resid(glm.object,"working")*glm.object$weights
    B<-svyCprod(estfun,design$strata,design$cluster[[1]],design$fpc, design$nPSU)
    Ainv%*%B%*%Ainv
}

residuals.svyglm<-function(object,type = c("deviance", "pearson", "working", 
    "response", "partial"),...){
	type<-match.arg(type)
	if (type=="pearson"){
   	   y <- object$y
	   mu <- object$fitted.values
    	   wts <- object$prior.weights
           pwts<- 1/object$survey.design$prob
           pwts<- pwts/sum(pwts)
	   r<-(y - mu) * sqrt(wts/pwts)/(sqrt(object$family$variance(mu)))
	   if (is.null(object$na.action)) 
        	r
    	   else 
	        naresid(object$na.action, r)
	} else 
		NextMethod()

}

summary.svyglm<-function (object, correlation = FALSE, ...) 
{
    Qr <- object$qr
    est.disp <- TRUE
    df.r <- object$df.residual
    dispersion<-svyvar(na.omit(resid(object,"pearson")), object$survey.design)
    coef.p <- coef(object)
    covmat<-vcov(object)
    dimnames(covmat) <- list(names(coef.p), names(coef.p))
    var.cf <- diag(covmat)
    s.err <- sqrt(var.cf)
    tvalue <- coef.p/s.err
    dn <- c("Estimate", "Std. Error")
    if (!est.disp) {
        pvalue <- 2 * pnorm(-abs(tvalue))
        coef.table <- cbind(coef.p, s.err, tvalue, pvalue)
        dimnames(coef.table) <- list(names(coef.p), c(dn, "z value", 
            "Pr(>|z|)"))
    }
    else if (df.r > 0) {
        pvalue <- 2 * pt(-abs(tvalue), df.r)
        coef.table <- cbind(coef.p, s.err, tvalue, pvalue)
        dimnames(coef.table) <- list(names(coef.p), c(dn, "t value", 
            "Pr(>|t|)"))
    }
    else {
        coef.table <- cbind(coef.p, Inf)
        dimnames(coef.table) <- list(names(coef.p), dn)
    }
    ans <- c(object[c("call", "terms", "family", "deviance", 
        "aic", "contrasts", "df.residual", "null.deviance", "df.null", 
        "iter")], list(deviance.resid = residuals(object, type = "deviance"), 
        aic = object$aic, coefficients = coef.table, dispersion = dispersion, 
        df = c(object$rank, df.r,NCOL(Qr$qr)), cov.unscaled = covmat, 
        cov.scaled = covmat))
    if (correlation) {
        dd <- sqrt(diag(covmat))
        ans$correlation <- covmat/outer(dd, dd)
    }
    ans$aliased<-is.na(object$coef)
    ans$survey.design<-list(call=object$survey.design$call)
    class(ans) <- c("summary.svyglm","summary.glm")
    return(ans)
}

print.summary.svyglm<-function(x,...){
  print(x$survey.design$call,varnames=FALSE,design.summaries=FALSE,...)
  NextMethod("print")
}

logLik.svyglm<-function(object,...){
   stop("svyglm not fitted by maximum likelihood.")
}

extractAIC.svyglm<-function(fit,...){
    stop("svyglm not fitted by maximum likelihood")
}


svymle<-function(loglike, gradient=NULL, design, formulas, start=NULL, control=list(maxit=1000), na.action="na.fail", ...){
  
 method<-if(is.null(gradient)) "Nelder-Mead" else "BFGS"

  if (!inherits(design,"survey.design")) 
	stop("design is not a survey.design")

  weights<-1/design$prob
  wtotal<-sum(weights)
  if (is.null(control$fnscale))
      control$fnscale<- -wtotal
  data<-design$variables

## Get the response variable
  nms<-names(formulas)
  if (nms[1]==""){
	if (inherits(formulas[[1]],"formula"))
	  y<-eval.parent(model.frame(formulas[[1]],data=data,na.action=na.pass))
	else
	  y<-eval(y,data,parent.frame())
	formulas[1]<-NULL
	if (NCOL(y)>1) stop("Y has more than one column")
    }   else {
  	## one formula must have response
	has.response<-sapply(formulas,length)==3
	if (sum(has.response)!=1) stop("Need a response variable")
	ff<-formulas[[which(has.response)]]
	ff[[3]]<-1
	y<-eval.parent(model.frame(ff,data=data,na.action=na.pass))
	formulas[[which(has.response)]]<-delete.response(terms(formulas[[which(has.response)]]))
        nms<-c("",nms)
  }

  if(length(which(nms==""))>1) stop("Formulas must have names")
  
  
  mf<-vector("list",length(formulas))
  for(i in 1:length(formulas)){
	mf[[i]]<-eval.parent(model.frame(formulas[[i]], data=data, na.action=na.pass))
  	if (NCOL(mf[[i]])==0) mf[[i]]<-NULL
	}
  mf<-as.data.frame(do.call("cbind",c(y,mf)))
  names(mf)[1]<-"(Response)"
  mf<-mf[,!duplicated(colnames(mf)),drop=FALSE]

  mf<-get(na.action)(mf)  
  nas<-attr(mf,"na.action")
  if (length(nas))
	design<-design[-nas,]

  Y<-mf[,1]
  mm<-lapply(formulas,model.matrix, data=mf)

  ## parameter names
  parnms<-lapply(mm,colnames)
  for(i in 1:length(parnms))
	parnms[[i]]<-paste(nms[i+1],parnms[[i]],sep=".")
  parnms<-unlist(parnms)

  # maps position in theta to model matrices
  np<-c(0,cumsum(sapply(mm,NCOL)))


  objectivefn<-function(theta,...){
     args<-vector("list",length(nms))
     args[[1]]<-Y
     for(i in 2:length(nms))
	args[[i]]<-mm[[i-1]]%*%theta[(np[i-1]+1):np[i]]
     names(args)<-nms
     args<-c(args, ...)
     sum(do.call("loglike",args)*weights)
  }

  if (is.null(gradient)) {
     grad<-NULL
  } else {  
     fnargs<-names(formals(loglike))[-1]
     grargs<-names(formals(gradient))[-1]
     if(!identical(fnargs,grargs)) stop("loglike and gradient have different arguments.")
     reorder<-na.omit(match(grargs,nms[-1]))
     ##FIXME: need to convert d/deta into d/dtheta using modelmatrix.
     grad<-function(theta,...){
       args<-vector("list",length(nms))
       args[[1]]<-Y
       for(i in 2:length(nms))
	  args[[i]]<-drop(mm[[i-1]]%*%theta[(np[i-1]+1):np[i]])
       names(args)<-nms
       args<-c(args,...)
       rval<-NULL
       tmp<-do.call("gradient",args)
       for(i in reorder){
	   rval<-c(rval, colSums(as.matrix(tmp[,i]*weights*mm[[i]])))
	}
       drop(rval)
     }
  }

  theta0<-numeric(np[length(np)])
  if (is.list(start))
      st<-do.call("c",start)
  else
      st<-start

  if (length(st)==length(theta0)) {
	theta0<-st
  } else {
	stop("starting values wrong length")
  }

  rval<-optim(theta0, objectivefn, grad,control=control,hessian=TRUE,method=method,...)
 
  if (rval$conv!=0) warning("optim did not converge")

  names(rval$par)<-parnms
  dimnames(rval$hessian)<-list(parnms,parnms)

  if (is.null(gradient)) {
	rval$invinf<-solve(-rval$hessian)
	rval$scores<-NULL
	rval$sandwich<-NULL
    }  else {
       theta<-rval$par
       args<-vector("list",length(nms))
       args[[1]]<-Y
       for(i in 2:length(nms))
	  args[[i]]<-drop(mm[[i-1]]%*%theta[(np[i-1]+1):np[i]])
       names(args)<-nms
       args<-c(args,...)
       deta<-do.call("gradient",args)
       rval$scores<-NULL
       for(i in reorder)
       	 rval$scores<-cbind(rval$scores,deta[,i]*weights*mm[[i]])

       rval$invinf<-solve(-rval$hessian)
       dimnames(rval$invinf)<-list(parnms,parnms)

       db<-rval$scores%*%rval$invinf

       rval$sandwich<-svyCprod(db,design$strata,design$psu, design$fpc, design$nPSU)
       dimnames(rval$sandwich)<-list(parnms,parnms)
     }
  rval$call<-match.call()
  rval$design<-design
  class(rval)<-"svymle"
  rval

}

coef.svymle<-function(object,...) object$par

vcov.svymle<-function(object,stderr=c("robust","model"),...) {
    stderr<-match.arg(stderr)
    if (stderr=="robust"){
	rval<-object$sandwich
	if (is.null(rval)) {
		p<-length(coef(object))
		rval<-matrix(NA,p,p)
	}
    } else {
        rval<-object$invinf*mean(1/object$design$prob)
    }
    rval
}


print.svymle<-function(x,...){
  cat("Survey-sampled mle: \n")
  print(x$call)
  cat("Coef:  \n")
  print(x$par)
}

summary.svymle<-function(object,stderr=c("robust","model"),...){
    cat("Survey-sampled mle: \n")
    print(object$call)
    stderr<-match.arg(stderr)
    tbl<-data.frame(Coef=coef(object),SE=sqrt(diag(vcov(object,stderr=stderr))))
    tbl$p.value<-format.pval(2*(1-pnorm(abs(tbl$Coef/tbl$SE))), digits=3,eps=0.001)
    print(tbl)
    print(object$design)
}



.First.lib<-function(...){
    if (is.null(getOption("survey.lonely.psu")))
        options(survey.lonely.psu="fail")
}


##
##  tables of statistics.
##

svyby<-function(formula, by, design, FUN,...,  keep.var=FALSE,keep.names=TRUE){

  if (inherits(by, "formula"))
    byfactors<-model.frame(by, design$variables, na.action=na.pass)
  else
    byfactors<-as.data.frame(by)
  
  byfactor<-do.call("interaction", byfactors)
  uniques <- which(!duplicated(byfactors))
  unwrap<-function(x) c(statistic=unclass(x),sd=sqrt(diag(as.matrix(attr(x,"var")))))
  
  if (keep.var)
    rval<-t(sapply(uniques, function(i) unwrap(FUN(formula,design[byfactor==byfactor[i],],...))))
  else {
    rval<-sapply(uniques, function(i) FUN(formula,design[byfactor==byfactor[i],],...))
    if (is.matrix(rval)) rval<-t(rval)
  }
  if (NCOL(rval)>1)
    rval<-cbind(byfactors[uniques,,drop=FALSE], rval)
  else
    rval <-cbind(byfactors[uniques,,drop=FALSE], statistic=rval)

  if (keep.names)
    rownames(rval)<-as.character(byfactor[uniques])

  rval<-rval[do.call("order",rval),]

  if (!keep.names)
    rownames(rval)<-1:NROW(rval)
  
  attr(rval,"call")<-sys.call()
  rval
}
##
## Tests for contingency tables
##


svychisq<-function(formula, design,
                   statistic=c("F","Chisq","Wald","adjWald")){
  if (ncol(attr(terms(formula),"factors"))>2)
    stop("Only 2-way tables at the moment")
  statistic<-match.arg(statistic)
  
  rows<-formula[[2]][[2]]
  cols<-formula[[2]][[3]]
  nr<-length(unique(design$variables[,as.character(rows)]))
  nc<-length(unique(design$variables[,as.character(cols)]))
  
  fsat<-eval(bquote(~interaction(factor(.(rows)),factor(.(cols)))-1))
  mm<-model.matrix(fsat,model.frame(fsat, design$variables))
  N<-nrow(mm)
  nu <- length(unique(design$cluster[,1]))-length(unique(design$strata))


  warn<-options(warn=-1) ## turn off the small-cell count warning.
  pearson<- chisq.test(svytable(formula,design,Ntotal=N),
                       correct=FALSE)
  options(warn)
  
  mf1<-expand.grid(rows=1:nr,cols=1:nc)
  X1<-model.matrix(~factor(rows)+factor(cols),mf1)
  X12<-model.matrix(~factor(rows)*factor(cols),mf1)

  
  if(statistic %in% c("Wald", "adjWald")){
    frow<-eval(bquote(~factor(.(rows))-1))
    fcol<-eval(bquote(~factor(.(cols))-1))
    mr<-model.matrix(frow, model.frame(frow,design$variables))
    mc<-model.matrix(fcol, model.frame(fcol,design$variables))
    one<-rep(1,NROW(mc))
    cells<-svytotal(~mm+mr+mc+one,design)

    Jcb <- cbind(diag(nr*nc),
                 -outer(mf1$rows,1:nr,"==")*rep(cells[(nr*nc)+nr+1:nc]/cells[(nr*nc)+nr+nc+1],each=nr),
                 -outer(mf1$cols,1:nc,"==")*cells[(nr*nc)+1:nr]/cells[(nr*nc)+nr+nc+1],
                 as.vector(outer(cells[(nr*nc)+1:nr],cells[(nr*nc+nr)+1:nc])/cells[(nr*nc)+nr+nc+1]^2))

    Y<-cells[1:(nc*nr)]-as.vector(outer(cells[(nr*nc)+1:nr],cells[(nr*nc+nr)+1:nc]))/cells[(nr*nc)+nr+nc+1]
    V<-Jcb%*%attr(cells,"var")%*%t(Jcb)
    use<-as.vector(matrix(1:(nr*nc),nrow=nr,ncol=nc)[-1,-1])
    waldstat<-Y[use]%*%solve(V[use,use],Y[use])
    if (statistic=="Wald"){
      waldstat<-waldstat/((nc-1)*(nr-1))
      numdf<-(nc-1)*(nr-1)
      denomdf<-nu
    } else {
      numdf<-(nr-1)*(nc-1)
      denomdf<-(nu-numdf+1)
      waldstat <- waldstat*denomdf/(numdf*nu)
    }
    pearson$statistic<-waldstat
    pearson$parameter<-c(ndf=numdf,ddf=denomdf)
    pearson$p.value<-pf(pearson$statistic, numdf, denomdf, lower.tail=FALSE)
    attr(pearson$statistic,"names")<-"F"
    pearson$data.name<-deparse(sys.call())
    pearson$method<-"Design-based Wald test of association"
    return(pearson)
  }
  
  mean2<-svymean(mm,design)



  
  Cmat<-qr.resid(qr(X1),X12[,-(1:(nr+nc-1)),drop=FALSE])
  Dmat <- diag(mean2)
  iDmat<- diag(ifelse(mean2==0,0,1/mean2))
  Vsrs <- (Dmat - outer(mean2,mean2))/N
  V <- attr(mean2,"var")
  denom<- t(Cmat) %*% (iDmat/N) %*% Cmat
  numr<-t(Cmat)%*% iDmat %*% V %*% iDmat %*% Cmat
  Delta<-solve(denom,numr)
  d0<- sum(diag(Delta))^2/(sum(diag(Delta%*%Delta)))
  
  warn<-options(warn=-1) ## turn off the small-cell count warning.
  pearson<- chisq.test(svytable(formula,design,Ntotal=N),
                       correct=FALSE)
  options(warn)
  
  if (match.arg(statistic)=="F"){
    pearson$statistic<-pearson$statistic/sum(diag(Delta))
    pearson$p.value<-pf(pearson$statistic, d0, d0*nu, lower.tail=FALSE)
    attr(pearson$statistic,"names")<-"F"
    pearson$parameter<-c(ndf=d0,ddf=d0*nu)
  }  else {
    pearson$p.value<-pchisq(pearson$statistic/mean(diag(Delta)),
                               df=NCOL(Delta),lower.tail=FALSE)
    pearson$parameter<-c(df=NCOL(Delta))
  }
  
  pearson$data.name<-deparse(sys.call())
  pearson$method<-"Pearson's X^2: Rao & Scott adjustment"
  pearson
  
}

summary.svreptable<-function(object,...){
  object
}

summary.svytable<-function(object, statistic=c("F","Chisq","Wald","adjWald"),...){

  statistic<-match.arg(statistic)
  call<-attr(object, "call")
  ff<-call$formula

  if (is.null(environment(ff)))
    env<-parent.frame()
  else
    env<-environment(ff)
      
  test<-eval(bquote(svychisq(.(ff), design=.(call$design), statistic=.(statistic))), env)

  rval<-list(table=object,statistic=test)
  class(rval)<-"summary.svytable"
  rval
}

print.summary.svytable<-function(x,...){
  print(x$table)
  print(x$statistic)
}

svyplot<-function(formula,
                  design,
                  style=c("bubble","hex","grayhex","subsample"),
                  sample.size=500, subset=NULL,legend=1,inches=0.05,...){
  
  style<-match.arg(style)
  if (style %in% c("hex","grayhex") && !require(hexbin)){
    stop(style," plots require the hexbin package")
  }

  subset<-substitute(subset)
  subset<-with(design$variables, subset)
  if(length(subset)>0)
    design<-design[subset,]

  W<-weights(design, "sampling")

  mf<-model.frame(formula, design$variables,na.action=na.pass)  
  Y<-model.response(mf)
  X<-mf[,attr(attr(mf,"terms"),"term.labels")]
  
  switch(style, 
         bubble={
           symbols(X,Y,circles=sqrt(W),inches=inches,...)
         },
         hex={
           tmp<-hcell(X,Y)
           rval<-hexbin(X,Y)
           rval$cnt<-tapply(W,tmp$cell,sum)
           rval$xcm<-tapply(1:length(X), tmp$cell,
                          function(ii) weighted.mean(X[ii],W[ii]))
           rval$ycm<-tapply(1:length(Y), tmp$cell,
                           function(ii) weighted.mean(Y[ii],W[ii]))
           plot(rval,legend=legend,style="centroids",...)
         },
         grayhex={
           tmp<-hcell(X,Y)
           rval<-hexbin(X,Y)
           rval$cnt<-tapply(W,tmp$cell,sum)
           plot(rval, legend=legend,...)
         },
         subsample={
           index<-sample(length(X),sample.size,replace=TRUE, prob=W)
           if (is.numeric(X))
             xs<-jitter(X[index],factor=3)
           else
             xs<-X[index]
           if (is.numeric(Y))
             ys<-jitter(Y[index],factor=3)
           else
             ys<-Y[index]
           plot(xs,ys,...)
         }) 
  

  
}
##
## BRR and Fay's replication method for variances.
##

hadamard<-local({
  load(system.file("hadamard.rda",package="survey"))
  
  hadamard.doubler<-function(H){
    rbind(cbind(H,H),cbind(H,1-H))
  }
  
  function(n){
    m<-n-(n %% 4)
    precooked<- which(m < hadamard.sizes)
    if (length(precooked))
      return(hadamard.list[[min(precooked)]])
    
    bestfit<- which.min(log(hadamard.sizes/(m+4), 2) %% 1)
    
    ndoubles<-log(hadamard.sizes[bestfit]/(m+4), 2)
    H<-hadamard.list[[bestfit]]
    for(i in 1:ndoubles)
      H<-hadamard.doubler(H)
    
    H
  }
})


jk1weights<-function(psu, fpc=NULL, fpctype=c("population","fraction","correction")){
    fpctype<-match.arg(fpctype)
  unq<-unique(psu)
  n<-length(unq)
  if (is.null(fpc))
      fpc<-1
  else {
      fpc<-unique(fpc)
      if (length(fpc)>1) stop("More than one fpc value given")
      if (fpc<0) stop("Negative finite population correction")
      if (fpctype=="population" && fpc<n) stop("Population size smaller than sample size. No can do.")
      fpc <-switch(fpctype, population=(fpc-n)/fpc, fraction=1-fpc, correction=fpc)
      }
  repweights<-outer(psu, unq, "!=")*n/(n-1)
  list(type="jk1", repweights=repweights,scale=(fpc*(n-1)/n))
}


jknweights<-function(strata,psu, fpc=NULL, fpctype=c("population","fraction","correction")){

  sunq<-unique(strata)
  unq<-unique(psu)
  nstrat<-length(sunq)
  n<-length(strata)

  fpctype<-match.arg(fpctype)
  
  if (is.null(fpc)){
      fpc<-rep(1,nstrat)
      names(fpc)<-as.character(sunq)
      fpctype<-"correction"
  } else if (length(fpc)==n){
      if (length(unique(fpc))>nstrat)
          stop("More distinct fpc values than strata")
      fpc<-sapply(sunq, function(ss) fpc[match(ss,strata)])
      names(fpc)<-as.character(sunq)
  } else if (length(fpc)==1) {
      fpc<-rep(fpc,nstrat)
      names(fpc)<-as.character(sunq)
  } else if (length(fpc)==nstrat){
      nn<-names(fpc)
      if (is.null(nn)) names(fpc)<-as.character(sunq)
      if (!all(names(fpc) %in% as.character(sunq)))
          stop("fpc has names that do not match the stratum identifiers")
  }

   
  repweights<-matrix(1,ncol=length(unq), nrow=length(psu))
  counter<-0
  rscales<-numeric(length(unique(psu)))
  
  for(ss in as.character(sunq)){
      thisfpc<-fpc[match(ss,names(fpc))]
      theseweights<-jk1weights(psu[strata %in% ss], fpc=thisfpc, fpctype=fpctype)
      repweights[strata %in% ss, counter+1:NCOL(theseweights$repweights)]<-theseweights$repweights
      rscales[counter+1:NCOL(theseweights$repweights)]<-theseweights$scale
      counter<-counter+NCOL(theseweights$repweights)
  }
  
  list(type="jkn", repweights=repweights, rscales=rscales, scale=1)
}



brrweights<-function(strata,psu, match=NULL, small=c("fail","split","merge"),
                     large=c("split","merge","fail")){

  small<-match.arg(small)
  large<-match.arg(large)

  strata<-as.character(strata)
  
  ssize<-table(strata[!duplicated(psu)])
  if (any(ssize<2) && small=="fail")
    stop("Some strata have fewer than 2 PSUs")
  if (any(ssize>2) && large=="fail")
    stop("Some strata have more than 2 PSUs")

  unq<-which(!duplicated(psu))
  sunq<-strata[unq]
  psunq<-psu[unq]
  weights<-matrix(ncol=2,nrow=length(unq))
  weightstrata<-numeric(length(unq))
  
  if (length(match)==length(strata))
    match<-match[unq]
  if (is.null(match))
    match<-unq  ## default is to match by dataset order
  oo<-order(sunq,match)

  upto <- 0
  
  if(any(ssize==1)){
    smallstrata<-names(ssize)[ssize==1]
    if(small=="split"){
      weights[sunq %in% smallstrata,1]<- 0.5
      weights[sunq %in% smallstrata,2]<- 0.5
      weightstrata[sunq %in% smallstrata]<-1:length(smallstrata)
      upto<-length(smallstrata)
    } else {
      ##small=="merge"
      if (length(smallstrata) > 1){
        weights[oo,][sunq[oo] %in% smallstrata, 1]<-rep(0:1,length.out=length(smallstrata))
        weights[oo,][sunq[oo] %in% smallstrata, 2]<-rep(1:0,length.out=length(smallstrata))
        if(length(smallstrata) %% 2==0)
          weightstrata[oo][sunq[oo] %in% smallstrata]<-rep(1:(length(smallstrata) %/%2), 2)
        else
          weightstrata[oo][sunq[oo] %in% smallstrata]<-c(1,rep(1:(length(smallstrata) %/%2), 2))
        upto<-length(smallstrata) %/% 2
      } else stop("Can't merge with a single small stratum")
    }
  }

  if (any(ssize>2)){
    largestrata<-names(ssize)[ssize>2]
    if (large=="split"){
      if (any(ssize[largestrata] %%2 ==1))
        stop("Can't split with odd numbers of PSUs in a stratum")
      ## make substrata of size 2
      for(ss in largestrata){
        weights[oo,][sunq[oo] %in% ss, 1]<-rep(0:1,length.out=ssize[ss])
        weights[oo,][sunq[oo] %in% ss, 2]<-rep(1:0,length.out=ssize[ss])
        weightstrata[oo][sunq[oo] %in% ss]<-upto+rep(1:(ssize[ss] %/%2),each=2)
        upto<-upto+(ssize[ss] %/% 2)
      }
    } else {
      ## make two substrata.
      halfsize<-ssize[largestrata] %/%2
      otherhalfsize<-ssize[largestrata] - halfsize
      reps<-as.vector(rbind(halfsize,otherhalfsize))
      nlarge<-length(halfsize)
      weights[oo,][sunq[oo] %in% largestrata, 1]<-rep(rep(0:1,nlarge),reps) 
      weights[oo,][sunq[oo] %in% largestrata, 2]<-rep(rep(1:0,nlarge),reps)
      weightstrata[oo][sunq[oo] %in% largestrata]<-upto+rep(1:length(largestrata),ssize[largestrata])
      upto<-upto+length(largestrata)
    }
  }
  if(any(ssize==2)){
    goodstrata<-names(ssize)[ssize==2]
    weights[oo,][sunq[oo] %in% goodstrata, 1]<-rep(0:1,length(goodstrata))
    weights[oo,][sunq[oo] %in% goodstrata, 2]<-rep(1:0,length(goodstrata))
    weightstrata[oo][sunq[oo] %in% goodstrata]<-upto+rep(1:length(goodstrata),each=2)
    upto<-upto+length(goodstrata)
  }
  
  H<-hadamard(upto)
  ii<-1:upto
  jj<-1:length(weightstrata)
  sampler<-function(i, fay.rho=0){
    h<-H[1+ii, i]+1
    col<-h[match(weightstrata,ii)]
    wa<-weights[cbind(jj,col)]
    wb<-weights[cbind(jj,3-col)]
    wa[match(psu,psunq)]*(2-fay.rho)+wb[match(psu,psunq)]*fay.rho
  }


  list(weights=weights, wstrata=weightstrata, strata=sunq, psu=psunq,
       npairs=NCOL(H),sampler=sampler)

}
  

  


##
## Designs with replication weights rather than survey structure.
##

as.svrepdesign<-function(design,type=c("auto","JK1","JKn","BRR","Fay"), fay.rho=0,...){

  type<-match.arg(type)

  if (type=="auto"){
    if (!design$has.strata)
      type<-"JK1"
    else
      type<-"JKn"
  }
  
  if (type=="JK1" && design$has.strata)
    stop("Can't use JK1 for a stratified design")
  if (type!="JK1" && !design$has.strata)
    stop("Must use JK1 for an unstratified design")
  
  fpctype<-"population"
  if (is.null(design$fpc)){
      fpc<-NULL
  } else if (type %in% c("Fay","BRR")){
      warning("Finite population correction dropped in conversion")
  } else {
      fpc<-design$fpc[,2]
      names(fpc)<-design$fpc[,1]
  }

  
  if (type=="JK1"){
    ##JK1
    r<-jk1weights(design$cluster[,1], fpc=fpc,fpctype=fpctype)
    repweights<-r$repweights
    scale<-r$scale
    rscales<-rep(1, NCOL(repweights))
    type<-"JK1"
    pweights<-1/design$prob
  } else if (type %in% c("BRR","Fay")){
    ##BRR
    r<-brrweights(design$strata, design$cluster[,1],...)
    repweights<-sapply(1:r$npairs,r$sampler, fay.rho=fay.rho)
    
    pweights<-1/design$prob
    if (length(pweights)==1)
      pweights<-rep(pweights, NROW(design$variables))
    
    if (fay.rho==0)
      type<-"BRR"
    else
      type<-"Fay"

    rscales<-rep(1,r$npairs)
    scale<-1/(r$npairs*(1-fay.rho)^2)
    
  } else if (type=="JKn"){
    ##JKn
    r<-jknweights(design$strata,design$cluster[,1], fpc=fpc,fpctype=fpctype)
    pweights<-1/design$prob
    repweights<-r$repweights
    scale<-1
    rscales<-r$rscales
  } else stop("Can't happen")
  
  rval<-list(variables=design$variables, pweights=pweights, scale=scale, rscales=rscales,
             repweights=as.matrix(repweights),type=type, rho=fay.rho,call=sys.call(), combined.weights=FALSE)
  
  class(rval)<-"svyrep.design"
  rval
}




svrepdesign<-function(variables=NULL,repweights=NULL, weights=NULL,
     data=NULL,type=c("BRR","Fay","JK1", "JKn","other"), combined.weights=FALSE, rho=NULL,
     scale=NULL,rscales=NULL,fpc=NULL, fpctype=c("fraction","correction"))
{
  
  type<-match.arg(type)
  
  if(type=="Fay" && is.null(rho))
    stop("With type='Fay' you must supply the correct rho")
  
  if (type %in% c("JK1","JKn")  && !is.null(rho))
    warning("rho not relevant to JK1 design: ignored.")
  
  if (type %in% c("other")  && !is.null(rho))
    warning("rho not relevant to JK1 design: ignored.")

  
  if(is.null(variables))
    variables<-data
    
  if(inherits(variables,"formula")){
    mf<-substitute(model.frame(variables, data=data))
    variables<-eval.parent(mf)
  }
    
  if(inherits(repweights,"formula")){
    mf<-substitute(model.frame(repweights, data=data))
    repweights<-eval.parent(mf)
    repweights<-na.fail(repweights)
  }

  if (is.null(repweights))
    stop("You must provide replication weights")
  
  
  if(inherits(weights,"formula")){
    mf<-substitute(model.frame(weights, data=data))
    weights<-eval.parent(mf)
    weights<-na.fail(weights)
  }

  if (is.null(weights)){
    warning("No sampling weights provided: equal probability assumed")
    weights<-rep(1,NROW(repweights))
  }

    
  if (type == "BRR")
    scale<-1/ncol(repweights)
  if (type=="Fay")
    scale <-1/(ncol(repweights)*(1-rho)^2)
  if (type=="JK1" && is.null(scale)) {
    if(!combined.weights){
      warning("scale (n-1)/n not provided: guessing from weights")
      scale<-1/max(repweights[,1])
    } else stop("Must provide scale (n-1)/n for combined JK1 weights")
  }
  
  if (type =="JKn" && is.null(rscales))
    if (!combined.weights) {
      warning("rscales (n-1)/n not provided:guessing from weights")
      rscales<-1/apply(repweights,2,max)
    } else stop("Must provide rscales for combined JKn weights")
  
  if (is.null(rscales)) rscales<-rep(1,NCOL(repweights))

  if (!is.null(fpc)){
      if (missing(fpctype)) stop("Must specify fpctype")
      fpctype<-match.arg(fpctype)
      if (type %in% c("BRR","Fay")) stop("fpc not available for this type")
      if (length(fpc)!=length(rscales)) stop("fpc is wrong length")
      if (any(fpc>1) || any(fpc<0)) stop("Illegal fpc value")
      fpc<-switch(fpctype,correction=fpc,fraction=1-fpc)
      rscales<-rscales*fpc
  }
  
  
  rval<-list(variables=variables, pweights=weights, repweights=as.matrix(repweights),type=type, scale=scale, rscales=rscales,  rho=rho,call=sys.call(), combined.weights=combined.weights)
  
  class(rval)<-"svyrep.design"
  rval
  
}


print.svyrep.design<-function(x,...){
  cat("Survey with replicate weights:\nCall: ")
  print(x$call)
}

summary.svyrep.design<-function(object,...){
  class(object)<-c("summary.svyrep.design", class(object))
  object
}

print.summary.svyrep.design<-function(x,...){
  cat("Survey with replicate weights:\n")
  cat("Call: ")
  print(x$call)
  if (x$type=="Fay")
    cat("Fay's variance method (rho=",x$rho,") ")
  if (x$type=="BRR")
    cat("Balanced Repeated Replicates\n")
  if (x$type=="JK1")
    cat("Unstratified cluster jacknife (JK1) ")
  if (x$type=="JKn")
    cat("Stratified cluster jackknife (JKn) ")
  cat("with",NCOL(x$repweights),"replicates.\n")
  cat("Variables: \n")
  print(names(x$variables)) 
}


image.svyrep.design<-function(x, ..., col=grey(seq(.5,1,length=30)), type.=c("rep","total")){
  type<-match.arg(type.)
  m<-x$repweights
  if (type=="total"){
    m<-m*x$pweights
  } 
  
  image(1:NCOL(m), 1:NROW(m), t(m),  col=col, xlab="Replicate", ylab="Observation",...)
  invisible(NULL)
}

"[.svyrep.design"<-function(x, i, j, drop=FALSE){
  if (!missing(i)){
    pwt<-x$pweights
    if (is.data.frame(pwt)) pwt<-pwt[[1]]
    x$pweights<-pwt[i]
    x$repweights<-x$repweights[i,]
    if (!missing(j))
      x$variables<-x$variables[i,j]
    else
      x$variables<-x$variables[i,]
  } else {
    x$variables<-x$variables[,j]
  }
  x
}


subset.svyrep.design<-function(x,subset,...){
        e <- substitute(subset)
        r <- eval(e, x$variables, parent.frame())
        r <- r & !is.na(r) 
        x<-x[r,]
	x$call<-sys.call()
	x
}

update.svyrep.design<-function(object,...){

  dots<-substitute(list(...))[-1]
  newnames<-names(dots)
  
  for(j in seq(along=dots)){
    object$variables[,newnames[j]]<-eval(dots[[j]],object$variables, parent.frame())
  }
  
  object$call<-sys.call()
  object 
}

weights.svyrep.design<-function(object,type=c("replication","sampling","analysis"),...){
  type<-match.arg(type)
  switch(type,
         replication=object$repweights,
         sampling=object$pweights,
         analysis=if(object$combined.weights) object$repweights else object$repweights*object$pweights)
}

weights.survey.design<-function(object,...){
  return(1/object$prob)
}


svrepquantile<-function(x,design,quantiles,method="linear",f=1, return.replicates=FALSE){
    if (!inherits(design,"svyrep.design"))
      stop("Not a survey replicates object")
    if (design$type %in% c("JK1","JKn"))
      warning("Jackknife replicate weights may not give valid standard errors for quantiles")
    if (design$type %in% "other")
      warning("Not all replicate weight designs give valid standard errors for quantiles.")
    if (inherits(x,"formula"))
		x<-model.frame(x,design$variables)
    else if(typeof(x) %in% c("expression","symbol"))
        x<-eval(x, design$variables)
    
    
    w<-weights(design,"analysis")
    computeQuantiles<-function(xx){
      oo<-order(xx)
      cum.w<-apply(w,2,function(wi) cumsum(wi[oo])/sum(wi))
    
      qq<-apply(cum.w, 2,function(cum.wi) approx(cum.wi,xx[oo],method=method,f=f,
                                                 yleft=min(xx),yright=max(xx),
                                                 xout=quantiles,ties=max)$y)
      if (length(quantiles)>1)
        qq<-t(qq)
      else
        qq<-as.matrix(qq)
      rval<-colMeans(qq)
            
      rval<-list(quantiles=rval,
                 variances=diag(as.matrix(svrVar(qq,design$scale,design$rscales))))
      if (return.replicates)
        rval<-c(rval, list(replicates=qq))
      rval
    }

    if (!is.null(dim(x)))
      results<-apply(x,2,computeQuantiles)
    else
      results<-computeQuantiles(x)

    rval<-matrix(sapply(results,"[[","quantiles"),ncol=NCOL(x),nrow=length(quantiles),
                 dimnames=list(paste("q",round(quantiles,2),sep=""), names(x)))
    vv<-matrix(sapply(results,"[[","variances"),ncol=NCOL(x),nrow=length(quantiles),
                 dimnames=list(paste("q",round(quantiles,2),sep=""), names(x)))
    attr(rval,"var")<-vv
    attr(rval, "statistic")<-"quantiles"
    if (return.replicates)
      rval<-list(mean=rval, replicates=lapply(results,"[[","replicates"))
    class(rval)<-"svrepstat"
    rval

}


svrVar<-function(thetas, scale, rscales,na.action=getOption("na.action")){
  thetas<-get(na.action)(thetas)
  naa<-attr(thetas,"na.action")
  if (!is.null(naa)){
    rscales<-rscales[-naa]
    warning(length(naa), " replicates gave NA results and were discarded.")
  }
  if (length(dim(thetas))==2){
    meantheta<-colMeans(thetas)
    v<-crossprod( sweep(thetas,2, meantheta,"-")*sqrt(rscales))*scale
  }  else {
    meantheta<-mean(thetas)
    v<- sum( (thetas-meantheta)^2*rscales)*scale
  }
  attr(v,"na.replicates")<-naa
  return(v)
}


svrepvar<-function(x, design, na.rm=FALSE, rho=NULL, return.replicates=FALSE){

  if (!inherits(design,"svyrep.design")) stop("design is not a replicate survey design")
  
  if (inherits(x,"formula"))
    x<-model.frame(x,design$variables,na.action=na.pass)
  else if(typeof(x) %in% c("expression","symbol"))
    x<-eval(x, design$variables)

  wts<-design$repweights
  scale<-design$scale
  rscales<-design$rscales
  if (design$type=="Fay" ){
    if (!is.null(rho))
      stop("The replication weights have fixed rho: you cannot specify it here.")
  } else  if (design$type=="BRR"){
    rho<-design$rho
  } else if (design$type %in% c("JK1","JKn","other")){
    if(!is.null(rho))
      stop("You cannot specify rho for this design")
  }
  
  
  x<-as.matrix(x)
  
  if (na.rm){
    nas<-rowSums(is.na(x))
    design<-design[nas==0,]
    x[is.na(x)]<-0
  }
  
  if (!design$combined.weights)
    wts<-wts*design$pweights

  v<-function(w){
    xbar<-colSums(w*x)/sum(w)
    xdev<-sweep(x,1,xbar,"-")
    colSums(xdev*xdev*w)/sum(w)
  }
  rval<-v(design$pweights)
  
  repvars<-apply(wts,2, v)

  repvars<-drop(t(repvars))
  attr(rval,"var")<-svrVar(repvars, scale, rscales)
  attr(rval, "statistic")<-"variance"
  if (return.replicates)
    rval<-list(variance=rval, replicates=repvars)
  class(rval)<-"svrepstat"
  rval

}

svrepmean<-function(x,design, na.rm=FALSE, rho=NULL, return.replicates=FALSE,deff=FALSE)
{
  if (!inherits(design,"svyrep.design")) stop("design is not a replicate survey design")
  
  if (inherits(x,"formula"))
    x<-model.frame(x,design$variables,na.action=na.pass)
  else if(typeof(x) %in% c("expression","symbol"))
    x<-eval(x, design$variables)

  wts<-design$repweights
  scale<-design$scale
  rscales<-design$rscales
  if (design$type=="Fay" ){
    if (!is.null(rho))
      stop("The replication weights have fixed rho: you cannot specify it here.")
  } else  if (design$type=="BRR"){
    rho<-design$rho
  } else if (design$type %in% c("JK1","JKn","other")){
    if(!is.null(rho))
      stop("You cannot specify rho for this design")
  }
  
  
  x<-as.matrix(x)
  
  if (na.rm){
    nas<-rowSums(is.na(x))
    design<-design[nas==0,]
    x[is.na(x)]<-0
  }
  
  if (!design$combined.weights)
    wts<-wts*design$pweights
  
  rval<-colSums(design$pweights*x)/sum(design$pweights)
  
  repmeans<-apply(wts,2, function(w)  colSums(w*x)/sum(w))

  repmeans<-drop(t(repmeans))
  attr(rval,"var") <- v <- svrVar(repmeans, scale, rscales)
  attr(rval, "statistic")<-"mean"
  if (return.replicates)
    rval<-list(mean=rval, replicates=repmeans)
  if (deff){
    vsrs<-svrepvar(x,design,na.rm=na.rm, return.replicates=FALSE)/length(design$pweights)
    attr(rval,"deff") <- v/vsrs
  }
  class(rval)<-"svrepstat"
  rval
}



svreptotal<-function(x,design, na.rm=FALSE, rho=NULL, return.replicates=FALSE, deff=FALSE)
{
  if (!inherits(design,"svyrep.design")) stop("design is not a replicate survey design")
  
  if (inherits(x,"formula"))
    x<-model.frame(x,design$variables,na.action=na.pass)
  else if(typeof(x) %in% c("expression","symbol"))
    x<-eval(x, design$variables)

  wts<-as.matrix(design$repweights)
  scale<-design$scale
  rscales<-design$rscales
  if (design$type=="Fay" ){
    if (!is.null(rho))
      stop("The replication weights have fixed rho: you cannot specify it here.")
  } else  if (design$type=="BRR"){
    rho<-design$rho
  } else if (design$type %in% c("JK1","JKn","other")){
    if(!is.null(rho))
      stop("You cannot specify rho for this design")
  }
  
  
  x<-as.matrix(x)
  
  if (na.rm){
    nas<-rowSums(is.na(x))
    design<-design[nas==0,]
    x[is.na(x)]<-0
  }
  
  if (!design$combined.weights)
    wts<-wts*design$pweights
  
  rval<-colSums(design$pweights*x)
  
  repmeans<-apply(wts,2, function(w)  colSums(w*x))

  repmeans<-drop(t(repmeans))
  attr(rval,"var")<-v<-svrVar(repmeans, scale, rscales)
  attr(rval,"statistic")<-"total"
  if (return.replicates)
    rval<-list(mean=rval, replicates=repmeans)
  if (deff){
    vsrs<-svrepvar(x,design, return.replicates=FALSE, na.rm=na.rm)*sum(design$pweights^2)
    attr(rval,"deff")<-v/vsrs
  }
  class(rval)<-"svrepstat"
  rval
  
}

svrepglm<-function(formula, design, subset=NULL, ..., rho=NULL, return.replicates=FALSE, na.action){

      subset<-substitute(subset)
      subset<-eval(subset, design$variables, parent.frame())
      if (!is.null(subset))
        design<-design[subset,]
      
      data<-design$variables


      g<-match.call()
      g$design<-NULL
      g$var<-g$rho<-g$return.replicates<-NULL
      g$weights<-quote(.survey.prob.weights)
      g[[1]]<-quote(glm)      
      g$model<-TRUE
      g$x<-TRUE
      g$y<-TRUE
      
      scale<-design$scale
      rscales<-design$rscales
      if (design$type=="Fay" ){
        if (!is.null(rho))
          stop("The replication weights have fixed rho: you cannot specify it here.")
        wts<-design$repweights
        rho<-design$rho
      } else if (design$type %in% c("JK1","JKn","other")){
        if(!is.null(rho))
          stop("You cannot specify rho for this design")
        wts<-design$repweights
      } else if (design$type=="BRR"){
        if (is.null(rho))
          rho<-0 
        wts<-ifelse(design$repweights==2, 2-rho, rho)
        if (rho!=0) scale<-scale/((1-rho)^2)
      }
    
      pwts<-design$pweights/sum(design$pweights)
      if (is.data.frame(pwts)) pwts<-pwts[[1]]
      
      if (!all(all.vars(formula) %in% names(data))) 
	stop("all variables must be in design= argument")
      .survey.prob.weights<-pwts
      full<-with(data,eval(g))

      nas<-attr(full$model, "na.action")
 
      betas<-matrix(ncol=length(coef(full)),nrow=ncol(design$repweights))

      if (!design$combined.weights)
        wts<-wts*pwts

      if (length(nas))
        wts<-wts[-nas,]
      XX<-full$x
      YY<-full$y
      beta0<-coef(full)
      if(is.null(full$offset))
          offs<-rep(0,nrow(XX))
      else
          offs<-full$offset
      incpt<-as.logical(attr(terms(full),"intercept"))
      fam<-full$family
      contrl<-full$control
      for(i in 1:NCOL(wts)){
        betas[i,]<-glm.fit(XX, YY, weights = wts[,i],
             start =beta0,
             offset = offs,
             family = fam, control = contrl,
             intercept = incpt)$coefficients
      }

      full$model<-NULL
      full$x<-NULL
      
      if (length(nas))
	design<-design[-nas,]

      v<-svrVar(betas,scale, rscales)
      
      full$cov.unscaled<-v
      if (return.replicates) full$replicates<-betas
      
      class(full)<-c("svrepglm","svyglm",class(full))
      full$call<-match.call()
      full$survey.design<-design
      full
}


print.summary.svyglm<-function (x, digits = max(3, getOption("digits") - 3), symbolic.cor = x$symbolic.cor, 
    signif.stars = getOption("show.signif.stars"), ...) 
{
  if (!exists("printCoefmat")) printCoefmat<-print.coefmat

  cat("\nCall:\n")
    cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), 
        "\n\n", sep = "") 

    cat("Survey design:\n")
    print(x$survey.design$call)
   
        if (!is.null(df <- x$df) && (nsingular <- df[3] - df[1])) 
            cat("\nCoefficients: (", nsingular, " not defined because of singularities)\n", 
                sep = "")
        else cat("\nCoefficients:\n")
        coefs <- x$coefficients
        if (!is.null(aliased <- is.na(x$coefficients)) && any(aliased)) {
            cn <- names(aliased)
            coefs <- matrix(NA, length(aliased), 4, dimnames = list(cn, 
                colnames(coefs)))
            coefs[!aliased, ] <- x$coefficients
        }
        printCoefmat(coefs, digits = digits, signif.stars = signif.stars, 
            na.print = "NA", ...)
    
    cat("\n(Dispersion parameter for ", x$family$family, " family taken to be ", 
        format(x$dispersion), ")\n\n",  "Number of Fisher Scoring iterations: ", 
        x$iter, "\n", sep = "")
    correl <- x$correlation
    if (!is.null(correl)) {
        p <- NCOL(correl)
        if (p > 1) {
            cat("\nCorrelation of Coefficients:\n")
            if (is.logical(symbolic.cor) && symbolic.cor) {
                print(symnum(correl, abbr.col = NULL))
            }
            else {
                correl <- format(round(correl, 2), nsmall = 2, 
                  digits = digits)
                correl[!lower.tri(correl)] <- ""
                print(correl[-1, -p, drop = FALSE], quote = FALSE)
            }
        }
    }
    cat("\n")
    invisible(x)
}


    

svrepratio<-function(numerator,denominator, design){

  if (!inherits(design, "svyrep.design")) stop("design must be a svyrepdesign object")
  
    if (inherits(numerator,"formula"))
		numerator<-model.frame(numerator,design$variables)
    else if(typeof(numerator) %in% c("expression","symbol"))
        numerator<-eval(numerator, design$variables)
    if (inherits(denominator,"formula"))
		denominator<-model.frame(denominator,design$variables)
    else if(typeof(denominator) %in% c("expression","symbol"))
        denominator<-eval(denominator, design$variables)

    nn<-NCOL(numerator)
    nd<-NCOL(denominator)

    all<-cbind(numerator,denominator)
    allstats<-svrepmean(all,design, return.replicates=TRUE)
  
  rval<-list(ratio=outer(allstats$mean[1:nn],allstats$mean[nn+1:nd],"/"))

  vars<-matrix(nrow=nn,ncol=nd)
  for(i in 1:nn){
    for(j in 1:nd){
      vars[i,j]<-svrVar(allstats$replicates[,i]/allstats$replicates[,nn+j], design$scale, design$rscales)
    }
  }
                  

  rval$var<-vars
  rval$call<-sys.call()
  class(rval)<-"svyratio"
  rval
    
  }


residuals.svrepglm<-function(object,type = c("deviance", "pearson", "working", 
    "response", "partial"),...){
	type<-match.arg(type)
	if (type=="pearson"){
   	   y <- object$y
	   mu <- object$fitted.values
    	   wts <- object$prior.weights
	   r<-(y - mu) * sqrt(wts)/(sqrt(object$family$variance(mu))*sqrt(object$survey.design$pweights/sum(object$survey.design$pweights)))
	   if (is.null(object$na.action)) 
        	r
    	   else 
	        naresid(object$na.action, r)
	} else 
		NextMethod()

}

logLik.svrepglm<-function(object,...){
   stop("svrepglm not fitted by maximum likelihood.")
}

extractAIC.svrepglm<-function(fit,...){
    stop("svrepglm not fitted by maximum likelihood")
}


withReplicates<-function(design, theta,rho=NULL,..., scale.weights=FALSE, return.replicates=FALSE){
  
  wts<-design$repweights
  scale<-design$scale
  rscales<-design$rscales
  if (design$type=="Fay" ){
    if (!is.null(rho))
      stop("The replication weights have fixed rho: you cannot specify it here.")
    rho<-design$rho
  } else if (design$type %in% c("JK1","JKn","other")){
    if(!is.null(rho))
      stop("You cannot specify rho for this design")
  } else if (design$type=="BRR"){
    if (is.null(rho))
      rho<-0
    wts<-ifelse(design$repweights==2, 2-rho, rho)
    if (rho!=0)
      scale<-scale/((1-rho)^2)
  }

  if (scale.weights)
    pwts<-design$pweights/sum(design$pweights)
  else
    pwts<-design$pweights
  
  if (!design$combined.weights)
    wts<-wts*pwts
  else if (scale.weights)
    wts<-sweep(wts,2, drop(colSums(wts)),"/")
  
  data<-design$variables

  if (is.function(theta)){
    full<-theta(pwts,data,...)
    thetas<-drop(t(apply(wts,2, function(ww) theta(ww, data, ...))))
  } else{
    .weights<-pwts
    full<-with(data, eval(theta))
    thetas<-drop(t(apply(wts,2, function(.weights) with(data, eval(theta)))))
  }

  v<-svrVar(thetas, scale, rscales)

  attr(full,"var")<-v
  if (return.replicates)
    rval<-list(theta=full, replicates=thetas)
  else
    rval<-full
  attr(rval,"statistic")<-"theta"
  class(rval)<-"svrepstat"
  rval
}

print.svrepstat<-function(x,...){
  if (is.list(x)){
    x<-x[[1]]
  }
  vv<-attr(x,"var")
  deff<-attr(x, "deff")
  if (!is.null(dim(x)) && length(x)==length(vv)){
    cat("Statistic:\n")
    printCoefmat(x)
    cat("SE:\n")
    print(sqrt(vv))
    if (!is.null(deff)){
      cat("Design Effect:\n")
      printCoefmat()
    }
  } else if(length(x)==NCOL(vv)){
    m<-cbind(x,sqrt(diag(as.matrix(vv))))
    if (is.null(deff))
      colnames(m)<-c(attr(x,"statistic"),"SE")
    else {
      m<-cbind(m,diag(as.matrix(deff)))
      colnames(m)<-c(attr(x,"statistic"),"SE","DEff")
    }
    printCoefmat(m)
  } else {stop("incorrect structure of svrepstat object")}

  naa<-attr(vv,"na.replicates")
  if (!is.null(naa))
    cat("Note: NA results discarded for",length(naa),"replicates (",naa,")\n")
}

summary.svrepglm<-function (object, correlation = FALSE, ...) 
{
    Qr <- object$qr
    est.disp <- TRUE
    df.r <- object$df.residual
    presid<-resid(object,"pearson")
    dispersion<- sum(  object$survey.design$pweights*presid^2,na.rm=TRUE)/sum(object$survey.design$pweights)
    coef.p <- coef(object)
    covmat<-vcov(object)
    dimnames(covmat) <- list(names(coef.p), names(coef.p))
    var.cf <- diag(covmat)
    s.err <- sqrt(var.cf)
    tvalue <- coef.p/s.err
    dn <- c("Estimate", "Std. Error")
    if (!est.disp) {
        pvalue <- 2 * pnorm(-abs(tvalue))
        coef.table <- cbind(coef.p, s.err, tvalue, pvalue)
        dimnames(coef.table) <- list(names(coef.p), c(dn, "z value", 
            "Pr(>|z|)"))
    }
    else if (df.r > 0) {
        pvalue <- 2 * pt(-abs(tvalue), df.r)
        coef.table <- cbind(coef.p, s.err, tvalue, pvalue)
        dimnames(coef.table) <- list(names(coef.p), c(dn, "t value", 
            "Pr(>|t|)"))
    }
    else {
        coef.table <- cbind(coef.p, Inf)
        dimnames(coef.table) <- list(names(coef.p), dn)
    }
    ans <- c(object[c("call", "terms", "family", "deviance", 
        "aic", "contrasts", "df.residual", "null.deviance", "df.null", 
        "iter")], list(deviance.resid = residuals(object, type = "deviance"), 
        aic = object$aic, coefficients = coef.table, dispersion = dispersion, 
        df = c(object$rank, df.r,NCOL(Qr$qr)), cov.unscaled = covmat, 
        cov.scaled = covmat))
    if (correlation) {
        dd <- sqrt(diag(covmat))
        ans$correlation <- covmat/outer(dd, dd)
    }

    ans$aliased<-is.na(ans$coef)
    ans$survey.design<-list(call=object$survey.design$call,
                            type=object$survey.design$type)
    class(ans) <- c("summary.svyglm","summary.glm")
    return(ans)
}


svreptable<-function(formula, design, Ntotal=sum(weights(design, "sampling")), round=FALSE){
   weights<-design$pweights
   if (is.data.frame(weights)) weights<-weights[[1]]
   ## unstratified or unadjusted.
   if (is.null(Ntotal) || length(Ntotal)==1){
       ff<-eval(substitute(lhs~rhs,list(lhs=quote(weights), rhs=formula[[2]])))
       tbl<-xtabs(ff, data=design$variables)
       if (!is.null(Ntotal)) {
           tbl<-tbl*sum(Ntotal)/sum(tbl)
       }
       if (round)
           tbl<-round(tbl)
       return(tbl)
   }
   ## adjusted and stratified
   ff<-eval(substitute(lhs~strata+rhs,list(lhs=quote(weights),
                                           rhs=formula[[2]],
                                           strata=quote(design$strata))))
   tbl<-xtabs(ff, data=design$variables)
   ss<-match(sort(unique(design$strata)), Ntotal[,1])
   dm<-dim(tbl)
   layer<-prod(dm[-1])
   tbl<-sweep(tbl,1,Ntotal[ss, 2]/apply(tbl,1,sum),"*")
   tbl<-apply(tbl, 2:length(dm), sum)
   if (round)
       tbl<-round(tbl)
   class(tbl)<-c("svytable", "xtabs","table")
   attr(tbl, "call")<-match.call()

   tbl
}



postStratify<-function(design, strata, population, partial=FALSE){

  if(!inherits(design, "svyrep.design"))
    stop("design must be a survey with replicate weights")
  
  if(inherits(strata,"formula")){
    mf<-substitute(model.frame(strata, data=design$variables))
    strata<-eval.parent(mf)
  }
  strata<-as.data.frame(strata)

  sampletable<-xtabs(design$pweights~.,data=strata)
  sampletable<-as.data.frame(sampletable)

  if (inherits(population,"table"))
    population<-as.data.frame(population)
  else if (!is.data.frame(population))
    stop("population must be a table or dataframe")

  if (!all(names(strata) %in% names(population)))
    stop("Stratifying variables don't match")
  nn<- names(population) %in% names(strata)
  if (sum(!nn)!=1)
    stop("stratifying variables don't match")

  names(population)[which(!nn)]<-"Pop.Freq"
  
  both<-merge(sampletable, population, by=names(strata), all=TRUE)

  samplezero <- both$Freq %in% c(0, NA)
  popzero <- both$Pop.Freq %in% c(0, NA)
  both<-both[!(samplezero & popzero),]
  
  if (any(onlysample<- popzero & !samplezero)){
    print(both[onlysample,])
    stop("Strata in sample absent from population. This Can't Happen")
  }
  if (any(onlypop <- samplezero & !popzero)){
    if (partial){
      both<-both[!onlypop,]
      warning("Some strata absent from sample: ignored")
    } else {
      print(both[onlypop,])
      stop("Some strata absent from sample: use partial=TRUE to ignore them.")
    }
  } 

  reweight<-both$Pop.Freq/both$Freq
  both$label <- do.call("interaction", list(both[,names(strata)]))
  designlabel <- do.call("interaction", strata)
  index<-match(designlabel, both$label)

  design$pweights<-design$pweights*reweight[index]

  
  if (design$combined.weights){
    replicateFreq<- rowsum(repweights, match(designlabel, both$label), reorder=TRUE)
    repreweight<-  both$Pop.Freq/replicateFreq
    design$repweights <- design$repweights*repreweight[index]
  } else { 
    replicateFreq<- rowsum(design$repweights*design$pweights, match(designlabel, both$label), reorder=TRUE)
    repreweight<- both$Pop.Freq/replicateFreq
    design$repweights <- design$repweights* (repreweight/reweight)[index,]
  }

  design$call<-sys.call()
  
  design
}


rake<-function(design, sample.margins, population.margins,
               control=list(maxit=10, epsilon=1, verbose=FALSE)){

    if (!missing(control)){
        control.defaults<-formals(rake)$control
        for(n in names(control.defaults))
            if(!(n %in% names(control)))
                control[[n]]<-control.defaults[[n]]
    }
    
    if(!inherits(design, "svyrep.design"))
        stop("design must be a survey with replicate weights")

    if (length(sample.margins)!=length(population.margins))
        stop("sample.margins and population.margins do not match.")

    nmar<-length(sample.margins)
    
    if (control$epsilon<1) 
        epsilon<-control$epsilon*sum(design$pweights)
    else
        epsilon<-control$epsilon

    
    
    strata<-lapply(sample.margins, function(margin)
                   if(inherits(margin,"formula")){
                       mf<-model.frame(margin, data=design$variables)
                   }
                   )
    

    allterms<-unlist(lapply(sample.margins,all.vars))
    oldtable<-svreptable(formula(paste("~", paste(allterms,collapse="+"),sep="")),design)
    if (control$verbose)
        print(oldtable)

    iter<-0
    converged<-FALSE
    while(iter < control$maxit){
        for(i in 1:nmar){
            design<-postStratify(design, strata[[i]], population.margins[[i]])
        }
        newtable<-svreptable(formula(paste("~", paste(allterms,collapse="+"),sep="")),design)
        if (control$verbose)
            print(newtable)

        delta<-max(abs(oldtable-newtable))
        if (delta<epsilon){
            converged<-TRUE
            break
        }
        oldtable<-newtable
        iter<-iter+1
    }
    
    design$call<-sys.call()

    if(!converged)
        warning("Raking did not converge after ", iter, " iterations.\n")

    return(design)
        
}
