# This function fits a generalized linear model via
# iteratively reweighted least squares for any family.
# Written by Simon Davies, Dec 1995
# glm.fit modified by Thomas Lumley, Apr 1997, and then others..

glm <- function(formula, family=gaussian, data=list(), weights=NULL,
	subset=NULL, na.action=na.fail, start=NULL, offset=NULL,
	control=glm.control(epsilon=0.0001, maxit=10, trace=FALSE),
	model=TRUE, method="glm.fit", x=FALSE, y=TRUE)
{
	call <- match.call()

	## family
	if(is.character(family)) family <- get(family)
	if(is.function(family)) family <- family()
	if(is.null(family$family)) stop("'family' not recognised")

	## extract x, y, etc from the model formula and frame
	mt <- terms(formula, data=data)
	if(missing(data)) data <- sys.frame(sys.parent())
	mf <- match.call()
	mf$family <- mf$start <- mf$control <- mf$maxit <- NULL
	mf$model <- mf$method <- mf$x <- mf$y <- NULL
	mf[[1]] <- as.name("model.frame")
	mf <- eval(mf, sys.frame(sys.parent()))
	if(method == "model.frame")
		return(mf)
	## null model support
	X <- if (is.empty.model(mt)) NULL else model.matrix(mt, mf)
	Y <- model.response(mf, "numeric")
	weights <- model.weights(mf)
	if(is.null(offset)) offset <- model.offset(mf)

	## check weights and offset
	if( !is.null(weights) && any(weights<0) )
		stop("Negative wts not allowed")
	if(!is.null(offset) && length(offset) != NROW(Y))
		stop(paste("Number of offsets is", length(offset),
			", should equal", NROW(Y), "(number of observations)"))

	## fit model via iterative reweighted least squares
	fit <- (if (is.empty.model(mt)) glm.fit.null else glm.fit)(
			x=X, y=Y, weights=weights, start=start,
			offset=offset, family=family, control=control)

	if(model) fit$model <- mf
	if(!y) fit$y <- NULL
	structure(c(fit,
		    list(call=call, formula=formula,
			 terms=mt, data=data, x= if(x) X,# x=x,
			 offset=offset, control=control, method=method)),
		  class= c(if(is.empty.model(mt)) "glm.null", "glm", "lm"))
}


glm.control <- function(epsilon = 0.0001, maxit = 10, trace = FALSE)
{
	if(!is.numeric(epsilon) || epsilon <= 0)
		stop("value of epsilon must be > 0")
	if(!is.numeric(maxit) || maxit <= 0)
		stop("maximum number of iterations must be > 0")
	list(epsilon = epsilon, maxit = maxit, trace = trace)
}

## Modified by Thomas Lumley 26 Apr 97
## Added boundary checks and step halving
## Modified detection of fitted 0/1 in binomial

