gaussian <- function()
{
	#this is a function used in the glm function
	#it holds everything personal to the family

	stats <- make.link("identity")
	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
			})
	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)
	class(family) <- "family"
	return(family)
}


binomial <- function(link="logit")
{
	# this is a function used in the glm function
	# it holds everything personal to the family

	# converts link into character string

	linktemp <- substitute(link)
	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)
	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+.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)
	class(family) <- "family"
	return(family)
}


poisson <- function(link="log")
{
	#this is a function used in the glm function
	#it holds everything personal to the family

	#converts link into character string

       	linktemp <- substitute(link)
       	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
	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)
	class(family) <- "family"
	return(family)
}


Gamma <- function(link="inverse")
{
	#this is a function used in the glm function
	#it holds everything personal to the family

	#converts link into character string

	linktemp <- substitute(link)
	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
	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)
	class(family) <- "family"
	return(family)
}


inverse.gaussian <- function()
{
	# this is a function used in the glm function
	# it holds everything personal to the family

	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
			})

	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)
	class(family) <- "family"
	return(family)
}


quasi <- function(link="identity", variance="constant")
{
	#this is a function used in the glm function
	#it holds everything personal to the family

	#converts link into character string

       	linktemp <- substitute(link)
	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)
	}
	if(variancetemp=="mu(1-mu)")  {
		variance <- function(mu) mu*(1-mu)
		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
		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
		dev.resids <- function(y, mu, wt)  -2*wt*(log(y/mu) - (y-mu)/mu)
	}
	if(variancetemp=="mu^3")  {
		variance <- function(mu) mu^3
		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)
	class(family) <- "family"
	return(family)
}


power <- function(lambda = 1)
{
	if(lambda <= 0)
		return("log")
	return(lambda)
}


make.link <- function(link) 
{
	#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

	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
		recognise <- TRUE
	}
	if(link=="probit")  {
		linkfun <- function(mu) qnorm(mu)
		linkinv <- pnorm
		mu.eta <- function(eta) .3989422*exp(-0.5*eta^2)
		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))
		recognise <- TRUE
	}
	if(link=="identity")  {
		linkfun <- function(mu)  mu
		linkinv <- function(eta) eta
		mu.eta <- function(eta)  rep(1, length(eta))
		recognise <- TRUE
	}
	if(link=="log")  {
		linkfun <- function(mu)  log(mu)
		linkinv <- function(eta) exp(eta)
		mu.eta <- function(eta)  exp(eta)
		recognise <- TRUE
	}
	if(link=="sqrt")  {
		linkfun <- function(mu)  mu^0.5
		linkinv <- function(eta) eta^2
		mu.eta <- function(eta)  2*eta
		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)
		recognise <- TRUE
	}
	if(link=="inverse")  {
		linkfun <- function(mu)  1/mu
		linkinv <- function(eta) 1/eta
		mu.eta <- function(eta)  -1/(eta^2)
		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)
		recognise <- TRUE
	}
	if(!recognise)
		stop(paste(link, "link not recognised"))
	return(list(linkfun=linkfun, linkinv=linkinv, mu.eta=mu.eta))
}

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

print.family <- function(x, ...)
{
	cat("\nFamily:", x$family, "\n")
	cat("Link function:", x$link, "\n\n") 
}
