"family" <-
function(x, ...)
UseMethod("family")

"print.family" <-
function(x, ...)
{
	cat("\nFamily:", x$family, "\n")
	cat("Link function:", x$link, "\n\n") 
}
"power" <-
function(lambda = 1)
{
	if(lambda <= 0)
		return("log")
	return(lambda)
}

# this function is used with the glm function
# given a link it returns a link function, an inverse link
# function and the derivative dmu/deta
# Written by Simon Davies Dec 1995

## Modified by Thomas Lumley 26 Apr 97
## added valideta(eta) function returning TRUE if all of eta
## is in the domain of linkinv

"make.link" <-
function (link) 
{
	recognise <- FALSE
	if (link == "logit") {
		linkfun <- function(mu) log(mu/(1 - mu))
		linkinv <- function(eta) exp(eta)/(1 + exp(eta))
		mu.eta <- function(eta) exp(eta)/(1 + exp(eta))^2
		valideta <- function(eta) TRUE
		recognise <- TRUE
	}
	if (link == "probit") {
		linkfun <- function(mu) qnorm(mu)
		linkinv <- pnorm
		mu.eta <- function(eta) 0.3989422 * exp(-0.5 * eta^2)
		valideta <- function(eta) TRUE
		recognise <- TRUE
	}
	if (link == "cloglog") {
		linkfun <- function(mu) log(-log(1 - mu))
		linkinv <- function(eta) 1 - exp(-exp(eta))
		mu.eta <- function(eta) exp(eta) * exp(-exp(eta))
		valideta <- function(eta) TRUE
		recognise <- TRUE
	}
	if (link == "identity") {
		linkfun <- function(mu) mu
		linkinv <- function(eta) eta
		mu.eta <- function(eta) rep(1, length(eta))
		valideta <- function(eta) TRUE
		recognise <- TRUE
	}
	if (link == "log") {
		linkfun <- function(mu) log(mu)
		linkinv <- function(eta) exp(eta)
		mu.eta <- function(eta) exp(eta)
		valideta <- function(eta) TRUE
		recognise <- TRUE
	}
	if (link == "sqrt") {
		linkfun <- function(mu) mu^0.5
		linkinv <- function(eta) eta^2
		mu.eta <- function(eta) 2 * eta
		valideta <- function(eta) all(eta>0)
		recognise <- TRUE
	}
	if (link == "1/mu^2") {
		linkfun <- function(mu) 1/mu^2
		linkinv <- function(eta) 1/eta^0.5
		mu.eta <- function(eta) -1/(2 * eta^1.5)
		valideta <- function(eta) all(eta>0)
		recognise <- TRUE
	}
	if (link == "inverse") {
		linkfun <- function(mu) 1/mu
		linkinv <- function(eta) 1/eta
		mu.eta <- function(eta) -1/(eta^2)
		valideta <- function(eta) all(eta!=0)
		recognise <- TRUE
	}
	if (!is.na(as.numeric(link))) {
		lambda <- as.numeric(link)
		linkfun <- function(mu) mu^lambda
		linkinv <- function(eta) eta^(1/lambda)
		mu.eta <- function(eta) (1/lambda) * eta^(1/lambda - 1)
		valideta <- function(eta) all(eta>0)
		recognise <- TRUE
	}
	if (!recognise) 
		stop(paste(link, "link not recognised"))
	return(list(linkfun = linkfun,
		linkinv = linkinv,
		mu.eta = mu.eta,
		valideta=valideta))
}

"poisson" <-
function (link = "log") 
{
	linktemp <- substitute(link)
	#this is a function used in the glm function
	#it holds everything personal to the family
	#converts link into character string
	if (!is.character(linktemp)) {
		linktemp <- deparse(linktemp)
		if (linktemp == "link") 
			linktemp <- eval(link)
	}
	if (any(linktemp == c("log", "identity", "sqrt"))) 
		stats <- make.link(linktemp)
	else stop(paste(linktemp, "link not available for poisson",
			"family, available links are \"identity\", ",
			"\"log\" and \"sqrt\""))
	variance <- function(mu) mu
	validmu <- function(mu) all(mu>0)
	dev.resids <- function(y, mu, wt)
		2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) - (y - mu))
	initialize <- expression({
		if (any(y < 0)) 
			stop(paste("Negative values not allowed for",
				"the Poisson family"))
		n <- rep(1, nobs)
		mustart <- y + 0.1
	})
	family <- list(family = "poisson",
			link = linktemp,
			linkfun = stats$linkfun,
			linkinv = stats$linkinv,
			variance = variance,
			dev.resids = dev.resids,
			mu.eta = stats$mu.eta,
			initialize = initialize,
			validmu = validmu,
			valideta = stats$valideta)
	class(family) <- "family"
	return(family)
}