glm.fit <-
function (x, y, weights = rep(1, nobs), start = NULL, offset = rep(0, nobs),
	family = gaussian(), control = glm.control(), intercept = TRUE)
{
	xnames <- dimnames(x)[[2]]
	ynames <- names(y)
	conv <- FALSE
	nobs <- NROW(y)
	nvars <- NCOL(x)
	# define weights and offset if needed
	if (is.null(weights))
		weights <- rep(1, nobs)
	if (is.null(offset))
		offset <- rep(0, nobs)
	# get family functions
	variance <- family$variance
	dev.resids <- family$dev.resids
	linkinv <- family$linkinv
	mu.eta <- family$mu.eta
	if (!is.function(variance) || !is.function(linkinv) )
		stop("illegal 'family' argument")
	valideta<-family$valideta
	if (is.null(valideta)) valideta<-function(eta) TRUE
	validmu<-family$validmu
	if (is.null(validmu)) validmu<-function(mu) TRUE
	eval(family$initialize, sys.frame(sys.nframe()))
	if (NCOL(y) > 1)
		stop("y must be univariate unless binomial")
	if (is.null(start)) { # calculate initial estimate of eta and mu:
	  start<-c(0.5,rep(0,nvars-1))
	  linkfun <- family$linkfun
	  if (validmu(mustart)) {
	    etastart <- linkfun(mustart)
	    if (valideta(etastart)) {
		z <- etastart + (y - mustart)/mu.eta(etastart) - offset
		w <- sqrt((weights * mu.eta(etastart)^2)/variance(mustart))
		fit <- qr(x * w)
		start <- qr.coef(fit, w * z)
		start[is.na(start)] <- 0
	    }
	  }
	} else if (length(start) != nvars)
	    stop(paste("Length of start should equal", nvars,
		       "and correspond to initial coefs for", deparse(xnames)))
	eta <- as.vector(if (NCOL(x) == 1) x * start else x %*% start)
	mu <- linkinv(eta + offset)
	if (!(validmu(mu) && valideta(eta)))
	  stop("Can't find valid starting values: please specify with start=")
	## calculate initial deviance and coefficient
	devold <- sum(dev.resids(y, mu, weights))
	coefold <- start
	boundary<-FALSE

	##------------- THE Iteratively Reweighting L.S. iteration -----------
	for (iter in 1:control$maxit) {
		mu.eta.val <- mu.eta(eta + offset)
		if (any(ina <- is.na(mu.eta.val)))
			mu.eta.val[ina]<- mu.eta(mu)[ina]
		if (any(is.na(mu.eta.val)))
			stop("NAs in d(mu)/d(eta)")
		# calculate z and w using only values where mu.eta != 0
		good <- mu.eta.val != 0
		if (all(!good)) {
			conv <- FALSE
			warning("No observations informative at iteration",iter)
			break
		}
		z <- eta[good] + (y - mu)[good]/mu.eta.val[good]
		w <- sqrt((weights * mu.eta.val^2)[good]/variance(mu)[good])
		x <- as.matrix(x)
		ngoodobs <- as.integer(nobs - sum(!good))
		ncols <- as.integer(1)
		# call linpack code
		fit <- .Fortran("dqrls",
			qr = x[good, ] * w,
			n = as.integer(ngoodobs),
			p = nvars,
			y = w * z,
			ny = ncols,
			tol = min(1e-7, control$epsilon/1000),
			coefficients = mat.or.vec(nvars, 1),
			residuals = mat.or.vec(ngoodobs, 1),
			effects = mat.or.vec(ngoodobs, 1),
			rank = integer(1),
			pivot = 1:nvars,
			qraux = double(nvars),
			work = double(2 * nvars)
		)
		# stop if not enough parameters
		if (nobs < fit$rank)
			stop(paste("X matrix has rank", fit$rank,
				   "but only", nobs, "observations"))
		# calculate updated values of eta and mu with the new coef
		start <- coef <- fit$coefficients
		start[fit$pivot] <- coef
		eta[good] <- if (nvars == 1)
		  x[good] * start else as.vector(x[good, ] %*% start)
		mu <- linkinv(eta + offset)
		if (family$family == "binomial") {
			if (any(mu == 1) || any(mu == 0))
				warning("fitted probabilities of 0 or 1 occured")
			mu0 <- 0.5 * control$epsilon/length(mu)
			mu[mu == 1] <- 1 - mu0
			mu[mu == 0] <- mu0
		}
		else if (family$family == "poisson") {
			if (any(mu == 0))
				warning("fitted rates of 0 occured")
			mu[mu == 0] <- 0.5 * control$epsilon/length(mu)^2
		}
		dev <- sum(dev.resids(y, mu, weights))
		if (control$trace)
			cat("Deviance =", dev, "Iterations -", iter, "\n")
		# check for divergence
		boundary<-FALSE
		if (any(is.na(dev)) || any(is.na(coef))) {
			warning("Step size truncated due to divergence")
			ii<-1
			while((any(is.na(dev)) || any(is.na(start)))) {
			  if (ii>control$maxit)
				stop("inner loop 1; can't correct step size")
			  ii<-ii+1
			  start<-(start+coefold)/2
			  eta[good] <- if (nvars == 1)
			    x[good] * start else as.vector(x[good, ] %*% start)
			  mu <- linkinv(eta + offset)
			  dev <- sum(dev.resids(y, mu, weights))
			}
			boundary<-TRUE
			coef<-start
			if (control$trace)
				cat("New Deviance =", dev, "\n")
		}
		## check for fitted values outside domain.
		if (!(valideta(eta) && validmu(mu))) {
			warning("Step size truncated: out of bounds.")
			ii<-1
			while(!(valideta(eta) && validmu(mu))){
			  if (ii>control$maxit)
				stop("inner loop 2; can't correct step size")
			  ii<-ii+1
			  start<-(start+coefold)/2
			  eta[good] <- if (nvars == 1)
			    x[good] * start else as.vector(x[good, ] %*% start)
			  mu <- linkinv(eta + offset)
			}
			boundary<-TRUE
			coef<-start
			dev <- sum(dev.resids(y, mu, weights))
			if (control$trace)
				cat("New Deviance =", dev, "\n")
		}

		## check for convergence
		if (abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon) {
			conv <- TRUE
			break
		} else {
			devold <- dev
			coefold <- coef
		}
	}#-------------- end IRLS iteration -------------------------------
	if (!conv)
		warning("Algorithm did not converge")
	if (boundary)
		warning("Algorithm stopped at boundary value")
	## If X matrix was not full rank then columns were pivoted,
	## hence we need to re-label the names:
	if (fit$rank != nvars) {
		xnames <- xnames[fit$pivot]
		dimnames(fit$qr) <- list(NULL, xnames)
	}
	## calculate residuals
	residuals <- rep(NA, nobs)
	##	residuals[good] <- z - eta
	residuals[good]<- z-eta[good]

	## name output
	fit$qr <- as.matrix(fit$qr)

	nr <- min(sum(good), nvars)
	if(nr < nvars) {
		Rmat <- diag(nvars)
		Rmat[1:nr,1:nvars] <- fit$qr[1:nr,1:nvars]
	} else	Rmat <- fit$qr[1:nvars, 1:nvars]
	Rmat <- as.matrix(Rmat)

	Rmat[row(Rmat) > col(Rmat)] <- 0
	names(coef) <- xnames
	colnames(fit$qr) <- xnames
	dimnames(Rmat) <- list(xnames, xnames)
	names(residuals) <- ynames
	names(mu) <- ynames
	names(eta) <- ynames
	names(w) <- ynames
	names(weights) <- ynames
	names(y) <- ynames
	## calculate null deviance
	wtdmu <-
	  if (intercept) sum(weights * y)/sum(weights) else linkinv(offset)
	nulldev <- sum(dev.resids(y, wtdmu, weights))

	## calculate df
	n.ok <- nobs - sum(weights==0)
	nulldf <- n.ok - as.integer(intercept)
	resdf  <- n.ok - fit$rank
	list(coefficients = coef, residuals = residuals, fitted.values = mu,
	     effects = fit$effects, R = Rmat, rank = fit$rank,
	     qr = list(qr = fit$qr, rank = fit$rank, qraux = fit$qraux),
	     family = family, linear.predictors = eta, deviance = dev,
	     null.deviance = nulldev, iter = iter, weights = w^2,
	     prior.weights = weights, df.residual = resdf, df.null = nulldf,
	     y = y, converged = conv, boundary = boundary)
}

