.packageName <- "perturb"
colldiag <- function(mod,scale=TRUE,center=FALSE,add.intercept=TRUE) {
	result <- NULL
	if (center) add.intercept<-FALSE
	if (is.matrix(mod)||is.data.frame(mod)) {
		X<-as.matrix(mod)
		nms<-colnames(mod)
	}
	else if (!is.null(mod$call$formula)) {
		nms<-all.vars(terms(mod))
		nms<-nms[-1] # delete the dependent variable
		X<-sapply(nms,get,mode="numeric")
	}
	X<-X[!is.na(apply(X,1,all)),] # delete missing cases
	if (add.intercept) {
		X<-cbind(1,X) # add the intercept
		colnames(X)[1]<-"intercept"
	}
	X<-scale(X,scale=scale,center=center)

	svdX<-svd(X)
	svdX$d
	condindx<-svdX$d[1]/svdX$d

	Phi<-solve(diag(svdX$d),svdX$v)
	Phi<-t(Phi^2)
	pi<-prop.table(Phi,2)

	dim(condindx)<-c(length(condindx),1)
	colnames(condindx)<-"cond.index"
	rownames(condindx)<-1:nrow(condindx)
	colnames(pi)<-colnames(X)
	result$condindx<-condindx
	result$pi<-pi
	class(result)<-"colldiag"
	result
}

print.colldiag <- function(x,dec.places=3,fuzz=NULL,fuzzchar=".",...){
	stopifnot(fuzz>0 & fuzz<1)
	stopifnot(is.character(fuzzchar))
	stopifnot(nchar(fuzzchar)==1)
	fuzzchar<-paste(" ",fuzzchar,sep="")
	width<-dec.places+2
	pi<-formatC(x$pi,format="f",width=width,digits=dec.places)
	if (!is.null(fuzz )) {
		pi[pi < fuzz] <- fuzzchar
	}
	width<-max(nchar(trunc(max(x$condindx))))+dec.places+2
	condindx<-formatC(x$condindx,format="f",width=width,digits=dec.places)
	colnames(condindx)<-NULL
	cat("Condition\nIndex\tVariance Decomposition Proportions\n")
	print(noquote(cbind(condindx,pi)))
}
perturb <- function(mod,pvars=NULL,prange=NULL,ptrans=NULL,pfac=NULL,uniform=FALSE,niter=100) {
	cutsp<-function(indx,tbl) {
		findInterval(runif(1),tbl[indx,],rightmost.closed=TRUE)
	}

	if (is.null(mod$call$formula)) stop("First argument does not contain a formula")
	stopifnot(is.list(pfac)||is.null(pfac))

	nms<-all.vars(terms(mod))
	stopifnot(all(pvars %in% nms))

	result<-NULL
	ncases<-length(get(nms[1]))
	frm<-deparse(formula(mod),width.cutoff = 500)
	result$formula<-frm
	allb<-coefficients(mod)

	# modify the formula
	if (length(pvars) > 0) {
		stopifnot(is.vector(get(pvars)))
		stopifnot(length(pvars)==length(prange))
		result$pvars<-pvars
		result$prange<-prange
		if (length(ptrans)>0) result$ptrans<-ptrans
		b<-make.names(c(nms,pvars),unique=TRUE)
		pvars.1<-b[(length(nms)+1):length(b)]
		for (i in 1:length(pvars)) {
			inp<-paste("\\<",pvars[i],"(\\>[^.]|$)",sep="")
			outp<-paste(pvars.1[i],"\\1",sep="")
			frm<-gsub(inp,outp,frm)
			ptrans<-gsub(inp,outp,ptrans)
		}
		result$ptrans2<-ptrans
	}
	if (length(pfac[[1]]) > 0) {
		rcls.tbl<-NULL
		pfac.1<-NULL
		if (is.list(pfac[[1]])) n<-length(pfac)
		else n<-1
		for (i in 1:n) {
			if (n == 1) lstnm<-pfac
			else lstnm<-pfac[[i]]
			stopifnot(all(lstnm[[1]] %in% nms))
			b<-make.names(c(nms,lstnm[[1]]),unique=TRUE)
			pfc<-b[(length(nms)+1):length(b)]
			inp<-paste("\\<",lstnm[[1]],"(\\>[^.]|$)",sep="")
			outp<-paste(pfc,"\\1",sep="")
			frm<-gsub(inp,outp,frm)
			rcls<-do.call("reclassify",lstnm)
			rcls.tbl<-c(rcls.tbl,list(rcls))
			pfac.1<-c(pfac.1,pfc)
		}
		result$reclassify.tables<-rcls.tbl
	}
	result$formula2<-frm
	mod$call$formula<-as.formula(frm)

	if (uniform) {
		ranexp<-"runif(ncases,-prange[i],prange[i])"
		result$distribution<-"uniform"
	}
	else {
		ranexp<-"rnorm(ncases,0,prange[i])"
		result$distribution<-"normal"
	}

	for (k in 1:niter) {
		# add random perturbances to pvars using values in prange
		if (length(prange)>0) {
			for (i in 1:length(prange)) {
				assign(pvars.1[i],get(pvars[i])+eval(parse(text=ranexp)))
			}
		}
		# re-execute the transformations
		for (trans in ptrans) eval(trans)
		# reclassify factors here
		if (length(pfac[[1]])>0) {
			for (i in 1:length(rcls.tbl)) {
				tbl<-rcls.tbl[[i]]$cum.reclass.prob
				tbl<-cbind(0,tbl)
				assign("tmpvar",as.numeric(get(rcls.tbl[[i]]$variable)))
				assign(pfac.1[i],sapply(tmpvar,cutsp,tbl))
				assign(pfac.1[i],as.factor(get(pfac.1[i])))
			}
		}
		# re-estimate the model using the perturbed variables
		mod2<-eval(mod$call)
		# collect the coefficients
		allb<-rbind(allb,coefficients(mod2))
	}
	# "allb" is the rowname value for the first row of allb; remove
	rownames(allb)<-NULL
	result$coeff.table<-allb
	class(result)<-"perturb"
	result
}