"gaussian" <-
function () 
{
	stats <- make.link("identity")
	# this is a function used in the glm function
	# it holds everything personal to the family
	variance <- function(mu) rep(1, length(mu))
	dev.resids <- function(y, mu, wt) wt * ((y - mu)^2)
	initialize <- expression({
		n <- rep(1, nobs)
		mustart <- y
	})
	validmu <- function(mu) TRUE
	family <- list(family = "gaussian",
			link = "identity",
			linkfun = stats$linkfun,
			linkinv = stats$linkinv,
			variance = variance,
			dev.resids = dev.resids,
			mu.eta = stats$mu.eta,
			initialize = initialize,
			validmu = validmu,
			valideta = stats$valideta)
	class(family) <- "family"
	return(family)
}

"binomial" <-
function (link = "logit") 
{
	linktemp <- substitute(link)
	# this is a function used in the glm function
	# it holds everything personal to the family
	# converts link into character string
	if (!is.character(linktemp)) {
		linktemp <- deparse(linktemp)
		if (linktemp == "link") 
			linktemp <- eval(link)
	}
	if (any(linktemp == c("logit", "probit", "cloglog"))) 
		stats <- make.link(linktemp)
	else stop(paste(linktemp, "link not available for binomial",
		"family, available links are \"logit\", ",
		"\"probit\" and \"cloglog\""))
	variance <- function(mu) mu * (1 - mu)
	validmu <- function(mu) all(mu>0) && all(mu<1)
	dev.resids <- function(y, mu, wt)
		2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) +
		(1 - y) * log(ifelse(y == 1, 1, (1 - y)/(1 - mu))))
	initialize <- expression({
		if (NCOL(y) == 1) {
			n <- rep(1, nobs)
			if (any(y < 0 | y > 1)) 
				stop("y values must be 0 <= y <= 1")
		}
		else if (NCOL(y) == 2) {
			n <- y[, 1] + y[, 2]
			y <- y[, 1]/n
			weights <- weights * n
		}
		else stop(paste("For the binomial family, y must be",
			"a vector of 0 and 1\'s or a 2 column",
			"matrix where col 1 is no. successes",
			"and col 2 is no. failures"))
		mustart <- (n * y + 0.5)/(n + 1)
	})
	family <- list(family = "binomial",
			link = linktemp,
			linkfun = stats$linkfun,
			linkinv = stats$linkinv,
			variance = variance,
			dev.resids = dev.resids,
			mu.eta = stats$mu.eta,
			initialize = initialize,
			validmu = validmu,
			valideta = stats$valideta)
	class(family) <- "family"
	return(family)
}

"Gamma" <-
function (link = "inverse") 
{
	linktemp <- substitute(link)
	#this is a function used in the glm function
	#it holds everything personal to the family
	#converts link into character string
	if (!is.character(linktemp)) {
		linktemp <- deparse(linktemp)
		if (linktemp == "link") 
			linktemp <- eval(link)
	}
	if (any(linktemp == c("inverse", "log", "identity"))) 
		stats <- make.link(linktemp)
	else stop(paste(linktemp, "link not available for gamma",
		"family, available links are \"inverse\", ",
		"\"log\" and \"identity\""))
	variance <- function(mu) mu^2
	validmu <- function(mu) all(mu>0) 
	dev.resids <- function(y, mu, wt)
		-2 * wt * (log(ifelse(y == 0, 1, y/mu)) - (y - mu)/mu)
	initialize <- expression({
		if (any(y < 0)) 
			stop(paste("Negative values not",
				"allowed for the gamma family"))
		n <- rep(1, nobs)
		mustart <- y
	})
	family <- list(family = "Gamma",
			link = linktemp,
			linkfun = stats$linkfun,
			linkinv = stats$linkinv,
			variance = variance,
			dev.resids = dev.resids,
			mu.eta = stats$mu.eta,
			initialize = initialize,
			validmu = validmu,
			valideta = stats$valideta)
	class(family) <- "family"
	return(family)
}

