https://github.com/cran/MuMIn
Tip revision: 261df4b532c6a0965133d1a7a57c3860bdd3bc18 authored by Kamil BartoĊ on 09 April 2019, 11:32:46 UTC
version 1.43.6
version 1.43.6
Tip revision: 261df4b
class-glmmTMB.R
#wrapCoefficients <-
#function(x, pfx = names(x), empty = "") {
# i <- pfx != empty
# if(any(i)) x[i] <- paste0(pfx[i], "(", x[i], ")")
# x
#}
`getAllTerms.glmmTMB` <-
function(x, intercept = FALSE, offset = TRUE, ...) {
at <- x$modelInfo$allForm[c("formula", "ziformula", "dispformula")]
at <- lapply(at, getAllTerms.formula, intercept = FALSE, offset = TRUE)
names(at) <- c("cond", "zi", "disp")
deps <- termdepmat_combine(lapply(at, attr, "deps"))
attrInt <- sapply(at, attr, "intercept")
#rval <- unlist(at)
#rval <- wrapCoefficients(rval, rep(names(at), vapply(at, length, 0)))
rval <- unlist(lapply(names(at), function(i)
if (length(at[[i]])) paste0(i, "(", at[[i]], ")")
else character(0L)))
off <- lapply(at, function(tt) if(is.null(off <- attr(tt,"offset"))) integer(0L) else match(off, tt))
loff <- sapply(off, length)
off <- if(any(loff > 0L)) {
unlist(off) + rep(c(0L, cumsum(sapply(at[-length(at)], length))), sapply(off, length))
} else NULL
if(hasOffset <- !is.null(off)) {
offsetTerm <- rval[off]
if(!isTRUE(offset)) {
depnames <- rval <- rval[-off]
} else depnames <- rval[-off]
} else depnames <- rval
dimnames(deps) <- list(depnames, depnames)
intLabel <- paste0(names(attrInt[attrInt != 0L]), "((Int))")
ord <- lapply(at, attr, "order")
ordl <- vapply(ord, length, 0, USE.NAMES = FALSE)
ord <- unlist(ord, use.names = FALSE) + rep(c(0, ordl[-length(ordl)]), ordl)
if(intercept) {
rval <- c(intLabel, rval)
ord <- c(seq.int(along.with = intLabel), ord + length(intLabel))
}
if(hasOffset) attr(rval, "offset") <- offsetTerm
rt <- lapply(at, "attr", "random.terms")
if(!all(vapply(rt, is.null, FALSE))) {
rt <- paste0(rep(names(rt), vapply(rt, length, 0L)), "(", unlist(rt), ")")
random <- reformulate(c(".", rt), response = ".")
environment(random) <- environment(x$modelInfo$allForm$combForm)
} else
rt <- random <- NULL
attr(rval, "random.terms") <- rt
attr(rval, "random") <- random
attr(rval, "response") <- attr(at$cond, "response")
attr(rval, "order") <- ord
attr(rval, "intercept") <- attrInt
attr(rval, "interceptLabel") <- intLabel
attr(rval, "deps") <- deps
return(rval)
}
coefTable.glmmTMB <-
function (model, ...) {
dfs <- df.residual(model)
cf <- summary(model, ...)$coefficients
cf1 <- do.call("rbind", cf)
nm <- paste0(rep(names(cf), sapply(cf, NROW)), "(", rownames(cf1), ")")
nm <- sub("\\(\\(Intercept\\)\\)$", "((Int))", nm)
.makeCoefTable(cf1[, 1L], cf1[, 2L], dfs, coefNames = nm)
}
coeffs.glmmTMB <-
function(model) {
coefTable(model)[, 1L]
}
`makeArgs.glmmTMB` <-
function(obj, termNames, opt, ...) {
.addRanTermToFormula <- function(f, r) {
if(is.null(r)) return(f)
dot <- as.symbol(".")
rflhs <- call("+", dot, call("(", r))
if(is.null(f)) f <- ~ 1
update.formula(f, as.formula(if(length(f) == 2L) call("~", rflhs) else call("~", dot, rflhs)))
}
fnm <- c("cond", "zi", "disp")
randomterms <- attr(opt$allTerms, "random.terms")
randomterms <- lapply(randomterms, function(x) parse(text = x)[[1L]])
names(randomterms) <- vapply(lapply(randomterms, "[[", 1L), as.character, "")
randomterms <- lapply(randomterms, "[[", 2L)
rval <- umf_terms2formulalist(termNames, opt, replaceInt = "1")[fnm]
for(i in fnm)
while(i %in% names(randomterms)) {
rval[[i]] <- .addRanTermToFormula(rval[[i]], randomterms[[i]])
randomterms[[i]] <- NULL
}
argnm <- c("formula", "ziformula", "dispformula")
names(rval) <- argnm
for(i in which(vapply(rval, is.null, FALSE))) {
rval[[i]] <- ~ 0
environment(rval[[i]]) <- opt$gmFormulaEnv
}
rval$formula <- as.formula(call("~", as.symbol(opt$response), rval$formula[[2L]]), opt$gmFormulaEnv)
rval
}