.packageName <- "catspec"
# ctab: oneway, twoway, multiway percentage tables
# first argument must consist of one or more factors
# or a table object (class table, xtabs, or ftable)
# digits: number of digits after the decimal (default 2)
# type: "n" for counts, "row", "column" or "total"
# for percentages (default "n")
# row.vars:
# col.vars: same usage as ftable, ignored for one- and
# two-way tables
# percentages: FALSE==> proportions are presented rather
# than percentages (default TRUE)

# comments to John Hendrickx <John_Hendrickx@yahoo.com>

ctab<-function(...,dec.places=NULL,digits=NULL,type=NULL,style=NULL,row.vars=NULL,col.vars=NULL,percentages=NULL,addmargins=NULL) {
	mk.pcnt.tbl<-function(tbl,type) {
		a<-length(row.vars)
		b<-length(col.vars)
		mrgn<-switch(type,
			column=c(row.vars[-a],col.vars),
			   row=c(row.vars,col.vars[-b]),
			 total=c(row.vars[-a],col.vars[-b]))
		tbl<-prop.table(tbl,mrgn)
		if (percentages) {tbl<-tbl*100}
		tbl
	}

	# options have default NULL so attributes of a ctab object can be used as default
	# defaults for other classes are assigned below
	if (attributes(...)$class=="factor") {
		tbl<-table(...)
	}
	else if ("table" %in% class(...)) {
		tbl<-eval(...)
	}
	else if (class(...)=="ftable") {
		tbl<-eval(...)
		if (is.null(row.vars) && is.null(col.vars)) {
			row.vars<-names(attr(tbl,"row.vars"))
			col.vars<-names(attr(tbl,"col.vars"))
		}
		tbl<-as.table(tbl)
	}
	else if (class(...)=="ctab") {
		tbl<-eval(...)
		if (is.null(row.vars) && is.null(col.vars)) {
			row.vars<-tbl$row.vars
			col.vars<-tbl$col.vars
		}
		for (opt in c("dec.places","type","style","percentages","addmargins")) if (is.null(get(opt))) assign(opt,eval(parse(text=paste("tbl$",opt,sep=""))))
		tbl<-tbl$table
	}
	else {
		stop("first argument must be either factors or a table object")
	}

	# defaults for options and checks for valid values
	if (!is.null(digits)) dec.places<-digits
	if (is.null(dec.places)) dec.places<-2
	stopifnot(as.integer(dec.places)==dec.places,dec.places>0)
	if (is.null(percentages)) percentages<-TRUE
	stopifnot(is.logical(percentages))
	if (is.null(addmargins)) addmargins<-FALSE
	stopifnot(is.logical(addmargins))

	types<-NULL
	choices<-c("n", "row", "column", "total")
	for(tp in type) types<-c(types,match.arg(tp,choices))
	type<-types

	# one dimensional table,restrict choices to "n" and "total"
	if (length(dim(tbl))==1) {
		if (is.null(type)) {
			type<-c("n","total")
			row.vars<-1
			if (is.null(style)) style<-"wide"
		}
		else type<-ifelse(type=="n","n","total")
	}
	else if (is.null(type)) type<-"n"
	style<-match.arg(style,c("long","wide"))
	if (is.null(style)) style<-"long"

	# use row.vars and col.vars to determine the
	# marginals to use when calculating percentages
	# start by translating names to variable positions
	nms<-names(dimnames(tbl))
	z<-length(nms)
	if (!is.null(row.vars) && !is.numeric(row.vars)) {
		row.vars<-order(match(nms,row.vars),na.last=NA)
	}
	if (!is.null(col.vars) && !is.numeric(col.vars)) {
		col.vars<-order(match(nms,col.vars),na.last=NA)
	}
	# calculate the other if only one is given
	if (!is.null(row.vars) && is.null(col.vars)) {
		col.vars<-(1:z)[-row.vars]
	}
	if (!is.null(col.vars) && is.null(row.vars)) {
		row.vars<-(1:z)[-col.vars]
	}
	# evidently, both row.vars and col.vars were NULL
	# assign the last variable to col.vars, the rest to row.vars
	if (is.null(row.vars) && is.null(col.vars)) {
		col.vars<-z
		row.vars<-(1:z)[-col.vars]
	}

	if (type[1] == "n") ctab <- tbl
	else ctab<-mk.pcnt.tbl(tbl,type[1])

	if (length(type) > 1) {
		# create the (percentage) tables, then convert them to data frames
		# stack the data frames, adding a new variable as percentage type
		tbldat<-as.data.frame.table(ctab)
		z<-length(names(tbldat))+1
		tbldat[z]<-1
		pcntlab<-type
		pcntlab[match("n",type)]<-"Count"
		pcntlab[match("row",type)]<-"Row %"
		pcntlab[match("column",type)]<-"Column %"
		pcntlab[match("total",type)]<-"Total %"
		for (i in 2:length(type)) {
			if (type[i] == "n") ctab <- tbl
			else ctab<-mk.pcnt.tbl(tbl,type[i])
			ctab<-as.data.frame.table(ctab)
			ctab[z]<-i
			tbldat<-rbind(tbldat,ctab)
		}
		tbldat[[z]]<-as.factor(tbldat[[z]])
		levels(tbldat[[z]])<-pcntlab
		ctab<-xtabs(Freq ~ .,data=tbldat)
		names(dimnames(ctab))[z-1]<-""
	}

	result<-NULL
	result$row.vars<-row.vars
	result$col.vars<-col.vars
	result$dec.places<-dec.places
	result$type<-type
	result$style<-style
	result$percentages<-percentages
	result$addmargins<-addmargins
	result$ctab<-ctab
	result$table<-tbl
	class(result)<-"ctab"
	result
}