"inverse.gaussian" <-
function()
{
	stats <- make.link("1/mu^2")
	variance <- function(mu) mu^3
	dev.resids <- function(y, mu, wt)  wt*((y - mu)^2)/(y*mu^2)
	initialize <- expression({
			if(any(y <= 0))
				stop(paste("Positive values only allowed for",
					"the inverse.gaussian family"))
			n <- rep(1, nobs)
			mustart <- y
			})
	validmu <- function(mu) TRUE

	family <- list(family = "inverse.gaussian",
			link = "1/mu^2",
			linkfun = stats$linkfun,
			linkinv = stats$linkinv,
			variance = variance,
			dev.resids = dev.resids,
			mu.eta = stats$mu.eta,
			initialize = initialize,
			validmu = validmu,
			valideta = stats$valideta)
	class(family) <- "family"
	return(family)
}

"quasi" <-
function (link = "identity", variance = "constant") 
{
	linktemp <- substitute(link)
	#this is a function used in the glm function
	#it holds everything personal to the family
	#converts link into character string
	if (is.expression(linktemp)) 
		linktemp <- eval(linktemp)
	if (!is.character(linktemp)) {
		linktemp <- deparse(linktemp)
		if (linktemp == "link") 
			linktemp <- eval(link)
	}
	stats <- make.link(linktemp)
	#converts variance into character string
	variancetemp <- substitute(variance)
	if (!is.character(variancetemp)) {
		variancetemp <- deparse(variancetemp)
		if (linktemp == "variance") 
			variancetemp <- eval(variance)
	}
	if (!any(variancetemp == c("mu(1-mu)",
		"mu", "mu^2", "mu^3", "constant"))) 
		stop(paste(variancetemp, "not recognised, possible variances",
			"are \"mu(1-mu)\", \"mu\", \"mu^2\", \"mu^3\" and",
			"\"constant\""))
	if (variancetemp == "constant") {
		variance <- function(mu) rep(1, length(mu))
		dev.resids <- function(y, mu, wt) wt * ((y - mu)^2)
		validmu <-function(mu) TRUE
	}
	if (variancetemp == "mu(1-mu)") {
		variance <- function(mu) mu * (1 - mu)
		validmu <-function(mu) all(mu>0) && all(mu<1)
		dev.resids <- function(y, mu, wt)
			2 * wt * (y * log(ifelse(y == 0, 1,
			y/mu)) + (1 - y) * log(ifelse(y == 1, 1, (1 - y)/(1 - mu))))
	}
	if (variancetemp == "mu") {
		variance <- function(mu) mu
		validmu<-function(mu) all(mu>0)
		dev.resids <- function(y, mu, wt)
			2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) - (y - mu))
	}
	if (variancetemp == "mu^2") {
		variance <- function(mu) mu^2
		validmu<-function(mu) all(mu!=0)
		dev.resids <- function(y, mu, wt)
			-2 * wt * (log(y/mu) - (y - mu)/mu)
	}
	if (variancetemp == "mu^3") {
		variance <- function(mu) mu^3
		validmu <-function(mu) all(mu>0)
		dev.resids <- function(y, mu, wt) wt * ((y - mu)^2)/(y * mu^2)
	}
	initialize <- expression({
		n <- rep(1, nobs)
		mustart <- y
	})
	family <- list(family = "quasi",
			link = linktemp,
			linkfun = stats$linkfun,
			linkinv = stats$linkinv,
			variance = variance,
			dev.resids = dev.resids,
			mu.eta = stats$mu.eta,
			initialize = initialize,
			validmu = validmu,
			valideta = stats$valideta)
	class(family) <- "family"
	return(family)
}
