https://github.com/cran/MuMIn
Raw File
Tip revision: f8469f452d8a1be30d399d978de9550b4632bb51 authored by Kamil BartoĊ„ on 31 January 2012, 16:44:51 UTC
version 1.7.2
Tip revision: f8469f4
ext.R
# This is merely to get rid of the annoying behaviour in summary.glmML.
# it does not do anything except for printing the model output.
`summary.glmmML` <- function(object, ...) object

# family
`family.default` <- function (object, ...)  {
	cl <- getElement(object, "call")
	if(is.null(cl)) return(NULL)
	fam <- cl$family
	if(is.null(fam)) fam <- formals(match.fun(cl[[1L]]))$family
	if(is.null(fam)) return(gaussian())
	switch(mode(fam), call = eval(fam), name =, character = match.fun(fam)())
}


`family.gls` <-
`family.lme` <-
stats:::family.lm

`nobs.rq` <-
function (object, ...) length(object$y)

`coefTable.rq` <- function(model, ...)
	.makeCoefTable(model$coefficients, rep(NA_real_, length(model$coefficients)))


# Classes 'coxme' and 'lmekin' from package 'coxme':

`logLik.coxme` <-
function(object, type = c("integrated", "penalized"), ...) {
	type <- match.arg(type)
	i <- which(type == c("integrated", "penalized"))[1L]
	ret <- object$loglik[[i + 1L]]
	attr(ret, "df") <- object$df[i]
	attr(ret, "nobs") <- object$n[1L]
	class(ret) <- "logLik"
	ret
}

`logLik.lmekin` <-
function(object, ...) {
	ret <- object$loglik
	attr(ret, "nobs") <- object$n
	attr(ret, "df") <- length(object$coefficients$fixed) +
		length(object$coefficients$random) + 1L
	class(ret) <- "logLik"
	ret
}

`nobs.coxme` <-
function (object, ...) object$n[2L]

`nobs.lmekin` <-
function (object, ...) object$n[1L]

`getAllTerms.coxme` <-
function(x, ...)  {
	ret <- MuMIn:::getAllTerms.terms(terms(x))
	random <- x$formulaList$random
	attr(ret, "random.terms") <- as.character(random)
	f <- as.name(".")
	for(f1 in random) f <- call("+", f, f1)
	attr(ret, "random") <- call("~", as.name("."), f)
	attr(ret, "intercept") <- 0L
	attr(ret, "interceptLabel") <- NULL
	ret
}

`formula.coxme` <-
function(x, ...)  {
	ret <- x$formulaList$fixed
	f <- ret[[3L]]
	for(f1 in x$formulaList$random) f <- call("+", f, f1)
	ret[[3L]] <- f
	ret
}

`formula.lmekin` <-
function(x, ...) eval(x$call$formula, parent.frame())


`coeffs.coxme` <-
`coeffs.lmekin` <-
function(model) {
	# for class coxme:
	ret <- model$coefficients
	# for class lmekin and older coxme
	if(is.list(ret) && !is.null(ret$fixed)) return(ret$fixed)
	ret
}


`makeArgs.coxme` <-
`makeArgs.lmekin` <-
function(obj, termNames, comb, opt, ...) {
	ret <- makeArgs.default(obj, termNames, comb, opt)
	f <- .Internal(update.formula(as.formula(ret$formula), as.formula(. ~ . + 1)))
	ret$formula <- update.formula(f, opt$random)
	ret
}


## Classes 'hurdle' and 'zeroinfl' from package 'pscl':

`nobs.hurdle` <-
`nobs.zeroinfl` <- `nobs.lmekin`

`getAllTerms.hurdle` <- function(x, intercept = FALSE, ...) {
	f <- as.formula(formula(x))
	# to deal with a dot in formula (other classes seem to expand it)
	if("." %in% all.vars(f))
		getAllTerms.terms(terms.formula(f, data = eval(x$call$data, envir =
			environment(f))), intercept = intercept)
	else getAllTerms.formula(f, intercept = intercept)
}

`getAllTerms.zeroinfl` <- function(x, intercept = FALSE, ...) {
	f <- formula(x)
	if(length(f[[3L]]) != 1L && f[[3L]][[1L]] == "|"){
		f1 <- call("~", f[[2L]], f[[3L]][[2L]])
		f2 <- call("~", f[[3L]][[3L]])
	} else {
		f1 <- f
		f2 <- NULL
	}
	fs <- lapply(lapply(c(f1, f2), terms.formula, data = eval(x$call$data)),
		formula)
	z <- lapply(fs, getAllTerms, intercept = TRUE)

	ord <- unlist(lapply(z, attr, "order"))
	n <- sapply(z, length)
	if(length(z) > 1L) ord[-j] <- ord[-(j <- seq_len(n[1L]))] + n[1L]
	zz <- unlist(z)
	Ints <- which(zz == "(Intercept)")
	#zz[Ints] <- "1"
	#zz <- paste(rep(c("count", "zero")[seq_along(z)], sapply(z, length)),
		#"(", zz, ")", sep = "")
	zz <- paste(rep(c("count", "zero")[seq_along(z)], sapply(z, length)),
		"_", zz, sep = "")
	ret <- if(!intercept) zz[-Ints] else zz
	attr(ret, "intercept") <- pmin(Ints, 1)
	attr(ret, "interceptLabel") <- zz[Ints]
	attr(ret, "response") <- attr(z[[1L]], "response")
	attr(ret, "order") <- if(!intercept) order(ord[-Ints]) else ord
	ret
}

`coefTable.zeroinfl` <-
function(model, ...)
	.makeCoefTable(coef(model), sqrt(diag(vcov(model, ...))))

`coefTable.hurdle` <- function(model, ...) {
	cts <- summary(model)$coefficients
	ct <- do.call("rbind", unname(cts))
	cfnames <- paste(rep(names(cts), vapply(cts, nrow, 1L)), "_", rownames(ct),
		sep = "")
	.makeCoefTable(ct[, 1L], ct[, 2L], coefNames = cfnames)
	#.makeCoefTable(coef(model), sqrt(diag(vcov(model, ...))))
}
back to top