print.ctab<-function(x,dec.places=x$dec.places,addmargins=x$addmargins,...) {
	if (length(dim(x$ctab))==1) {
		tbl<-x$ctab
		if (addmargins) tbl<-addmargins(tbl)
		if (x$style=="long") {
			tbl<-as.matrix(tbl)
			colnames(tbl)<-names(dimnames(x$ctab))
		}
	}
	else {
		row.vars<-x$row.vars
		col.vars<-x$col.vars
		a=length(row.vars)
		if (length(x$type)>1) {
			z<-length(names(dimnames(x$ctab)))
			if (x$style=="long") row.vars<-c(row.vars,z)
			else col.vars<-c(z,col.vars)
		}
		b=length(col.vars)
		tbl<-x$ctab
		mrgn<-c(row.vars[a],col.vars[b])
		# if the table contains counts and percentages of a factor
		if (length(dim(x$table))==1) mrgn<-1
		if (addmargins) tbl<-addmargins(tbl,margin=mrgn)
		tbl<-ftable(tbl,row.vars=row.vars,col.vars=col.vars)
	}

	if (!all(as.integer(tbl)==as.numeric(tbl))) tbl<-round(tbl,dec.places)
	print(tbl,...)
}

summary.ctab<-function(object,...) {
	summary(object$table,...)
}

ctab0<-function(...) {
	specs<-substitute(expression(...))
	specs<-sub("^expression\\(\(.*\)\\)$","\\1", deparse(specs))
	result<-ctab(...)

	if (length(grep("col.vars",specs,fixed=TRUE))==0 & length(grep("row.vars",specs,fixed=TRUE))==0) {
		indx<-c(result$row.vars,result$col.vars)
		k<-length(indx)
		rv<-paste(rev(indx[-2]),sep="",collapse=",")
		cmd<-paste("ctab(",specs,", row.vars=c(",rv,"), col.vars=2)",sep="")
		cat("For future use:\n",cmd,"\n")
		result<-eval(parse(text=cmd))
	}
	result
}