print.glm <- function (x, digits= max(3, .Options$digits - 3), na.print="", ...)
{
	cat("\nCall: ", deparse(x$call), "\n\n")
	cat("Coefficients:\n")
	print.default(round(x$coefficients, digits), print.gap = 2)
	cat("\nDegrees of Freedom:", x$df.null, "Total; ",
		 x$df.residual, "Residual\n")
	cat("Null Deviance:", format(signif(x$null.deviance, digits)), "\n")
	cat("Residual Deviance:", format(signif(x$deviance, digits)), "\n")
	invisible(x)
}


anova.glm <- function(object, ..., test=NULL, na.action=na.omit)
{
	## check for multiple objects
	dotargs<-list(...)
	named<- if (is.null(names(dotargs)))
			rep(FALSE,length(dotargs))
		else (names(dotargs) != "")
	dotargs<-dotargs[!named]
	is.glm<-unlist(lapply(dotargs,function(x) inherits(x,"glm")))
	dotargs<-dotargs[is.glm]
	if (length(dotargs)>0)
		return(anova.glmlist(c(list(object),dotargs),test=test,
				na.action=na.action))
	#args <- function(...) nargs()
	#if(args(...)) return(anova.glmlist(list(object, ...), test=test))

	## extract variables from model

	varlist <- attr(object$terms, "variables")
	if(!is.null(object$x) && !(is.logical(object$x) || object$x==FALSE))
		x <- object$x
	else {
		if(is.null(object$model)) {
			if(is.null(object$data))
				object$data <- sys.frame(sys.parent())
			object$model <- na.action(
				model.frame(eval(varlist, object$data),
					as.character(varlist[-1]), NULL))
		}
		x <- model.matrix(object$terms, object$model)
	}
	varseq <- attr(x, "assign")
	nvars <- max(varseq)
	resdev <- resdf <- NULL

	## if there is more than one explanatory variable then
	## recall glm.fit to fit variables sequentially

	if(nvars > 1) {
	  method <- object$method
	  if(!is.function(method))
		method <- get(method, mode = "function")
	  for(i in 1:(nvars-1)) {
		## explanatory variables up to i are kept in the model
		## use method from glm to find residual deviance
		## and df for each sequential fit
		fit <- method(x=x[, varseq <= i],
			      y=object$y,
			weights=object$prior.weights,
			start  =object$start,
			offset =object$offset,
			family =object$family,
			control=object$control)
		resdev <- c(resdev, fit$deviance)
		resdf <- c(resdf, fit$df.residual)
	  }
	}

	## add values from null and full model

	resdf <- c(object$df.null, resdf, object$df.residual)
	resdev <- c(object$null.deviance, resdev, object$deviance)

	## construct table and title

	table <- cbind(c(NA, -diff(resdf)), c(NA, -diff(resdev)), resdf, resdev)
	dimnames(table) <- list(c("NULL", attr(object$terms, "term.labels")),
				c("Df", "Deviance", "Resid. Df", "Resid. Dev"))
	title <- paste("Analysis of Deviance Table", "\n\nModel: ",
		object$family$family, ", link: ", object$family$link,
		"\n\nResponse: ", as.character(varlist[-1])[1],
		"\n\nTerms added sequentially (first to last)\n\n", sep="")

	## calculate test statistics if needed

	if(!is.null(test))
	 table <- stat.anova(table=table, test=test, scale=sum(
			object$weights*object$residuals^2)/object$df.residual,
			df.scale=object$df.residual, n=NROW(x))
	structure(list(title=title, table=table), class= "anova.glm")
}