summary.perturb <-function(object,dec.places=3,full=FALSE,...) {
	coeffs<-object$coeff.table
	mysumm<-cbind(apply(coeffs,2,mean),apply(coeffs,2,sd),apply(coeffs,2,min),apply(coeffs,2,max))
	colnames(mysumm)<-c("mean","s.d.","min","max")
	object$coeff.table<-NULL
	object$summ<-mysumm
	object$dec.places<-dec.places
	object$full<-full
	dots<-substitute(expression(...))
	dots<-sub("^expression\\(\(.*\)\\)$","\\1", deparse(dots))
	object$dots<-dots
	class(object)<-"summary.perturb"
	object
}

print.summary.perturb <-function(x,...) {
	if (x$full) {
		cat("formula:\n",x$formula,"\nformula2:\n",x$formula2,"\n\n")
	}
	if (length(x$pvars)>0) {
		cat("Perturb variables:\n")
		if (x$distribution=="uniform") {
			for (i in 1:length(x$pvars)) {
				prnt<-paste("uniform[",-round(x$prange[i],1),",",round(x$prange[i],1),"]",sep="")
				cat(x$pvars[i],"\t\t",prnt,"\n")
			}
		}
		else {
			for (i in 1:length(x$pvars)) {
				prnt<-paste("normal(0,",round(x$prange[i],1),")",sep="")
				cat(x$pvars[i],"\t\t",prnt,"\n")
			}
		}
		cat("\n")
	}
	if (length(x$ptrans)>0) {
		cat("Transformations:\n")
		for (trans in x$ptrans) {
			cat(trans,"\n")
		}
		if (x$full) {
			cat("\nTransformations2:\n")
			for (trans in x$ptrans2) {
				cat(trans,"\n")
			}
		}
		cat("\n")
	}
	if (!is.null(x$reclassify.tables)) {
		for (i in 1:length(x$reclassify.tables)) {
			if (x$dots=="") print(x$reclassify.tables[[i]],dec.places=x$dec.places,full=x$full,...)
			else eval(parse(text=paste("print(x$reclassify.tables[[i]],dec.places=x$dec.places,full=x$full,",x$dots,",...)")))
		}
	}
	cat("Impact of perturbations on coefficients:\n")
	#print(round(x$summ,x$dec.places),...)
	eval(parse(text=paste("print(round(x$summ,x$dec.places),",x$dots,",...)")))
}
reclassify <- function(varname,pcnt=NULL,adjust=TRUE,bestmod=TRUE,min.val=.1,diag=NULL,unif=NULL,dist=NULL,assoc=NULL) {
	# subroutines used below:
	exptab <- function(pcnt) {
		result<-NULL
		mdl2<-NULL
		if (length(pcnt)==1) {
			init.pcnt<-(100-pcnt)/(100*(ncat-1))
			init.pcnt<-matrix(init.pcnt,ncat,ncat)
			diag(init.pcnt)<-pcnt/100
			mdl<-"diag1"
		}
		else if (length(pcnt)==ncat) {
			init.pcnt<-(100-pcnt)/(100*(ncat-1))
			init.pcnt<-replicate(ncat,cbind(init.pcnt))
			diag(init.pcnt)<-pcnt/100
			mdl<-"diag"
		}
		else if (length(pcnt)==ncat^2) {
			init.pcnt<-as.matrix(pcnt)
			dim(init.pcnt)<-c(ncat,ncat)
			init.pcnt<-prop.table(init.pcnt,1)
			mdl<-"diag1+unif"
			mdl2<-"diag1+dist"
		}
		else stop("Invalid argument for pcnt option")
		init.tbl<-diag(freq)%*%init.pcnt
		init.tbl[init.tbl < min.val]<-min.val
		result$init.pcnt<-init.pcnt
		result$init.tbl<-init.tbl
		result$mdl<-mdl
		result$mdl2<-mdl2
		result
	}

	best.model <- function(init.tbl,ncat,mdl,mdl2) {
		result<-NULL
		ncase<-length(init.tbl)
		pm<-init.tbl
		dim(pm)<-c(ncase,1)
		orig<-gl(ncat,ncat,ncase)
		dest<-gl(ncat,1,ncase)
		diag<-as.factor((as.numeric(orig)==as.numeric(dest))*(as.numeric(orig)))
		diag1<-as.numeric(as.numeric(orig)==as.numeric(dest))
		dist<-abs(as.numeric(orig)-as.numeric(dest))
		unif<-as.numeric(orig)*as.numeric(dest)
		m<-suppressWarnings(glm(as.formula(paste("pm~orig+dest+",mdl)),family=poisson(),maxit=1000))
		if (!is.null(mdl2)) {
			m2<-suppressWarnings(glm(as.formula(paste("pm~orig+dest+",mdl2)),family=poisson(),maxit=1000))
			if (m2$deviance < m$deviance ) {
				m<-m2
				mdl<-mdl2
			}
		}
		cf.all<-coef(m)
		mmat<-model.matrix(as.formula(paste("~",mdl)))
		cf.names<-colnames(mmat)[-1]
		cf<-cf.all[cf.names]
		mmat<-as.matrix(mmat[,-1])
		paras<-mmat%*%cf
		result$model<-mdl
		result$coefs<-cf
		result$paras<-paras
		result
	}

	assocPat <- function(freq,ncat,diag=NULL,unif=NULL,dist=NULL,assoc=NULL) {
		result<-NULL
		cf <- NULL
		tbl<-diag(freq)

		ncase<-length(tbl)
		dim(tbl)<-c(ncase,1)
		paras<-rep(0,ncase)
		orig<-gl(ncat,ncat,ncase)
		dest<-gl(ncat,1,ncase)
		rmat<-model.matrix(~orig)
		rmat<-rmat[,attr(rmat,"assign")==1]
		cmat<-model.matrix(~dest)
		cmat<-cmat[,attr(cmat,"assign")==1]
		eqmain<-rmat+cmat

		if (!is.null(assoc)) {
			dim(assoc)<-NULL
			paras<-assoc
		}
		else {
			if (!is.null(diag)) {
				paras <- paras + as.numeric(orig==dest)*diag
				cf <- cbind(diag,cf)
				colnames(cf)[1]<-"diag"
			}
			if (!is.null(unif)) {
				paras <- paras + as.numeric(orig)*as.numeric(dest)*unif
				cf <- cbind(unif,cf)
				colnames(cf)[1]<-"unif"
			}
			if (!is.null(dist)) {
				paras <- paras + abs(as.numeric(orig)-as.numeric(dest))*dist
				cf <- cbind(dist,cf)
				colnames(cf)[1]<-"dist"
			}
		}
		ll<-suppressWarnings(glm(tbl~eqmain+offset(paras),family=poisson(),maxit=1000))
		pred<-ll$fitted.values
		dim(pred)<-c(ncat,ncat)
		result$pred<-pred
		result$iter<-ll$iter
		result$converged<-ll$converged
		result$coefs<-cf
		result
	}

	### reclassify starts here
	if (all(is.null(pcnt),is.null(assoc),is.null(diag),is.null(unif),is.null(dist))) {
		stop("Either pcnt=, assoc= or one of diag=, unif=, or dist= must be specified")
	}
	if (!adjust) bestmod<-FALSE
	result<-NULL
	if (is.character(varname)) {
		result$variable<-varname
		varname<-get(varname)
	}
	else {
		result$variable<-substitute(varname)
	}
	stopifnot(is.factor(varname))
	freq<-table(varname)
	ncat<-length(freq)

	if (!is.null(pcnt)) {
		if (is.character(pcnt)) {pcnt<-get(pcnt)}
		etab<-exptab(pcnt)
		result$exptab<-etab
		if (bestmod) {
			bm<-best.model(etab$init.tbl,ncat,etab$mdl,etab$mdl2)
			result$bestmod<-bm
			pred<-assocPat(freq,ncat,assoc=bm$paras)
		}
		else if (adjust) {
			init.tbl<-etab$init.tbl
			init.tbl[init.tbl==0]<-1e-12
			init.tbl<-log(init.tbl)
			init.tbl<-(init.tbl+t(init.tbl))/2
			pred<-assocPat(freq,ncat,assoc=init.tbl)
		}
		else {
			rcd<-prop.table(etab$init.tbl,1)
			result$reclass.prob<-rcd
			rcdcum<-t(apply(rcd,1,cumsum))
			colnames(rcdcum)<-levels(varname)
			result$cum.reclass.prob<-rcdcum
			class(result)<-"reclassify"
			return(result)
		}
	}
	else if (!is.null(assoc)){
		if (is.character(assoc)) {assoc<-get(assoc)}
		stopifnot(length(assoc)==ncat^2)
		dim(assoc)<-c(ncat,ncat)
		assoc<-(assoc+t(assoc))/2
		rownames(assoc)<-levels(varname)
		colnames(assoc)<-levels(varname)
		pred<-assocPat(freq,ncat,assoc=assoc)
		result$assoc<-assoc
	}
	else if (!is.null(diag) | !is.null(unif) | !is.null(dist)) {
		pred<-assocPat(freq,ncat,diag=diag,unif=unif,dist=dist)
		result$coefs<-pred$coefs
	}

	if (!pred$converged) {
		stop(cat("The requested association pattern could not be fitted to",
		substitute(varname),"in",pred$iter,"iterations."))
	}
	rownames(pred$pred)<-levels(varname)
	colnames(pred$pred)<-levels(varname)
	rcd<-prop.table(pred$pred,1)
	result$fitted.table<-pred$pred

	result$reclass.prob<-rcd
	rcdcum<-t(apply(rcd,1,cumsum))
	colnames(rcdcum)<-levels(varname)
	result$cum.reclass.prob<-rcdcum
	class(result)<-"reclassify"
	result
}