# function to restructure a data-frame as a "person-choice" file:
# "datamat" is the name of the data-frame
# "catvar" is the response factor,
# i.e. the dependent variable in a multinomial logistic model
# In the "person-choice" file, each record of "datamat" is duplicated
# "ncat" times, where "ncat" is the number of categories of "catvar")
# The variable "id" indexes respondents
# and is used as the stratifying variable in "clogit"
# The variable "newy" indexes response options for each respondent
# The variable "depvar" equals 1 for the record
# corresponding with the respondents actual choice
# and is 0 otherwise.
# "depvar" is the dependent variable in "clogit"
# Once "depvar" has been created, the variable "catvar" is redundant
# and it's contents can be replaced by "newy"
# In "clogit", the main effects of "catvar" will now correspond with the
# intercept term of a multinomial logit model, interactions of "catvar" with
# other independent variables will correspond with their effects
mclgen <- function (datamat,catvar) {
	stopifnot(is.data.frame(datamat))
	attach(datamat)
	stopifnot(is.factor(catvar))
	ncat <- nlevels(catvar)
	perschoice<-as.data.frame(rep(datamat,ncat))
	perschoice<-reshape(perschoice,direction="long",
		varying=lapply(names(datamat),rep,ncat),
		timevar="newy")
	perschoice<-perschoice[sort.list(perschoice$id),]
	dep<-parse(text=paste("perschoice$",substitute(catvar),sep=""))
	perschoice$depvar<-ifelse(as.numeric(eval(dep))==perschoice$newy,1,0)
	perschoice[[substitute(catvar)]]<-as.factor(perschoice$newy)
	perschoice[[substitute(catvar)]]<-factor(eval(dep),labels=levels(catvar))
	perschoice
}
# calculates BIC and AIC relative to a saturated loglinear model
# rather than relative to a null model
fitmacro<-function(object) {
	stopifnot(class(object)[1]=="glm",object$family$family=="poisson",object$family$link=="log")
	ncases<-sum(object$y)
	bic<-object$deviance-object$df.residual*log(ncases)
	aic<-object$deviance-object$df.residual*2
	cat("\n","\n")
	cat("deviance:            ",formatC(object$deviance,    width = 12, digits = 3, format = "f"),"\n")
	cat("df:                  ",formatC(object$df.residual, width = 12, digits = 0, format = "f"),"\n")
	cat("bic:                 ",formatC(bic,                width = 12, digits = 3, format = "f"),"\n")
	cat("aic:                 ",formatC(aic,                width = 12, digits = 3, format = "f"),"\n")
	cat("Number of parameters:",formatC(object$rank,        width = 12, digits = 0, format = "f"),"\n")
	cat("Number of cases:     ",formatC(ncases,             width = 12, digits = 0, format = "f"),"\n")
	cat("\n","\n")
}

# utility function to check if the variables are factors
# with the same number of categories
# called by functions for mobility models below
check.square <- function(rowvar,colvar,equal=TRUE) {
	stopifnot(is.factor(rowvar))
	stopifnot(is.factor(colvar))
	if (equal) {
		stopifnot(nlevels(rowvar)==nlevels(colvar))
	}
}

# Quasi-independence
mob.qi <- function(rowvar,colvar,constrained=FALSE,print.labels=FALSE) {
	check.square(rowvar,colvar)
	if (constrained) {
		qi <- ifelse(rowvar==colvar, 1, 0)
		nms<-c("diagonal")
	}
	else {
		qi <- ifelse(rowvar==colvar, rowvar, 0)
		nms<-levels(rowvar)
	}

	qi<-factor(qi)
	qi<-C(qi,contr.treatment,base=1)
	if (print.labels) {
		levels(qi)<-c("offdiag",nms)
	}
	qi
}