anova.glmlist <- function(object, na.action=na.omit, test=NULL)
{

	# find responses for all models and remove
	# any models with a different response

	responses <- as.character(lapply(object, function(x) {
			as.character(x$formula[2])} ))
	sameresp <- responses==responses[1]
	if(!all(sameresp)) {
		object <- object[sameresp]
		warning(paste("Models with response", deparse(responses[
			!sameresp]), "removed because response differs from",
			"model 1"))
	}

	# calculate the number of models

	nmodels <- length(object)
	if(nmodels==1)	return(anova.glm(object[[1]], na.action=na.action,
					test=test))

	# extract statistics

	resdf <- as.numeric(lapply(object, function(x) x$df.residual))
	resdev <- as.numeric(lapply(object, function(x) x$deviance))

	# construct table and title

	table <- cbind(resdf, resdev, c(NA, -diff(resdf)), c(NA, -diff(resdev)))
	variables <- as.character(lapply(object, function(x) {
			as.character(x$formula[3])} ))
	dimnames(table) <- list(variables, c("Resid. Df", "Resid. Dev", "Df",
				"Deviance"))
	title <- paste("Analysis of Deviance Table \n\nResponse: ", responses[1],
			"\n\n", sep="")

	# calculate test statistic if needed

	if(!is.null(test)) {
		bigmodel <- object[[(order(resdf)[1])]]
		table <- stat.anova(table=table, test=test, scale=sum(
			bigmodel$weights * bigmodel$residuals^2)/
			bigmodel$df.residual, df.scale=min(resdf),
			n=length(bigmodel$residuals))
	}

	structure(list(table=table, title=title),
		  class= "anova.glm")
}