print.reclassify <-function(x,dec.places=3,full=FALSE,...) {
	prnt.tbl<-function(obj,header,lbl=TRUE,...){
		cat(header,"\n")
		if (lbl) cat("original\treclassified\n")
		print(round(obj,digits=dec.places),quote=FALSE,...)
		cat("\n")
	}

	## print.reclassify starts here
	cat("\nVariable",x$variable,"to be reclassified ")
	if (full) {
		if (!is.null(x$exptab)) {
			prnt.tbl(x$exptab$init.pcnt,"using the following initial probabilities:")
			prnt.tbl(addmargins(x$exptab$init.tbl),"Initial expected table based on these probabilities:")
		}
		if (!is.null(x$bestmod)) {
			prnt.tbl(x$bestmod$coefs,"Best model for the intial expected table:",lbl=FALSE)
		}
		else if (!is.null(x$assoc)) {
			prnt.tbl(x$assoc,"using the following log pattern of association:")
		}
		else if (!is.null(x$coefs)) {
			prnt.tbl(x$coefs,"using the following model coefficients:",lbl=FALSE)
		}
		if (!is.null(x$fitted.table)) {
			prnt.tbl(addmargins(x$fitted.table),"Table generated with specified pattern of association:")
		}
	}
	cat("Reclassification probabilities:\n")
	cat("original\treclassified\n")
	print(round(x$reclass.prob,digits=dec.places),quote=FALSE,...)
	cat("\n")
	if (full) {
		cat("Cumulative reclassification probabilities:\n")
		cat("original\treclassified\n")
		print(round(x$cum.reclass.prob,digits=dec.places),quote=FALSE,...)
		cat("\n")
	}
}