# symmetric interaction effects
mob.symint <- function(rowvar,colvar,print.labels=FALSE) {
	check.square(rowvar,colvar)
	# remove factor levels to avoid messy output
	if (!print.labels) {
		attr(rowvar,"levels")<-1:nlevels(rowvar)
		attr(colvar,"levels")<-1:nlevels(colvar)
	}
	mdl<-model.matrix(~rowvar*colvar)
	intrct<-mdl[,attr(mdl,"assign")==3]
	# remove factor names
	colnames(intrct)<-sub("rowvar","",colnames(intrct))
	colnames(intrct)<-sub("colvar","",colnames(intrct))
	w<-ncol(intrct)
	x<-matrix(1:w,sqrt(w),sqrt(w))
	symint<-intrct[,t(x)[lower.tri(x,diag=TRUE)]]+intrct[,x[lower.tri(x,diag=TRUE)]]
	symint
}

# equal main effects, Hope's halfway model
mob.eqmain <- function(rowvar,colvar,print.labels=FALSE) {
	check.square(rowvar,colvar)
	if (!print.labels) {
		attr(rowvar,"levels")<-1:nlevels(rowvar)
		attr(colvar,"levels")<-1:nlevels(colvar)
	}
	rmat<-model.matrix(~rowvar)
	rmat<-rmat[,attr(rmat,"assign")==1]
	cmat<-model.matrix(~colvar)
	cmat<-cmat[,attr(cmat,"assign")==1]
	eqmain<-rmat+cmat
	colnames(eqmain)<-sub("rowvar","",colnames(eqmain))
	eqmain
}
# Crossings parameter
mob.cp <- function(rowvar,colvar) {
	check.square(rowvar,colvar)
	cp<-NULL
	rvar<-as.numeric(rowvar)
	cvar<-as.numeric(colvar)
	for (i in 1:(nlevels(rowvar)-1)) {
		cp<-cbind(cp,as.numeric((rvar <= i & cvar > i) | (rvar > i & cvar <= i)))
	}
	cp
}

# Uniform association
mob.unif <- function(rowvar,colvar) {
	check.square(rowvar,colvar,equal=FALSE)
	as.numeric(rowvar)*as.numeric(colvar)
}

# RC model 1 (unequal row and column effects, page 58)
# Fits a uniform association parameter and row and column effect
# parameters. Row and column effect parameters have the
# restriction that the first and last categories are zero.
mob.rc1 <- function(rowvar,colvar,equal=FALSE,print.labels=FALSE) {
	# the number of row and column categories need not be equal
	# unless an equality restriction is applied
	check.square(rowvar,colvar,equal=equal)
	# use numbers rather than factor levels by default
	if (!print.labels) {
		attr(rowvar,"levels")<-1:nlevels(rowvar)
		attr(colvar,"levels")<-1:nlevels(colvar)
	}

	# row effects, first and last category constrained to 0
	# multiplied by column variable as continuous
	rowvar<-C(rowvar,contr.treatment,base=1)
	rmat<-model.matrix(~rowvar)
	rmat<-rmat[,attr(rmat,"assign")==1]
	rmat<-rmat[,1:(ncol(rmat)-1)]*as.numeric(colvar)

	# column effects, same construction
	colvar<-C(colvar,contr.treatment,base=1)
	cmat<-model.matrix(~colvar)
	cmat<-cmat[,attr(cmat,"assign")==1]
	cmat<-cmat[,1:(ncol(cmat)-1)]*as.numeric(rowvar)

	u<-mob.unif(rowvar,colvar)
	# add a name for the uniform association effect
	dim(u)<-c(length(u),1)
	colnames(u)<-c("U")

	if (equal) {
		# rowmain and colmain are added to impose an equality restriction
		colnames(rmat)<-sub("rowvar","RC",colnames(rmat))
		rc1<-cbind(rmat+cmat,u)
	}
	else {
		colnames(rmat)<-sub("rowvar","R",colnames(rmat))
		colnames(cmat)<-sub("colvar","C",colnames(cmat))
		rc1<-cbind(rmat,u,cmat)
	}
	rc1
}