stat.anova <- function(table, test, scale, df.scale, n)
{
	testnum <- match(test, c("Chisq", "F", "Cp"))
	if(is.na(testnum))
		stop(paste("Test \"", test, "\" not recognised", sep=""))
	cnames <- colnames(table)
	rnames <- rownames(table)
	if(testnum==1) {
		chisq <- 1-pchisq(abs(table[, "Deviance"]), abs(table[, "Df"]))
		table <- cbind(table, chisq)
		dimnames(table) <- list(rnames, c(cnames, "P(>|Chi|)"))
	} else if(testnum==2) {
		Fvalue <- abs((table[, "Deviance"]/table[, "Df"])/scale)
		pvalue <- 1-pf(Fvalue, abs(table[, "Df"]), abs(df.scale))
		table <- cbind(table, Fvalue, pvalue)
		dimnames(table) <- list(rnames, c(cnames, "F", "Pr(>F)"))
	} else if(testnum==3) {
		Cp <- table[, "Resid. Dev"] + 2*scale*(n - table[, "Resid. Df"])
		table <- cbind(table, Cp)
		dimnames(table) <- list(rnames, c(cnames, "Cp"))
	}
	return(table)
}


summary.glm <- function(object, dispersion = NULL,
	correlation = TRUE, na.action=na.omit)
{
	est.disp<-FALSE
	if(is.null(dispersion))	# calculate dispersion if needed
	  dispersion <-
		if(any(object$family$family == c("poisson", "binomial")))
		  1
		else {
			est.disp<-TRUE
			if(any(object$weights==0))
				warning(paste("observations with zero weight",
				"not used for calculating dispersion"))
			sum(object$weights*object$residuals^2)/
				object$df.residual
		}


	## extract x to get column names

	if(is.null(object$x)) {
		if(is.null(object$model)) {
			varlist <- attr(object$terms, "variables")
			if(is.null(object$data))
				object$data <- sys.frame(sys.parent())
			object$model <- na.action(model.frame(eval(varlist,
				object$data), as.character(varlist[-1]), NULL))
		}
		object$x <- model.matrix(object$terms, object$model)
	}

	## calculate scaled and unscaled covariance matrix

	p <- object$rank
	p1 <- 1:p
	coef.p <- object$coefficients[p1]
	covmat.unscaled <- chol2inv(object$qr$qr[p1,p1,drop=FALSE])
	dimnames(covmat.unscaled) <- list(names(coef.p),names(coef.p))
	covmat <- dispersion*covmat.unscaled
	##not necess.: dimnames(covmat) <- dimnames(covmat.unscaled)

	## calculate coef table

##	nas <- is.na(object$coefficients)
	var.cf <- diag(covmat)
	s.err <- sqrt(var.cf)
	tvalue <- coef.p/s.err
	if(est.disp) {
		pvalue <- 2*pt(-abs(tvalue), object$df.residual)
		coef.table <- cbind(coef.p, s.err, tvalue, pvalue)
		dimnames(coef.table) <- list(names(coef.p),
				     c("Value","Std.error","t value","P(>|t|)"))
	}
	else {
		pvalue <- 2*pnorm(-abs(tvalue))
		coef.table <- cbind(coef.p, s.err, tvalue, pvalue)
		dimnames(coef.table) <- list(names(coef.p),
				     c("Value","Std.error","z value","P(>|z|)"))
	}

	## return answer

	ans <- c(object[c("call","terms","family","deviance",
			  "df.residual","null.deviance","df.null","iter")],
		 list(deviance.resid=residuals(object, type = "deviance"),
		      coefficients=coef.table,
		      dispersion=dispersion,
		      df=c(object$rank, object$df.residual),
		      cov.unscaled=covmat.unscaled,
		      cov.scaled=covmat))
##		      nas=nas))

	if(correlation)
	  ans$correlation <-
		as.matrix(covmat/sqrt(crossprod(rbind(var.cf))))
	class(ans) <- "summary.glm"
	return(ans)
}


print.summary.glm <- function (x, digits = max(3, .Options$digits - 3),
	roundfun=round, na.print="", ...)
{
	cat("\nCall:\n")
	cat(paste(deparse(x$call), sep="\n", collapse="\n"), "\n\n", sep="")
	cat("Deviance Residuals: \n")
	if(x$df.residual > 5) {
		x$deviance.resid <- quantile(x$deviance.resid)
		names(x$deviance.resid) <- c("Min", "1Q", "Median", "3Q", "Max")
	}
	print.default(x$deviance.resid, digits=digits, na = "", print.gap = 2)
	cat("\nCoefficients:\n")
	print.default(roundfun(x$coefficients, digits=digits), print.gap = 2)
	cat(paste("\n(Dispersion parameter for ", x$family$family,
		" family taken to be ", x$dispersion,
		")\n\n	  Null deviance: ", x$null.deviance,
		" on ", x$df.null, " degrees of freedom\n\n",
		"Residual deviance: ", x$deviance,
		" on ", x$df.residual, " degrees of freedom\n\n",
		"Number of Fisher Scoring iterations: ", x$iter,
		"\n\n", sep=""))

	correl <- x$correlation
	if(!is.null(correl)) {
		p <- dim(correl)[2]
		if(p > 1) {
			cat("Correlation of Coefficients:\n")
			correl[!lower.tri(correl)] <- NA
			print(correl[-1, -NCOL(correl), drop=FALSE],
			      digits=digits, na="")
		}
		cat("\n")
	}
	invisible(x)
}


print.anova.glm <- function(x, digits = max(3, .Options$digits - 3),
	na.print = "", ...)
{
	cat("\n", x$title, sep="")
	print.default(x$table, digits=digits, na = "", print.gap = 2)
	cat("\n")
}

# GLM Methods for Generic Functions :

coefficients.glm <- function(object) object$coefficients
deviance.glm	 <- function(object) object$deviance
effects.glm	 <- function(object) object$effects
fitted.values.glm<- function(object) object$fitted.values

family.glm <- function(object) {
	family <- get(as.character(object$family$family), mode="function")
	family()
}

residuals.glm <- function(object, type="deviance")
{
	type <- match(type, c("deviance", "pearson", "working", "response"))
	y <- object$y
	mu <- object$fitted.values
	wts <- object$prior.weights
	switch(type,
		deviance = {
			dev.resids <- object$family$dev.resids
			ifelse(y > mu, sqrt(dev.resids(y, mu, wts)),
				      -sqrt(dev.resids(y, mu, wts)))
		},
		pearson	 = object$residuals * sqrt(object$weights),
		working	 = object$residuals,
		response = y - mu
		)
}

update.glm <- function (glm.obj, formula, data, weights, subset, na.action,
			offset, family, x)
{
	call <- glm.obj$call
	if (!missing(formula))
	  call$formula <- update.formula(call$formula, formula)
	if (!missing(data))	call$data <- substitute(data)
	if (!missing(subset))	call$subset <- substitute(subset)
	if (!missing(na.action))call$na.action <- substitute(na.action)
	if (!missing(weights))	call$weights <- substitute(weights)
	if (!missing(offset))	call$offset <- substitute(offset)
	if (!missing(family))	call$family <- substitute(family)
	if (!missing(x))	call$x <- substitute(x)
##	notparent <- c("NextMethod", "update", methods(update))
##	for (i in 1:(1+sys.parent())) {
##		parent <- sys.call(-i)[[1]]
##		if (is.null(parent))
##		break
##	if (is.na(match(as.character(parent), notparent)))
##			break
##	}
##	eval(call, sys.frame(-i))
	eval(call, sys.frame(sys.parent()))
}
