MuMIn/0000755000176200001440000000000015161557552011253 5ustar liggesusersMuMIn/tests/0000755000176200001440000000000015161444475012414 5ustar liggesusersMuMIn/tests/misc-tests.R0000644000176200001440000000335012730246630014623 0ustar liggesusers# Test varia require(MuMIn) packageVersion("MuMIn") options(na.action = "na.fail") #print(packageDescription("MuMIn", fields = "Version")) # TEST binary response --------------------------------------------------------- ldose <- rep(0:5, 2) numdead <- c(1, 4, 9, 13, 18, 20, 0, 2, 6, 10, 12, 16) sex <- factor(rep(c("M", "F"), c(6, 6))) SF <- cbind(numdead, numalive=20-numdead) budworm.lg <- glm(SF ~ sex*ldose, family = binomial) dd <- dredge(budworm.lg, trace=FALSE) gm <- get.models(dd, 1:4) model.avg(gm) # The same, but use cbind directly in the formula budworm.lg <- glm(cbind(numdead, numalive=20-numdead) ~ sex*ldose, family=binomial) dd <- dredge(budworm.lg, trace=TRUE) avgmod <- model.avg(get.models(dd, 1:4)) # TEST for consistency of vcov and se calculation ------------------------------ if(!isTRUE(all.equal(coefTable(avgmod, adjust.se = FALSE)[,2], sqrt(diag(vcov(avgmod))), tolerance = .001))) stop("'vcov' has a problem") # TEST evaluation from within function ----------------------------------------- budworm <- data.frame(ldose = rep(0:5, 2), numdead = c(1, 4, 9, 12, 18, 20, 0, 2, 6, 10, 12, 16), sex = factor(rep(c("M", "F"), c(6, 6)))) budworm$SF <- cbind(numdead = budworm$numdead, numalive = 20 - budworm$numdead) # evaluate within an exotic environment (function(dat) (function(dat2) { #mod <- glm(SF ~ sex*ldose, data = dat2, family = "quasibinomial", trace=T) mod <- glm(SF ~ sex*ldose, data = dat2, family = "binomial") #mod <- glm(SF ~ sex*ldose, data = budworm, family = "binomial", trace=F) print(dd <- dredge(mod, rank = "QAIC", chat = summary(budworm.lg)$dispersion)) gm <- get.models(dd, subset = NA, family = "binomial") #print(sys.frames()) summary(model.avg(gm)) })(dat))(budworm) rm(list=ls()) # END TESTS MuMIn/tests/gam.R0000644000176200001440000000155513452746103013303 0ustar liggesusersif (MuMIn:::testStart("mgcv")) { RNGkind("Mersenne") set.seed(0) ## simulate some data... dat <- gamSim(1, n = 400, dist = "binary", scale = 2) #gam1 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3), data=dat) ops <- options(warn = -1) gam1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3) + (x1+x2+x3)^2, data = dat, method = "GCV.Cp", family = binomial) dd <- dredge(gam1, subset = !`s(x0)` & (!`s(x1)` | !x1) & (!`s(x2)` | !x2) & (!`s(x3)` | !x3), fixed = "x1") gm <- get.models(dd, cumsum(weight) <= .95) ma <- model.avg(gm) print(summary(ma)) print(predict(ma, dat[1:10, ], se.fit = TRUE, type = "link")) print(predict(ma, dat[1:10, ], se.fit = TRUE, type = "response")) print(predict(ma, dat[1:10, ], se.fit = TRUE, type = "link", backtransform = TRUE)) options(ops) } MuMIn/tests/rlm.R0000644000176200001440000000074213452746062013332 0ustar liggesusersif (MuMIn:::testStart("MASS")) { data(Cement, package = "MuMIn") nseq <- function(x, len = length(x)) seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length = len) fm1 <- rlm(y ~X1 + X2 * X3 + X4, data = Cement) dd <- dredge(fm1, trace = TRUE) gm <- get.models(dd, subset = 1:10) ma <- model.avg(gm) stopifnot(all(predict(ma) == predict(ma, Cement))) predict(ma, lapply(Cement, nseq, len = 30), se.fit = TRUE) vcov(ma) }MuMIn/tests/quasibinomial.R0000644000176200001440000000177613452727675015416 0ustar liggesuserslibrary("MuMIn") options(na.action = na.fail) budworm <- data.frame(ldose = rep(0:5, 2), numdead = c(1, 4, 9, 13, 18, 20, 0, 2, 6, 10, 12, 16), sex = factor(rep(c("M", "F"), c(6, 6)))) budworm$SF = cbind(numdead = budworm$numdead, numalive = 20 - budworm$numdead) qbinomial <- function(...) { res <- quasibinomial(...) res$aic <- binomial(...)$aic res } budworm.qqlg <- glm(SF ~ sex*ldose + sex*I(ldose^2), data = budworm, family = qbinomial) budworm.lg <- glm(SF ~ sex*ldose + sex*I(ldose^2), data = budworm, family = binomial) r.squaredLR(budworm.lg) r.squaredGLMM(budworm.lg) dd <- dredge(budworm.lg, rank = "QAIC", chat = summary(budworm.lg)$dispersion) #dd <- dredge(budworm.lg) # should be the same mod <- get.models(dd, subset = NA) mod # Note: this works: # ma <- model.avg(mod) # but this will not: ('rank' attribute passed from 'dredge' is lost) # ma <- model.avg(mod) # so, need to supply them model.avg(mod[1:5], rank = "QAICc", rank.args = list(chat = 0.403111)) MuMIn/tests/glm.R0000644000176200001440000000220513452753500013306 0ustar liggesuserslibrary("MuMIn") options(na.action = "na.fail") data(Orthodont, package = "nlme") fm1 <- lm(distance ~ Sex * age + age * Sex, data = Orthodont) dispersion <- function(object) { wts <- weights(object) if (is.null(wts)) wts <- 1 sum((wts * resid(object, type = "working")^2)[wts > 0])/df.residual(object) } dd <- dredge(fm1, extra = alist(dispersion)) gm <- get.models(dd, subset = 1:4) ma <- model.avg(gm, revised = F) vcov(ma) summary(ma) confint(ma) predict(ma) predict(ma, se.fit = TRUE) predict(ma, data.frame(Sex = "Male", age = 8:12)) rm(list = ls()) data(Cement, package = "MuMIn") nseq <- function(x, len = length(x)) seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length = len) fm1 <- glm(y ~ (X1 + X2 + X3)^2, data = Cement) dd <- dredge(fm1) gm <- get.models(dd, subset = 1L:10L) summary(ma <- model.avg(gm)) vcov(ma) summary(ma1 <- model.avg(dd[1L:10L])) summary(ma2 <- model.avg(model.sel(dd[1L:10L], rank = "AICc"))) all.equal(ma$avg.model, ma1$avg.mode) predict(ma) == predict(ma, Cement) predict(ma, se.fit = TRUE) predict(ma, lapply(Cement, nseq)) MuMIn/tests/singularities.R0000644000176200001440000000061712730246630015415 0ustar liggesuserslibrary(MuMIn) options(na.action = "na.fail") set.seed(1) zz <- data.frame(x=runif(15), f1=gl(3,5), f2=factor(rep(1:2,c(10,5)))) zz$y <- 100*zz$x + as.numeric(zz$f1)*10 * as.numeric(zz$f2) nafit <- lm(y~f1*f2*x, zz) summary(nafit) coef(nafit) gm <- get.models(dredge(nafit), subset = NA) ma <- model.avg(gm) summary(ma) coef(ma, T) confint(ma) predict(ma) #Sys.sleep(5) MuMIn/tests/parallel.R0000644000176200001440000000454614205453714014336 0ustar liggesusersif(MuMIn:::.parallelPkgCheck(quiet = TRUE)) { clusterType <- if(length(find.package("snow", quiet = TRUE))) "SOCK" else "PSOCK" clust <- try(makeCluster(getOption("cl.cores", 2), type = clusterType)) if(inherits(clust, "cluster")) { library(MuMIn) library(nlme) data(Orthodont, package = "nlme") #Orthodont <- Orthodont[sample.int(nrow(Orthodont), size = 64, #replace = TRUE), ] Orthodont$rand1 <- runif(nrow(Orthodont)) Orthodont$rand2 <- runif(nrow(Orthodont)) clusterExport(clust, "Orthodont") clusterCall(clust, "library", "nlme", character.only = TRUE) # fm2 <- lmer(log(distance) ~ rand*Sex*age + (1|Subject) + (1|Sex), # data = Orthodont, REML=FALSE) fm2 <- lme(log(distance) ~ rand1*Sex*age + rand2, ~ 1|Subject / Sex, data = Orthodont, method = "ML") print(system.time(pdd1 <- dredge(fm2, cluster = FALSE))) print(system.time(pddc <- dredge(fm2, cluster = clust))) print(system.time(dd1 <- dredge(fm2))) print(pddc) print(pdd1) print(dd1) #print(all.equal(pddc, dd1)) ma1 <- model.avg(pdd1, beta = "none") ma0 <- model.avg(pddc) if(!isTRUE(test <- all.equal(ma1$avg.model, ma0$avg.model))) { print(test) warning("'ma1' and 'ma0' are not equal") } if(!isTRUE(test <- all.equal(ma1$summary, ma0$summary))) { print(test) warning("'ma1' and 'ma0' are not equal") } if(!(identical(c(pddc), c(pdd1)) && identical(c(pdd1), c(dd1)))) { warning("results of 'dredge' and 'pdredge' are not equal") print(all.equal(c(pddc), c(pdd1))) print(all.equal(c(pdd1), c(dd1))) } stopCluster(clust) # suppressPackageStartupMessages(library(spdep)) # suppressMessages(example(NY_data, echo = FALSE)) # esar1f <- spautolm(Z ~ PEXPOSURE * PCTAGE65P + PCTOWNHOME, # data=nydata, listw=listw_NY, family="SAR", method="full", verbose=FALSE) # clusterCall(clust, "library", "spdep", character.only = TRUE) # clusterExport(clust, "listw_NY", "nydata") # options(warn=1) # varying <- list(family = list("CAR", "SAR"), method=list("Matrix_J", "full")) # dd <- dredge(esar1f, m.lim=c(0, 1), fixed=~PEXPOSURE, varying = varying, trace=FALSE) } else # if(inherits(clust, "try-error")) message("Could not set up the cluster") } #system.time(pdredge(fm2, cluster = clust)) #system.time(pdredge(fm2, cluster = F)) #system.time(dredge(fm2)) MuMIn/tests/gam-smooth-match.R0000644000176200001440000000364512730246630015704 0ustar liggesusers library(MuMIn) suppressPackageStartupMessages(library(mgcv)) RNGkind("Mersenne") set.seed(0) ## simulate some data... dat <- gamSim(1, n = 200, dist = "binary", scale = 2) gamsmoothwrap <- function(formula, k1 = NA, ...) { cl <- origCall <- match.call() cl[[1]] <- as.name("gam") cl$formula <- exprApply(formula, "s", function(e, k, x) { i <- which(e[[2]] == x)[1] if(!is.na(i) && !is.na(k[i])) e[["k"]] <- k[i] e }, k = c(k1), x = c("x0")) cl$k1 <- NULL fit <- eval(cl, parent.frame()) fit$call <- origCall # replace the stored call fit } glo <- gamsmoothwrap(y ~ s(x0, fx = TRUE), k1 = 3, data = dat, family = binomial) print(ms <- model.sel(models <- lapply(dredge(glo, varying = list(k1 = 3:16), fixed = TRUE, evaluate = FALSE), eval))) # should throw a warning stopifnot(isTRUE(tryCatch(model.avg(models), warning = function(e) TRUE))) #_______________________________________________________________________________ set.seed(0) ## simulate some data... dat <- gamSim(1, n = 400, dist = "binary", scale = 2) testSmoothKConsistency <- MuMIn:::testSmoothKConsistency glm1 <- glm(y ~ x1 * x2, data = dat, family = binomial) gam53 <- gam(y ~ s(x0, k = 5) + s(x1, k = 3), data = dat, family = binomial) gam37 <- update(gam53, . ~ s(x0, k = 3) + s(x1, k = 7)) gam3e44 <- update(gam53, . ~ s(x0, k = 3) + te(x2, x1, k = 4)) gam3e54 <- update(gam53, . ~ s(x0, k = 3) + te(x2, x1, k = c(5, 4))) gam3i54 <- update(gam53, . ~ s(x0, k = 3) + ti(x2, x1, k = c(5, 4))) gam3e54 <- update(gam53, . ~ s(x0, k = 3) + te(x2, x1, k = c(5, 4))) gam3i34 <- update(gam53, . ~ s(x0, k = 3) + ti(x2, x1, k = c(3, 4))) ms <- model.sel(gam53, gam37, gam3e44, gam3e54, gam3i54, glm1) testSmoothKConsistency(ms) testSmoothKConsistency(list(gam3e54, gam3i34)) #_______________________________________________________________________________ MuMIn/tests/survival.R0000644000176200001440000000337414404346727014421 0ustar liggesusersif (MuMIn:::testStart("survival")) { bladder1 <- bladder[bladder$enum < 5, ] fmcph <- coxph(Surv(stop, event) ~ (rx + size + number) * strata(enum) + cluster(id), bladder1) r.squared.coxph <- function(object, ...) { logtest <- -2 * (object$loglik[1L] - object$loglik[2L]) c(rsq = 1 - exp(-logtest/object$n), maxrsq = 1 - exp(2 * object$loglik[1L]/object$n)) } getAllTerms(fmcph) coef(fmcph) ms <- dredge(fmcph, fixed=c("strata(enum)"), extra = list(R2 = "r.squared.coxph"), trace = TRUE) # BUG in survival if(! "logLik.coxph.null" %in% methods("logLik")) registerS3method("logLik", "coxph.null", survival:::logLik.coxph.null) summary(model.avg(ms[1:10])) fits <- get.models(ms, delta < 5) summary(model.avg(fits)) #### lung <- na.omit(lung) fm <- coxph(Surv(time, status) ~ ph.ecog + tt(age), data=lung, tt=function(x,t,...) pspline(x + t/365.25)) ma <- model.avg(dredge(fm)) coef(ma) coefTable(ma) #### fmsrvrg <- survreg(Surv(futime, fustat) ~ ecog.ps + rx, ovarian, dist='weibull', scale = 1, cluster = rx) r.squaredLR(fmsrvrg) #null <- survreg(Surv(futime, fustat) ~ 1, ovarian, dist='weibull', scale = 1) #R2survreg <- function(x) r.squaredLR(x, null = null) #dredge(fmsrvrg, extra = "R2survreg") summary(model.avg(dredge(fmsrvrg), delta < 4)) fmsrvrg2 <- survreg(Surv(futime, fustat) ~ ecog.ps + rx, ovarian, dist='weibull') fmsrvrg3 <- survreg(Surv(time, status) ~ ph.ecog + age + strata(sex), lung, na.action = "na.omit") r.squaredLR(fmsrvrg3) coefTable(fmsrvrg) coefTable(fmsrvrg2) coefTable(fmsrvrg3) }MuMIn/tests/glm.nb.R0000644000176200001440000000157313452745553013724 0ustar liggesusersif (MuMIn:::testStart("MASS")) { quine.nb1 <- glm.nb(Days ~ 0 + Sex / (Age + Eth * Lrn), data = quine) #quine.nb1 <- glm.nb(Days ~ Sex/(Age + Eth*Lrn), data = quine) ms <- dredge(quine.nb1) models <- get.models(ms, subset = TRUE) models <- get.models(ms, subset = NA) print(summary(model.avg(models))) #dredge(quine.nb1) # OK #dredge(quine.nb1x = NA) # OK #dredge(quine.nb1) # OK print(dredge(quine.nb1)) # OK #dredge(quine.nb1) # Right, should be the same as above ma <- model.avg(dredge(quine.nb1), subset = cumsum(weight) <= .9999) print(summary(ma)) # Cannot predict with this 'averaging' #pred <- predict(ma, se=TRUE) #pred <- cbind(pred$fit, pred$fit - (2 * pred$se.fit), pred$fit + (2 * pred$se.fit)) #matplot(pred, type="l") #matplot(family(quine.nb1)$linkinv(pred), type="l") }MuMIn/tests/multinom.R0000644000176200001440000000121013452745547014402 0ustar liggesusersif (MuMIn:::testStart("nnet", "MASS")) { # Trimmed-down model from example(birthwt) data(birthwt) bwt <- with(birthwt, data.frame( low = low, race = factor(race, labels = c("white", "black", "other")), ptd = factor(ptl > 0), smoke = (smoke > 0) )) options(contrasts = c("contr.treatment", "contr.poly")) bwt.mu <- multinom(low ~ ., data = bwt) dd <- dredge(bwt.mu, trace=T) summary(model.avg(dd[1:5])) gm <- get.models(dd, subset = 1:5) ma <- model.avg(gm) summary(ma) # predict(ma) // Cannot average factors! } MuMIn/tests/nlme.R0000644000176200001440000000200213452745626013467 0ustar liggesusersif (MuMIn:::testStart("nlme")) { fm1Dial.gls <- gls(rate ~ (pressure + I(pressure^2) + I(pressure^3)) * QB, Dialyzer, method = "ML") varying <- list(correlation = alist(AR1_0.771 = corAR1(0.771, form = ~1 | Subject), AR1 = corAR1(), NULL), weights = alist(vp.press = varPower(form = ~pressure), NULL)) dd <- dredge(fm1Dial.gls, m.lim = c(1, 2), fixed = ~pressure, varying = varying) models <- get.models(dd, subset = 1:4) predict(fm1Dial.gls, se.fit = TRUE, newdata = Dialyzer[1:5, ]) subset(dd, correlation == "AR1_0.771", recalc.delta = TRUE) ma <- model.avg(models, revised = TRUE) ms <- model.sel(models) print(ms, abbr = FALSE) print(ms, abbr = TRUE) summary(ma) predict(ma)[1:10] # testing predict replacement: fm1 <- lme(rate ~ (pressure + I(pressure^2) + I(pressure^3)) * QB, ~1 | Subject, data = Dialyzer) predict(fm1, newdata = Dialyzer[1:5, ], level = 0, se.fit = TRUE) } MuMIn/MD50000644000176200001440000001623115161557552011566 0ustar liggesusersc29331f58b4fb1b6f9eb1d39aa991bb6 *DESCRIPTION 506a9820945c266506d1b9dece21b4ca *NAMESPACE 3dd7d2590113a7d1816edb59dc14c44d *NEWS d6aef97b8781b804e09f3e58c0894474 *R/AICc.R 536fdb4d7afc4338564230ddbbc5555e *R/Cp.R 871f16d89f7b002fdfcfb1c414344fa7 *R/DIC.R 45f3f39f221ae1a450e2dbac34cc4ce0 *R/ICOMP.R 3ad6b428ff35b60cd0a1b6bd045f1132 *R/Weights.R 1b20bcc11ec0974a9e444122b09da5c0 *R/addresponse.R c4030f799e934b438431ec3696a8fa79 *R/arm.glm.R 7c4a973dc5e1184e117ce95d35b3d222 *R/class-cplm.R 8629e8cf758c213855c722cdfe1f9541 *R/class-fitdistr.R e2450a1d1b529ec033606415ea5410bf *R/class-gamlss.R ec06c3484a57dcb5c8cad4f8043b4afa *R/class-gamm.R 3388d79b4fe6830c103bfc5aadb1c34b *R/class-glmmADMB.R a110d926f58b9e38f5d94c195293c80e *R/class-glmmTMB.R f9d7f8e07fab7b774a50d0670de64958 *R/class-mark.R 59e1aa5b69371a97f957a7ad81db787f *R/class-pkg-spatialreg.R d4b74dcd016a21166e6a7768b8e26029 *R/class-unmarkedFit.R 27c2b6398019aea2894c19a92972fb79 *R/class-wgee.R 828cd38ed32808926ccbec6d85d6bcd0 *R/coefTable-methods.R ba58c35452b7aceb4350929c7f8f7a9b *R/coefTable.R 307ca6cc7906112e6a68f448132a6b94 *R/coeffs.R 09d3f33494078d708f1e64bb5b9b22bd *R/coefplot.R 5d79584b0a4a97b4f7ace377d70c2be4 *R/desaturate.R 7e6b53ad700f94c62154ca8f5b651f63 *R/dredge.R 2476d3ef3f56cdca99f93cf660fb24f2 *R/ext.R e45b3a2a6543a2a61e099eeb1f03ab89 *R/extras.R ccab045a9d2440930dd04496249aca89 *R/formlist.R ece76dcc8fe7cd22663b37ded069d6ab *R/formulas.R 5313d88e974da45a60414f85aaa5b41e *R/frmsplit.R da63dc863efa567efd7b29039406a860 *R/get.models.R d18c8f81b3a686fed2fc10119006e3e3 *R/get.response.R b072ff43c88fa59bc218509164ac4b2f *R/getAllTerms.R f6ce0d1f79146d57bd0a82f5e254906e *R/getModelArgs.R fd793e8340f662b571d840e1ab45487e *R/getspecs.R 452a39bd8e2dc74acce62f9ff418a815 *R/glm_fit.R b5bded2dd233991b41d809000cc670e3 *R/init.R 89e321c920192a1b5309b6d4f028f66d *R/is.R 700c8e508e8f5391ce5199b4d4cb387b *R/loo.R 890295fb968a96d6cdc211e9a303bfb6 *R/makeArgs.R 24f395e92822fb8945a20362db9a9701 *R/matchCoef.R 705b2f4873b4f96003971bba10400286 *R/methods-averaging.R 944db296fc491edaa981d73c8db4612e *R/methods-logLik.R 5bf7353da0092522db32a39cf7a82017 *R/methods-nobs.R e16146bdeceba98d7171db913cd8f539 *R/methods-predict.R 5803165d683ca26c8a215ba4802ebfaa *R/methods-xtable.R 44bd034d5de5c653ad3fdf761b0c6b98 *R/model.avg.R c70b03e8ce3ccb4b0c9ff05042c08bd2 *R/model.names.R 9e9b71bece310621a0562b5142e8e2ef *R/model.sel.R 2c62d4df5a5a8b6d937aac1d8919d130 *R/model.selection.R b8378f63ba75e6a4dc52cd01dc8922bd *R/modelspecs.R aab8c46a30f7459f3a40780ea860c207 *R/modify.model.selection.R d44cac6a24cbe0c15432c2f85273c4d9 *R/nested.R 534643c9c474a04a22d705f5ed6b7cfc *R/nsubsets.R 012bdd0bcd4b4f24a72c29406a1efadb *R/par.avg.R c26c1dee8dc8e1f5fbe49e1d33ebe774 *R/pdredge.R d5951a54fba1a209cac83013adee4f76 *R/plot.model.selection.R 55293ab88de161370fcd6992087fce4e *R/predict.R eefa5b10b65afc4d1d91edc78803e915 *R/predict.averaging.R c2b422ac8a0f7baf826f63d90a1fc0b7 *R/print.model.selection.R d353e94f2ebd0397c379cbf60a14c207 *R/progbar.R 030ec234b8b4c961d13601fa6cc5032e *R/quasiLik.R 44385031087c507cd6ac276394bcb31b *R/r.squaredGLMM-helper-fn.R 82945f7541f675994d2e3e22a882781f *R/r.squaredGLMM2.R 623cc2635765ec23323738880114cd60 *R/r.squaredLR.R a853f72d113d94490e6f43e78ad6eb20 *R/rbind.model.selection.R 2e1c2937d47ce7bcacce3e6b6e0cee0f *R/simulateData.R f63575c93ef4c00bfb2bb29de3ea01c7 *R/std.coef.R e64165f1c51313c3268b749021683b81 *R/stdize.R ed06c0e7600b43416f6b78e57cf0b930 *R/substitution.R b2003b82d2351756c2342046481d79b5 *R/sumofweights.R 1d97ad7a5853414eb7a78b29f425b543 *R/termdeps.R be2093f51869b17830694d433ea90efb *R/unfckme.R 0d32e61ae273266747fe24d6b8cc1e11 *R/updateable.R 28a8e3bebbf1273ebfea58b1a9a0b7db *R/utils-debug.R dc8edc80dbbd15c0f0c87c7be9b208db *R/utils-misc.R 0990df0326f37630b0f1f4153ca23166 *R/utils-models.R d0b70f32d7a40a902e4ca028e30e3f99 *R/utils-terms.R 2892f7efde6471b8403f72e3758bae20 *R/weights-bg.R 4110e7e4f4fc6f8624b29aec050240e4 *R/weights-boot.R 1a4780776880f1114fbc5fdafc8b09f6 *R/weights-cos2.R ad02264c88eeb1fe0d727f6b526a1b54 *R/weights-jackknife.R e07ef3edb8bfbf5df4992c992751388e *R/weights-stacking.R 5aca7863216dd3e52ed3f1b33a075b0e *data/Beetle.rda 2a94545d293dff0f68474246a9e11560 *data/Cement.rda 95be4598e612d36660e6419b644a5360 *data/GPA.rda 53cb21d4452d1916e078e7082b5cd15a *demo/00Index 0ef079549f38add0ddd9ea0eb7fe7ee4 *demo/dredge.distsamp.R e92d031102ae46f80d0fa73abf36c70f *demo/dredge.subset.R c95b99079d3ad5a765d4c3d267c0c452 *demo/dredge.varying.R d8c80c9ce10c2bd6d3a4f0f9bf7f130d *demo/gees.R d71f4726131c71c4973e5c70ac305728 *demo/pdredge.pcount.R 4165cc75edb712c023619656d1865ae5 *man/AICc.Rd c9b5ee099b39b993180a4c27c000f5aa *man/BGweights.Rd a721626a2554e38c8406540870c2e161 *man/ICs.Rd c824ca63682c2086faa010d31dd055f4 *man/MuMIn-package.Rd df339b8df333099cc867968e2dcb97e3 *man/QAIC.Rd af14ab90af50274fdf60a3694a7edbc5 *man/QIC.Rd bd1affbf658ac9e020cdaee8ab526e12 *man/Weights.Rd 06d9a842e933098d6a653a17b3bcfcef *man/arm.glm.Rd e86b87887ad61f6636baf6fb17166e9d *man/bootWeights.Rd 2aa182287dd1c480d31dd69592255284 *man/coefplot.Rd c19c200e915a873da1ec836d459ca4fb *man/cos2weights.Rd 8f7c7c5f66edbe5188ebd50d7530fe42 *man/data-Beetle.Rd ea9bedc09493f8b91647e97a6d1478eb *man/data-Cement.Rd 22561e48f4fd0a3c779a384694a6f131 *man/data-GPA.Rd c4b77ba94ef1a5791835f3901d6b471f *man/dredge.Rd 394f99e956332cbd47620fe9a6e453a4 *man/exprApply.Rd f44d9232f68e795a6ef1d2f523d96f4f *man/get.models.Rd 2ab3f755e31167820e8ef3d8716ca691 *man/jackknifeWeights.Rd f5aa6d0f7193453a00f86432213df2a6 *man/loo.Rd f97fa06e9148c141011f897a0d394484 *man/macros/macros.Rd a5bea7057fad41fc83ff2286c14e445c *man/manip-formula.Rd c910e0ba2ebc8f6c6c2996ac011004ca *man/merge.model.selection.Rd 521fa09e21a16770c13f801bd4959e8f *man/model-utils.Rd c3c47c4da12ead72da5ea525433c9f11 *man/model.avg.Rd be3c3c20bf8ba41e5bc1a7b15e322b6a *man/model.sel.Rd e91b11385119bd4a96c6e74d41be1e4a *man/model.selection.object.Rd 0843aea69ecf398579ae69b058303715 *man/nested.Rd 148c67d8f51729ea29139253474918a3 *man/par.avg.Rd efe5929759f6b03379dad2f438fb1539 *man/pdredge.Rd b1bf890c20ce56ffec6ac95a65afb978 *man/plot.model.selection.Rd 6178d82a66bcbc036bbcf44b70d26831 *man/predict.averaging.Rd f095e57dd94e250b2e6a386fc6a329c3 *man/r.squaredGLMM.Rd 8117561ad227a89b28e37ef2d0954229 *man/r.squaredLR.Rd 0a78d4c23b005d7afb175a4e2a05c74b *man/stackingWeights.Rd 2f8ce564c881599d44f256d21a5694ce *man/std.coef.Rd de0e02444274d0baadbafa4b27a336f8 *man/stdize.Rd 5140ad1c655b96c613d05d32cd5f4294 *man/subset.model.selection.Rd 2fa2eef0edbb2bf370105123868f5247 *man/sumofweights.Rd f1ed9d8a568ba9a77777afdad6d3752a *man/supported-classes.Rd b3b8741820b9755a2111ed57b5fe3072 *man/updateable.Rd 1a7712899c4edfc6e5bb5b3081dd1a3c *tests/gam-smooth-match.R e4ca22c0b4e6ec27b3f7a509f8b56a63 *tests/gam.R 3ac2d15780ab346f8389d9162318ee62 *tests/glm.R 4a72574237c9e4a8dd6b81e1d6c16e89 *tests/glm.nb.R 0e2964f1d6a49bc4238dc0267018982a *tests/misc-tests.R 2071449d07ee1636d1f1899240e6301a *tests/multinom.R 49fdcf38d26814b63eb60a4fda0d5afa *tests/nlme.R 47355f13076c209bb7c5a28f1c788272 *tests/parallel.R 0255b37816469915e9f5702d53889906 *tests/quasibinomial.R dd03752fc7c0c51ea9d7ce9b2de1b5ee *tests/rlm.R e16dadb36d0c96ca26f8903c13f876ff *tests/singularities.R 756403ed8d0272a92a2047e037fc637a *tests/survival.R MuMIn/R/0000755000176200001440000000000015161444373011450 5ustar liggesusersMuMIn/R/weights-stacking.R0000644000176200001440000000632615161443462015053 0ustar liggesusersstackingWeights <- function(object, ..., data, R, p = 0.5 #, seed = NULL ) { models <- getModelArgs() M <- length(models) # TODO: check for lm class / add support for other models if(M < 2L) stop("need more than one model") R <- as.integer(R[1L]) if(R <= 1L) stop("'R' must be positive") if(p <= 0 || p >= 1) stop("'p' must be in range <0,1>") n <- nrow(data) nt <- round(n * p) wmat <- array(dim = c(R, M)) r <- counter <- 1L counterLimit <- R * 2L mode(R) <- mode(counterLimit) <- "integer" if (M >= (n - nt)) stop("more models than test points. ", "Increase the test set or reduce the number of models") while(counter < counterLimit && r <= R) { counter <- counter + 1L k <- sample.int(n, size = nt) pymat <- array(dim = c(n - nt, M)) for(j in 1L:M) { fit <- models[[j]] tf <- terms(fit) fam <- family(fit) off <- fit$offset wts <- fit$weights coef1 <- do_glm_fit(tf, data[k, , drop = FALSE], fam, wts[k], off[k])$coefficients pymat[, j] <- predict_glm_fit(coef1, model.matrix(tf, data[-k, , drop = FALSE]), offset = off[-k], family = fam)[, 1L] } y.test <- get.response(fit, data[-k, , drop = FALSE]) if(!is.matrix(pymat)) stop("\"predicted\" must be a matrix") if(nrow(pymat) != length(y.test)) stop("number of rows in \"predicted\" is not equal to length of \"observed\"") sw1 <- tryCatch(.stacking(pymat, y.test), error = function(...) NULL) if(!is.null(sw1)) { wmat[r, ] <- sw1 r <- r + 1L } } wts <- rbind(colMeans(wmat), apply(wmat, 2L, median), deparse.level = 0) dimnames(wts) <- list(c("mean", "median"), names(models)) structure(wts / rowSums(wts), wt.type = "stacking", class = c("model.weights", class(wts))) } .stacking <- function(predicted, observed) { #if(nrow(predicted) != length(observed)) # stop("number of rows in \"predicted\" is not equal to length of \"observed\"") #if (NCOL(predicted) >= length(observed)) # stop("more models than test points. ", # "Increase the test set or reduce the number of models") # TODO: make the error message more specific. # now do an internal splitting into "folds" data sets: weightsopt <- function(ww) { # function to compute RMSE on test data w <- c(1, exp(ww)) w <- w / sum(w) ## w all in (0,1) SIMON; set weight1 always to 1, other weights are ## scaled accordingly (this leads to a tiny dependence of optimal ## weights on whether model1 is any good or utter rubbish; see by moving ## the 1 to the end instead -> 3rd digit changes) pred <- as.vector(predicted %*% w) return(sqrt(mean((pred - observed)^2))) } ops <- optim(par = runif(NCOL(predicted) - 1L), weightsopt, method = "BFGS") if (ops$convergence != 0) stop("optimization not converged") round(c(1, exp(ops$par)) / sum(c(1, exp(ops$par))), 4L) } MuMIn/R/utils-terms.R0000644000176200001440000000106315161443462014061 0ustar liggesusers .multipleformula2list <- function(x) { f <- formula(x) env <- environment(f) rval <- list() while(is.call(f) && f[[1L]] == "~") { rval[[length(rval) + 1L]] <- as.formula(f[c(1L, length(f))], env = env) f <- f[[2L]] } rval <- rev(rval) if(!identical(f, rval[[1L]][[2L]])) { # has lhs - attach the response to each right-sided formula: rval <- lapply(rval, function(g) { g <- g[c(1L, NA, 2L)] g[[2L]] <- f g }) } lapply(rval, `environment<-`, env) } MuMIn/R/class-fitdistr.R0000644000176200001440000000154215161443462014526 0ustar liggesusers coefTable.fitdistr <- function(model, ...) .makeCoefTable(coef(model), sqrt(diag(model$vcov))) family.fitdistr <- function (object, ...) structure(list(family = "none", link = "NA"), class = "family") formula.fitdistr <- function(x, ...) reformulate(names(x$estimate), env = parent.frame()) nobs.fitdistr <- function (object, ...) object$n fitdistr2 <- function (x, densfun, start, ...) { rval <- MASS::fitdistr(x, densfun, start, ...) densfunc <- c("beta", "cauchy", "chi-squared", "exponential", "gamma", "geometric", "log-normal", "lognormal", "logistic", "negative binomial", "normal", "Poisson", "t", "weibull") if(is.character(densfun)) { densfun <- charmatch(densfun, densfunc) } else { densfun <- deparse1(substitute(densfun)) } rval$densfun <- densfun rval$call <- match.call() rval } MuMIn/R/termdeps.R0000644000176200001440000000555315161443462013424 0ustar liggesusers# returns formula's terms as a list of symbols (interactions as sub-lists) # [note that it does not expand formulas] # termlist(terms(~a * b+ c, simplify = TRUE)) ## termlist(~a+b+a:b) --> list(a, b, list(a, b)) termlist <- function(x) { is.plus <- function(x) is.call(x) && x[[1L]] == "+" ## parses interaction expression into list: a:b:c --> list(a,b,c) intr <- function(x) { # is it an expression for interaction? (e.g. a:b:c) is.intr <- function(x) is.call(x) && x[[1L]] == ":" if(is.intr(x)) { res <- list() repeat { res <- c(x[[3L]], res) x <- x[[2L]] if(!is.intr(x)) break } list(c(x, res)) } else x } if(x[[1L]] == "~") x <- x[[length(x)]] res <- list() while(is.plus(x)) { res <- c(intr(x[[3L]]), res) x <- x[[2L]] } res <- c(intr(x), res) res } # calculates all lower order term names: # expandinteraction(1:3) --> c("1", "2", "1:2", "3", "1:3", "2:3", "1:2:3") expandinteraction <- function(x) { asstr <- function(x) asChar(x, backtick = TRUE) if(!is.language(x)) { a <- sapply(x, asstr) k <- length(a) vapply(seq.int(2L^k - 1L), function(y) paste0(a[as.logical(intToBits(y)[1L:k])], collapse = ":"), "") } else asstr(x) } # given a formula, returns 'term dependency matrix', i.e. dependency of higher # order terms on lower order terms termdepmat <- function(f) { trm <- terms(f, simplify = TRUE) tl <- termlist(trm) v <- attr(trm, "term.labels") n <- length(v) mat <- matrix(FALSE, n, n, dimnames = list(v, v)) for(i in seq.int(n)) mat[match(expandinteraction(tl[[i]]), v), i] <- TRUE mat } # like 'termdepmat', but dimnames of the returned matrix are term indices rather # than names. So a,b,a:b become 1,2,1:2. (seems to be slightly less efficient # than termdepmat (~1.5x)) termdepmat2 <- function(f) { filist <- formula2idx(f, asCall = FALSE) n <- length(filist) v <- vapply(filist, paste0, "", collapse = ":") mat <- matrix(FALSE, n, n, dimnames = list(v, v)) for(i in seq.int(n)) mat[match(expandinteraction(filist[[i]]), v), i] <- TRUE mat } ## combines term-dependency-matrices #termdepmat_list <- function(fl) # termdepmat_combine(lapply(fl, termdepmat)) termdepmat_combine <- function(x) { dm <- sum(vapply(x, nrow, 1L)) mat <- matrix(FALSE, dm, dm) j <- 1L for(i in seq_along(x)) { n <- nrow(x[[i]]) k <- seq.int(j, length.out = n) mat[k, k] <- x[[i]] j <- j + n } dn <- unlist(lapply(x, rownames)) dimnames(mat) <- list(dn, dn) mat } # converts formula to an unevaluated list of numeric indices # e.g. a*b --> list(1,2,1:2) formula2idx <- function(x, asCall = TRUE) { if(!is.call(x) || !inherits(x, "formula")) stop("'x' is not a formula") fac <- attr(delete.response(terms(x)), "factors") dimnames(fac) <- NULL ret <- apply(fac > 0L, 2L, which) if(asCall) as.call(c(as.name("list"), ret)) else ret } formula_margin_check <- function(j, m) { mode(j) <- "logical" !any(m[!j, j], na.rm = TRUE) } MuMIn/R/ICOMP.R0000644000176200001440000000535515161443462012450 0ustar liggesusers#ICOMP information criterion (I for informational and COMP for complexity) #developed by Bozdogan (1988, 1990, 1993, 1994) #Bozdogan, H (1990) On the information-based measure of covariance complexity #and its application to the evaluation of multivariate linear models. \emph{Comm. #Stat. Theory and Methods} 19:221-278 #Bozdogan, H. (2000). Akaike's Information Criteria and recent developments in #Information Complexity. \emph{J. Math. Psych.} 44:62-91 #Bozdogan, H. and Haughton, D.M.A. (1998) Information complexity criteria for #regression models. \emph{Comp. Stat. & Data Analysis} 28:51-76 `ICOMP` <- # function (object, ..., type = c("vcov", "r", "cv"), REML = NULL) { function (object, ..., REML = NULL) { # type <- match.arg(type) type <- "vcov" ret <- sapply(list(object, ...), function(x) { ll <- if (!is.null(REML) && inherits(x, c("mer", "lme", "gls", "lm"))) logLik(x, REML = REML) else logLik(x) covmat <- .vcov(x) k <- nrow(covmat) # attr(ll, "df") switch(type, vcov = { mat <- covmat }, r = { cov <- diag(diag(1 / covmat), nrow = nrow(covmat), ncol = ncol(covmat)) mat <- sqrt(cov) %*% covmat %*% sqrt(cov) }, cv = { coefs <- coef(x) ncoef <- length(coefs) coefmat <- diag(1 / coefs, nrow = ncoef, ncol = ncoef) mat <- coefmat %*% covmat %*% coefmat }) as.vector(-2 * c(ll) + k * log(sum(diag(mat)) / k) - log(det(mat))) # ICOMP = -2 * LL + k * log(tr(IFIM) / k) - log(det(IFIM)) # ICOMP = -2 * LL + 2 * C * (sig(model)) # where C is a complexity measure and sig(model) is the variance- # covariance matrix of the parameters estimated under the model. }) if (length(ret) > 1L) { Call <- match.call() Call$type <- Call$REML <- NULL ret <- data.frame(ICOMP = ret, row.names = as.character(Call[-1L])) } return(ret) } # Bozdogans's CAICF (C denoting "consistent" and F denoting the use of the Fisher # information matrix), `CAICF` <- function (object, ..., REML = NULL) { ret <- sapply(list(object, ...), function(x) { ll <- if (!is.null(REML) && inherits(x, c("mer", "lme", "gls", "lm", "glmmTMB"))) logLik(x, REML = REML) else logLik(x) covmat <- .vcov(x) k <- attr(ll, "df") n <- attr(ll, "nobs") #log(det(solve(covmat))) == -log(det(covmat)) -(2 * c(ll)) + (k * (log(n) + 2)) - log(det(covmat)) }) # I is the natural logarithm of the determinant of the estimated Fisher information matrix. if (length(ret) > 1L) { Call <- match.call() Call$type <- Call$REML <- NULL ret <- data.frame(CAICF = ret, row.names = make.unique(as.character(Call[-1L]))) } return(ret) } MuMIn/R/class-wgee.R0000644000176200001440000000063615161443462013630 0ustar liggesuserscoef.wgee <- function (object, ...) object$beta coefTable.wgee <- function (model, ..., type = c("robust", "naive")) { if (match.arg(type) == "naive") stop("naive std. errors are not available for 'wgee' models.") .makeCoefTable(model$beta, summary(model)$se.robust, coefNames = names(model$beta)) } nobs.wgee <- function (object, ...) length(object$mu_fit) formula.wgee <- function (x, ...) x$modelMuMIn/R/utils-misc.R0000644000176200001440000002621315161443462013666 0ustar liggesusers .MuMInEnv <- new.env(parent = baseenv()) testStart <- function(...) { p <- c(...) res <- length(find.package(p, quiet = TRUE)) == length(p) if(res) { for(a in p) suppressPackageStartupMessages( library(a, character.only = TRUE, quietly = TRUE)) require(.packageName, character.only = TRUE) options(na.action = "na.fail") } res } warnonce <- function(..., show.instance = 0L) { id <- make.names(deparse1(match.call(expand.dots = FALSE)$...)) count <- get0(flag <- paste0("warned.", as.character(id)[1L]), .MuMInEnv, ifnotfound = 0L) if(count <= show.instance) assign(flag, count + 1L, envir = .MuMInEnv) if(count == show.instance) { cl <- match.call() cl$show.instance <- NULL cl[[1L]] <- as.name("warning") eval.parent(cl) } } `cry` <- function(Call = NA, Message, ..., warn = FALSE, domain = paste0("R-", .packageName)) { if (is.character(Call)) { Call <- call(Call[1L], sys.call(-1L)[[1L]]) } else if(is.numeric(Call)) { Call <- sys.call(Call - 1L) } else if (!is.call(Call) && !is.null(Call)) Call <- sys.call(-1L) if(warn) warning(simpleWarning(gettextf(Message, ..., domain = domain), Call)) else stop(simpleError(gettextf(Message, ..., domain = domain), Call)) } `getElement` <- function (object, name) { if (isS4(object)) if (.hasSlot(object, name)) slot(object, name) else NULL else object[[name, exact = TRUE]] } # cbind list of data.frames omitting duplicated column (names) `cbindDataFrameList` <- function(x) { dfnames <- unlist(lapply(x, colnames), use.names = FALSE) uq <- !duplicated(dfnames) res <- do.call("cbind", x)[,uq] colnames(res) <- dfnames[uq] return(res) } # same for rbind, check colnames and add NA's when any are missing `rbindDataFrameList` <- function(x) { all.colnames <- unique(unlist(lapply(x, colnames), use.names = FALSE)) x <- lapply(x, function(y) { y[all.colnames[!(all.colnames %in% colnames(y))]] <- NA return(y[all.colnames]) }) return(do.call("rbind", x)) } `videntical` <- function(x) all(vapply(x[-1L], identical, logical(1L), x[[1L]])) # Check class for each object in a list `linherits` <- function(x, whats) { as.logical(vapply(x, inherits, integer(length(whats)), names(whats), which = TRUE)) == whats } # tries to make a list of element names `.makeListNames` <- function(x) { nm <- names(x) lapply(seq_along(x), function(i) { if(is.null(nm) || !nzchar(nm[i])) { switch(mode(x[[i]]), call = { v <- asChar(x[[i]], width.cutoff = 20L) if(length(v) != 1L) v <- sprintf("%s...", v[1L]) v }, symbol =, name = as.character(x[[i]]), NULL =, logical =, numeric =, complex =, character = x[[i]], i ) } else nm[i] }) } # test if dependency chain is satisfied: x[n] can be TRUE only if x[n+1] are also TRUE `.subset_dc` <- function(...) { n <- length(x <- c(...)) if(n > 1L) all(x[-n] >= x[-1L]) else TRUE } # vectorized version of .subset_do (used within subset.model.selection) `.subset_vdc` <- function(...) apply(cbind(..., deparse.level = 0L), 1L, .subset_dc) `prettyEnumStr` <- function(x, sep = ", ", sep.last = gettext(" and "), quote = TRUE) { n <- length(x) if(is.function(quote)) x <- quote(x) else { if(identical(quote, TRUE)) quote <- '"' if(is.character(quote)) x <- paste0(quote, x, quote) } paste0(x, if(n > 1L) c(rep(sep, n - 2L), sep.last, "") else NULL, collapse = "") } # `splitList` <- function (x, k) { # n <- length(x) # ret <- unname(split.default(x, findInterval(seq_len(n), seq(0L, n + # 1L, length = k + 1L)))) # if(k > n) ret <- c(ret, vector(k - n, mode = "list")) # ret # } `.parallelPkgCheck` <- function(quiet = FALSE) { # all this is to trick the R-check if(!("snow" %in% loadedNamespaces())) { if(getRversion() < "2.14.0") { if(length(find.package("snow", quiet = TRUE))) do.call("require", list("snow")) } else if(length(find.package("parallel", quiet = TRUE))) do.call("require", list("parallel", quiet = TRUE)) } if(!exists("clusterCall", mode = "function")) { if(quiet) return(FALSE) else stop("cannot find function 'clusterCall'") } else return(TRUE) } `clusterVExport` <- local({ `getv` <- function(obj, env = as.environment(1L)) for (i in names(obj)) assign(i, obj[[i]], envir = env) function(cluster, ...) { Call <- match.call() Call$cluster <- NULL Call <- Call[-1L] vars <- list(...) vnames <- names(vars) if (is.null(vnames)) { names(vars) <- vapply(Call, asChar, "") } else if (any(!nzchar(vnames))) { names(vars) <- ifelse(!nzchar(vnames), vapply(Call, asChar, ""), vnames) } get("clusterCall")(cluster, getv, vars) # clusterCall(cluster, getv, vars) } }) # test if 'x' can be updated (in current environment or on a cluster) # level is 0/FALSE - no checking, 1 - check if variables and functions exist, # >1 - reevaluate x and compare with original `testUpdatedObj` <- function(cluster = NA, x, call = get_call(x), level = 1L, exclude = "subset") { if(isTRUE(level)) level <- 2L if (level > 0L) { xname <- asChar(substitute(x)) doParallel <- inherits(cluster, "cluster") if(doParallel) { clusterCall <- get("clusterCall") whereStr <- gettext(" in the cluster nodes' environment") csapply <- function(...) clusterCall(cluster, "sapply", ...) } else { whereStr <- "" csapply <- function(...) sapply(...) } if(is.null(call)) stop(gettextf("'%s' has no call component", xname)) call.orig <- call if(!is.null(call$data)) { # get rid of formulas, as they are evaluated within 'data' call <- call[!sapply(call, function(x) "~" %in% all.names(x))] call[exclude] <- NULL } v <- all.vars(call, functions = FALSE) if(!all(z <- unlist(csapply(v, "exists", where = 1L)))) { z <- unique(names(z[!z])) stop(sprintf(ngettext(length(z), "variable %s not found%s", "variables %s not found%s"), prettyEnumStr(z, quote = "'"), whereStr)) } vfun <- all.vars(call, functions = TRUE) if(!all(z <- unlist(csapply(vfun[!(vfun %in% v)], "exists", mode = "function", where = 1L)))) { zz <- unique(names(z[!z])) stop(sprintf(ngettext(length(zz), "function %s not found%s", "functions %s not found%s"), prettyEnumStr(zz, quote = "'"), whereStr)) } if(level > 1L && !missing(x)) { if(doParallel) { # XXX: Import: clusterCall if(!all(vapply(lapply(clusterCall(cluster, eval, call.orig), all.equal, x), isTRUE, TRUE))) stop(gettextf("'%s' evaluated on the cluster nodes differs from the original one", xname)) } else if (!isTRUE(all.equal(x, update(x)))) stop(gettextf("updated '%s' differ(s) from the original one", xname)) } } } `tryCatchWE` <- function (expr) { Warnings <- NULL list(value = withCallingHandlers(tryCatch(expr, error = function(e) e), warning = function(w) { Warnings <<- c(Warnings, list(w)) invokeRestart("muffleWarning") }), warnings = Warnings) } # like apply(, 2) but returns a list (does not do any checking) `applyrns` <- function (X, FUN, ...) { n <- nrow(X) ret <- vector(n, mode = "list") for(i in seq_len(n)) if(!is.null(z <- FUN(X[i, ], ...))) ret[[i]] <- z ret } ## from stats:::format_perc `format_perc` <- function (probs, digits) paste(format(100 * probs, trim = TRUE, scientific = FALSE, digits = digits), "%") return_null <- function(...) NULL ## Cheating RCheck: getFrom <- function(pkg, name) get(name, envir = asNamespace(pkg), inherits = FALSE) # used by 'model.sel' and 'dredge' with argument 'extra' .get.extras <- function(extra, r2nullfit = NULL) { extraExpr <- substitute(extra) if(!is.vector(extra)) { extraExpr <- call("alist", extraExpr) extra <- list(extra) } isfun <- vapply(extra, is.function, NA) if(any(isfun)) { if(all(isfun) && !is.null(names(extra)) && all(nzchar(names(extra)))) return(extra) extraExpr[[1L]] <- as.name("alist") extra <- eval.parent(extraExpr) } extraNames <- names(extra) %||% character(length(extra)) emptynames <- !nzchar(extraNames) if(any(emptynames)) { extraNames[emptynames] <- do.call("c", .mapply(function(x, i) switch(mode(x), call = asChar(x[[1L]]), name = asChar(x), `function` = paste0("function", i), character = , as.character(x)[1L]), list(x = extra[emptynames], i = which(emptynames)), MoreArgs = list())) } extra <- as.list(extra) names(extra) <- extraNames if(anyDuplicated(extra)) { ok <- !duplicated(extra) extra <- extra[ok] } if(any(i <- vapply(extra, is.language, TRUE))) extra[i] <- lapply(extra[i], eval.parent) pos <- match(c("R^2", "adjR^2"), extra, nomatch = 0L) if(any(pos != 0L)) { nullfit_ <- NULL # to pass R check if(!is.null(r2nullfit)) { r2env <- new.env() assign("nullfit_", r2nullfit, envir = r2env) if(pos[1L] != 0L) { f <- function(x) r.squaredLR(x, null = nullfit_) environment(f) <- r2env extra[["R^2"]] <- f } if(pos[2L] != 0L) { f <- function(x) attr(r.squaredLR(x, null = nullfit_), "adj.r.squared") environment(f) <- r2env extra[["adjR^2"]] <- f } } else { if(pos[1L] != 0L) extra[["R^2"]] <- function(x) r.squaredLR(x) if(pos[2L] != 0L) extra[["adjR^2"]] <- function(x) attr(r.squaredLR(x), "adj.r.squared") } } sapply(extra, match.fun, simplify = FALSE) } .applyExtras <- function(model, extra) { rval <-.mapply(function(f, a, model) tryCatch({ z <- f(model) mode(z) <- "numeric" z }, error = function(err) { err$call <- call(a, quote(submodel)) err$message <- sprintf("while evaluating \"extra\" function '%s': '%s'", a, err$message) stop(err) }), list(f = extra, a = names(extra)), MoreArgs = list(model = model)) names(rval) <- names(extra) unlist(rval) } ## matrix multiplication with option of calculating the diagonal only ## It is more memory efficient and faster than `crossprod` for large matrices matmult <- function(x, y, diag.only = FALSE) { if(ncol(x) != nrow(y)) stop('non-conformable arguments') n1 <- nrow(x) n2 <- ncol(y) if(diag.only) { if(n1 != n2) stop('non-conformable arguments') ## >2x faster: return(rowSums(x * t(y))) #res <- numeric(n1) #for(i in seq.int(n1)) res[i] <- sum(x[i, ] * y[, i]) } else { res <- matrix(nrow = n1, ncol = n2) for(i in seq.int(n1)) for(j in seq.int(n2)) res[i, j] <- sum(x[i, ] * y[, j]) return(res) } } ## matmultdiag(x, ty = y) == diag(x %*% t(y)) matmultdiag <- function(x, y, ty = t(y)) { if(ncol(x) != ncol(ty)) stop('non-conformable arguments') if(nrow(x) != nrow(ty)) stop('result is not a square matrix') return(rowSums(x * ty)) } tmpvarname <- function(envir, n = 8L) { while(exists(x <- paste0(c("*", sample(letters, n), "*"), collapse = ""), envir)) {} x } .lab2expr <- function(x) { x <- gsub(":", "%*%", x, perl = TRUE) x <- gsub("\\B_?(\\d+)(?![\\w\\._])", "[\\1]", x, perl = TRUE) x <- gsub("((?<=[,=]) +(?=[\\w\"'])|(?<=[\\w\"']) +(?==))", "", x, perl = TRUE) x <- gsub("[ _]", "~~", x) x <- str2expression(x) x[] <- lapply(x, function(x) if(is.call(x) && x[[1L]] == "I" && length(x) == 2L) x[[2]] else x) x } coefmatch <- function(x, y) { match(fixCoefNames(names(coeffs(x))), fixCoefNames(names(coeffs(y)))) } MuMIn/R/Cp.R0000644000176200001440000000124615161443462012136 0ustar liggesusers# Mallow's Cp `Cp` <- function (object, ..., dispersion = NULL) { .cp <- function(x, disp) { rss <- deviance(x) df.r <- df.residual(x) if(is.null(df.r)) { ll <- logLik(x) df.r <- attr(ll, "nobs") - attr(ll, "df") + 1 } scale <- if (!is.null(disp)) disp else if (family(x)$family %in% c("poisson", "binomial")) 1 else if (df.r > 0) rss / df.r else NaN rss + 2 * scale * (nobs(x) - df.r) } if (!missing(...)) { cps <- vapply(list(object, ...), .cp, 1L, disp = dispersion) val <- data.frame(Cp = cps) Call <- match.call() row.names(val) <- as.character(Call[-1L]) val } else .cp(object, dispersion) }MuMIn/R/methods-averaging.R0000644000176200001440000001642315161443462015203 0ustar liggesusers `formula.averaging` <- function (x, ...) { if (!is.null(x$formula)) { x$formula } else if (!is.null(modelList <- attr(x, "modelList"))) { update(formula(modelList[[1L]]), reformulate(unique(unlist(lapply(modelList, function(x) attr(terms(formula(x)), "term.labels")))))) } else NULL } `coef.averaging` <- function(object, full = FALSE, ...) { full <- .checkFull(object, full) object$coefficients[if(full) 1L else 2L, ] } `fitted.averaging` <- function (object, ...) .NotYetImplemented() # predict.averaging(object, backtransform = TRUE, type = "link") model.frame.averaging <- function (formula, ...) { mergeMF(getModelList(formula)) } model.matrix.averaging <- function (object, ...) { if(j <- match("x", names(object), nomatch = 0L)) return(object[[j]]) mf <- model.frame(object) do.call("model.matrix", list(object = terms(mf), data = mf, contrasts.arg = get.contrasts(object))) } `summary.averaging` <- function (object, ...) { .makecoefmat <- function(cf) { no.ase <- all(is.na(cf[, 3L])) z <- abs(cf[, 1L] / cf[, if(no.ase) 2L else 3L]) pval <- 2 * pnorm(z, lower.tail = FALSE) cbind(cf[, if(no.ase) 1L:2L else 1L:3L, drop = FALSE], `z value` = z, `Pr(>|z|)` = zapsmall(pval)) } is.arm <- ncol(object$msTable) == 6L && (colnames(object$msTable)[6L] == "ARM weight") weight <- object$msTable[, if(is.arm) 6L else 5L] object$coefmat.full <- .makecoefmat(.coefarr.avg(object$coefArray, weight, attr(object, "revised.var"), TRUE, 0.05)) if(!is.arm) object$coefmat.subset <- .makecoefmat(.coefarr.avg(object$coefArray, weight, attr(object, "revised.var"), FALSE, 0.05)) object$coef.nmod <- colSums(!is.na(object$coefArray[, 1L, , drop = FALSE])) structure(object, ARM = is.arm, class = c("summary.averaging", "averaging")) } `confint.averaging` <- function (object, parm, level = 0.95, full = FALSE, ...) { full <- .checkFull(object, full) a2 <- 1 - level a <- a2 / 2 cf <- object$coefArray[, 1L, ] pnames <- colnames(cf) if (missing(parm)) parm <- pnames else if (is.numeric(parm)) parm <- pnames[parm] missing.par <- is.na(cf) se <- object$coefArray[, 2L, ] dfs <- object$coefArray[, 3L, ] if(full) { se[missing.par] <- cf[missing.par] <- 0 if(!all(is.na(dfs))) dfs[missing.par] <- Inf } wts <- Weights(object) ## XXX: ! ci <- t(sapply(parm, function(i) par.avg(cf[,i], se[,i], wts, dfs[, i], alpha = a2)))[, 4L:5L, drop = FALSE] ci[is.na(object$coefficients[1L, parm]), ] <- NA_real_ colnames(ci) <- format_perc(c(a, 1L - a), 3L) return(ci) } `print.summary.averaging` <- function (x, digits = max(3L, getOption("digits") - 3L), signif.stars = getOption("show.signif.stars"), ...) { cat("\nCall:\n", paste(asChar(x$call, nlines = -1L), sep = "\n", collapse = "\n"), "\n\n", sep = "") comcallstr <- if(!is.null(attr(x, "model.calls"))) { commonCallStr(calls = attr(x, "model.calls")) } else if(!is.null(attr(x, "modelList"))) { commonCallStr(attr(x, "modelList")) } else NA if(!is.na(comcallstr)) { cat("Component model call: \n") cat(strwrap(comcallstr), sep = " \n ") } cat("\nComponent models: \n") msTable <- x$msTable wi <- ncol(msTable) if(!isTRUE(attr(x, "ARM")) && names(msTable)[wi] != "weight") msTable <- msTable[, c(1L, wi), drop = FALSE] print(round(as.matrix(msTable), 2L), na.print = "") if(!is.null(attr(x$msTable, "term.codes"))) { cat("\nTerm codes: \n") print.default(attr(x$msTable, "term.codes"), quote = FALSE) } cat("\nModel-averaged coefficients: ") if (nnotdef <- sum(is.na(x$coefmat.full[, 1L]))) { msg <- paste0("\n(", nnotdef, " not defined because of singularities in all ", "component models)", collapse = "") cat(strwrap(msg, exdent = 4L), sep = "\n") } hasPval <- TRUE coefTitles <- if(isTRUE(attr(x, "ARM"))) c(coefmat.full = "(ARM average)") else c(coefmat.full = "(full average)", coefmat.subset = "(conditional average)") n <- length(coefTitles) for (i in seq.int(n)) { iname <- names(coefTitles[i]) if (is.null(x[[i]])) next cat(" \n", coefTitles[i], " \n", sep = "") printCoefmat(x[[iname]], P.values = hasPval, has.Pvalue = hasPval, digits = digits, signif.stars = signif.stars, signif.legend = i == n ) } nose <- apply(x$coefArray[, 2L, ], 1L, function(x) all(is.na(x))) msg <- if(all(nose)) "Standard errors cannot be calculated because no component models provide them \n" else if(any(nose)) "Standard errors cannot be calculated because some component models do not provide them \n" cat(strwrap(msg, exdent = 4L), sep = "\n") #if (no.ase) cat("Confidence intervals are unadjusted \n") #printCoefmat(matrix(x$coef .shrinkage, nrow = 1L, #dimnames = list("", x$term.names)), P.values = FALSE, #has.Pvalue = FALSE, cs.ind = seq_along(x$term.names), tst.ind = NULL) # cat("\nSum of weights: \n") # print(round(x$sw, 2L)) } `print.averaging` <- function(x, ...) { cat("\nCall:\n", paste(asChar(x$call, nlines = -1L), sep = "\n", collapse = "\n"), "\n\n", sep = "") cat("Component models:", "\n") comp.names <- rownames(x$msTable) comp.names[!nzchar(comp.names)] <- "null" cat(format(sQuote(comp.names), justify = "l"), fill = TRUE) cat("\nCoefficients:", "\n") print(x$coefficients[!is.na(x$coefficients[,1L]), , drop = FALSE]) x } `vcov.averaging` <- function (object, full = FALSE, ...) { full <- .checkFull(object, full) full <- as.logical(full)[1L] models <- attr(object, "modelList") if(is.null(models)) stop("cannot calculate covariance matrix from ", "'averaging' object without component models") vcovs <- lapply(models, .vcov) names.all <- dimnames(object$coefArray)[[3L]] nvars <- length(names.all) nvarseq <- seq(nvars) wts <- Weights(object) wts <- wts / sum(wts) # normalize just in case vcov0 <- matrix(if(full) 0 else NA_real_, nrow = nvars, ncol = nvars, dimnames = list(names.all, names.all)) vcovs2 <- lapply(vcovs, function(v) { i <- match(fixCoefNames(dimnames(v)[[1L]]), names.all) vcov0[i, i] <- v return(vcov0) }) b1 <- object$coefArray[, 1L, ] if(full) b1[is.na(b1)] <- 0 avgb <- object$coefficients[2L - full, ] res <- sapply(nvarseq, function(c1) sapply(nvarseq, function(c2) { weighted.mean(sapply(vcovs2, "[", c1, c2) + (b1[, c1] - avgb[c1]) * (b1[, c2] - avgb[c2]), wts, na.rm = TRUE) })) dimnames(res) <- list(names.all, names.all) return(res) } `logLik.averaging` <- function (object, ...) { models <- attr(object, "modelList") if(is.null(models)) { nobs <- attr(object, "nobs") apply(object$msTable, 1L, function(x) structure(list(x[2L]), df = x[1L], nobs = nobs, class = "logLik")) } else { structure(lapply(attr(object, "modelList"), logLik), names = rownames(object$msTable)) } } `coefTable.averaging` <- function (model, full = FALSE, adjust.se = TRUE, ...) { full <- .checkFull(model, full) no.ase <- any(is.na(model$coefArray[,3L,]) & !is.na(model$coefArray[,1L,])) if(!missing(adjust.se) && adjust.se && no.ase) warning("adjusted std. error not available for this type of model") weight <- model$msTable[, ncol(model$msTable)] cols <- c(1L, if(!adjust.se || no.ase) 2L else 3L) ct <- .coefarr.avg(model$coefArray, weight, TRUE, full, .05)[, cols, drop = FALSE] .makeCoefTable(ct[,1L], ct[,2L], NA, rownames(ct)) } MuMIn/R/rbind.model.selection.R0000644000176200001440000000742515161443462015762 0ustar liggesusers# TODO: apply extras if models included `rbind.model.selection` <- function (..., deparse.level = 1, make.row.names = TRUE) { n <- ...length() if(n == 1L) return(...elt(1L)) items <- list(...) if(!all(vapply(items, inherits, FALSE, "model.selection"))) stop("not all objects are \"model.selection\"") ### XXX: This modifies original objects!!! items <- lapply(items, "class<-", "data.frame") ## ... reverting to original (?) class on exit: on.exit(lapply(items, "class<-", c("model.selection", "data.frame"))) .allitemsidentical <- function(x) all(vapply(x[-1L], identical, FALSE, x[[1L]])) if(!.allitemsidentical(lapply(items, attr, "beta"))) stop("coefficient standardisation is not consistent across tables") if(!.allitemsidentical(lapply(items, \(x) .getRankCall(attr(x, "rank"))))) stop("tables are not ranked by the same IC") if(!.allitemsidentical(lapply(items, "attr", "nobs"))) stop("number of observations differs across models") .combine <- function(x, y, pos, len = length(y)) { if(is.factor(x) || is.factor(y)) { if(is.factor(x)) { if(!is.factor(y)) y <- factor(y) } else if(is.factor(y)) x <- factor(x) alllev <- unique(c(levels(x), levels(y))) x <- factor(x, levels = alllev, labels = alllev) } x[pos:(pos + len - 1L)] <- y x } ct <- unname(lapply(items, attr, "column.types")) vct <- unlist(ct, recursive = FALSE) vct <- vct[order(as.integer(unlist(ct)))] #vct <- vct[order(as.integer(unlist(ct)), unlist(lapply(ct, seq_along)))] vct <- vct[!duplicated(names(vct))] # TODO: check mismatch in column.types nm <- names(vct) rval <- as.data.frame(array(NA, dim = c(sum(sapply(items, nrow)), length(nm)), dimnames = list(NULL, nm))) row1 <- 1L for(z in items) { n <- nrow(z) nmz <- nm[nm %in% names(z)] for(j in nmz) rval[, j] <- .combine(rval[, j], z[, j], row1, n) row1 <- row1 + n } combineAttrs <- c("model.calls", "coefTables") hasModelList <- vapply(items, function(x) is.list(attr(x, "modelList")), logical(1L)) if(any(hasModelList)) { if(!all(hasModelList)) { warning("not all combined tables include model lists. The missing items will be NULL.") for(i in which(!hasModelList)) attr(items[[i]], "modelList") <- structure(vector("list", nrow(items[[i]])), names = rownames(items[[i]])) } combineAttrs[length(combineAttrs) + 1L] <- "modelList" } newattr <- list(column.types = vct) for(i in combineAttrs) newattr[[i]] <- unlist(lapply(items, attr, i), recursive = FALSE, use.names = FALSE) k <- c("rank", "nobs", "beta") newattr[k] <- attributes(items[[1L]])[k] tmp <- lapply(items, attr, "terms") newattr[["terms"]] <- structure(unique(unlist(tmp, recursive = FALSE, use.names = FALSE)), interceptLabel = unique(unlist(lapply(tmp, attr, "interceptLabel")))) for(i in names(newattr)) attr(rval, i) <- newattr[[i]] class(rval) <- c("model.selection", "data.frame") if(make.row.names) { rn1 <- rep(names(items), sapply(items, nrow)) rn1[i] <- paste0(rn1[i <- nzchar(rn1)], ".") rlabs <- paste0(rn1, unlist(lapply(items, rownames))) if(anyDuplicated(rlabs)) rlabs <- make.unique(as.character(rlabs), sep = "") } else { rlabs <- as.character(1L:nrow(rval)) } rownames(rval) <- rlabs o <- order(rval[, names(vct)[vct == "ic"]]) rval <- rval[o, recalc.delta = TRUE] attr(rval, "merged-order") <- o rval } `merge.model.selection` <- function (x, y, suffixes = c(".x", ".y"), ...) { rval <- rbind(x, y, make.row.names = FALSE) if (!is.null(suffixes)) row.names(rval) <- c(paste0(row.names(x), suffixes[1L]), paste0(row.names(y), suffixes[2L]))[attr(rval, "merged-order")] attr(rval, "merged-order") <- NULL rval } MuMIn/R/unfckme.R0000644000176200001440000000542615161443462013230 0ustar liggesusers# Extractor for model object elements returning values in consistent format # (which is as it should be by default) # vcov alternative that always returns a matrix (as it should be) .vcov <- function(object, ...) UseMethod(".vcov") .vcov.default <- function(object, ...) as.matrix(vcov(object, ...)) .vcov.glmmTMB <- function(object, component = c("cond", "zi", "disp"), ...) { component <- match.arg(component) rval <- vcov(object, ...)[[component]] nm <- rownames(rval) nm[nm == "(Intercept)"] <- "(Int)" nm <- paste0(component, "(", nm, ")") dimnames(rval) <- list(nm, nm) rval } .numfixef <- function (object, ...) UseMethod(".numfixef") .numfixef.default <- function (object, ...) fixef(object, ...) .numfixef.cpglm <- function (object, ...) coef(object, ...) .numfixef.cpglmm <- function (object, ...) cplm::fixef(object, ...) .numfixef.glmmTMB <- function (object, ...) fixef(object, ...)$cond # Consistent sigma (residual standard deviation) sigma2 <- function(object) UseMethod("sigma2") sigma2.default <- function(object) { if(startsWith(family(object)$family, "Negative Binomial(")) { get(".Theta", environment(family(object)$aic)) } else { sigma(object) } } sigma2.glmmPQL <- function(object) { switch(family(object)$family, gaussian = , Gamma = object$sigma, object$sigma^2 ) } sigma2.glmmTMB <- function(object) { if(family(object)$family == "nbinom1") sigma(object) + 1 else sigma(object) } sigma2.glmerMod <- function(object) { if(startsWith(family(object)$family, "Negative Binomial(")) { lme4::getME(object, "glmer.nb.theta") } else { NextMethod() } } # VarCorr wrapper returning consistent format (list of named RE variances) .varcorr <- function(object, ...) UseMethod(".varcorr") .varcorr.default <- function(object, ...) unclass(VarCorr(object, ...)) # RE model matrix colnames for models with >1 random formulas are prefixed with # the grouping factor name, e.g. : # {~ 1 | X1, ~ 1 | X2} has model.matrix columns "X1.(Intercept)", "X2.(Intercept)" # Need to rename VC matrix dimnames to match them. .varcorr.lme <- function(object, ...) { reStruct <- object$modelStruct$reStruct rval <- lapply(reStruct, function(v, sig2) nlme::pdMatrix(v) * sig2, object$sigma^2) if ((m <- length(rval)) > 1L) { nm <- names(rval) for (i in seq.int(m)) { dn <- paste(nm[i], dimnames(rval[[i]])[[1L]], sep=".") dimnames(rval[[i]]) <- list(dn, dn) } } attr(rval, "sc") <- object$sigma rval } .varcorr.glmmTMB <- function(object, component = c("cond", "zi", "disp"), ...) { component <- match.arg(component) unclass(VarCorr(object, ...)[[component]]) } .varcorr.glmmadmb <- function(object, ...) { suppressWarnings(VarCorr(object)) } MuMIn/R/class-glmmADMB.R0000644000176200001440000000252015161443462014253 0ustar liggesusersfamily.glmmadmb <- function(object, ...) { famstr <- switch(object$family, gamma = "Gamma", binom = "binomial", nbinom = { # nbinom1 or nbinom2 ? Impossible to discern... s <- object$call$family if(!is.character(s)) { warning("\"nbinom\" family may be incorrectly determined if ", sQuote(deparse(s)), " has changed since model fitting") s <- eval(s, environment(formula(object))) if(!is.character(s) || length(s) != 1L || !tolower(s) %in% c("nbinom", "nbinom2", "nbinom1")) stop("cannot determine \"nbinom\" family type. Use a character string literal in the model call.") if(s == "nbinom") s <- "nbinom2" } s }, object$family) if(famstr %in% c("poisson", "binomial", "gaussian", "Gamma")) return(do.call(match.fun(famstr), list(object$link))) rval <- list(family = famstr, link = object$link, linkfun = object$linkfun, linkinv = object$ilinkfun) class(rval) <- "family" rval } # residual std. dev. or dispersion parameter sigma.glmmadmb <- function (object, ...) { switch(family(object)$family, Gamma = 1 / sqrt(object$alpha), object$alpha ) # XXX: not checked with other non-standard families } MuMIn/R/plot.model.selection.R0000644000176200001440000001462315161444373015642 0ustar liggesusers `plot.model.selection` <- function(x, ylab = NULL, xlab = NULL, main = "Model selection table", labels = NULL, terms = NULL, labAsExpr = TRUE, vlabels = rownames(x), mar.adj = TRUE, col = NULL, col.mode = 2, bg = "white", border = par("col"), par.lab = NULL, par.vlab = NULL, axes = TRUE, ann = TRUE, ...) { if(is.null(xlab)) xlab <- NA if(is.null(ylab)) ylab <- expression("Cumulative model weight" ~~ (omega)) vlabels.wts.cutoff <- 0.01 if(is.numeric(col.mode)) { if(col.interpolate <- col.mode[1L] > 0) { col.interp.bias <- col.mode[1L] col.by.value <- FALSE } else if(col.mode[1L] < 0) { col.by.value <- TRUE } else col.by.value <- FALSE } else if (is.character(col.mode) && startsWith("value", tolower(col.mode[1L]))) { col.by.value <- TRUE col.interpolate <- FALSE } else { col.by.value <- col.interpolate <- FALSE } if(...length() != 0L) { dots <- list(...) if(!is.null(dots$col2)) { warning("argument 'col2' is now defunct") dots$col2 <- NULL } op <- do.call("par", c(dots, no.readonly = TRUE)) on.exit(par(op)) } wts <- Weights(x) ok <- wts > 1e-5 wts <- wts[ok] cwts <- cumsum(wts) #xp <- !is.na(itemByType(x, "terms", drop = FALSE)) xp <- !is.na(itemByType(x, c("terms", "varying"), drop = FALSE)) if(is.null(terms)) terms <- TRUE xp <- xp[ok, terms, drop = FALSE] m <- ncol(xp) n <- nrow(xp) if (isTRUE(col.by.value)) { if(is.null(col)) { col1 <- hcl.colors(10L, palette = "Blue-Red 3") col2 <- "gray50" } else { if(length(col) < 2L) stop("colours by value need 'col' with at least two elements") col2 <- col[1L] col1 <- col[-1L] } ncq <- length(col1) ncqscale <- (ncq - 1) / 2 cft <- do.call("cbind", lapply(x[, terms], function(x) { if(all(is.na(x))) { as.integer(x) } else if(is.character(x)) { # in case stringsAsFactors was not used in dredge as.numeric(factor(x)) + ncq } else if(is.factor(x)) { as.numeric(x) + ncq } else { m <- max(abs(x), na.rm = TRUE) floor((x / m * ncqscale) + ncqscale + 1L) } })) mode(cft) <- "integer" col <- array(c(col1, col2[1L])[cft], dim = dim(x)) col.interp.bias <- 0L col.interpolate <- FALSE } else if(is.null(col)) { cola <- grDevices::hcl.colors(25L, palette = "Blues 3", rev = TRUE) colb <- grDevices::rgb(desaturate(t(col2rgb(cola)), .66), maxColorValue = 255) col <- cbind(cola, colb, deparse.level = 0L) } if(isTRUE(col.interpolate)) { if(!is.matrix(col)) { col <- matrix(col) } else if(m < ncol(col)) col <- col[, seq.int(min(m, ncol(col))), drop = FALSE] colwts <- wts / max(wts) if(nrow(col) < 3L) col <- apply(col, 2L, function(a) grDevices::colorRampPalette(a)(3L)) col1 <- array("", dim = c(length(colwts), ncol(col))) for(i in 1L:ncol(col)) col1[, i] <- rgb(grDevices::colorRamp((col[, i]), bias = col.interp.bias)(colwts), maxColorValue = 255) col <- col1 } else { #recycle colors row- and column-wise if(is.matrix(col)) col <- col[rep(seq.int(nrow(col)), length.out = n), rep(seq.int(ncol(col)), length.out = m)] } if(is.matrix(col)) { a <- rep(seq(0, by = n, length.out = ncol(col)), each = n, length.out = length(xp)) x2 <- array(rep(seq.int(n), m), dim = dim(xp)) * xp x2[!xp] <- NA #x2 <- unname(x2) } else { a <- 0L x2 <- array(NA_integer_, dim = dim(xp)) x2[xp] <- rep(seq.int(length(col)), length.out = sum(xp)) #x2[] <- (x2 - 1L) %% length(col) + 1L } plot.new() # need it here for reading 'par' if(isTRUE(ann)) { commonpar <- list(col = par("col.axis"), font = par("font.axis"), cex = par("cex.axis") * par("cex")) if(missing(labels)) labels <- colnames(xp) if(!is.null(labels)) { if(length(labels) != m) stop("length of 'labels' is not equal to number of terms") if(labAsExpr && is.character(labels)) labels <- .lab2expr(labels) arglab <- c(list(las = 2L, line = 0.33, padj = 0.5), commonpar) for(i in names(par.lab)) arglab[i] <- par.lab[i] vlabels <- vlabels[ok][vli <- wts > vlabels.wts.cutoff] argvlab <- c(list(las = 2L, mgp = c(1, .5, 0), hadj = 0), commonpar) for(i in names(par.vlab)) argvlab[i] <- par.vlab[i] if(!is.numeric(argvlab$mgp)) argvlab$mgp <- par("mgp") if(is.numeric(argvlab$line)) { argvlab$mgp[2L] <- argvlab$line argvlab$line <- NULL } # for rhs-axis, replace 'axpar' with 'axpar.axis' axp <- c("col", "font", "cex") j <- match(axp, names(argvlab), nomatch = 0L) names(argvlab)[j] <- paste0(names(argvlab)[j], ".axis") if(isTRUE(mar.adj)) { # top labels: sw <- max((if(arglab$las == 1) strheight else strwidth)( labels, font = arglab$font, cex = arglab$cex / par("cex"), units = "in")) mai <- par("mai") mai[3L] <- max(mai[3L], sw + grconvertY(arglab$line + .33 + (if(is.null(main)) 0 else 2), "lines", "inches")) # right-hand side labels: ml <- argvlab$mgp[2L] if(argvlab$las == 3) { sw <- 0 ml <- ml + 1 } else { sw <- (1 - argvlab$hadj) * max(strwidth(vlabels, font = argvlab$font, cex = argvlab$cex, units = "in")) ml <- ml + .25 } mai[4L] <- max(mai[4L], sw + grconvertX(ml, "lines", "inches")) op2 <- par(mai = mai) on.exit(par(op2), add = TRUE) } # mar.adj } # labels } # ann plot.window(xlim = c(0.5, m + .5), ylim = c(1, 0), xaxs = "i", yaxs = "i") rect(0.5, 0, m + .5, 1, col = bg, border = 0) cx <- seq(0.5, ncol(x2) + .5) cy <- c(0, cwts) ixy <- expand.grid(y = seq.int(length(cwts)), x = seq.int(ncol(x2))) ixy <- ixy[xp, , drop = FALSE] plot.window(xlim = c(0.5, m + .5), ylim = c(1, 0), xaxs = "i", yaxs = "i") rect(cx[ixy[, 2L]], cy[ixy[, 1L]], cx[ixy[, 2L] + 1L], cy[ixy[, 1L] + 1L], col = col[c(x2 + a)][xp]) abline(h = cwts, v = seq(.5, length.out = m)) box() if(isTRUE(ann)) { do.call(mtext, c(list(labels, at = seq.int(m), side = 3L), arglab)) do.call(axis, c(list(side = 4L, at = cwts[vli] - 0.5 * wts[vli], tick = FALSE, labels = vlabels), argvlab)) title(main = main, line = par("mar")[3L] - 1.5) title(ylab = ylab) title(xlab = xlab, line = 2) } if(axes) { axis(2L, col = border, col.ticks = border) box(col = border) } invisible(NULL) } MuMIn/R/dredge.R0000644000176200001440000005036315161444373013034 0ustar liggesusers # code snippet to handle argument 'beta' .expr_beta_arg <- expression({ if(is.logical(beta) && beta) { betaMode <- as.integer(beta) strbeta <- if(beta) "sd" else "none" } else if(is.character(beta)) { strbeta <- match.arg(beta) beta <- strbeta != "none" betaMode <- (strbeta != "none") + (strbeta == "partial.sd") } else { cry(, "invalid value for 'beta' : the argument is taken to be \"none\"", warn = TRUE) betaMode <- 0L strbeta <- "none" } }) dredge <- function(global.model, beta = c("none", "sd", "partial.sd"), evaluate = TRUE, rank = "AICc", fixed = NULL, m.lim = NULL, m.min, m.max, subset, trace = FALSE, varying, extra, ct.args = NULL, deps = attr(allTerms0, "deps"), cluster = NULL, ...) { if(isTRUE(evaluate) && inherits(cluster, "cluster")) { cl <- match.call() cl[[1L]] <- quote(.dredge.par) return(eval(cl)) } trace <- min(as.integer(trace), 2L) strbeta <- betaMode <- NULL eval(.expr_beta_arg) gmEnv <- parent.frame() gmNobs <- nobs(global.model) gmCall <- get_call(global.model) if (is.null(gmCall)) { gmCall <- substitute(global.model) if(!is.call(gmCall)) { stop("need a 'global.model' with a call component. Consider using ", if(inherits(global.model, c("gamm", "gamm4"))) "'uGamm'" else "'updateable'") } #"For objects without a 'call' component the call to the fitting function \n", #" must be used directly as an argument to 'dredge'.") # NB: this is unlikely to happen if(!is.function(eval(gmCall[[1L]], gmEnv))) cry(, "could not find function '%s'", asChar(gmCall[[1L]])) } else { # if 'update' method does not expand dots, we have a problem with # expressions like ..1, ..2 in the call. So try to replace them with # respective arguments in the original call isDotted <- grep("^\\.\\.", sapply(as.list(gmCall), asChar)) if(length(isDotted) != 0L) { if(is.name(substitute(global.model))) { cry(, "the call stored in 'global.model' contains dotted names and cannot be updated. \n Consider using 'updateable' on the modelling function") } else gmCall[isDotted] <- substitute(global.model)[names(gmCall[isDotted])] } # object from 'run.mark.model' has $call of 'make.mark.model' - fixing # it here: if(inherits(global.model, "mark") && gmCall[[1L]] == "make.mark.model") { gmCall <- call("run.mark.model", model = gmCall, invisible = TRUE) } } thisCall <- sys.call() exprApply(gmCall[["data"]], NA, function(expr) { if(!is.symbol(expr[[1L]]) || all(expr[[1L]] != c("@", "$", "::"))) cry(thisCall, "'global.model' uses \"data\" that is a function value: use a variable instead") }) lik <- .getLik(global.model) logLik <- lik$logLik # *** Rank *** rank.custom <- !missing(rank) if(!rank.custom && lik$name == "qLik") { rank <- "QIC" cry(, "using 'QIC' instead of 'AICc'", warn = TRUE) } rankArgs <- list(...) if(any(badargs <- names(rankArgs) == "marg.ex")) { cry(, "argument \"marg.ex\" is defunct and has been ignored", warn = TRUE) rankArgs <- rankArgs[!badargs] } if(any(names(rankArgs) == "na.action")) cry("RTFM", "argument \"na.action\" is inappropriate here", warn = FALSE) IC <- .getRank(rank, rankArgs) if(any(badargs <- is.na(match(names(rankArgs), c(names(formals(get("rank", environment(IC))))[-1L], names(formals())))))) cry("RTFM", ngettext(sum(badargs), "argument %s is not a name of formal argument of %s", "arguments %s are not names of formal arguments of %s"), prettyEnumStr(names(rankArgs[badargs])), "'dredge' or 'rank'", warn = TRUE) ICName <- as.character(.getRankCall(IC)[[1L]]) if(length(tryCatch(IC(global.model), error = function(e) { stop(simpleError(conditionMessage(e), subst(.getRankCall(IC), x = as.name("global.model")))) })) != 1L) { cry(, "result of '%s' is not of length 1", asChar(.getRankCall(IC))) } allTerms <- allTerms0 <- getAllTerms(global.model, intercept = TRUE, data = eval(gmCall$data, envir = gmEnv)) # Intercept(s) interceptLabel <- attr(allTerms, "interceptLabel") if(is.null(interceptLabel)) interceptLabel <- "(Intercept)" nIntercepts <- sum(attr(allTerms, "intercept")) # Check for na.omit if(!(gmNaAction <- .checkNaAction(cl = gmCall, what = "'global.model'", envir = gmEnv))) cry(, attr(gmNaAction, "message")) if(!nzchar(names(gmCall)[2L])) gmCall <- match.call(gmCall, definition = eval(gmCall[[1L]], envir = gmEnv), expand.dots = TRUE) # TODO: other classes: model, fixed, etc... gmCoefNames <- names(coeffs(global.model)) if(any(dup <- duplicated(gmCoefNames))) cry(, "model cannot have duplicate coefficient names: ", prettyEnumStr(gmCoefNames[dup])) gmCoefNames <- fixCoefNames(gmCoefNames) nVars <- length(allTerms) if(isTRUE(rankArgs$REML) || (isTRUE(.isREMLFit(global.model)) && is.null(rankArgs$REML))) cry(, "comparing models fitted by REML", warn = TRUE) if ((betaMode != 0L) && is.null(tryCatch(std.coef(global.model, betaMode == 2L), error = return_null, warning = return_null))) { cry(, "do not know how to standardize coefficients of '%s': argument 'beta' ignored", class(global.model)[1L], warn = TRUE) betaMode <- 0L strbeta <- "none" } if(nomlim <- is.null(m.lim)) m.lim <- c(0, NA) ## XXX: backward compatibility: if(!missing(m.max) || !missing(m.min)) { warning("arguments 'm.min' and 'm.max' are deprecated, use 'm.lim' instead") if(!nomlim) stop("cannot use both 'm.lim' and 'm.min' or 'm.max'") if(!missing(m.min)) m.lim[1L] <- m.min[1L] if(!missing(m.max)) m.lim[2L] <- m.max[1L] } if(!is.numeric(m.lim) || length(m.lim) != 2L || any(m.lim < 0, na.rm = TRUE)) stop("invalid 'm.lim' value") m.lim[2L] <- if (!is.finite(m.lim[2L])) (nVars - nIntercepts) else min(nVars - nIntercepts, m.lim[2L]) if (!is.finite(m.lim[1L])) m.lim[1L] <- 0 m.min <- m.lim[1L] m.max <- m.lim[2L] # fixed variables: if (!is.null(fixed)) { if (inherits(fixed, "formula")) { if (fixed[[1L]] != "~" || length(fixed) != 2L) cry(, "'fixed' should be a one-sided formula", warn = TRUE) fixed <- as.vector(getAllTerms(fixed)) } else if (identical(fixed, TRUE)) { fixed <- as.vector(allTerms[!(allTerms %in% interceptLabel)]) } else if (!is.character(fixed)) { cry(, paste("'fixed' should be either a character vector with", " names of variables or a one-sided formula")) } if (!all(i <- (fixed %in% allTerms))) { cry(, "some terms in 'fixed' do not exist in 'global.model': %s", prettyEnumStr(fixed[!i]), warn = TRUE) fixed <- fixed[i] } } fixed <- union(fixed, rownames(deps)[rowSums(deps, na.rm = TRUE) == ncol(deps)]) fixed <- c(fixed, allTerms[allTerms %in% interceptLabel]) fixed <- fixed[!duplicated(fixed)] nFixed <- length(fixed) if(nFixed != 0L) message(sprintf(ngettext(nFixed, "Fixed term is %s", "Fixed terms are %s"), prettyEnumStr(fixed))) termsOrder <- order(allTerms %in% fixed) allTerms <- allTerms[termsOrder] di <- match(allTerms, rownames(deps)) deps <- deps[di, di, drop = FALSE] gmFormulaEnv <- environment(as.formula(formula(global.model), env = gmEnv)) # TODO: gmEnv <- gmFormulaEnv ??? ### BEGIN 'varying' ## @param: varying ## @value: varying, varyingNames, variants, nVariants, nVarying if(!missing(varying) && !is.null(varying)) { nVarying <- length(varying) varyingNames <- names(varying) fvarying <- unlist(varying, recursive = FALSE, use.names = FALSE) vlen <- vapply(varying, length, 1L) nVariants <- prod(vlen) variants <- as.matrix(expand.grid(split(seq_len(sum(vlen)), rep(seq_len(nVarying), vlen)))) variantsFlat <- unlist(lapply(varying, .makeListNames), recursive = FALSE, use.names = FALSE) } else { variants <- varyingNames <- NULL nVariants <- 1L nVarying <- 0L } ## END: varying ## BEGIN 'extra' ## @param: extra, global.model, gmFormulaEnv, ## @value: extra, nExtra, extraNames, nullfit_ if(!missing(extra) && length(extra) != 0L) { r2inExtra <- is.vector(extra) && any(c("adjR^2", "R^2") %in% extra) if (r2inExtra) { if(nVariants > 1L) stop("\"R^2\" in 'extra' cannot be used when 'varying' is given") nullfit <- null.fit(global.model, evaluate = TRUE, envir = gmFormulaEnv) } else { nullfit <- NULL } extra <- eval.parent(call(".get.extras", substitute(extra), r2nullfit = nullfit)) extraResult <- .applyExtras(global.model, extra) nExtra <- length(extraResult) extraNames <- names(extraResult) } else { extra <- NULL nExtra <- 0L extraNames <- character() } ## END: 'extra' ## BEGIN: 'subset' ## @param: hasSubset, subset, allTerms, [interceptLabel], ## @value: hasSubset, subset if(missing(subset)) { hasSubset <- 1L } else { if(!tryCatch(is.language(subset) || is.matrix(subset) || is.null(subset) || isTRUE(subset), error = function(e) FALSE)) subset <- substitute(subset) if(is.null(subset) || isTRUE(subset)) { hasSubset <- 1L } else if(is.matrix(subset)) { dn <- dimnames(subset) #at <- allTerms[!(allTerms %in% interceptLabel)] n <- length(allTerms) if(is.null(dn) || any(sapply(dn, is.null))) { di <- dim(subset) if(any(di != n)) stop("unnamed 'subset' matrix does not have both dimensions", " equal to number of terms in 'global.model': %d", n) dimnames(subset) <- list(allTerms, allTerms) } else { if(!all(unique(unlist(dn)) %in% allTerms)) warning("at least some dimnames of 'subset' matrix do not ", "match term names in 'global.model'") subset0 <- subset subset <- matrix(subset[ match(allTerms, rownames(subset)), match(allTerms, colnames(subset))], dimnames = list(allTerms, allTerms), nrow = n, ncol = n) nas <- is.na(subset) lotri <- lower.tri(subset) i <- lotri & nas & !t(nas) subset[i] <- t(subset)[i] subset[!lotri] <- NA } if(any(!is.na(subset[!lower.tri(subset)]))) { warning("non-missing values exist outside the lower triangle of 'subset'") subset[!lower.tri(subset)] <- NA } mode(subset) <- "logical" hasSubset <- 2L # subset as matrix } else { # subset is not null, TRUE or a matrix if(inherits(subset, "formula")) { if (subset[[1L]] != "~" || length(subset) != 2L) stop("'subset' formula should be one-sided") subset <- subset[[2L]] } subset <- as.expression(subset) ssValidNames <- c("comb", "*nvar*") tmpTerms <- terms(reformulate(allTerms0[!(allTerms0 %in% interceptLabel)])) gloFactorTable <- t(attr(tmpTerms, "factors") != 0) offsetNames <- sapply(attr(tmpTerms, "variables")[attr(tmpTerms, "offset") + 1L], asChar) if(length(offsetNames) != 0L) { gloFactorTable <- rbind(gloFactorTable, matrix(FALSE, ncol = ncol(gloFactorTable), nrow = length(offsetNames), dimnames = list(offsetNames, NULL))) for(i in offsetNames) gloFactorTable[offsetNames, offsetNames] <- TRUE #Note `diag<-` does not work for x[1x1] matrix: # diag(gloFactorTable[offsetNames, offsetNames, drop = FALSE]) <- TRUE } .DebugPrint(gloFactorTable) # fix interaction names in rownames: rownames(gloFactorTable) <- allTerms0[!(allTerms0 %in% interceptLabel)] subsetExpr <- subset[[1L]] subsetExpr <- exprapply0(subsetExpr, c("with", "."), .subst.with, gloFactorTable, allTerms, as.name("comb"), gmEnv) subsetExpr <- exprapply0(subsetExpr, c("{", "Term"), .subst.term) #@@@ TODO has subsetExpr <- exprapply0(subsetExpr, "has", .subst.term) tmp <- updateDeps(subsetExpr, deps) subsetExpr <- tmp$expr deps <- tmp$deps subsetExpr <- exprapply0(subsetExpr, "dc", .subst.vars.for.args) subsetExpr <- .subst.names.for.items(subsetExpr, allTerms, "comb") if(nVarying) { ssValidNames <- c("cVar", "comb", "*nvar*") subsetExpr <- exprapply0(subsetExpr, "V", .subst.v, as.name("cVar"), varyingNames) if(!all(all.vars(subsetExpr) %in% ssValidNames)) subsetExpr <- .subst.names.for.items(subsetExpr, varyingNames, "cVar", fun = "[[") } ssVars <- all.vars(subsetExpr) okVars <- ssVars %in% ssValidNames if(!all(okVars)) stop("unrecognized names in 'subset' expression: ", prettyEnumStr(ssVars[!okVars])) ssEnv <- new.env(parent = parent.frame()) ssFunc <- setdiff(all.vars(subsetExpr, functions = TRUE), ssVars) if("dc" %in% ssFunc) assign("dc", .subset_dc, ssEnv) hasSubset <- if(any(ssVars == "cVar")) 4L else # subset as expression 3L # subset as expression using 'varying' variables } } # END: 'subset' nov <- as.integer(nVars - nFixed) ncomb <- (2L ^ nov) * nVariants novMax <- log2(.Machine$integer.max %/% nVariants) if(nov > novMax) cry(, "number of non-fixed predictors [%d] exceeds the allowed maximum of %.0f (with %d variants)", nov, novMax, nVariants) resultChunkSize <- 25L resultInitialSize <- resultChunkSize * nVariants if(evaluate) { rvNcol <- nVars + nVarying + 3L + nExtra rval <- matrix(NA_real_, ncol = rvNcol, nrow = resultInitialSize) coefTables <- vector(resultInitialSize, mode = "list") } comb.sfx <- rep(TRUE, nFixed) comb.seq <- if(nov != 0L) seq_len(nov) else 0L k <- 0L extraResult1 <- integer(0L) calls <- vector(mode = "list", length = resultInitialSize) ord <- integer(resultInitialSize) argsOptions <- list( response = attr(allTerms0, "response"), intercept = nIntercepts, interceptLabel = interceptLabel, random = attr(allTerms0, "random"), gmCall = gmCall, gmEnv = gmEnv, allTerms = allTerms0, gmCoefNames = gmCoefNames, ## TODO: is 'gmDataHead' needed anymore? gmDataHead = if(!is.null(gmCall$data)) { if(eval(call("is.data.frame", gmCall$data), gmEnv)) eval(call("head", gmCall$data, 1L), gmEnv) else gmCall$data } else NULL, gmFormulaEnv = gmFormulaEnv ) ## [[end of common code]] matchCoefCall <- as.call(c(alist(matchCoef, fit1, all.terms = allTerms, beta = betaMode, allCoef = TRUE), ct.args)) retColIdx <- if(nVarying) -nVars - seq_len(nVarying) else TRUE dotrace <- if(trace == 1L) { dotrace <- function() { cat(iComb, ": "); print(clVariant) utils::flush.console() } } else if(trace > 1L) { progressBar <- .progbar(max = ncomb, title = "\"dredge\" working...") on.exit(.closeprogbar(progressBar)) function() progressBar(value = iComb, title = sprintf("dredge: %d of ca. %.0f subsets (%d total)", k, (k / iComb) * ncomb, iComb)) } else function() {} iComb <- -1L while((iComb <- iComb + 1L) < ncomb) { varComb <- iComb %% nVariants jComb <- (iComb - varComb) %/% nVariants #if(iComb %% 100L == 0L) setProgressBar(progressBar, value = iComb, title = sprintf("dredge: %d/%d total", k, iComb)) if(varComb == 0L) { isok <- TRUE ## comb : logical term indexes comb <- c(as.logical(intToBits(jComb)[comb.seq]), comb.sfx) nvar <- sum(comb) - nIntercepts if(nvar > m.max || nvar < m.min || !formula_margin_check(comb, deps) || switch(hasSubset, FALSE, !all(subset[comb, comb], na.rm = TRUE), !evalExprInEnv(subsetExpr, env = ssEnv, enclos = parent.frame(), comb = comb, `*nvar*` = nvar), FALSE )) { isok <- FALSE next } newArgs <- makeArgs(global.model, allTerms[comb], argsOptions) # comb if(!is.null(attr(newArgs, "problems"))) { print.warnings(structure(vector(mode = "list", length = length(attr(newArgs, "problems"))), names = attr(newArgs, "problems"))) } # end if cl <- gmCall cl[names(newArgs)] <- newArgs } # end if(jComb != prevJComb) if(!isok) next; ## --- Variants --------------------------- clVariant <- cl if (nVarying) { #cvi <- variants[(iComb - 1L) %% nvariants + 1L, ] cvi <- variants[varComb + 1L, ] if(hasSubset == 4L && !evalExprInEnv(subsetExpr, env = ssEnv, enclos = parent.frame(), comb = comb, `*nvar*` = nvar, cVar = variantsFlat[cvi])) next; clVariant[varyingNames] <- fvarying[cvi] } dotrace() if(evaluate) { # begin row1: (clVariant, gmEnv, modelId, IC(), applyExtras(), # nExtra, allTerms, beta, # if(nVarying) variantsIdx[v] else NULL fit1 <- tryCatch(eval(clVariant, gmEnv), error = function(err) { err$message <- paste(conditionMessage(err), "(model", iComb, "skipped)", collapse = "") class(err) <- c("simpleError", "warning", "condition") warning(err) return(NULL) }) if (is.null(fit1)) next; if(nExtra != 0L) { extraResult1 <- .applyExtras(fit1, extra) if(length(extraResult1) < nExtra) { tmp <- rep(NA_real_, nExtra) tmp[match(names(extraResult1), names(extraResult))] <- extraResult1 extraResult1 <- tmp } } mcoef1 <- eval(matchCoefCall) ll1 <- logLik(fit1) nobs1 <- nobs(fit1) if(nobs1 != gmNobs) cry(, "model #%d [%d] is fitted to a different number of observations than the global model [%d]", iComb, nobs1, gmNobs, warn = TRUE) row1 <- c(mcoef1[allTerms], extraResult1, df = attr(ll1, "df"), ll = ll1, ic = IC(fit1) ) ## end -> row1 k <- k + 1L # all OK, add model to table rvlen <- nrow(rval) if(retNeedsExtending <- k > rvlen) { # append if necesarry nadd <- min(resultChunkSize, ncomb - rvlen) rval <- rbind(rval, matrix(NA_real_, ncol = rvNcol, nrow = nadd), deparse.level = 0L) addi <- seq.int(rvlen + 1L, length.out = nadd) coefTables[addi] <- vector("list", nadd) } rval[k, retColIdx] <- row1 coefTables[[k]] <- attr(mcoef1, "coefTable") } else { # if !evaluate k <- k + 1L rvlen <- length(ord) if(retNeedsExtending <- k > rvlen) { nadd <- min(resultChunkSize, ncomb - rvlen) addi <- seq.int(rvlen + 1L, length.out = nadd) } } if(retNeedsExtending) { calls[addi] <- vector("list", nadd) ord[addi] <- integer(nadd) } ord[k] <- iComb calls[[k]] <- clVariant } ### for (iComb ...) if(k == 0L) stop("result is empty") ord <- ord + 1L names(calls) <- ord if(!evaluate) return(calls[seq_len(k)]) if(k < nrow(rval)) { i <- seq_len(k) rval <- rval[i, , drop = FALSE] ord <- ord[i] calls <- calls[i] coefTables <- coefTables[i] } if(nVarying) { varlev <- ord %% nVariants varlev[varlev == 0L] <- nVariants rval[, nVars + seq_len(nVarying)] <- variants[varlev, ] } rval <- as.data.frame(rval, stringsAsFactors = TRUE) row.names(rval) <- ord # Convert columns with presence/absence of terms to factors tfac <- which(!(allTerms %in% gmCoefNames)) rval[tfac] <- lapply(rval[tfac], factor, levels = NaN, labels = "+") rval[, seq_along(allTerms)] <- rval[, v <- order(termsOrder)] allTerms <- allTerms[v] colnames(rval) <- c(allTerms, varyingNames, extraNames, "df", lik$name, ICName) if(nVarying) { variant.names <- vapply(variantsFlat, asChar, "", width.cutoff = 20L) vnum <- split(seq_len(sum(vlen)), rep(seq_len(nVarying), vlen)) names(vnum) <- varyingNames for (i in varyingNames) rval[, i] <- factor(rval[, i], levels = vnum[[i]], labels = variant.names[vnum[[i]]]) } #koBrowseHere() rval <- rval[o <- order(rval[, ICName], decreasing = FALSE), ] coefTables <- coefTables[o] rval$delta <- rval[, ICName] - rval[1L, ICName] rval$weight <- Weights(rval$delta) mode(rval$df) <- "integer" structure(rval, model.calls = calls[o], global = global.model, global.call = gmCall, terms = structure(allTerms, interceptLabel = interceptLabel), rank = IC, beta = strbeta, #eval(formals(sys.function())[["beta"]])[betaMode + 1L], call = match.call(expand.dots = TRUE), coefTables = coefTables, nobs = gmNobs, vCols = varyingNames, column.types = { colTypes <- c(terms = length(allTerms), varying = length(varyingNames), extra = length(extraNames), df = 1L, loglik = 1L, ic = 1L, delta = 1L, weight = 1L) column.types <- rep(1L:length(colTypes), colTypes) names(column.types) <- colnames(rval) lv <- 1L:length(colTypes) factor(column.types, levels = lv, labels = names(colTypes)[lv]) }, extra = extra, class = c("model.selection", "data.frame") ) } # `dredgeAll` <- function(global.model, beta = FALSE, ...) { cl <- match.call(definition = dredge) cl$evaluate <- FALSE cl[[1L]] <- as.name("dredge") models <- lapply(eval.parent(cl), eval, parent.frame()) rval <- model.sel(models) attr(rval, "modelList") <- models attr(rval, "global") <- global.model attr(rval, "global.call") <- get_call(global.model) attr(rval, "call") <- cl rval } MuMIn/R/methods-nobs.R0000644000176200001440000000411715161443462014176 0ustar liggesusers`nobs.glmmML` <- function(object, ...) length(object$coefficients) + object$cluster.null.df # Extends: nlme --- No longer needed `nobs.gls` <- function(object, nall = TRUE, ...) { p <- object$dims$p N <- object$dims$N if (nall) return (N) REML <- object$method == "REML" N - REML * p } `nobs.lme` <- function(object, nall = TRUE, ...) { N <- object$dims$N if (nall) return (N) p <- object$dims$ncol[object$dims$Q + 1L] REML <- object$method == "REML" N - REML * p } # # p - the number of coefficients in the linear model. # #N - the number of observations in the data, # #Q - the number of grouping levels # #ncol - the number of columns in the model matrix for each level of grouping from innermost to outermost # # (last two values are equal to the number of fixed effects and one). # Extends: nnet `nobs.multinom` <- function(object, ...) NROW(fitted(object)) `nobs.rq` <- function (object, ...) length(object$y) `nobs.coxme` <- function (object, ...) object$n[2L] `nobs.lmekin` <- function (object, ...) object$n[1L] `nobs.hurdle` <- `nobs.zeroinfl` <- `nobs.lmekin` `nobs.glimML` <- function (object, ...) attr(logLik(object), "nobs") `nobs.unmarkedFit` <- function(object, ...) #get("sampleSize", asNamespace("unmarked"))(object) unmarked::sampleSize(object) `nobs.yagsResult` <- function (object, ...) length(object@residuals) `nobs.asreml` <- `nobs.aodml` <- `nobs.splm` <- function (object, ...) length(resid(object)) `nobs.MCMCglmm` <- function (object, ...) object$Residual$nrl `nobs.gamm` <- function (object, ...) getFrom("stats", "nobs.glm")(object$gam, ...) `nobs.mark` <- function (object, ...) object$results[['n']] `nobs.pgls` <- `nobs.logistf` <- `nobs.phylolm` <- function (object, ...) object$n `nobs.coxph` <- function (object, ...) object$nevent `nobs.caic` <- function (object, ...) nobs(object$mod) `nobs.aodql` <- function (object, ...) nobs(object$fm) `nobs.cpglmm` <- function (object, ...) object@dims[['n']] `nobs.maxlikeFit` <- function (object, ...) nrow(object[['points.retained']]) `nobs.geem` <- function (object, ...) sum(object$weights != 0) MuMIn/R/quasiLik.R0000644000176200001440000001660315161443462013361 0ustar liggesusers# Code based on 'compar.gee' from package 'ape' ## Comparative Analysis with GEEs ## compar.gee.R (2011-06-14) ## Copyright 2002-2010 Emmanuel Paradis ## https://svn.mpl.ird.fr/ape/dev/ape/R/compar.gee.R ##============================================================================= ## quasiLik ##============================================================================= `quasiLik` <- function (object, ...) UseMethod("quasiLik") # TODO: add weights to families # TODO: update calls to .qlik, add weights .qlik <- function(y, mu, fam, w, scale = 1) { w <- w / (sum(w) / length(w)) switch(fam$family, gaussian = -0.5 * sum(w * (y - mu)^2) / scale, binomial = sum(w * (y * log(mu / (1 - mu)) + log(1 - mu))), #binomial.sqvar = sum(((2 * y - 1) * log(mu /(1 - mu))) - (y / mu) - ((1 - y)/(1 - mu))), poisson = sum(w * ((y * log(mu)) - mu)), Gamma = -sum(w * (y / mu + log(mu))) / scale, inverse.gaussian = sum(w * (mu - 0.5 * y) / mu^2) / scale, { # negative.binomial = sum((y * log(mu)) - (2 * log(mu + 1))) / scale, if(startsWith(tolower(fam$family), "negative binomial(")) { gt <- fam$getTheta th <- if(is.function(gt)) { if(is.null(formals(gt)$trans)) gt() else gt(TRUE) } else environment(fam$aic)$.Theta a <- (1 / th) * mu ap1 <- a + 1 sum(w * (lgamma(y + th) - lgamma(th) + y * log(a / ap1) + th * log(1 / ap1))) } else cry(, "do not know how to calculate quasi-likelihood for family '%s'", fam$family) }) } `print.quasiLik` <- function (x, digits = getOption("digits"), ...) { cat("'quasi Lik.' ", paste(format(c(x), digits = digits), collapse = ", "), "\n", sep = "") invisible(x) } `quasiLik.geeglm` <- `quasiLik.gee` <- function(object, ...) { scale <- if(is.null(object$geese)) object$scale else object$geese$gamma[[1L]] ret <- .qlik(object$y, object$fitted.values, family(object), 1, # XXX should use weights(object) for 'geeglm', 'gee' gives no weights, scale) attr(ret, "df") <- NA attr(ret, "nobs") <- length(object$y) class(ret) <- "quasiLik" ret } # XXX: check weights `quasiLik.yagsResult` <- function(object, ...) { mu <- object@fitted.values ret <- .qlik(mu + object@residuals, mu, family(object), 1, # 'yags' object gives no weights, object@phi) attr(ret, "df") <- NA attr(ret, "nobs") <- length(mu) class(ret) <- "quasiLik" ret } `quasiLik.geem` <- function(object, ...) { fam <- family(object) scale <- object$phi ret <- .qlik(object$y, fitted(object), if(inherits(fam, "family")) fam else list(family = "custom"), 1, # object$weights, scale) attr(ret, "df") <- NA attr(ret, "nobs") <- length(object$y) class(ret) <- "quasiLik" ret } quasiLik.wgee <- function(object, ...) { dat <- match.fun(getOption('na.action'))(model.frame(object$model, data = object$data)) bad <- attr(dat, "na.action") ret <- .qlik(if(!is.null(bad)) object$y[-bad] else object$y, object$mu_fit, family(object), 1, # object$weight XXX" no -s, object$scale[[1L]]) attr(ret, "df") <- NA attr(ret, "nobs") <- length(object$mu_fit) class(ret) <- "quasiLik" ret } ##============================================================================= ## QIC ##============================================================================= .qic2 <- function(y, mu, vbeta, mui, vbeta.naiv.i, fam, wts, scale, typeR = FALSE) { ql <- .qlik(y, if(typeR) mu else mui, fam, wts, scale) # XXX: should be typeR = TRUE for QICu??? n <- length(y) invert <- if (is.matrix(vbeta.naiv.i) && "MASS" %in% loadedNamespaces()) MASS::ginv else solve AIinv <- invert(vbeta.naiv.i) tr <- sum(matmult(AIinv, vbeta, diag.only = TRUE)) ## tr <- sum(diag(AIinv %*% vbeta)) #px <- length(mu) px <- dim(vbeta)[1L] ## When all modelling specifications in GEE are correct tr = px. c(2 * (c(QIC = tr, QICu = px) - ql), n = n) } `getQIC` <- function(x, typeR = FALSE) UseMethod("getQIC") `getQIC.default` <- function(x, typeR = FALSE) .NotYetImplemented() `getQIC.coxph` <- function(x, ...) { #warnonce("getQIC.coxph", "QIC for 'coxph' is experimental") warnonce("QIC for 'coxph' is experimental") naive.var <- x[[ if (is.null(x$naive.var)) "var" else "naive.var" ]] # tr <- sum(diag(solve(naive.var) %*% x$var)) tr <- sum(matmultdiag(solve(naive.var), x$var)) ll <- x$loglik[2L] px <- dim(x$var)[1L] c(2 * (c(QIC = tr, QICu = px) - ll), n = length(x$y)) } `getQIC.gee` <- function(x, typeR = FALSE) { if(x$model$corstr != "Independent") utils::capture.output(suppressMessages(xi <- update(x, corstr = "independence", silent = TRUE))) else xi <- x y <- if(x$family$family == "binomial" && any(x$y > 1)) { cl <- getCall(x) cl <- cl[names(cl) %in% c("", "formula", "data", "subset", "na.action")] cl[[1L]] <- as.name("model.frame") mf <- eval.parent(cl) warning(gettextf("using response \"%s\" from the current %s.", names(mf)[1L], if(is.null(cl$data)) "environment" else sQuote(asChar(cl$data)))) y <- mf[, 1L] y <- y[, 1L] / rowSums(y) } else x$y .qic2(y, x$fitted.values, x$robust.variance, xi$fitted.values, xi$naive.variance, family(x), 1, # no weights scale = x$scale, typeR = typeR) } `getQIC.geeglm` <- function(x, typeR = FALSE) { xi <- if(x$corstr != "independence") { cl <- getCall(x) cl$corstr <- "independence" cl$zcor <- NULL eval.parent(cl) } else x .qic2(x$y, x$fitted.values, x$geese$vbeta, xi$fitted.values, xi$geese$vbeta.naiv, family(x), 1, # weights(x) scale = x$geese$gamma[[1L]], typeR = typeR) } `getQIC.wgee` <- function(x, typeR = FALSE) { if(isTRUE(typeR)) warning("argument 'typeR' ignored.") qic <- getFrom("wgeesel", "QIC.gee")(x) c(QIC = qic[[1L]], QICu = qic[[2L]], n = length(x$mu_fit)) } `getQIC.yagsResult` <- function(x, typeR = FALSE) { xi <- if(x@corstruct.tag != "independence") update(x, corstruct = "independence") else x .qic2(x@fitted.values + x@residuals, x@fitted.values, x@robust.parmvar, xi@fitted.values, xi@naive.parmvar, family(x), 1, # no weights scale = x@phi, typeR = typeR) } `getQIC.geem` <- function(x, typeR = FALSE) { fam <- family(x) xi <- if(x$corr != "independence") update(x, corstr = "independence") else x .qic2(x$y, fitted(x), x$var, fitted(xi), xi$naiv.var, if (inherits(fam, "family")) fam else list(family = "custom"), 1, # x$weights scale = x$phi, typeR = typeR ) } `QIC` <- function(object, ..., typeR = FALSE) { if (!missing(...)) { res <- sapply(list(object, ...), getQIC, typeR = typeR) val <- as.data.frame(t(res[1L, , drop = FALSE])) colnames(val) <- c("QIC") Call <- match.call() Call$typeR <- NULL row.names(val) <- as.character(Call[-1L]) val } else getQIC(object, typeR = typeR)[1L] } `QICu` <- function (object, ..., typeR = FALSE) { if (!missing(...)) { res <- sapply(list(object, ...), getQIC, typeR = typeR) val <- as.data.frame(t(res[2L,, drop = FALSE])) colnames(val) <- "QICu" Call <- match.call() Call$typeR <- NULL row.names(val) <- as.character(Call[-1L]) val } else getQIC(object, typeR = typeR)[2L] } MuMIn/R/nested.R0000644000176200001440000000347315161443462013062 0ustar liggesusers`nested` <- function(x, indices = c("none", "numeric", "rownames"), rank = NULL) { indices <- match.arg(indices) if(!inherits(x, "model.selection")) stop("'x' is not a \"model.selection\" object") vColIdx <- type2col(x, "varying") if(nVCols <- length(vColIdx)) { vtab <- x[, vColIdx, drop = FALSE] for(i in 1L:ncol(vtab)) vtab[, i] <- as.numeric(vtab[, i]) vtab <- as.matrix(vtab) } tab <- !is.na(x[, attr(x, "terms")]) # TERMS n <- nrow(tab) if(indices == "none") { if(is.null(rank)) { rank <- colnames(x)[which(colnames(x) == "delta")[1L] - 1L] } else if (!is.na(rank) && !rank %in% colnames(x)) cry(, "column named \"%s\" does not exist in 'x'", rank) if(!is.na(rank) && any(diff(x[, rank]) < 0)) cry(, "'x' is not ordered by \'%s\'", rank, warn = TRUE) is.nested <- function(x, inside) all(inside == x | inside) vmatch <- if(nVCols) function(i, j) vtab[i, ] == vtab[j, ] else function(i, j) TRUE res <- logical(n) for(i in 2L:n) for(j in seq_len(i - 1L)) if(vmatch(i, j) && is.nested(tab[j, ], tab[i, ])) { res[i] <- TRUE break; } } else { # 'alldf': same as apply(g, margin, all) but ~2x faster alldf <- function(g, margin = 1L) { g <- as.matrix(g) dg <- dim(g) mode(g) <- "integer" if(margin == 1L) .rowSums(g, dg[1L], dg[2L]) == dg[2L] else .colSums(g, dg[1L], dg[2L]) == dg[1L] } vmatch <- if(nVCols) function(i) alldf(apply(vtab, 1L, "==", vtab[i, ]), 1L) else function(i) TRUE tab <- t(tab) idx <- seq.int(n) res <- vector(length = n, mode = "list") for(i in idx) { z <- vmatch(i) & alldf(tab == tab[, i] | tab[, i], 2L) z[i] <- FALSE res[[i]] <- which(z) } if(indices == "rownames") { res <- lapply(res, function(i, x) x[i], rownames(x)) } names(res) <- rownames(x) } return(res) } MuMIn/R/methods-xtable.R0000644000176200001440000000366315161443462014521 0ustar liggesusersxtable.summary.averaging <- function (x, caption = NULL, label = NULL, align = NULL, digits = NULL, display = NULL, coefType = c("full", "subset"), ...) { coefType <- match.arg(coefType) x <- as.data.frame(x[[switch(coefType, full = "coefmat.full", subset = "coefmat.subset")]]) has.ase <- all(!is.na(x[, 3L])) if(!has.ase) x <- x[, -3L] getFrom("xtable", "xtable")(x, caption = caption, label = label, align = if(is.null(align)) rep("r", ncol(x) + 1L) else align, digits = if(is.null(digits)) c(0, 4, 4, if(has.ase) 4, 2, 4) else digits, display = if(is.null(display)) c("s", "f", "f", if(has.ase) "f", "f", "f") else display, ...) return(x) } xtable.averaging <- function (x, caption = NULL, label = NULL, align = NULL, digits = NULL, display = NULL, coefType, ...) { return(xtable.summary.averaging(summary(x, ...), caption = caption, label = label, align = align, digits = digits, display = display, coefType = coefType)) } xtable.model.selection <- function (x, caption = NULL, label = NULL, align = NULL, digits = NULL, display = NULL, ...) { column.types <- attr(x, "column.types") x <- as.data.frame(x, stringsAsFactors = TRUE) vclass <- vapply(x, function(v) { if(is.integer(v)) return("integer") if(is.factor(v) || is.character(v)) return("character") if(is.numeric(v)) return("real") "other" }, "") if(is.null(align)) align <- c("r", ifelse(vclass == "character", "c", "r")) dig <- c(terms = NA, varying = NA, extra = NA, df = 0L, loglik = 1L, ic = 1L, delta = 1L, weight = 2L) decprint <- dig[column.types[colnames(x)]] decprint[is.na(decprint)] <- 2L display <- character(ncol(x)) display[vclass == "character"] <- "s" display[vclass == "real"] <- "f" display[vclass == "integer"] <- "d" display[vclass == "other"] <- "s" getFrom("xtable", "xtable")(x, caption = caption, label = label, align = align, digits = c(NA, decprint), display = c("s", display), ...) } MuMIn/R/frmsplit.R0000644000176200001440000000346715161443462013443 0ustar liggesusers# split multi-sided formula into a list of (one- or two-sided) formulas # * for tilde-separated formulas, response is only for the first model # * for bar-separated formulas, response is with all component models frmsplit <- function(x) { f <- formula(x) env <- environment(f) .op <- \(expr) if(is.call(expr)) deparse1(expr[[1L]], backtick = FALSE) else "" # decompose multi-sided (n > 2), i.e. [y] ~ a ~ b ~ c f1 <- f rval <- list() while(.op(f1) == "~") { rval[[length(rval) + 1L]] <- f1[[length(f1)]] f1 <- f1[[2L]] } response <- if(!identical(f1, rval[[length(rval)]])) f1 else NULL mform.tilde <- length(rval) != 1L # one or two-sided [y] ~ a + b if(length(rval) == 1L) { rhs <- rval[[1L]] # remove ~ rval <- list() # bar-split formula y ~ a | b while(.op(rhs) == "|") { rval[[length(rval) + 1L]] <- rhs[[3L]] rhs <- rhs[[2L]] } rval[[length(rval) + 1L]] <- rhs } rval <- rev(rval) if(is.null(response)) { noresp <- seq.int(1L, length(rval)) resp <- 0L } else { if(mform.tilde) { # has lhs and is ~-separated - attach the response to FIRST right-sided formula: resp <- 1L noresp <- seq.int(2L, length(rval)) # because length(rval) > 1L } else { # has lhs - attach the response to each right-sided formula: resp <- seq.int(1L, length(rval)) noresp <- 0L } } rval[resp] <- lapply(rval[resp], function(g) formula(call("~", response, g), env = env)) rval[noresp] <- lapply(rval[noresp], function(g) formula(call("~", g), env = env)) if(length(rval) != 1L) attr(rval, "mform.style") <- if(mform.tilde) "~" else "|" rval } MuMIn/R/pdredge.R0000644000176200001440000005711715161443462013216 0ustar liggesusers## TODO: chunk size for evaluate = FALSE `pdredge` <- function(global.model, cluster = NULL, beta = c("none", "sd", "partial.sd"), evaluate = TRUE, rank = "AICc", fixed = NULL, m.lim = NULL, m.min, m.max, subset, trace = FALSE, varying, extra, ct.args = NULL, deps = attr(allTerms0, "deps"), check = FALSE, ...) { .Deprecated("dredge") allTerms0 <- 0L # placeholder for Rcheck cl <- match.call() cl[[1L]] <- as.symbol(".dredge.par") return(eval(cl)) } `.dredge.par` <- function(global.model, cluster = NULL, beta = c("none", "sd", "partial.sd"), evaluate = TRUE, rank = "AICc", fixed = NULL, m.lim = NULL, m.min, m.max, subset, trace = FALSE, varying, extra, ct.args = NULL, deps = attr(allTerms0, "deps"), check = FALSE, ...) { #FIXME: m.max cannot be 0 - e.g. for intercept only model trace <- min(as.integer(trace), 2L) strbeta <- betaMode <- NULL eval(.expr_beta_arg) ###PAR qlen <- 25L # Imports: clusterCall, clusterApply doParallel <- isTRUE(evaluate) && inherits(cluster, "cluster") if(doParallel) { .parallelPkgCheck() # XXX: workaround to avoid importing from 'parallel' clusterCall <- get("clusterCall") clusterApply <- get("clusterApply") clusterCall(cluster, "require", .packageName, character.only = TRUE) .getRow <- function(X) clusterApply(cluster, X, fun = ".pdredge_process_model") } else { .getRow <- function(X) lapply(X, pdredge_process_model, envir = props) clusterCall <- function(...) NULL message("Not using cluster.") } ###PAR gmEnv <- parent.frame() gmNobs <- nobs(global.model) gmCall <- get_call(global.model) if (is.null(gmCall)) { gmCall <- substitute(global.model) if(!is.call(gmCall)) { stop("need a 'global.model' with a call component. Consider using ", if(inherits(global.model, c("gamm", "gamm4"))) "'uGamm'" else "'updateable'") } #"For objects without a 'call' component the call to the fitting function \n", #" must be used directly as an argument to 'dredge'.") # NB: this is unlikely to happen if(!is.function(eval.parent(gmCall[[1L]]))) cry(, "could not find function '%s'", asChar(gmCall[[1L]])) } else { # if 'update' method does not expand dots, we have a problem with # expressions like ..1, ..2 in the call. So try to replace them with # respective arguments in the original call isDotted <- grep("^\\.\\.", sapply(as.list(gmCall), asChar)) if(length(isDotted) != 0L) { if(is.name(substitute(global.model))) { cry(, "the call stored in 'global.model' contains dotted names and cannot be updated. \n Consider using 'updateable' on the modelling function") } else gmCall[isDotted] <- substitute(global.model)[names(gmCall[isDotted])] } # object from 'run.mark.model' has $call of 'make.mark.model' - fixing # it here: if(inherits(global.model, "mark") && gmCall[[1L]] == "make.mark.model") { gmCall <- call("run.mark.model", model = gmCall, invisible = TRUE) } } thisCall <- sys.call() exprApply(gmCall[["data"]], NA, function(expr) { if(is.symbol(expr[[1L]]) && all(expr[[1L]] != c("@", "$"))) cry(thisCall, "'global.model' uses \'data\' that is a function value: use a variable instead") }) lik <- .getLik(global.model) logLik <- lik$logLik # *** Rank *** rank.custom <- !missing(rank) if(!rank.custom && lik$name == "qLik") { rank <- "QIC" cry(, "using 'QIC' instead of 'AICc'", warn = TRUE) } rankArgs <- list(...) if(any(badargs <- names(rankArgs) == "marg.ex")) { cry(, "argument \"marg.ex\" is defunct and has been ignored", warn = TRUE) rankArgs <- rankArgs[!badargs] } if(any(names(rankArgs) == "na.action")) cry("RTFM", "argument \"na.action\" is inappropriate here", warn = FALSE) IC <- .getRank(rank, rankArgs) if(any(badargs <- is.na(match(names(rankArgs), c(names(formals(get("rank", environment(IC))))[-1L], names(formals())))))) cry("RTFM", ngettext(sum(badargs), "argument %s is not a name of formal argument of %s", "arguments %s are not names of formal arguments of %s"), prettyEnumStr(names(rankArgs[badargs])), "'dredge' or 'rank'", warn = TRUE) ICName <- as.character(.getRankCall(IC)[[1L]]) if(length(tryCatch(IC(global.model), error = function(e) { stop(simpleError(conditionMessage(e), subst(.getRankCall(IC), x = as.name("global.model")))) })) != 1L) { cry(, "result of '%s' is not of length 1", asChar(.getRankCall(IC))) } allTerms <- allTerms0 <- getAllTerms(global.model, intercept = TRUE, data = eval(gmCall$data, envir = gmEnv)) # Intercept(s) interceptLabel <- attr(allTerms, "interceptLabel") if(is.null(interceptLabel)) interceptLabel <- "(Intercept)" nIntercepts <- sum(attr(allTerms, "intercept")) ###PAR # parallel: check whether the models would be identical: if(doParallel && check) testUpdatedObj(cluster, global.model, gmCall, level = check) ###PAR # Check for na.omit if(!(gmNaAction <- .checkNaAction(cl = gmCall, what = "'global.model'", envir = gmEnv))) cry(, attr(gmNaAction, "message")) if(!nzchar(names(gmCall)[2L])) gmCall <- match.call(gmCall, definition = eval.parent(gmCall[[1L]]), expand.dots = TRUE) gmCoefNames <- names(coeffs(global.model)) if(any(dup <- duplicated(gmCoefNames))) cry(, "model cannot have duplicated coefficient names: ", prettyEnumStr(gmCoefNames[dup])) gmCoefNames <- fixCoefNames(gmCoefNames) nVars <- length(allTerms) if(isTRUE(rankArgs$REML) || (isTRUE(.isREMLFit(global.model)) && is.null(rankArgs$REML))) cry(, "comparing models fitted by REML", warn = TRUE) if ((betaMode != 0L) && is.null(tryCatch(std.coef(global.model, betaMode == 2L), error = return_null, warning = return_null))) { cry(, "do not know how to standardize coefficients of '%s', argument 'beta' ignored", class(global.model)[1L], warn = TRUE) betaMode <- 0L strbeta <- "none" } if(nomlim <- is.null(m.lim)) m.lim <- c(0, NA) ## XXX: backward compatibility: if(!missing(m.max) || !missing(m.min)) { warning("arguments 'm.min' and 'm.max' are deprecated, use 'm.lim' instead") if(!nomlim) stop("cannot use both 'm.lim' and 'm.min' or 'm.max'") if(!missing(m.min)) m.lim[1L] <- m.min[1L] if(!missing(m.max)) m.lim[2L] <- m.max[1L] } if(!is.numeric(m.lim) || length(m.lim) != 2L || any(m.lim < 0, na.rm = TRUE)) stop("invalid 'm.lim' value") m.lim[2L] <- if (!is.finite(m.lim[2L])) (nVars - nIntercepts) else min(nVars - nIntercepts, m.lim[2L]) if (!is.finite(m.lim[1L])) m.lim[1L] <- 0 m.min <- m.lim[1L] m.max <- m.lim[2L] # fixed variables: if (!is.null(fixed)) { if (inherits(fixed, "formula")) { if (fixed[[1L]] != "~" || length(fixed) != 2L) cry(, "'fixed' should be a one-sided formula", warn = TRUE) fixed <- as.vector(getAllTerms(fixed)) } else if (identical(fixed, TRUE)) { fixed <- as.vector(allTerms[!(allTerms %in% interceptLabel)]) } else if (!is.character(fixed)) { cry(, paste("'fixed' should be either a character vector with", " names of variables or a one-sided formula")) } if (!all(i <- (fixed %in% allTerms))) { cry(, "some terms in 'fixed' do not exist in 'global.model': %s", prettyEnumStr(fixed[!i]), warn = TRUE) fixed <- fixed[i] } } #deps <- attr(allTerms0, "deps") fixed <- union(fixed, rownames(deps)[rowSums(deps, na.rm = TRUE) == ncol(deps)]) fixed <- c(fixed, allTerms[allTerms %in% interceptLabel]) fixed <- fixed[!duplicated(fixed)] nFixed <- length(fixed) if(nFixed != 0L) message(sprintf(ngettext(nFixed, "Fixed term is %s", "Fixed terms are %s"), prettyEnumStr(fixed))) termsOrder <- order(allTerms %in% fixed) allTerms <- allTerms[termsOrder] di <- match(allTerms, rownames(deps)) deps <- deps[di, di, drop = FALSE] gmFormulaEnv <- environment(as.formula(formula(global.model), env = gmEnv)) # TODO: gmEnv <- gmFormulaEnv ??? ### BEGIN Manage 'varying' ## @param: varying ## @value: varying, varyingNames, variants, nVariants, nVarying if(!missing(varying) && !is.null(varying)) { nVarying <- length(varying) varyingNames <- names(varying) fvarying <- unlist(varying, recursive = FALSE, use.names = FALSE) vlen <- vapply(varying, length, 1L) nVariants <- prod(vlen) variants <- as.matrix(expand.grid(split(seq_len(sum(vlen)), rep(seq_len(nVarying), vlen)))) variantsFlat <- unlist(lapply(varying, .makeListNames), recursive = FALSE, use.names = FALSE) } else { variants <- varyingNames <- NULL nVariants <- 1L nVarying <- 0L } ## END: varying ## BEGIN Manage 'extra' ## @param: extra, global.model, gmFormulaEnv, ## @value: extra, nExtra, extraNames, nullfit_ if(!missing(extra) && length(extra) != 0L) { if (any(c("adjR^2", "R^2") %in% extra) && nVariants > 1L) stop("\"R^2\" in 'extra' can be used only with no 'varying'") # a cumbersome way of evaluating a non-exported function in a parent frame: extra <- eval(as.call(list(call("get", ".get.extras", envir = call("asNamespace", .packageName), inherits = FALSE), substitute(extra), r2nullfit = TRUE)), parent.frame()) #extra <- eval(call(".get.extras", substitute(extra), r2nullfit = TRUE), parent.frame()) if(any(c("adjR^2", "R^2") %in% names(extra))) { nullfit_ <- null.fit(global.model, evaluate = TRUE, envir = gmFormulaEnv) } applyExtras <- function(x) unlist(lapply(extra, function(f) f(x))) extraResult <- applyExtras(global.model) if(!is.numeric(extraResult)) cry(, "function in 'extra' returned non-numeric result") nExtra <- length(extraResult) extraNames <- names(extraResult) } else { nExtra <- 0L extraNames <- character(0L) } ## END: manage 'extra' nov <- as.integer(nVars - nFixed) ncomb <- (2L ^ nov) * nVariants novMax <- log2(.Machine$integer.max %/% nVariants) if(nov > novMax) cry(, "number of non-fixed predictors [%d] exceeds the allowed maximum of %.0f (with %d variants)", nov, novMax, nVariants) resultChunkSize <- 25L if(evaluate) { rvNcol <- nVars + nVarying + 3L + nExtra rval <- matrix(NA_real_, ncol = rvNcol, nrow = resultChunkSize) coefTables <- vector(resultChunkSize, mode = "list") } ## BEGIN: Manage 'subset' ## @param: hasSubset, subset, allTerms, [interceptLabel], ## @value: hasSubset, subset if(missing(subset)) { hasSubset <- 1L } else { if(!tryCatch(is.language(subset) || is.matrix(subset), error = function(e) FALSE)) subset <- substitute(subset) if(is.matrix(subset)) { dn <- dimnames(subset) #at <- allTerms[!(allTerms %in% interceptLabel)] n <- length(allTerms) if(is.null(dn) || any(sapply(dn, is.null))) { di <- dim(subset) if(any(di != n)) stop("unnamed 'subset' matrix does not have both dimensions", " equal to number of terms in 'global.model': %d", n) dimnames(subset) <- list(allTerms, allTerms) } else { if(!all(unique(unlist(dn)) %in% allTerms)) warning("at least some dimnames of 'subset' matrix do not ", "match term names in 'global.model'") subset0 <- subset subset <- matrix(subset[ match(allTerms, rownames(subset)), match(allTerms, colnames(subset))], dimnames = list(allTerms, allTerms), nrow = n, ncol = n) nas <- is.na(subset) lotri <- lower.tri(subset) i <- lotri & nas & !t(nas) subset[i] <- t(subset)[i] subset[!lotri] <- NA } if(any(!is.na(subset[!lower.tri(subset)]))) { warning("non-missing values exist outside the lower triangle of 'subset'") subset[!lower.tri(subset)] <- NA } mode(subset) <- "logical" hasSubset <- 2L # subset as matrix } else { if(inherits(subset, "formula")) { if (subset[[1L]] != "~" || length(subset) != 2L) stop("'subset' formula should be one-sided") subset <- subset[[2L]] } subset <- as.expression(subset) ssValidNames <- c("comb", "*nvar*") tmpTerms <- terms(reformulate(allTerms0[!(allTerms0 %in% interceptLabel)])) gloFactorTable <- t(attr(tmpTerms, "factors") != 0) offsetNames <- sapply(attr(tmpTerms, "variables")[attr(tmpTerms, "offset") + 1L], asChar) if(length(offsetNames) != 0L) { gloFactorTable <- rbind(gloFactorTable, matrix(FALSE, ncol = ncol(gloFactorTable), nrow = length(offsetNames), dimnames = list(offsetNames, NULL))) for(i in offsetNames) gloFactorTable[offsetNames, offsetNames] <- TRUE #Note `diag<-` does not work for x[1x1] matrix: # diag(gloFactorTable[offsetNames, offsetNames, drop = FALSE]) <- TRUE } .DebugPrint(gloFactorTable) # fix interaction names in rownames: rownames(gloFactorTable) <- allTerms0[!(allTerms0 %in% interceptLabel)] subsetExpr <- subset[[1L]] subsetExpr <- exprapply0(subsetExpr, c("with", "."), .subst.with, gloFactorTable, allTerms, as.name("comb"), gmEnv) subsetExpr <- exprapply0(subsetExpr, c("{", "Term"), .subst.term) tmp <- updateDeps(subsetExpr, deps) subsetExpr <- tmp$expr deps <- tmp$deps subsetExpr <- exprapply0(subsetExpr, "dc", .subst.vars.for.args) subsetExpr <- .subst.names.for.items(subsetExpr, allTerms, "comb") if(nVarying) { ssValidNames <- c("cVar", "comb", "*nvar*") subsetExpr <- exprapply0(subsetExpr, "V", .subst.v, as.name("cVar"), varyingNames) if(!all(all.vars(subsetExpr) %in% ssValidNames)) subsetExpr <- .subst.names.for.items(subsetExpr, varyingNames, "cVar", fun = "[[") } ssVars <- all.vars(subsetExpr) okVars <- ssVars %in% ssValidNames if(!all(okVars)) stop("unrecognized names in 'subset' expression: ", prettyEnumStr(ssVars[!okVars])) ssEnv <- new.env(parent = parent.frame()) ssFunc <- setdiff(all.vars(subsetExpr, functions = TRUE), ssVars) if("dc" %in% ssFunc) assign("dc", .subset_dc, ssEnv) hasSubset <- if(any(ssVars == "cVar")) 4L else # subset as expression 3L # subset as expression using 'varying' variables } } # END: manage 'subset' comb.sfx <- rep(TRUE, nFixed) comb.seq <- if(nov != 0L) seq_len(nov) else 0L k <- 0L extraResult1 <- integer(0L) calls <- vector(mode = "list", length = resultChunkSize) ord <- integer(resultChunkSize) argsOptions <- list( response = attr(allTerms0, "response"), intercept = nIntercepts, interceptLabel = interceptLabel, random = attr(allTerms0, "random"), gmCall = gmCall, gmEnv = gmEnv, allTerms = allTerms0, gmCoefNames = gmCoefNames, gmDataHead = if(!is.null(gmCall$data)) { if(eval(call("is.data.frame", gmCall$data), gmEnv)) eval(call("head", gmCall$data, 1L), gmEnv) else gmCall$data } else NULL, gmFormulaEnv = gmFormulaEnv ) # BEGIN parallel qi <- 0L queued <- vector(qlen, mode = "list") props <- list( gmEnv = gmEnv, IC = IC, # beta = beta, # allTerms = allTerms, nExtra = nExtra, matchCoefCall = as.call(c(list( as.name("matchCoef"), as.name("fit1"), all.terms = allTerms, beta = betaMode, allCoef = TRUE), ct.args)) # matchCoefCall = as.call(c(alist(matchCoef, fit1, all.terms = Z$allTerms, # beta = Z$beta, allCoef = TRUE), ct.args)) ) if(nExtra) { props$applyExtras <- applyExtras props$extraResultNames <- names(extraResult) } props <- as.environment(props) if(doParallel) { clusterVExport(cluster, pdredge_props = props, .pdredge_process_model = pdredge_process_model ) clusterCall(cluster, eval, call("options", options("na.action")), env = 0L) } # END parallel retColIdx <- if(nVarying) -nVars - seq_len(nVarying) else TRUE dotrace <- if(trace == 1L) { dotrace <- function() { cat(iComb, ": "); print(clVariant) utils::flush.console() } } else if(trace > 1L) { progressBar <- .progbar(max = ncomb, title = "\"dredge\" working...") on.exit(.closeprogbar(progressBar)) function() progressBar(value = iComb, title = sprintf("dredge: %d of ca. %.0f subsets", k, (k / iComb) * ncomb)) } else function() {} warningList <- list() iComb <- -1L while((iComb <- iComb + 1L) < ncomb) { varComb <- iComb %% nVariants jComb <- (iComb - varComb) / nVariants if(varComb == 0L) { isok <- TRUE comb <- c(as.logical(intToBits(jComb)[comb.seq]), comb.sfx) nvar <- sum(comb) - nIntercepts # !!! POSITIVE condition for 'pdredge', NEGATIVE for 'dredge': if((nvar >= m.min && nvar <= m.max) && formula_margin_check(comb, deps) && switch(hasSubset, # 1 - no subset, 2 - matrix, 3 - expression TRUE, # 1 all(subset[comb, comb], na.rm = TRUE), # 2 evalExprInEnv(subsetExpr, env = ssEnv, enclos = parent.frame(), comb = comb, `*nvar*` = nvar), # 3 TRUE ) ) { newArgs <- makeArgs(global.model, allTerms[comb], argsOptions) #comb formulaList <- if(is.null(attr(newArgs, "formulaList"))) newArgs else attr(newArgs, "formulaList") if(!is.null(attr(newArgs, "problems"))) { print.warnings(structure(vector(mode = "list", length = length(attr(newArgs, "problems"))), names = attr(newArgs, "problems"))) } # end if cl <- gmCall cl[names(newArgs)] <- newArgs } else isok <- FALSE # end if = nvar >= m.min> } # end if(jComb != prevJComb) if(isok) { ## --- Variants --------------------------- clVariant <- cl isok2 <- TRUE if(nVarying) { cvi <- variants[varComb + 1L, ] isok2 <- (hasSubset != 4L) || evalExprInEnv(subsetExpr, env = ssEnv, enclos = parent.frame(), comb = comb, `*nvar*` = nvar, cVar = variantsFlat[cvi]) clVariant[varyingNames] <- fvarying[cvi] } if(isok2) { if(evaluate) { dotrace() qi <- qi + 1L queued[[(qi)]] <- list(call = clVariant, id = iComb) } else { # if !evaluate k <- k + 1L # all OK, add model to table rvlen <- length(ord) if(k > rvlen) { nadd <- min(resultChunkSize, ncomb - rvlen) #message(sprintf("extending result from %d to %d", rvlen, rvlen + nadd)) addi <- seq.int(rvlen + 1L, length.out = nadd) calls[addi] <- vector("list", nadd) ord[addi] <- integer(nadd) } calls[[k]] <- clVariant ord[k] <- iComb } } } # if isok #if(evaluate && qi && (qi + nvariants > qlen || iComb == ncomb)) { if(evaluate && qi && (qi > qlen || (iComb + 1) == ncomb)) { qseq <- seq_len(qi) qresult <- .getRow(queued[qseq]) utils::flush.console() if(!all(vapply(qresult, function(x) is.list(x) && "value" %in% names(x), FALSE))) stop("some results returned from cluster node(s) are malformed or NULL. \n", "This should not happen and indicates problems with ", "the cluster node", domain = "R-MuMIn") haveProblems <- logical(qi) nadd <- sum(sapply(qresult, function(x) inherits(x$value, "condition") + length(x$warnings))) wi <- length(warningList) if(nadd) warningList <- c(warningList, vector(nadd, mode = "list")) # DEBUG: print(sprintf("Added %d warnings, now is %d", nadd, length(warningList))) for (i in qseq) for(cond in c(qresult[[i]]$warnings, if(inherits(qresult[[i]]$value, "condition")) list(qresult[[i]]$value))) { wi <- wi + 1L warningList[[wi]] <- if(is.null(conditionCall(cond))) queued[[i]]$call else conditionCall(cond) if(inherits(cond, "error")) { haveProblems[i] <- TRUE msgsfx <- "(model %d skipped)" } else msgsfx <- "(in model %d)" names(warningList)[wi] <- paste(conditionMessage(cond), gettextf(msgsfx, queued[[i]]$id)) attr(warningList[[wi]], "id") <- queued[[i]]$id } withoutProblems <- which(!haveProblems) qrows <- lapply(qresult[withoutProblems], "[[", "value") qresultLen <- length(qrows) rvlen <- nrow(rval) if(retNeedsExtending <- k + qresultLen > rvlen) { nadd <- min(max(resultChunkSize, qresultLen), ncomb - rvlen) rval <- rbind(rval, matrix(NA_real_, ncol = rvNcol, nrow = nadd), deparse.level = 0L) addi <- seq.int(rvlen + 1L, length.out = nadd) coefTables[addi] <- vector("list", nadd) calls[addi] <- vector("list", nadd) ord[addi] <- integer(nadd) } qseqOK <- seq_len(qresultLen) for(m in qseqOK) rval[k + m, retColIdx] <- qrows[[m]] ord[k + qseqOK] <- vapply(queued[withoutProblems], "[[", 1L, "id") calls[k + qseqOK] <- lapply(queued[withoutProblems], "[[", "call") coefTables[k + qseqOK] <- lapply(qresult[withoutProblems], "[[", "coefTable") k <- k + qresultLen qi <- 0L } } ### for (iComb ...) if(k == 0L) { if(length(warningList)) print.warnings(warningList) stop("the result is empty") } names(calls) <- ord if(!evaluate) return(calls[seq_len(k)]) if(k < nrow(rval)) { i <- seq_len(k) rval <- rval[i, , drop = FALSE] ord <- ord[i] calls <- calls[i] coefTables <- coefTables[i] } if(nVarying) { varlev <- ord %% nVariants varlev[varlev == 0L] <- nVariants rval[, nVars + seq_len(nVarying)] <- variants[varlev, ] } rval <- as.data.frame(rval, stringsAsFactors = TRUE) row.names(rval) <- ord # Convert columns with presence/absence of terms to factors tfac <- which(!(allTerms %in% gmCoefNames)) rval[tfac] <- lapply(rval[tfac], factor, levels = NaN, labels = "+") i <- seq_along(allTerms) v <- order(termsOrder) rval[, i] <- rval[, v] allTerms <- allTerms[v] colnames(rval) <- c(allTerms, varyingNames, extraNames, "df", lik$name, ICName) if(nVarying) { variant.names <- vapply(variantsFlat, asChar, "", width.cutoff = 20L) vnum <- split(seq_len(sum(vlen)), rep(seq_len(nVarying), vlen)) names(vnum) <- varyingNames for (i in varyingNames) rval[, i] <- factor(rval[, i], levels = vnum[[i]], labels = variant.names[vnum[[i]]]) } rval <- rval[o <- order(rval[, ICName], decreasing = FALSE), ] coefTables <- coefTables[o] rval$delta <- rval[, ICName] - min(rval[, ICName]) rval$weight <- Weights(rval$delta) mode(rval$df) <- "integer" rval <- structure(rval, model.calls = calls[o], global = global.model, global.call = gmCall, terms = structure(allTerms, interceptLabel = interceptLabel), rank = IC, beta = strbeta, call = { cl <- match.call(expand.dots = TRUE) cl[[1L]] <- as.symbol("dredge") cl }, coefTables = coefTables, nobs = gmNobs, vCols = varyingNames, ## XXX: remove column.types = { colTypes <- c(terms = length(allTerms), varying = length(varyingNames), extra = length(extraNames), df = 1L, loglik = 1L, ic = 1L, delta = 1L, weight = 1L) column.types <- rep(1L:length(colTypes), colTypes) names(column.types) <- colnames(rval) lv <- 1L:length(colTypes) factor(column.types, levels = lv, labels = names(colTypes)[lv]) }, class = c("model.selection", "data.frame") ) if(length(warningList)) { class(warningList) <- c("warnings", "list") attr(rval, "warnings") <- warningList } if (!is.null(attr(allTerms0, "random.terms"))) attr(rval, "random.terms") <- attr(allTerms0, "random.terms") if(doParallel) clusterCall(cluster, "rm", list = c(".pdredge_process_model", "pdredge_props"), envir = .GlobalEnv) return(rval) } ###### `pdredge_process_model` <- function(modv, envir = get("pdredge_props", .GlobalEnv)) { ### modv == list(call = clVariant, id = modelId) result <- tryCatchWE(eval(modv$call, get("gmEnv", envir))) if (inherits(result$value, "condition")) return(result) fit1 <- result$value if(get("nExtra", envir) != 0L) { extraResult1 <- get("applyExtras", envir)(fit1) nExtra <- get("nExtra", envir) if(length(extraResult1) < nExtra) { tmp <- rep(NA_real_, nExtra) tmp[match(names(extraResult1), get("extraResultNames", envir))] <- extraResult1 extraResult1 <- tmp } } else extraResult1 <- NULL ll <- .getLik(fit1)$logLik(fit1) mcoef <- eval(get("matchCoefCall", envir)) list(value = c(mcoef, extraResult1, df = attr(ll, "df"), ll = ll, ic = get("IC", envir)(fit1)), nobs = nobs(fit1), coefTable = attr(mcoef, "coefTable"), warnings = result$warnings) } .test_pdredge <- function(dd) { cl <- attr(dd, "call") cl$cluster <- cl$check <- NULL cl[[1L]] <- as.name("dredge") if(!identical(c(dd), c(eval(cl)))) stop("Whoops...") dd } MuMIn/R/model.avg.R0000644000176200001440000002503615161443462013453 0ustar liggesusers`model.avg` <- function (object, ..., revised.var = TRUE) { if (isTRUE("method" %in% names(match.call()))) stop("argument 'method' is defunct") UseMethod("model.avg") } .coefarr.avg <- function(cfarr, weight, revised.var, full, alpha) { weight <- weight / sum(weight) nCoef <- dim(cfarr)[3L] if(full) { nas <- is.na(cfarr[, 1L, ]) & is.na(cfarr[, 2L, ]) cfarr[, 1L, ][nas] <- cfarr[, 2L, ][nas] <- 0 #cfarr[, 1L:2L, ][is.na(cfarr[, 1L:2L, ])] <- 0 if(!all(is.na(cfarr[, 3L, ]))) cfarr[ ,3L, ][is.na(cfarr[ , 3L, ])] <- Inf } avgcoef <- array(dim = c(nCoef, 5L), dimnames = list(dimnames(cfarr)[[3L]], c("Estimate", "Std. Error", "Adjusted SE", "Lower CI", "Upper CI"))) for(i in seq_len(nCoef)) avgcoef[i, ] <- par.avg(cfarr[, 1L, i], cfarr[, 2L, i], weight, df = cfarr[, 3L, i], alpha = alpha, revised.var = revised.var) avgcoef[is.nan(avgcoef)] <- NA return(avgcoef) } `model.avg.model.selection` <- function(object, subset, fit = FALSE, ..., revised.var = TRUE) { if(!missing(subset)) { cl <- match.call() cl[[1L]] <- as.name("subset") names(cl)[2L] <- "x" object <- eval.parent(cl[1L:3L]) } # TODO: unify refitting conditions in model.avg and model.sel if(fit || !missing(...)) { cl <- match.call() cl$fit <- NULL arg1 <- names(cl)[-(1L:2L)] %in% names(formals("model.avg.default")) cl1 <- cl[c(TRUE, TRUE, !arg1)] cl1[[1L]] <- as.name("get.models") if(is.null(cl1[["subset"]])) cl1[["subset"]] <- NA # TODO: subset = TRUE cl2 <- cl[c(TRUE, TRUE, arg1)] cl2[[2L]] <- cl1 cl2[[1L]] <- as.name("model.avg") #message("Re-fitting model objects...") return(eval(cl2, parent.frame())) } if(nrow(object) <= 1L) stop("'object' consists of only one model") ct <- attr(object, "coefTables") cfarr <- coefArray(ct) weight <- Weights(object) cfmat <- as.matrix(cfarr[, 1L, ]) cfmat[is.na(cfmat)]<- 0 coefMat <- array(dim = c(2L, ncol(cfmat)), dimnames = list(c("full", "subset"), dimnames(cfarr)[[3L]])) coefMat[1L, ] <- drop(weight %*% cfmat) coefMat[2L, ] <- coefMat[1L, ] / colSums(array(weight * as.numeric(!is.na(cfarr[, 1L, ])), dim = dim(cfmat))) coefMat[is.nan(coefMat)] <- NA_real_ #allterms1 <- lapply(attr(object, "calls"), function(x) #getAllTerms(as.formula(x[[switch(as.character(x[[1L]]), #lme=, lme.formula= "fixed", gls= "model", "formula")]]))) all.terms <- attr(object, "terms") # TERMS all.vterms <- all.terms[!(all.terms %in% attr(all.terms, "interceptLabel") | apply(is.na(object[, all.terms, drop = FALSE]), 2L, all))] #allterms1 <- apply(!is.na(object[, all.vterms, drop = FALSE]), 1L, function(x) all.vterms[x]) allterms1 <- applyrns(!is.na(object[, all.vterms, drop = FALSE]), function(x) all.vterms[x]) allmodelnames <- .modelNames(allTerms = allterms1, uqTerms = all.vterms) mstab <- itemByType(object, c("df", "loglik", "ic", "delta", "weight")) rownames(mstab) <- allmodelnames .Debug(.Generic <- "model.avg") ret <- list( msTable = structure(as.data.frame(mstab, stringsAsFactors = TRUE), term.codes = attr(allmodelnames, "variables")), coefficients = coefMat, coefArray = cfarr, sw = sw(object), x = NULL, residuals = NULL, formula = if(!is.null(attr(object, "global"))) formula(attr(object, "global")) else NULL, call = { cl <- match.call() cl[[1L]] <- as.name(.Generic) cl } ) attr(ret, "rank") <- attr(object, "rank") if(is.null(attr(object, "modelList"))) { attr(ret, "model.calls") <- attr(object, "model.calls") attr(ret, "interceptLabel") <- attr(attr(object, "terms"), "interceptLabel") } else { attr(ret, "modelList") <- attr(object, "modelList") } attr(ret, "beta") <- attr(object, "beta") attr(ret, "nobs") <- attr(object, "nobs") attr(ret, "revised.var") <- revised.var class(ret) <- "averaging" return(ret) } `model.avg.default` <- function(object, ..., beta = c("none", "sd", "partial.sd"), rank = NULL, rank.args = NULL, revised.var = TRUE, dispersion = NULL, ct.args = NULL) { if (is.object(object)) { models <- list(object, ...) rank <- .getRank(rank, rank.args = rank.args, object = object) } else { if(length(object) == 0L) stop("'object' is an empty list") models <- object object <- object[[1L]] if (!is.null(rank) || is.null(rank <- attr(models, "rank"))) { rank <- .getRank(rank, rank.args = rank.args, object = object) } } strbeta <- betaMode <- NULL eval(.expr_beta_arg) nModels <- length(models) if(nModels == 1L) stop("only one model supplied. Nothing to do") checkIsModelDataIdentical(models) testSmoothKConsistency(models) # for gam, if any ICname <- asChar(.getRankCall(rank)[[1L]]) allterms1 <- lapply(models, getAllTerms) all.terms <- unique(unlist(allterms1, use.names = FALSE)) # sort by level (main effects first) all.terms <- all.terms[order(vapply(gregexpr(":", all.terms), function(x) if(x[1L] == -1L) 0L else length(x), 1L), all.terms)] # allmodelnames <- modelNames(models, asNumeric = FALSE, # withRandomTerms = FALSE, withFamily = FALSE) allmodelnames <- .modelNames(allTerms = allterms1, uqTerms = all.terms) #if(is.null(names(models))) names(models) <- allmodelnames coefTableCall <- if(betaMode == 2L) call("std.coef", as.symbol("m"), partial.sd = TRUE) else call("coefTable", as.symbol("m")) if(!is.null(dispersion)) coefTableCall[['dispersion']] <- as.symbol("d") for(a in names(ct.args)) coefTableCall[[a]] <- ct.args[[a]] .DebugPrint(coefTableCall) # NOTE: first argument in coefTableCall is "m" and "d" for dispersion coefTables <- mapply(function(m, d) { rval <- eval(coefTableCall) rownames(rval) <- fixCoefNames(rownames(rval)) rval }, m = models, d = if(is.null(dispersion)) NA else dispersion, SIMPLIFY = FALSE) #coefTables <- vector(nModels, mode = "list") # # NOTE: first argument in coefTableCall is "models[[i]]" # for(i in seq_len(nModels)) { # coefTables[[i]] <- eval(coefTableCall) # rownames(coefTables[[i]]) <- fixCoefNames(rownames(coefTables[[i]])) # } # check if models are unique: mcoeffs <- lapply(coefTables, "[", , 1L) dup <- unique(sapply(mcoeffs, function(i) which(sapply(mcoeffs, identical, i)))) dup <- dup[sapply(dup, length) > 1L] if (length(dup) > 0L) stop("models are not unique. Duplicates: ", prettyEnumStr(sapply(dup, paste0, collapse = " = "), quote = "'")) LL <- .getLik(object) logLik <- LL$logLik lLName <- LL$name ic <- vapply(models, rank, 0) logLiks <- lapply(models, logLik) delta <- ic - min(ic) weight <- exp(-delta / 2) / sum(exp(-delta / 2)) model.order <- order(weight, decreasing = TRUE) # ----!!! From now on, everything MUST BE ORDERED by 'weight' !!!----------- mstab <- cbind(df = vapply(logLiks, attr, 0, "df"), logLik = as.numeric(logLiks), IC = ic, delta = delta, weight = weight, deparse.level = 0L) if(!is.null(dispersion)) mstab <- cbind(mstab, Dispersion = dispersion) rownames(mstab) <- allmodelnames mstab <- mstab[model.order, ] weight <- mstab[, "weight"] # has been sorted in table models <- models[model.order] coefTables <- coefTables[model.order] if (betaMode == 1L) { response.sd <- sd(model.response(model.frame(object))) coefTables <- mapply(function(m, ct) { X <- model.matrix(m) ct[, 1L:2L] <- ct[, 1L:2L] * apply(X[, match(rownames(ct), colnames(X)), drop = FALSE], 2L, sd) / response.sd }, models, coefTables, SIMPLIFY = FALSE) } cfarr <- coefArray(coefTables) cfmat <- array(cfarr[, 1L, ], dim = dim(cfarr)[-2L], dimnames = dimnames(cfarr)[-2L]) cfmat[is.na(cfmat)]<- 0 coefMat <- array(NA_real_, dim = c(2L, ncol(cfmat)), dimnames = list(c("full", "subset"), colnames(cfmat))) coefMat[1L, ] <- drop(weight %*% cfmat) coefMat[2L, ] <- coefMat[1L, ] / colSums(array(weight * as.numeric(!is.na(cfarr[, 1L, ])), dim = dim(cfmat))) coefMat[is.nan(coefMat)] <- NA_real_ names(all.terms) <- seq_along(all.terms) colnames(mstab)[3L] <- ICname # Benchmark: 3.7x faster #system.time(for(i in 1:10000) t(array(unlist(p), dim=c(length(all.terms),length(models))))) #system.time(for(i in 1:10000) do.call("rbind", p)) vpresent <- do.call("rbind", lapply(models, function(x) all.terms %in% getAllTerms(x))) if(all(dim(vpresent) > 0L)) { sw <- apply(weight * vpresent, 2L, sum) names(sw) <- all.terms o <- order(sw, decreasing = TRUE) sw <- sw[o] attr(sw, "n.models") <- structure(colSums(vpresent)[o], names = all.terms) class(sw) <- c("sw", "numeric") } else { sw <- structure(integer(0L), n.models = integer(0L), class = c("sw", "numeric")) } mmxs <- tryCatch(cbindDataFrameList(lapply(models, model.matrix)), error = return_null, warning = return_null) # Far less efficient: #mmxs <- lapply(models, model.matrix) #mx <- mmxs[[1]]; #for (i in mmxs[-1]) # mx <- cbind(mx, i[,!(colnames(i) %in% colnames(mx)), drop=FALSE]) # residuals averaged (with brute force) #rsd <- tryCatch(apply(vapply(models, residuals, residuals(object)), 1L, #weighted.mean, w = weight), error = return_null) #rsd <- NULL ## XXX: how to calc residuals ? modelClasses <- lapply(models, class) frm <- if(all(vapply(modelClasses[-1L], identical, FALSE, modelClasses[[1L]]))) { trm <- tryCatch(terms(models[[1L]]), error = function(e) terms(formula(models[[1L]]))) response <- attr(trm, "response") m1 <- models[[1L]] makeArgs(m1, all.terms, opt = list( response = if(response > 0L) attr(trm, "variables")[[response + 1L]] else NULL, gmFormulaEnv = environment(formula(m1)), intercept = ! identical(unique(unlist(lapply(allterms1, attr, "intercept"))), 0), interceptLabel = unique(unlist(lapply(allterms1, attr, "interceptLabel"))), # random = attr(allTerms0, "random"), gmCall = get_call(m1), gmEnv = parent.frame(), allTerms = all.terms, random = . ~ . ))[[1L]] } else NA .Debug(.Generic <- "model.avg") ret <- list( msTable = structure(as.data.frame(mstab, stringsAsFactors = TRUE), term.codes = attr(allmodelnames, "variables")), coefficients = coefMat, coefArray = cfarr, sw = sw, x = mmxs, residuals = NULL, # no residuals, as they can be calculated in several ways formula = frm, call = { cl <- match.call() cl[[1L]] <- as.name(.Generic) cl } ) attr(ret, "rank") <- rank attr(ret, "modelList") <- models attr(ret, "beta") <- strbeta attr(ret, "nobs") <- nobs(object) attr(ret, "revised.var") <- revised.var class(ret) <- "averaging" return(ret) } .checkFull <- function(object, full, warn = TRUE) { if(isTRUE(attr(object, "arm")) && !full) { if(warn) cry(-1L, "'subset' averaged coefficients are not available with ARM algorithm", warn = TRUE) return(TRUE) } else return(full) } MuMIn/R/std.coef.R0000644000176200001440000000314615161443462013302 0ustar liggesusers`beta.weights` <- function(model) { .Deprecated("std.coef") std.coef(model, FALSE) } .vif <- function(x) { v <- .vcov(x) nam <- dimnames(v)[[1L]] if(dim(v)[1L] < 2L) return(structure(rep_len(1, dim(v)[1L]), names = dimnames(v)[[1L]])) if ((ndef <- sum(is.na(coef(x)))) > 0L) stop(sprintf(ngettext(ndef, "one coefficient is not defined", "%d coefficients are not defined"), ndef)) o <- attr(model.matrix(x), "assign") if (any(int <-(o == 0))) { v <- v[!int, !int, drop = FALSE] } else warning("no intercept: VIFs may not be sensible") d <- sqrt(diag(v)) rval <- numeric(length(nam)) names(rval) <- nam rval[!int] <- diag(solve(v / (d %o% d))) rval[int] <- 1 rval } .partialsd <- function(x, sd, vif, n, p = length(x) - 1) { sd * sqrt(1 / vif) * sqrt((n - 1) / (n - p)) } partial.sd <- function(x) { b <- coef(x) mm <- model.matrix(x) mm <- mm[, match(names(b), colnames(mm)), drop = FALSE] colnames(mm) <- names(b) m <- ncol(mm) .partialsd(b, apply(mm, 2L, sd), .vif(x), nobs(x), sum(attr(mm, "assign") != 0)) } `std.coef` <- function(x, partial.sd, ...) { #b <- coefTable(x, ...)[, 1L:2L, drop = FALSE] b <- coefTable(x, ...) mm <- model.matrix(x) mm <- mm[, match(rownames(b), colnames(mm)), drop = FALSE] colnames(mm) <- names(b) #b <- b[colnames(mm), ] if(partial.sd) { bx <- .partialsd(b[, 1L], apply(mm, 2L, sd), .vif(x), nobs(x), sum(attr(mm, "assign") != 0)) } else { response.sd <- sd(model.response(model.frame(x))) bx <- apply(mm, 2L, sd) / response.sd } b[, 1L:2L] <- b[, 1L:2L] * bx colnames(b)[1L:2L] <- c("Estimate*", "Std. Error*") return(b) } MuMIn/R/modelspecs.R0000644000176200001440000004776415161443462013751 0ustar liggesusers.modelspecs <- list(`` = structure(list(model = "mean", item.name = NA_character_, formula.arg = "formula"), row.names = c(NA, -1L), class = c("model.specs", "data.frame"), object.info = c(package = "", func = "", className = "")), betareg = structure(list(model = c("mean", "dispersion"), item.name = c("mean", "precision"), formula.arg = c("formula1", "formula2")), row.names = c(NA, -2L), class = c("model.specs", "data.frame"), object.info = c(package = "betareg", func = "betareg", className = "betareg")), gamlss = structure(list(model = c("mean", "dispersion", "power", "tau"), item.name = c("mu", "sigma", "nu", "tau"), formula.arg = c("formula", "sigma.formula", "nu.formula", "tau.formula")), row.names = c(NA, -4L), class = c("model.specs", "data.frame"), object.info = c(package = "gamlss", func = "gamlss", className = "gamlss")), glmmTMB = structure(list(model = c("mean", "zeroinfl", "dispersion"), item.name = c("cond", "zi", "disp" ), formula.arg = c("formula", "ziformula", "dispformula")), row.names = c(NA, -3L), class = c("model.specs", "data.frame"), object.info = c(package = "glmmTMB", func = "glmmTMB", className = "glmmTMB")), glmerMod = structure(list( model = "mean", item.name = NA_character_, formula.arg = "formula"), row.names = c(NA, -1L), class = c("model.specs", "data.frame"), object.info = c(package = "lme4", func = "glmer", className = "glmerMod")), lmerMod = structure(list( model = "mean", item.name = NA_character_, formula.arg = "formula"), row.names = c(NA, -1L), class = c("model.specs", "data.frame"), object.info = c(package = "lme4", func = "lmer", className = "lmerMod")), gls = structure(list( model = "mean", item.name = NA_character_, formula.arg = "model"), row.names = c(NA, -1L), class = c("model.specs", "data.frame"), object.info = c(package = "nlme", func = "gls", className = "gls")), lme = structure(list(model = "mean", item.name = NA_character_, formula.arg = "fixed,random"), row.names = c(NA, -1L), class = c("model.specs", "data.frame"), object.info = c(package = "nlme", func = "lme", className = "lme")), nlme = structure(list(model = "mean", item.name = NA_character_, formula.arg = "model,fixed,random"), row.names = c(NA, -1L), class = c("model.specs", "data.frame"), object.info = c(package = "nlme", func = "nlme", className = "nlme")), hurdle = structure(list( model = c("mean", "zeroinfl"), item.name = c("count", "zero" ), formula.arg = c("formula1", "formula2")), row.names = c(NA, -2L), class = c("model.specs", "data.frame"), object.info = c(package = "pscl", func = "hurdle", className = "hurdle")), zeroinfl = structure(list( model = c("mean", "zeroinfl"), item.name = c("count", "zero" ), formula.arg = c("formula1", "formula2")), row.names = c(NA, -2L), class = c("model.specs", "data.frame"), object.info = c(package = "pscl", func = "zeroinfl", className = "zeroinfl")), lm = structure(list( model = "mean", item.name = NA_character_, formula.arg = "formula"), row.names = c(NA, -1L), class = c("model.specs", "data.frame"), object.info = c(package = "stats", func = "lm", className = "lm")), unmarked = list(unmarkedFitColExt = list( colext = structure(list(model = c("initial occupancy", "colonization", "extinction", "detection"), item.name = c("psi", "col", "ext", "det"), formula.arg = c("psiformula", "gammaformula", "epsilonformula", "pformula"), name = c("Initial", "Colonization", "Extinction", "Detection"), short.name = c("psi", "col", "ext", "p"), formlist.name = c("psi", "col", "ext", "det"), data = structure(c(1L, 2L, 2L, 3L), levels = c("site", "site+year", "site+year+obs"), class = "factor")), row.names = c(NA, -4L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "colext", className = "unmarkedFitColExt", fitType = "colext" ))), unmarkedFitDS = list(distsamp = structure(list(model = c("abundance", "detection", "scale"), item.name = c("state", "det", "scale"), formula.arg = c("formula2", "formula1", NA), name = c("Abundance|Density", "Detection", "Hazard-rate(scale)"), short.name = c("lam", "p", "p"), formlist.name = c("state", "det", NA), data = structure(c(1L, 2L, NA), levels = c("site", "site+obs"), class = "factor")), row.names = c(NA, -3L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "distsamp", className = "unmarkedFitDS", fitType = "distsamp" ))), unmarkedFitDSO = list(distsampOpen = structure(list(model = c("abundance", "recruitment", "recruitment", "growth", "growth", "growth", "survival", "carrying capacity", "detection", "immigration", "scale", "dispersion", "zeroinfl"), item.name = c("lambda", "gamma", "gamma", "gamma", "gamma", "gamma", "omega", "omega", "det", "iota", "scale", "alpha", "psi"), formula.arg = c("lambdaformula", "gammaformula", "gammaformula", "gammaformula", "gammaformula", "gammaformula", "omegaformula", "omegaformula", "pformula", "iotaformula", NA, NA, NA), name = c("Abundance", "Recruitment", "Recruitment", "Growth Rate", "Growth Rate", "Growth Rate", "Apparent Survival", "Carrying Capacity", "Detection", "Immigration", "Hazard-rate(scale)", "Dispersion", "Zero-inflation"), short.name = c("lam", "gamConst", "gamAR", "gamTrend", "gamRicker", "gamGomp", "omega", "omCarCap", "sigma", "iota", "scale", "alpha", "psi"), formlist.name = c("lambda", "gamma", "gamma", "gamma", "gamma", "gamma", "omega", "omega", "det", "iota", NA, NA, NA), data = structure(c(1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, NA, NA, NA), levels = c("site", "site+year" ), class = "factor")), row.names = c(NA, -13L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "distsampOpen", className = "unmarkedFitDSO", fitType = "distsampOpen")), multmixOpen = structure(list( model = c("recruitment", "recruitment", "growth", "growth", "growth"), item.name = c("gamma", "gamma", "gamma", "gamma", "gamma"), formula.arg = c("gammaformula", "gammaformula", "gammaformula", "gammaformula", "gammaformula"), name = c("Recruitment", "Recruitment", "Growth Rate", "Growth Rate", "Growth Rate" ), short.name = c("gamConst", "gamAR", "gamTrend", "gamRicker", "gamGomp"), formlist.name = c("gamma", "gamma", "gamma", "gamma", "gamma"), data = structure(c(1L, 1L, 1L, 1L, 1L), levels = "site+year", class = "factor")), row.names = c(NA, -5L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "multmixOpen", className = "unmarkedFitDSO", fitType = "multmixOpen" ))), unmarkedFitGDR = list(gdistremoval = structure(list(model = c("abundance", "dispersion", "availability", "distance", "scale", "removal"), item.name = c("lambda", "alpha", "phi", "dist", "scale", "rem"), formula.arg = c("lambdaformula", NA, "phiformula", "distanceformula", NA, "removalformula"), name = c("Abundance", "Dispersion", "Availability", "Distance", "Hazard-rate (scale)", "Removal"), short.name = c("lambda", "alpha", "phi", "dist", "scale", "rem"), formlist.name = c("lambda", NA, "phi", "dist", NA, "rem"), data = structure(c(1L, NA, 2L, 2L, NA, 3L), levels = c("site", "site+year", "site+year+obs"), class = "factor")), row.names = c(NA, -6L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "gdistremoval", className = "unmarkedFitGDR", fitType = "gdistremoval" ))), unmarkedFitGDS = list(gdistsamp = structure(list(model = c("abundance", "availability", "detection", "scale", "dispersion", "zeroinfl" ), item.name = c("lambda", "phi", "det", "scale", "alpha", "psi" ), formula.arg = c("lambdaformula", "phiformula", "pformula", NA, NA, NA), name = c("Abundance", "Availability", "Detection", "Hazard-rate(scale)", "Dispersion", "Zero-inflation"), short.name = c("lambda", "phi", "p", "scale", "alpha", "psi"), formlist.name = c("lambda", "phi", "det", NA, NA, NA), data = structure(c(1L, 2L, 3L, NA, NA, NA), levels = c("site", "site+year", "site+year+obs"), class = "factor")), row.names = c(NA, -6L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "gdistsamp", className = "unmarkedFitGDS", fitType = "gdistsamp" ))), unmarkedFitGMM = list(gmn = structure(list(model = c("abundance", "availability", "detection", "dispersion", "zeroinfl"), item.name = c("lambda", "phi", "det", "alpha", "psi"), formula.arg = c("lambdaformula", "phiformula", "pformula", NA, NA), name = c("Abundance", "Availability", "Detection", "Dispersion", "Zero-inflation"), short.name = c("lambda", "phi", "p", "alpha", "psi"), formlist.name = c("lambda", "phi", "det", NA, NA), data = structure(c(1L, 2L, 3L, NA, NA), levels = c("site", "site+year", "site+year+obs"), class = "factor")), row.names = c(NA, -5L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "gmultmix", className = "unmarkedFitGMM", fitType = "gmn" ))), unmarkedFitGOccu = list(goccu = structure(list(model = c("occupancy", "availability", "detection"), item.name = c("psi", "phi", "det" ), formula.arg = c("psiformula", "phiformula", "pformula"), name = c("Occupancy", "Availability", "Detection"), short.name = c("psi", "phi", "p" ), formlist.name = c("psi", "phi", "det"), data = structure(1:3, levels = c("site", "site+year", "site+year+obs"), class = "factor")), row.names = c(NA, -3L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "goccu", className = "unmarkedFitGOccu", fitType = "goccu" ))), unmarkedFitGPC = list(gpcount = structure(list(model = c("abundance", "availability", "detection", "dispersion", "zeroinfl"), item.name = c("lambda", "phi", "det", "alpha", "psi"), formula.arg = c("lambdaformula", "phiformula", "pformula", NA, NA), name = c("Abundance", "Availability", "Detection", "Dispersion", "Zero-inflation"), short.name = c("lambda", "phi", "p", "alpha", "psi"), formlist.name = c("lambda", "phi", "det", NA, NA), data = structure(c(1L, 2L, 3L, NA, NA), levels = c("site", "site+year", "site+year+obs"), class = "factor")), row.names = c(NA, -5L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "gpcount", className = "unmarkedFitGPC", fitType = "gpcount" ))), unmarkedFitMMO = list(multmixOpen = structure(list(model = c("abundance", "survival", "carrying capacity", "detection", "immigration", "dispersion", "zeroinfl"), item.name = c("lambda", "omega", "omega", "det", "iota", "alpha", "psi"), formula.arg = c("lambdaformula", "omegaformula", "omegaformula", "pformula", "iotaformula", NA, NA), name = c("Abundance", "Apparent Survival", "Carrying Capacity", "Detection", "Immigration", "Dispersion", "Zero-inflation"), short.name = c("lam", "omega", "omCarCap", "p", "iota", "alpha", "psi"), formlist.name = c("lambda", "omega", "omega", "det", "iota", NA, NA), data = structure(c(1L, 2L, 2L, 3L, 2L, NA, NA), levels = c("site", "site+year", "site+year+obs"), class = "factor")), row.names = c(NA, -7L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "multmixOpen", className = "unmarkedFitMMO", fitType = "multmixOpen" ))), unmarkedFitMPois = list(multinomPois = structure(list(model = c("abundance", "detection"), item.name = c("state", "det"), formula.arg = c("formula2", "formula1"), name = c("Abundance", "Detection"), short.name = c("lambda", "p"), formlist.name = c("state", "det"), data = structure(1:2, levels = c("site", "site+obs"), class = "factor")), row.names = c(NA, -2L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "multinomPois", className = "unmarkedFitMPois", fitType = "multinomPois"))), unmarkedFitNmixTTD = list(nmixTTD = structure(list(model = c("abundance", "detection", "dispersion", "shape"), item.name = c("state", "det", "alpha", "shape"), formula.arg = c("stateformula", "detformula", NA, NA), name = c("Abundance", "Detection", "Dispersion", "Weibull shape"), short.name = c("lamN", "lamP", "alpha", "k"), formlist.name = c("state", "det", NA, NA), data = structure(c(1L, 2L, NA, NA), levels = c("site", "site+year+obs"), class = "factor")), row.names = c(NA, -4L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "nmixTTD", className = "unmarkedFitNmixTTD", fitType = "nmixTTD" ))), unmarkedFitOccu = list(occu = structure(list(model = c("occupancy", "detection"), item.name = c("state", "det"), formula.arg = c("formula2", "formula1"), name = c("Occupancy", "Detection"), short.name = c("psi", "p"), formlist.name = c("state", "det"), data = structure(1:2, levels = c("site", "site+obs"), class = "factor")), row.names = c(NA, -2L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "occu", className = "unmarkedFitOccu", fitType = "occu"))), unmarkedFitOccuCOP = list( occuCOP = structure(list(model = c("occupancy", "detection rate" ), item.name = c("psi", "lambda"), formula.arg = c("psiformula", "lambdaformula"), name = c("Occupancy probability", "Detection rate" ), short.name = c("psi", "lambda"), formlist.name = c("psi", "lambda"), data = structure(1:2, levels = c("site", "site+obs" ), class = "factor")), row.names = c(NA, -2L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "occuCOP", className = "unmarkedFitOccuCOP", fitType = "occuCOP" ))), unmarkedFitOccuFP = list(occuFP = structure(list( model = c("occupancy", "detection", "false positive", "certainity"), item.name = c("state", "det", "fp", "b" ), formula.arg = c("stateformula", "detformula", "Fpformula", "Bformula"), name = c("Occupancy", "Detection", "false positive", "Pcertain"), short.name = c("psi", "p", "fp", "b"), formlist.name = c("state", "det", "fp", "b"), data = structure(c(1L, 2L, 2L, 2L), levels = c("site", "site+obs"), class = "factor")), row.names = c(NA, -4L ), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "occuFP", className = "unmarkedFitOccuFP", fitType = "occuFP" ))), unmarkedFitOccuMS = list(occuMS = structure(list(model = c("occupancy", "initial occupancy", "detection", "transition"), item.name = c("state", "state", "det", "transition"), formula.arg = c("psiformulas", "psiformulas", "phiformulas", "detformulas"), name = c("Occupancy", "Initial Occupancy", "Detection", "Transition Probabilities" ), short.name = c("psi", "psi", "p", "phi"), formlist.name = c("state", "state", "det", "transition"), data = structure(c(1L, 1L, 2L, 2L), levels = c("site", "site+year+obs"), class = "factor")), row.names = c(NA, -4L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "occuMS", className = "unmarkedFitOccuMS", fitType = "occuMS" ))), unmarkedFitOccuMulti = list(occuMulti = structure(list( model = c("occupancy", "detection"), item.name = c("state", "det"), formula.arg = c("stateformulas", "detformulas" ), name = c("Occupancy", "Detection"), short.name = c("psi", "p"), formlist.name = c("state", "det"), data = structure(1:2, levels = c("site", "site+obs"), class = "factor")), row.names = c(NA, -2L ), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "occuMulti", className = "unmarkedFitOccuMulti", fitType = "occuMulti" ))), unmarkedFitOccuPEN = list(occu = structure(list(model = c("occupancy", "detection"), item.name = c("state", "det"), formula.arg = c("formula2", "formula1"), name = c("Occupancy", "Detection"), short.name = c("psi", "p"), formlist.name = c("state", "det"), data = structure(1:2, levels = c("site", "site+obs"), class = "factor")), row.names = c(NA, -2L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "occuPEN", className = "unmarkedFitOccuPEN", fitType = "occu"))), unmarkedFitOccuPEN_CV = list( occu = structure(list(model = c("occupancy", "detection" ), item.name = c("state", "det"), formula.arg = c("formula2", "formula1"), name = c("Occupancy", "Detection"), short.name = c("psi", "p"), formlist.name = c("state", "det"), data = structure(1:2, levels = c("site", "site+obs"), class = "factor")), row.names = c(NA, -2L ), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "occuPEN_CV", className = "unmarkedFitOccuPEN_CV", fitType = "occu"))), unmarkedFitOccuRN = list(occuRN = structure(list( model = c("abundance", "detection"), item.name = c("state", "det"), formula.arg = c("formula2", "formula1"), name = c("Abundance", "Detection"), short.name = c("lam", "p"), formlist.name = c("state", "det"), data = structure(1:2, levels = c("site", "site+obs" ), class = "factor")), row.names = c(NA, -2L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "occuRN", className = "unmarkedFitOccuRN", fitType = "occuRN"))), unmarkedFitOccuTTD = list( occuTTD = structure(list(model = c("occupancy", "detection", "colonization", "extinction", "shape"), item.name = c("psi", "det", "col", "ext", "shape"), formula.arg = c("psiformula", "detformula", "gammaformula", "epsilonformula", NA), name = c("Occupancy", "Detection", "Colonization", "Extinction", "Weibull shape"), short.name = c("psi", "lam", "col", "ext", "k"), formlist.name = c("psi", "det", "col", "ext", NA), data = structure(c(1L, 3L, 2L, 2L, NA), levels = c("site", "site+year", "site+year+obs"), class = "factor")), row.names = c(NA, -5L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "occuTTD", className = "unmarkedFitOccuTTD", fitType = "occuTTD" ))), unmarkedFitPCO = list(pcountOpen = structure(list( model = c("abundance", "recruitment", "recruitment", "growth", "growth", "growth", "survival", "carrying capacity", "detection", "immigration", "dispersion", "zeroinfl"), item.name = c("lambda", "gamma", "gamma", "gamma", "gamma", "gamma", "omega", "omega", "det", "iota", "alpha", "psi" ), formula.arg = c("lambdaformula", "gammaformula", "gammaformula", "gammaformula", "gammaformula", "gammaformula", "omegaformula", "omegaformula", "pformula", "iotaformula", NA, NA), name = c("Abundance", "Recruitment", "Recruitment", "Growth Rate", "Growth Rate", "Growth Rate", "Apparent Survival", "Carrying Capacity", "Detection", "Immigration", "Dispersion", "Zero-inflation" ), short.name = c("lam", "gamConst", "gamAR", "gamTrend", "gamRicker", "gamGomp", "omega", "omCarCap", "p", "iota", "alpha", "psi"), formlist.name = c("lambda", "gamma", "gamma", "gamma", "gamma", "gamma", "omega", "omega", "det", "iota", NA, NA), data = structure(c(1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, NA, NA), levels = c("site", "site+year", "site+year+obs"), class = "factor")), row.names = c(NA, -12L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "pcountOpen", className = "unmarkedFitPCO", fitType = "pcountOpen" ))), unmarkedFitPCount = list(pcount = structure(list(model = c("abundance", "detection", "dispersion", "zeroinfl"), item.name = c("state", "det", "alpha", "psi"), formula.arg = c("formula2", "formula1", NA, NA), name = c("Abundance", "Detection", "Dispersion", "Zero-inflation"), short.name = c("lam", "p", "alpha", "psi" ), formlist.name = c("state", "det", NA, NA), data = structure(c(1L, 2L, NA, NA), levels = c("site", "site+obs"), class = "factor")), row.names = c(NA, -4L), class = c("model.specs", "data.frame"), object.info = c(package = "unmarked", func = "pcount", className = "unmarkedFitPCount", fitType = "pcount" ))))) MuMIn/R/addresponse.R0000644000176200001440000000156515161443462014107 0ustar liggesusers addresponse <- function(x, f, y = getresponse(x), env = parent.frame()) { stopifnot(is.language(f) || (is.numeric(f) && (f == 1 || f == -1 || f == 0))) # 0 or -1 is a valid x stopifnot(is.null(y) || is.language(y)) if(length(f) == 1L || f[[1L]] != "~") { lhs <- f if(is.null(y)) { f <- ~ . f[[2L]] <- lhs } else { f <- . ~ . f[[2L]] <- y f[[3L]] <- lhs } } else { if(!inherits(f, "formula")) oldClass(f) <- "formula" f <- if(is.null(y)) f else { if(length(f) == 2L) f <- f[c(1L, NA, 2L)] f[[2L]] <- y f } } environment(f) <- env f } getresponse <- function(x, f) { tt <- terms(formula(x)) if(attr(tt, "response") == 0L) NULL else attr(tt, "variables")[-1L][[attr(tt, "response")]] } MuMIn/R/progbar.R0000644000176200001440000000114015161443462013221 0ustar liggesusers .progbar <- function(min = 0, max = 1, initial = 0, title = "") local({ if(.Platform$GUI == "Rgui") { pb <- utils::winProgressBar(min = min, max = max,, title = title) setpb <- utils::setWinProgressBar } else { pb <- utils::txtProgressBar(min = min, max = max, style = 3L) setpb <- utils::setTxtProgressBar } function(...) setpb(pb, ...) #function(value) koCmd(sprintf("kor.setProgressBar(%d, %f, %s, %s)", # pb$pb, as.double(value), "''", "''")) }) .closeprogbar <- function(x) close(environment(x)$pb) MuMIn/R/r.squaredGLMM2.R0000644000176200001440000002150215161443462014234 0ustar liggesusers # general function r2glmm <- function(family, varFE, varRE, varResid, link, pmean, lambda, omega, n) { if(inherits(family, "family")) { link <- family$link family <- family$family } if(missing(varResid) || !is.numeric(varResid) || (is.na(varResid) && !is.nan(varResid))) { varResid <- switch(paste(family, link, sep = "."), gaussian.identity = varResid, quasibinomial.logit =, binomial.logit = c( theoretical = 3.28986813369645 / n, delta = 1 / (n * pmean * (1 - pmean)) ), quasibinomial.probit =, binomial.probit = c( theoretical = 1 / n, delta = 6.2831853071795862 / n * pmean * (1 - pmean) * exp((qnorm(pmean) / 1.4142135623730951)^2)^2 ), quasibinomial.cloglog =, binomial.cloglog = c( theoretical = 1.6449340668482264 / n, # pi^2 / 6 delta = pmean / n / log(1 - pmean)^2 / (1 - pmean) ), Gamma.log =, poisson.log =, quasipoisson.log =, nbinom1.log = c( delta = omega / lambda, lognormal = log1p(omega / lambda), trigamma = trigamma(lambda / omega) ), quasipoisson.sqrt =, nbinom1.sqrt =, "poisson.mu^0.5" =, poisson.sqrt = c( delta = 0.25 * omega ), nbinom2.log = { vdelta <- (1 / lambda) + (1 / omega) c( delta = vdelta, lognormal = log1p(vdelta), trigamma = trigamma(1 / vdelta) )}, #Gamma.inverse =, # c( delta = 1 / nu / lambda^2 ), NotImplementedFamily = stop("not implemented yet for ", family, " and ", link), { cry(sys.call(-1L), "do not know how to calculate variance for %s(%s)", family, dQuote(link)) } ) } vtot <- sum(varFE, varRE) matrix(c(varFE, vtot) / (vtot + rep(varResid, each = 2L)), ncol = 2L, byrow = TRUE, dimnames = list(names(varResid), c("R2m", "R2c"))) } `r.squaredGLMM` <- function(object, null, ...) { UseMethod("r.squaredGLMM") } `r.squaredGLMM.merMod` <- function(object, null, envir = parent.frame(), pj2014 = FALSE, ...) { if(is.logical(envir)) { # backwards compatibility tmp <- envir if(!missing(pj2014)) envir <- pj2014 pj2014 <- tmp } fam <- family(object) #varOL <- lambda <- omega <- NA fe <- .numfixef(object) ok <- !is.na(fe) fitted <- (model.matrix(object)[, ok, drop = FALSE] %*% fe[ok])[, 1L] varFE <- var(fitted) mmRE <- .remodmat(object) ##Note: Argument 'contrasts' can only be specified for fixed effects ##contrasts.arg = eval(cl$contrasts, envir = environment(formula(object)))) vc <- .varcorr(object) if(!is.null(vc)) { for(i in seq.int(length(vc))) { a <- fixCoefNames(rownames(vc[[i]])) dimnames(vc[[i]]) <- list(a, a) } colnames(mmRE) <- fixCoefNames(colnames(mmRE)) if(!all(unlist(sapply(vc, rownames), use.names = FALSE) %in% colnames(mmRE))) stop("RE term names do not match those in model matrix. \n", "Have 'options(contrasts)' changed since the model was fitted?") varRE <- .varRESum(vc, mmRE) # == sum(as.numeric(VarCorr(fm))) } else { varRE <- 0 } familyName <- fam$family if(startsWith(familyName, "Negative Binomial(")) familyName <- "nbinom2" if(familyName %in% c("quasipoisson", "poisson", "nbinom1", "nbinom2", "binomial", "quasibinomial")) { if(missing(null) || !is.object(null)) null <- .nullFitRE(object, envir) fixefnull <- unname(.numfixef(null)) } else if(familyName == "Gamma" && fam$link == "inverse") { familyName <- "Gamma.inverse" # directs to "other" family and uses # insight::get_variance_residual } switch(familyName, gaussian = r2glmm(fam, varFE, varRE, varResid = sigma2(object)^2), binomial =, quasibinomial = { vt <- .varRESum(.varcorr(null), mmRE) # XXX: inverse-link seems to give more reasonable value for non-logit # links, should inv-logit (plogis) be used here always? pmean <- fam$linkinv(fixefnull - 0.5 * vt * tanh(fixefnull * (1 + 2 * exp(-0.5 * vt)) / 6)) r2glmm(fam, varFE, varRE, pmean = pmean, n = .binomial.sample.size(object)) }, nbinom2 = { vt <- .varRESum(.varcorr(null), mmRE) lambda <- unname(exp(fixefnull + 0.5 * vt)) theta <- sigma2(object) r2glmm(familyName, varFE, varRE, lambda = lambda, omega = theta, link = fam$link) }, Gamma = { nu <- sigma2(object)^-2 omega <- 1 r2glmm(fam, varFE, varRE, lambda = nu, omega = omega) }, quasipoisson = , nbinom1 = { vt <- .varRESum(.varcorr(null), mmRE) lambda <- unname(exp(fixefnull + 0.5 * vt)) omega <- sigma2(object) r2glmm(fam, varFE, varRE, lambda = lambda, omega = omega) }, poisson = { vt <- .varRESum(.varcorr(null), mmRE) lambda <- unname(exp(fixefnull + 0.5 * vt)) omega <- 1 rval <- r2glmm(fam, varFE, varRE, lambda = lambda, omega = omega) if(inherits(object, "merMod") && familyName == "poisson" && pj2014) { xo <- .OLREFit(object) vc <- .varcorr(xo) fe <- .numfixef(xo) ok <- !is.na(fe) fitted <- (model.matrix(xo)[, ok, drop = FALSE] %*% fe[ok])[, 1L] n <- nrow(mmRE) vname <- names(xo@flist)[sapply(xo@flist, nlevels) == n][1L] if(! vname %in% names(vc)) vname <- make.names(vname) stopifnot(vname %in% names(vc)) ### !!! varresid <- vc[[vname]][1L] rval <- rbind(pj2014 = r2glmm(fam, var(fitted), .varRESum(vc, mmRE) - varresid, varResid = log1p(1 / exp(mean(fitted))) + varresid)[1L, ], rval) } rval }, { varResid <- insight::get_variance_residual(object, ...)[[1L]] if(!is.finite(varResid)) warning("residual variance cannot be calculated.") r2glmm(fam, varFE, varRE, varResid) }) } `r.squaredGLMM.lme` <- function(object, null, ...) r.squaredGLMM.merMod(object, null, ...) `r.squaredGLMM.glmmTMB` <- function(object, null, envir = parent.frame(), ...) { has.components <- vapply(fixef(object), function(x) length(x) != 0L && (length(x) != 1L || names(x)[1L] != "(Intercept)"), logical(1L)) if(any(has.components[c("zi", "disp")])) warning("effects of ", prettyEnumStr(c("zero-inflation", "dispersion model")[ has.components[c("zi", "disp")] ], quote = FALSE), " are ignored") r.squaredGLMM.merMod(object, null, envir, ...) } `r.squaredGLMM.glmmadmb` <- function(object, null, envir = parent.frame(), ...) { if(object$zeroInflation) warning("effects of zero-inflation are ignored") r.squaredGLMM.merMod(object, null, envir, ...) } `r.squaredGLMM.lm` <- function(object, null, envir = parent.frame(), ...) { fam <- family(object) ok <- !is.na(coef(object)) fitted <- (model.matrix(object)[, ok, drop = FALSE] %*% coef(object)[ok])[, 1L] delayedAssign("fixefnull", coef(if(missing(null) || !is.object(null)) .nullFitRE(object, envir) else null)) varFE <- var(fitted) familyName <- fam$family if(substr(familyName, 1L, 17L) == "Negative Binomial") familyName <- "nbinom2" switch(familyName, gaussian = r2glmm(fam, varFE, 0, varResid = sigma2(object)^2), binomial =, quasibinomial = { r2glmm(fam, varFE, 0, pmean = fam$linkinv(unname(fixefnull)), n = .binomial.sample.size(object)) }, Gamma = { nu <- sigma2(object)^-2 omega <- 1 r2glmm(fam, varFE, 0, lambda = nu, omega = omega) }, nbinom2 = { r2glmm(familyName, varFE, 0, lambda = unname(exp(fixefnull)), omega = sigma2(object), link = fam$link) }, quasipoisson = , nbinom1 = { r2glmm(fam, varFE, 0, lambda = unname(exp(fixefnull)), omega = sigma2(object)) }, poisson = { r2glmm(fam, varFE, 0, lambda = unname(exp(fixefnull)), omega = 1) }, r2glmm(fam, varFE, 0)) } # TODO `r.squaredGLMM.glmmML` <- function(object, null, ...) { .NotYetImplemented() } `r.squaredGLMM.cplm` <- function(object, null, envir = parent.frame(), ...) { fam <- family(object) if(!fam$link %in% c("mu^0", "log")) stop("not implemented yet for ", fam$family, " and ", fam$link) fe <- .numfixef(object) ok <- !is.na(fe) fitted <- (model.matrix(object)[, ok, drop = FALSE] %*% fe[ok])[, 1L] varFE <- var(fitted) if(missing(null) || !is.object(null)) null <- .nullFitRE(object, envir) if(inherits(object, "cpglm")) { varRE <- vt <- 0 } else { mmRE <- .remodmat(object) varRE <- .varRESum(.varcorr(object), mmRE) # == sum(as.numeric(VarCorr(fm))) vt <- .varRESum(.varcorr(null), mmRE) } mu <- unname(exp(.numfixef(null) + 0.5 * vt)) # the same as getting lambda phi <- object@phi # the dispersion parameter p <- object@p # the index parameter varO <- c(delta = phi * mu^(p - 2), lognormal = log1p(phi * mu^(p - 2))) r2glmm(NA, varFE, varRE, varO) } MuMIn/R/class-unmarkedFit.R0000644000176200001440000001124115161443462015144 0ustar liggesusers `formula.unmarkedFit` <- function (x, ...) { if(.hasSlot(x, "formula")) x@formula else formula.formlist(x@formlist) } umf_terms2formulalist <- function(termNames, opt, replaceInt = "(1)") { i <- termNames %in% opt$interceptLabel termNames[i] <- gsub("(Int)", replaceInt, termNames[i], fixed = TRUE) fexpr <- lapply(termNames, str2lang) nm <- as.character(lapply(fexpr, "[[", 1L)) fsplt <- split(sapply(fexpr, "[[", 2L), nm)[nm[!duplicated(nm)]] farg <- lapply(fsplt, function(z) { if(! 1 %in% z) z <- c(0, z) rval <- z[[1L]] n <- length(z) if(n > 1) for(i in 2L:n) rval <- call("+", rval, z[[i]]) as.formula(call("~", rval), opt$gmFormulaEnv) }) farg[] <- lapply(farg, `environment<-`, opt$gmFormulaEnv) farg } umf.formlist <- function(x, specs = getspecs(x, TRUE), names.item = "model") { specs <- specs[!is.na(specs$formlist.name), ] if(!.hasSlot(x, "formlist")) stop("incompatible 'unmarkedFit' object (possibly created with unmarked version < 1.5.1): 'formlist' element is missing") fl <- x@formlist i <- match(specs$formlist.name, names(fl), nomatch = 0L) if(any(i == 0L)) stop("incompatible 'unmarkedFit' object (possibly created with unmarked version < 1.5.1): unrecognized items in 'formlist'") fl <- fl[i] names(fl) <- specs[[names.item]] fl } getAllTerms.unmarkedFit <- function(x, intercept = FALSE, ...) { formlist <- umf.formlist(x, names.item = "short.name") term.prefix <- names(formlist) allterms <- lapply(formlist, getAllTerms.formula, intercept = FALSE) .add.prefix <- function(pfx, s) paste0(pfx, "(", s, ")") allterms2 <- .mapply(function(ato, pfx, addInt) { if(length(ato) != 0L) ato[] <- .add.prefix(pfx, c(ato)) for(attrname in c("interceptLabel", "offset", "random.terms")) if(!is.null(attr(ato, attrname))) attr(ato, attrname) <- .add.prefix(pfx, attr(ato, attrname)) if(nrow(attr(ato,"deps")) != 0L) dimnames(attr(ato,"deps")) <- rep(list(setdiff(ato[], attr(ato,"offset"))), 2L) if(!is.null(intLab <- attr(ato, "interceptLabel"))) { attr(ato, "interceptLabel") <- intLab <- sub("((Intercept))", "(Int)", intLab, fixed = TRUE) if(addInt) ato[seq_len(length(ato) + length(intLab))] <- append(ato, intLab, after = 0L) } ato }, list(ato = allterms, pfx = term.prefix), MoreArgs = list(addInt = isTRUE(intercept))) n <- length(allterms) rval <- unlist(allterms2) mode(rval) <- "character" # in case of zero-length attrint <- vapply(allterms2, attr, integer(1L), "intercept") names(attrint) <- term.prefix attr(rval, "intercept") <- attrint for(attrname in c("interceptLabel", "random.terms")) attr(rval, attrname) <- unlist(lapply(allterms2, attr, attrname)) if(!is.null(attr(rval, "random.terms"))) { ranef.forms <- lapply(allterms2, attr, "random") names(ranef.forms) <- term.prefix # remove lhs from formulas: attr(rval, "random") <- lapply(ranef.forms[!vapply(ranef.forms, is.null, logical(1L))], "[", -2L) } if(intercept) attr(rval, "interceptIdx") <- which(unlist(sapply(allterms2, function(ato) { rval <- logical(length(ato)) rval[attr(ato, "intercept")] <- TRUE rval }, simplify = FALSE))) attr(rval, "deps") <- termdepmat_combine(lapply(allterms2, attr, "deps")) return(rval) } `makeArgs.unmarkedFit` <- function(obj, termNames, opt, ...) { specs <- getspecs(obj) specs <- specs[!is.na(specs$formula.arg), , drop = FALSE] formulanames <- as.character(specs$formula.arg) single_formula <- all(startsWith(formulanames, "formula")) # NOTE: elements are named after full short.name zarg <- umf_terms2formulalist(termNames, opt) if(!is.null(opt$random)) { for(a in names(opt$random)) zarg[[a]] <- update.formula(zarg[[a]], opt$random[[a]]) } zarg <- zarg[specs$short.name] names(zarg) <- specs$formula.arg if(single_formula) { n <- length(zarg) zarg <- zarg[paste0("formula", seq_len(n))] form <- zarg[[1L]] if(n > 1L) for(i in seq.int(2L, n)) form <- call("~", form, zarg[[i]][[2L]]) form <- as.formula(form, env = environment(zarg[[1L]])) environment(form) <- environment(zarg[[1L]]) list(formula = form) } else { names(zarg) <- formulanames zarg } } umf_vcov <- function(object, method = NA, ...) { method <- if(anyNA(method)) NA else match.arg(method, choices = c("hessian", "nonparboot")) if(is.na(method)) { if(.hasSlot(object, "TMB") && !is.null(object@TMB)) { method <- "TMB" } else if(!is.null(object@opt$hessian)) { method <- "hessian" } else if(!is.null(object@bootstrapSamples)) { method <- "nonparboot" } else return(NULL) } return(vcov(object, method = method, ...)) } MuMIn/R/utils-models.R0000644000176200001440000004513715161443462014224 0ustar liggesusersfixLogLik <- function(ll, object) { if(is.null(attr(ll, "nall")) && is.null(attr(ll, "nobs"))) attr(ll, "nobs") <- nobs(object) ll } `.getLik` <- function(x) { if(isGEE(x)) { list(logLik = quasiLik, name = "qLik") } else { list(logLik = logLik, name = "logLik") } } `.getRank` <- function(rank = "AICc", rank.args = NULL, object = NULL, envir = parent.frame(), ...) { rank.args <- c(rank.args, list(...)) namestr <- NULL # just not to annoy R check isrankfun <- FALSE if(is.null(rank)) { rank <- AICc namestr <- "AICc" } else { isrankfun <- is.function(rank) && ( inherits(rank, "rankFunction") || is.call(environment(rank)$..rankfunctioncall)) if(isrankfun && length(rank.args) == 0L) return(rank) if(is.list(rank) && length(rank) == 1L && is.function(rank[[1L]])) { namestr <- names(rank)[1L] rank <- rank[[1L]] } else { namestr <- substitute(rank, envir) if(namestr == "rank") namestr <- substitute(rank) } } rank <- match.fun(rank) funcname <- switch(mode(namestr), call = as.name("IC"), character = as.name(namestr), name =, namestr) funcargs <- c(list(as.name("x")), rank.args) funccall <- as.call(c(funcname, funcargs)) if(isrankfun) funcenv <- environment(rank) else { funcenv <- new.env(parent = environment(rank)) funcenv$rank <- rank } funcenv$..rankfunctioncall <- funccall wrappedrank <- as.function(c(alist(x = ), as.call(c(list(as.name("rank"), as.name("x")), rank.args)) ), envir = funcenv) if(!is.null(object)) { test <- wrappedrank(object) if (!is.numeric(test) || length(test) != 1L) stop("'rank' should return numeric vector of length 1") } wrappedrank } .getRankCall <- function(rank) { if(exists("..rankfunctioncall", environment(rank), inherits = FALSE, mode = "language")) { return(get("..rankfunctioncall", environment(rank), inherits = FALSE, mode = "language")) # backward compatibility: } else if(is.call(cl <- attr(rank,"call"))) { return(cl) } else return(as.symbol("undetermined criterion")) } # Like `regmatches`, but for captured groups, and simplistic. # Only does results of `regexpr`. .matches <- function (x, m) { cs <- attr(m, "capture.start") cl <- attr(m, "capture.length") rval <- array(NA_character_, dim = dim(cs)) for(i in seq_along(x)) rval[i, ] <- substring(x[i], cs[i, ], cs[i, ] + cl[i, ] - 1L) rval } # sorts alphabetically interaction components in model term names # if 'peel', tries to remove coefficients wrapped into function-like syntax # (this is meant mainly for 'unmarkedFit' models with names such as "psi(a:b:c)") # This unwrapping is done only if ALL names are suitable for it. # FIXME: this function would also "fix" strings like "log(b:a)" (but not # "log(`b:a`)") - but this is unlikely to be a valid model term. `fixCoefNames` <- function(x, peel = TRUE) { if(!length(x)) return(x) ia <- grep(":", x, fixed = TRUE) if(!length(ia)) return(structure(x, order = rep.int(1L, length(x)))) #koBrowseHere() ixi <- x[ia] if(peel) { # peel only when ALL items are prefixed/wrapped # for pscl::hurdle. Cf are prefixed with count_|zero_ if(peel <- all(startsWith(ixi, c("count_", "zero_")))) { pos <- regexpr("_", ixi, fixed = TRUE) peelpfx <- substring(ixi, 1L, pos) peelsfx <- "" ixi <- substring(ixi, pos + 1L) } else { # unmarkedFit with its phi(...), lambda(...) etc... if(peel <- all(grepl("^[a-zA-Z]{2,5}\\(.+\\)$", x, perl = TRUE))) { # only if 'XXX(...)', i.e. exclude 'XXX():YYY()' or such # assumes coefficient types are ascii letters only # and of length >= 2 #m <- regexpr("^([a-zA-Z]{2,5})(([a-zA-Z\\._]{0,5})\\(((?:[^()]*|(?2))*)\\))$", test, perl = TRUE, useBytes = TRUE) m <- regexpr("^([a-zA-Z]{2,5})(([a-zA-Z\\._]*)\\(((?:[^()]*|(?2))*)\\))$", ixi, perl = TRUE, useBytes = TRUE) #m <- regexpr("^(([a-zA-Z]{2,5})\\(((?:[^()]*|(?1))*)\\))$", ixi, perl = TRUE, useBytes = TRUE) cptgrps <- .matches(ixi, m) if(peel <- all(nzchar(cptgrps[, 1L]))) { peelpfx <- paste0(cptgrps[, 1L], "(") peelsfx <- ")" ixi <- cptgrps[, 4L] } } } } # replace {...}, [...], (...), ::, and ::: with placeholders # When using a single RX (with alternating patterns (a|b|c)), sometimes # there is a warning: PCRE error 'match limit exceeded'. # To work this around, the three bracket types are matched sequentially: rxx <- c("\\[[^\\[\\]]*+(?:(?0)[^\\]\\[]*)*+\\]", "\\([^\\(\\)]*+(?:(?0)[^\\)\\(]*)*+\\)", "\\{[^\\{\\}]*+(?:(?0)[^\\}\\{]*)*+\\}", ":::?") xtpl <- ixi for(rx in rxx) { m <- gregexpr(xtpl, pattern = rx, perl = TRUE) regmatches(xtpl, m) <- lapply(m, function(x) { if((ml <- attr(x, "match.length"))[1L] == -1L) return(character(0L)) vapply(ml, function(n) paste0(rep("_", n), collapse = ""), NA_character_) }) } # split by ':' and sort splits <- gregexpr(":", xtpl, fixed = TRUE) ixi <- mapply(function(x, p) { if(p[1L] == -1) return(x) paste0(base::sort(substring(x, c(1L, p + 1L), c(p - 1L, nchar(x)))), collapse = ":") }, ixi, splits, USE.NAMES = FALSE, SIMPLIFY = TRUE) if(peel) ixi <- paste0(peelpfx, ixi, peelsfx) x[ia] <- ixi ord <- rep.int(1L, length(x)) ord[ia] <- vapply(splits, length, 0L) + 1L attr(x, "order") <- ord x } ## like 'strsplit', but ignores split characters within quotes and matched ## parentheses expr.split <- function(x, split = ":", paren.open = c("(", "[", "{"), paren.close = c(")", "]", "}"), quotes = c("\"", "'", "`"), esc = "\\", prepare = NULL) { ## error checking: #if(length(paren.open) != length(paren.close)) # stop("'paren.open' and 'paren.close' are not of the same length") #if(any(test <- vapply(c('paren.open', 'paren.close', 'quotes', 'esc', 'split'), function(x, frame) { # any(nchar(get(x, frame, inherits = FALSE)) != 1L) #}, FALSE, frame = sys.frame()))) { # stop(sprintf(ngettext(sum(test), "argument %s is not single character", # "arguments %s are not single character") , prettyEnumStr(names(test)[test])), # domain = "R-MuMIn") #} x0 <- x if(is.function(prepare)) x <- prepare(x) m <- length(x) n <- nchar(x) res <- vector("list", m) for(k in 1L:m) { pos <- integer(0L) inquote <- ch <- "" inparen <- integer(3L) for(i in seq.int(n[k])) { chprv <- ch ch <- substr(x[k], i, i) if(nzchar(inquote)) { # in quotes if(chprv == esc && ch == esc) ch <- " " else if(chprv != esc && ch == inquote) inquote <- "" } else { inparen[j] <- inparen[j <- (inparen != 0L) & (ch == paren.close)] - 1L if(ch %in% quotes) inquote <- ch else if (any(j <- (ch == paren.open))) inparen[j] <- inparen[j] + 1L else if (all(inparen == 0L) && ch == split) pos <- c(pos, i) } } res[[k]] <- substring(x0[k], c(1L, pos + 1L), c(pos - 1L, n[k])) } res } getResponseFormula <- function(f) { f <- if(!is.null(tf <- attr(f, "terms"))) { formula(tf) } else formula(f) if((length(f) == 2L) || (is.call(f[[2L]]) && f[[2L]][[1L]] == "~")) 0 else f[[2L]] } #Tries to find out whether the models are fitted to the same data checkIsModelDataIdentical <- function(models, error = TRUE) { cl <- sys.call(sys.parent()) err <- if (error) function(x) stop(simpleError(x, cl)) else function(x) warning(simpleWarning(x, cl)) res <- TRUE responses <- lapply(models, function(x) getResponseFormula(formula(x))) if(!all(vapply(responses[-1L], "==", FALSE, responses[[1L]]))) { err("response differs between models") res <- FALSE } # XXX: need to compare deparse'd 'datas' due to ..1 bug(?) in which dotted # arguments (..1 etc) passed by lapply are not "identical" datas <- vapply(lapply(models, function(x) get_call(x)$data), asChar, "") # XXX: when using only 'nobs' - seems to be evaluated first outside of MuMIn # namespace which e.g. gives an error in glmmML - the glmmML::nobs method # is faulty. nresid <- vapply(models, function(x) nobs(x), 1) # , nall=TRUE if(!all(sapply(datas[-1L], identical, datas[[1L]])) || !all(nresid == nresid[[1L]])) { # better than 'nresid[-1L] == nresid[[1L]]' # XXX: na.action checking here err("models are not all fitted to the same data") res <- FALSE } invisible(res) } .checkNaAction <- function(x, cl = get_call(x), naomi = c("na.omit", "na.exclude"), what = "model", envir = parent.frame()) { naact <- NA_character_ msg <- NA_character_ # handles strings, symbols and calls (let's naively assume no one tries to pass # anything else here) .getNAActionString <- function(x) { if(is.symbol(x)) { x <- as.character(x) } else if(is.call(x)) { x <- eval(x, envir) if(is.symbol(x)) x <- as.character(x) } return(x) } # TEST: #.checkNaAction(list(call = as.call(alist(fun, na.action = getOption("na.action", default = na.fail))))) #.checkNaAction(list(call = as.call(alist(fun, na.action = na.fail)))) #.checkNaAction(list(call = as.call(alist(fun, na.action = na.omit)))) if (!is.null(cl$na.action)) { naact <- .getNAActionString(cl$na.action) if (naact %in% naomi) msg <- sprintf("%s uses 'na.action' = \"%s\"", what, naact) } else { naact <- formals(eval(cl[[1L]], envir))$na.action if (missing(naact)) { naact <- getOption("na.action") if(is.function(naact)) { statsNs <- getNamespace("stats") for(i in naomi) if(identical(get(i, envir = statsNs, inherits = FALSE), naact, ignore.environment = TRUE)) { naact <- i break } } naact <- .getNAActionString(naact) if (is.character(naact) && (naact %in% naomi)) msg <- sprintf("%s's 'na.action' argument is not set and options('na.action') is \"%s\"", what, naact) } else if (!is.null(naact)) { naact <- .getNAActionString(naact) if (naact %in% naomi) msg <- sprintf("%s uses the default 'na.action' = \"%s\"", what, naact) } } res <- is.na(msg) attr(res, "na.action") <- naact attr(res, "message") <- msg res } `abbreviateTerms` <- function(x, minlength = 4, minwordlen = 1, capwords = FALSE, deflate = FALSE) { if(!length(x)) return(x) if(deflate) dx <- #gsub("([\\(,]) *\\w+ *= *(~ *(1 *[\\+\\|]?)?)? *", "\\1", x, perl = TRUE) gsub("([,\\(\\[]|^)( *~ *)(1 *([\\|\\+] *)?)?", "\\1", gsub("([\\(,]) *\\w+ *= *", "\\1", x, perl = TRUE), perl = TRUE) else dx <- x #.DebugPrint(x) s <- strsplit(dx, "(?=[\\W_])", perl = TRUE) # remove I(...): s <- lapply(s, function(z) { z <- if((n <- length(z)) > 3L && all(z[c(1L, 2L, n)] == c("I", "(", ")"))) z[3L:(n - 1L)] else z z[z != " "] }) v <- unique(unlist(s, use.names = FALSE)) i <- grep("[[:alpha:]]", v, perl = FALSE) av <- v if(length(i)) { tb <- rbindDataFrameList(lapply(s, function(x) as.data.frame(rbind(c(table(x))), stringsAsFactors = TRUE))) tb[is.na(tb)] <- 0L if(length(v) > length(i)) minlength <- minlength - max(c(0L, apply(tb[, v[-i], drop = FALSE], 1L, "*", nchar(colnames(tb[, v[-i], drop = FALSE]))))) n <- min(minlength / rowSums(tb[, v[i], drop = FALSE])) if(deflate) { repl1 <- c("TRUE" = "T", "FALSE" = "F", "NULL" = "") for(j in seq_along(repl1)) av[av == names(repl1)[j]] <- repl1[j] } av[i] <- abbreviate(av[i], max(n, minwordlen)) if(capwords) av[i] <- paste0(toupper(substring(av[i], 1L, 1L)), tolower(substring(av[i], 2L))) } for(j in seq_along(s)) s[[j]] <- paste(av[match(s[[j]], v)], collapse = "") names(av) <- v structure(unlist(s), names = x, variables = av[i]) } `modelDescr` <- function(models, withModel = FALSE, withFamily = TRUE, withArguments = TRUE, remove.cols = c("formula", "random", "fixed", "model", "data", "family", "cluster", "model.parameters"), remove.pattern = "formula$", ...) { if(withModel) { allTermsList <- lapply(models, function(x) { tt <- getAllTerms(x) rtt <- attr(tt, "random.terms") if(!is.null(rtt)) rtt[i] <- paste0("(", rtt[i <- !grepl("^[a-z]*\\(.+\\)$", rtt)], ")") c(tt, rtt) }) allTerms <- unique(unlist(allTermsList)) abvtt <- abbreviateTerms(allTerms, ...) variables <- attr(abvtt, "variables") abvtt <- gsub("\\(1 \\| (\\S+)(?: %in%.*)?\\)", "(\\1)", abvtt, perl = TRUE) abvtt <- sapply(allTermsList, function(x) paste(abvtt[match(x, allTerms)], collapse = "+")) } else abvtt <- variables <- NULL if(withFamily) { fam <- sapply(models, function(x) tryCatch(unlist(family(x)[c("family", "link")]), error = function(e) character(2L))) f <- fam[1L, ] f[is.na(f)] <- "" #f <- vapply(strsplit(f, "(", fixed = TRUE), "[", "", 1L) #f[f == "Negative Binomial"] <- "negative.binomial" #fam <- cbind(fam, unlist(MASS::negative.binomial(1.345)[c("family", "link")])) f <- sub("(?:\\((.*)\\))?$", "(\\1", f) f <- paste0(f, ifelse(substring(f, nchar(f)) == "(", "", ","), fam[2, ], ")") fam <- f #fam[2L, fam[2L, ] == #vapply(unique(f), #function(x) { #rval <- if(is.na(x)) NA_character_ else formals(get(x))$link[1L] #if(!is.character(rval)) NA_character_ else rval #}, FUN.VALUE = "")[f]] <- NA_character_ #j <- !is.na(fam[2L,]) #fnm <- fam[1L, j] #fnm <- ifelse(substring(fnm, nchar(fnm)) != ")", #paste0(fnm, "("), paste0(substring(fnm, 1, nchar(fnm) - 1), #", ")) #fam[1L, j] <- paste0(fnm, fam[2L, j], ")") } if(withArguments) { cl <- lapply(models, get_call) haveNoCall <- vapply(cl, is.null, FALSE) cl[haveNoCall] <- lapply(cl[haveNoCall], function(x) call("none", formula = NA)) arg <- lapply(cl, function(x) sapply(x[-1L], function(argval) switch(mode(argval), character = , logical = argval, numeric = signif(argval, 3L), asChar(argval)))) arg <- rbindDataFrameList(lapply(lapply(arg, t), as.data.frame)) i <- !(colnames(arg) %in% remove.cols) i[i][grep(remove.pattern[1L], colnames(arg)[i])] <- FALSE arg <- cbind(class = as.factor(sapply(lapply(models, class), "[", 1L)), arg[, i, drop = FALSE]) reml <- rep(NA, length(models)) if(!is.null(arg$method)) { reml <- ((arg$class == "lme" & is.na(arg$method)) | arg$method == "REML") arg$method <- NULL } if(!is.null(arg$REML)) reml <- ifelse(is.na(arg$REML), reml, arg$REML == "TRUE") arg$REML <- as.factor(reml) arg <- as.matrix(arg) arg[is.na(arg) | arg == "NULL"] <- "" arg <- arg[, apply(arg, 2L, function(x) length(unique(x))) != 1L, drop = FALSE] if(ncol(arg)) arg <- gsub("([\"'\\s]+|\\w+ *=)","", arg, perl = TRUE) } ret <- as.data.frame(cbind(model = abvtt, family = if(withFamily) fam else NULL, arg, deparse.level = 0L), stringsAsFactors = TRUE) attr(ret, "variables") <- variables ret } # TODO: add theta # TODO: glmmTMB family # FIXME: family.betareg is not binomial #negbin(theta = .1, link = "log")$getTheta() #ocat(theta=1,link="identity",R=NULL)$getTheta(1) #ziP(theta = 1, link = "identity",b=0) family2char <- function(x, fam = x$family, link = x$link) { if(startsWith(fam, "Negative Binomial")) { theta <- as.numeric(strsplit(fam, "[\\(\\)]")[[1L]][2L]) paste0("negative.binomial", "(", theta, ",", link, ")") } else if (startsWith(fam, "Tweedie(")) { paste0(substr(fam, 1L, nchar(fam) - 1L), ",link=", link, ")") } else { switch(fam, "scaled t" = "scat", "Beta regression" = if("putTheta" %in% names(x)) "betar" else "beta.regression", "zero inflated Poisson" = "ziP", "Cox PH" = "cox.ph", "Ordered Categorical" = "ocat", "Multivariate normal" = "mvn", beta = "beta_family", ) paste0(fam, "(", link, ")") } } `commonCallStr` <- function(models, calls = lapply(models, get_call)) { x <- lapply(calls, as.list) alln <- unique(unlist(lapply(x, names))) uniq <- vector("list", length(alln)) names(uniq) <- alln uniq[[1L]] <- lapply(x, "[[", 1L) for(i in alln[-1]) uniq[[i]] <- lapply(x, "[[", i) uniq <- rapply(uniq, classes = "formula", function(x) { environment(x) <- .GlobalEnv x }, how = "replace") uniq <- lapply(uniq, unique) nu <- sapply(uniq, length) strvarious <- "<*>" rval <- lapply(uniq, '[[', 1L) j <- sapply(rval, inherits, "formula") & nu > 1L for(i in which(j)) { response <- getResponseFormula(rval[[i]]) rval[[i]] <- if(identical(response, 0)) call("~", as.name(sprintf("__%d-rhsform__", nu[i]))) else call("~", getResponseFormula(rval[[i]]), as.name(sprintf("__%d-rhsform__", nu[i]))) } notj <- !j & nu > 1 rval[notj] <- paste0("<", nu[notj], " unique values>") if(nu[1L] > 1) rval[[1L]] <- paste(sapply(uniq[[1L]], asChar), collapse = "|") rval <- paste(deparse(rval[[1L]], control = NULL), "(", paste(names(rval[-1L]), "=", rval[-1L], collapse = ", "), ")", sep = "") rval <- gsub("`__(\\d+)-rhsform__`", "<\\1 unique rhs>", rval, perl = TRUE) rval } updateDeps <- function(expr, deps) { ret <- list() env <- sys.frame(sys.nframe()) expr <- exprapply0(expr, "dc", function(z) { v <- vapply(as.list(z[-1L]), asChar, "") n <- length(v) k <- match(v, colnames(deps)) for(i in 2L:n) deps[k[1L:(i - 1L)], k[i]] <- TRUE assign("deps", deps, envir = env, inherits = FALSE) TRUE }) list(deps = deps, expr = expr) } # tests if smooth terms for variables in gam/gamm models have the same 'k' testSmoothKConsistency <- function(models) { # method 2: guess from coefficient names: if(inherits(models, "model.selection")) { x <- lapply(attr(models, "coefTables"), rownames) # XXX: add label 'te(x1,x2)' res <- unlist(unname(lapply(x, function(x) { s <- grep("^(s|t[ei2])\\(.+\\)\\.\\d+$", x, perl = TRUE) if(length(s) != 0L) { m <- regexpr("^(?:s|t[ei2])\\((.+)\\)\\.\\d+$", x[s], perl = TRUE) cst <- attr(m, "capture.start")[, 1L] y <- substring(x[s], cst, cst + attr(m, "capture.length")[, 1L] - 1L) tapply(y, y, length) } else NULL })), recursive = FALSE) names(res) <- sapply(lapply(expr.split(names(res), ","), sort), paste0, collapse = ",") } else { # use information stored in gam objects: .getSmoothK <- function(x) { if(inherits(x, "gamm") || (is.list(x) && (length(x) >= 2L) && identical(names(x)[2L], "gam"))) { x <- x[[2L]] } else if(!inherits(x, "gam")) return(NULL) n <- length(x$smooth) rval <- vector("list", n) nmv <- character(n) for(i in seq_len(n)) { y <- x$smooth[[i]] if(is.null(y$margin)) { nmv[i] <- y$term rval[[i]] <- y$bs.dim } else { nm1 <- vapply(y$margin, `[[`, "", "term") o <- order(nm1) nmv[i] <- paste0(nm1[o], collapse = ",") rval[[i]] <- sapply(y$margin, `[[`, "bs.dim")[o] } nmv[i] <- paste0(sub("\\(.*", "", y$label), "(", nmv[i], ")") } names(rval) <- nmv rval } res <- unlist(unname(lapply(models, .getSmoothK)), recursive = FALSE) } if(!is.null(res)) { res <- vapply(split(res, names(res)), function(x) { k1 <- x[[1L]] for(i in 1L:length(x)) if(!identical(x[[i]], k1)) return(TRUE) return(FALSE) }, FALSE) if(any(res)) warning("smooth term dimensions differ between models for variables ", prettyEnumStr(names(res)[res], quote = "'"), ". Related coefficients are incomparable." ) } invisible() } MuMIn/R/coefplot.R0000644000176200001440000001257415161443462013415 0ustar liggesusers coefplot <- function (x, lci, uci, labels = NULL, width = 0.15, shift = 0, horizontal = TRUE, main = NULL, xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL, labAsExpr = TRUE, mar.adj = TRUE, lab.line = 0.5, lty = par("lty"), lwd = par("lwd"), pch = 21, col = par("col"), bg = par("bg"), dotcex = par("cex"), dotcol = col, staplelty = lty, staplelwd = lwd, staplecol = col, zerolty = "dotted", zerolwd = lwd, zerocol = "gray", las = 2, ann = TRUE, axes = TRUE, add = FALSE, type = "p", ...) { do.plot <- !identical(type, "n") horizontal <- as.logical(horizontal)[1L] y <- x x <- seq_len(n <- length(y)) if(is.matrix(lci) && ncol(lci) == 2L) { uci <- lci[, 2L] lci <- lci[, 1L] } if(horizontal) x <- rev(x) add <- isTRUE(add) if(!add) { if(is.null(labels)) labels <- names(y) if(labAsExpr) labels <- .lab2expr(labels) mai <- par("mai") } if(...length() != 0L) { op2 <- par(...) on.exit(par(op2), add = TRUE) } inset <- max(.33, (width + abs(shift)) * 1.05) if(isTRUE(horizontal)) { if(!add) { if(mar.adj && las %in% c(1, 2)) { mai[2L] <- max(mai[2L], grconvertX(.5 + lab.line, from = "lines", to = "inches") + strwidth(labels, cex = par("cex.axis"), units = "inches")) } if(is.null(xlim)) xlim <- range(c(lci, uci)) if(is.null(ylim)) ylim <- c(1 - inset, length(x) + inset) } zl <- c(NA, 0) ly0 <- ly1 <- x + shift lx0 <- lci lx1 <- uci wy0 <- x + shift - width wy1 <- x + shift + width wx0 <- wx1 <- c(lci, uci) py <- x + shift px <- y axn <- c(1L, 2L) } else { # vertical if(!add) { if(mar.adj && las == 2) { mai[1L] <- max(mai[1L], grconvertY(.5 + lab.line, from = "lines", to = "inches") + strwidth(labels, cex = par("cex.axis"), units = "inches")) } if(is.null(ylim)) ylim <- range(c(lci, uci)) if(is.null(xlim)) xlim <- c(1 - inset, length(x) + inset) } zl <- c(0, NA) lx0 <- lx1 <- x + shift ly0 <- lci ly1 <- uci wx0 <- x + shift - width wx1 <- x + shift + width wy0 <- wy1 <- c(lci, uci) px <- x + shift py <- y axn <- c(2L, 1L) } # horizontal #on.exit(par(op), add = TRUE) if(!add) { #op <- par(mai = mai) plot.new() plot.window(xlim, ylim) if(!is.na(zerolty[1L])) abline(h = zl[1L], v = zl[2L], lty = zerolty, col = zerocol, lwd = zerolwd) title(main, xlab = xlab, ylab = ylab) } if(do.plot) { segments(lx0, ly0, lx1, ly1, col = col, lty = lty, lwd = lwd, lend = 1L) if(width > 0) segments(wx0, wy0, wx1, wy1, col = staplecol, lty = staplelty, lwd = staplelwd) points(px, py, pch = pch, cex = dotcex, col = dotcol, bg = bg) } if(!add && isTRUE(axes)) { axis(axn[1L]) axis(axn[2L], at = x, labels = labels, tick = 0, las = las, mgp = c(3, lab.line, 0)) box() } invisible(cbind(px, py, lx0, ly0, lx1, ly1)) } plot.averaging <- function(x, full = TRUE, level = 0.95, intercept = TRUE, parm = NULL, labels = NULL, width = 0.1, shift = max(.2, width * 2.1 + .05), horizontal = TRUE, xlim = NULL, ylim = NULL, main = "Model-averaged coefficients", xlab = NULL, ylab = NULL, add = FALSE, ...) { full <- as.logical(full[1L]) if(is.na(full)) full <- c(TRUE, FALSE) horizontal <- as.logical(horizontal)[1L] coeftypes <- c("full", "subset")[2L - full] if(!isTRUE(as.logical(add))) { lab <- substitute(lab %+-% level * `%` ~ CI, list(lab = sprintf("%s average ", prettyEnumStr(coeftypes)), level = round(level * 100, 1))) if(horizontal && missing(xlab)) xlab <- lab if(!horizontal && missing(ylab)) ylab <- lab } beta <- x$coefficients if(is.null(parm)) { parm <- if(isFALSE(intercept)) { interceptLabel <- if(!is.null(attr(x, "modelList"))) { unique(unlist(lapply(attr(x, "modelList"), function(m) attr(getAllTerms(m), "interceptLabel")))) } else if(!is.null(attr(x, "interceptLabel"))) attr(x, "interceptLabel") which(! colnames(beta) %in% interceptLabel) } else seq.int(ncol(beta)) } else if(isFALSE(intercept)) warning("argument 'intercept' ignored, since 'parm' is given") beta <- beta[, parm, drop = FALSE] lim <- numeric(0L) val <- vector("list", n <- length(full)) for(i in seq.int(n)) { ci <- confint(x, full = full[i], level = level, parm = parm) lim <- range(lim, ci, finite = TRUE) val[[i]] <- list(x = beta[2L - full[i], ], lci = ci) } xlim <- if(horizontal && is.null(xlim)) lim else xlim ylim <- if(!horizontal && is.null(ylim)) lim else ylim np <- sum(pn <- sapply(val, function(a) length(a$x))) fi <- rep(2 - full, pn) pi <- split(1L:np, rep(seq(length(pn)), pn)) gparnm <- c("lty", "lwd", "pch", "col", "bg", "dotcex", "dotcol", "staplelty", "staplelwd", "staplecol", "zerolty", "zerolwd", "zerocol") dots <- list(...) gpar <- dots[gpi <- names(dots) %in% gparnm] dots <- dots[!gpi] if(is.null(gpar$bg)) gpar$bg <- c("black", "white")[fi] if(is.null(gpar$pch)) gpar$pch <- 22L gpar <- as.data.frame(lapply(gpar, rep, length.out = np), stringsAsFactors = FALSE) off <- ((1:n) - ((n + 1) / 2)) * shift rval <- vector("list", n) names(rval) <- coeftypes for(i in seq.int(n)) { rval[[i]] <- do.call("coefplot", c(val[[i]], list(labels = labels, horizontal = horizontal, width = width, shift = off[i], add = add || i != 1L, xlab = xlab, ylab = ylab, main = main, xlim = xlim, ylim = ylim), gpar[pi[[i]], , drop = FALSE], dots)) } invisible(if(n == 1L) rval[[1L]] else rval) } MuMIn/R/DIC.R0000644000176200001440000000152315161443462012171 0ustar liggesusers`DIC` <- function (object, ...) { if (!missing(...)) { lls <- sapply(list(object, ...), function(x) { c(extractDIC(x), attr(logLik(x), "df")) }) val <- data.frame(df = lls[2L, ], DIC = lls[1L, ]) Call <- match.call() row.names(val) <- make.unique(as.character(Call[-1L])) val } else extractDIC(object) } if(!exists("extractDIC", mode = "function")) { extractDIC <- function (fit, ...) UseMethod("extractDIC") } ## from package 'arm' `extractDIC.merMod` <- function (fit, ...) { dev <- deviance(fit, REML = isREML(fit)) devML <- deviance(fit, REML = FALSE) as.vector(2 * devML - dev) } `extractDIC.MCMCglmm` <- function (fit, ...) fit$DIC `extractDIC.lme` <- function (fit, ...) { ll <- as.vector(logLik(fit, REML = fit$method == "REML")) llML <- as.vector(logLik(fit, REML = FALSE)) 2 * ll - 4 * llML } MuMIn/R/model.sel.R0000644000176200001440000001620615161443462013460 0ustar liggesusers#TODO: checking if models are fitted to the same dataset <- model.avg `model.sel` <- function (object, ...) UseMethod("model.sel") `model.sel.averaging` <- function (object, rank = attr(object, "rank"), rank.args = NULL, ..., beta = c("none", "sd", "partial.sd"), extra) { model.sel(get.models(object, NA), rank = rank, rank.args = rank.args, ..., beta = beta, extra) } `model.sel.model.selection` <- function (object, rank = NULL, rank.args = NULL, fit = NA, ..., beta = c("none", "sd", "partial.sd"), extra) { strbeta <- betaMode <- NULL eval(.expr_beta_arg) reFit <- !missing(extra) || (strbeta != attr(object, "beta")) if(!is.null(rank.args) && !identical(fit, FALSE)) reFit <- TRUE if(!isTRUE(fit) && !is.null(rank)) { rank <- .getRank(rank, rank.args = rank.args) ic <- tryCatch(sapply(logLik(object), rank), error = identity) if(inherits(ic, "error") || !is.numeric(ic)) { #message("'rank' cannot be applied to 'logLik' object. Re-fitting model objects.") reFit <- TRUE } } #else rank <- .getRank(attr(object, "rank")) # XXX: sometimes the message is shown but no refitting is needed or done. if(reFit && !isTRUE(fit)) { if(anyNA(fit)) message("Re-fitting models...") else stop("cannot proceed without re-fitting models ('fit' is FALSE)") } if(isTRUE(fit) || reFit) { #message("to compute 'extras' or beta-weights, need to re-fit model objects.") cl <- match.call() ss <- if(is.null(cl$subset)) TRUE else cl$subset models <- do.call("get.models", list(object, subset = ss), envir = parent.frame()) cl$subset <- NULL cl$object <- models rval <- do.call("model.sel", as.list(cl), envir = parent.frame()) } else if(!is.null(rank)) { newRankName <- as.character(.getRankCall(rank)[[1L]]) message(gettextf("New rank '%s' applied to logLik objects", newRankName)) k <- type2col(object, "ic") attr(object, "names")[k] <- names(attr(object, "column.types"))[k] <- newRankName itemByType(object, "ic") <- ic itemByType(object, "delta") <- ic - min(ic, na.rm = TRUE) itemByType(object, "weight") <- Weights(ic) rval <- object[order(ic), ] attr(rval, "rank") <- rank } else rval <- object return(rval) } `model.sel.default` <- function(object, ..., rank = NULL, rank.args = NULL, beta = c("none", "sd", "partial.sd"), extra) { .makemnames <- function(cl) { cl[c("rank", "rank.args", "beta", "extra")] <- NULL unlist(.makeListNames(cl[-1L])) } strbeta <- betaMode <- NULL eval(.expr_beta_arg) if (missing(object) && length(models <- list(...)) > 0L) { object <- models[[1L]] names(models) <- .makemnames(sys.call()) } else if (is.list(object) && !is.object(object)) { if(length(object) == 0L) stop("at least one model must be given") models <- object object <- models[[1L]] names(models) <- unlist(.makeListNames(models)) } else { models <- list(object, ...) if(length(models) > 1L) { names(models) <- .makemnames(sys.call()) } else { names(models)[1L] <- unlist(.makeListNames(list(substitute(object)))) } } if(length(models) == 0L) stop("at least one model must be given") checkIsModelDataIdentical(models, FALSE) if(is.null(names(models)) || anyNA(names(models))) names(models) <- seq_along(models) names(models) <- make.unique(names(models), sep = "") if(is.null(rank) && !missing(rank.args)) warning("'rank.args' ignored with no 'rank' given") rank <- .getRank(rank, rank.args = rank.args, object = object) ICname <- asChar(.getRankCall(rank)[[1L]]) allTermsList <- lapply(models, getAllTerms, intercept = TRUE) random.terms <- lapply(allTermsList, attr, "random.terms") all.terms <- unique(unlist(allTermsList, use.names = FALSE)) lapply(models, function(fit) { if(any(dup <- duplicated(cfn <- names(coeffs(fit))))) cry(-2L, "models cannot have duplicated coefficient names: %s", prettyEnumStr(cfn[dup])) }) all.coef <- fixCoefNames(unique(unlist(lapply(lapply(models, coeffs), names), use.names = FALSE))) ## TODO: case when models belong to different classes using logLik or qLik ## - give error LL <- .getLik(models[[1L]]) logLik <- LL$logLik lLName <- LL$name j <- !(all.terms %in% all.coef) #d <- as.data.frame(t(sapply(models, matchCoef, all.terms = all.terms))) coefTables <- lapply(models, matchCoef, all.terms = all.terms, allCoef = TRUE, beta = betaMode) d <- as.data.frame(do.call("rbind", coefTables)) coefTables <- lapply(coefTables, attr, "coefTable") d[,j] <- lapply(d[,j, drop = FALSE], function(x) factor(is.nan(x), levels = TRUE, labels = "+")) rval <- vapply(models, function(x) { ll <- logLik(x) ic <- tryCatch(rank(x), error = function(e) e) if(inherits(ic, "error")) { ic$call <- sys.call(sys.nframe() - 4L) ic$message <- gettextf("evaluating 'rank' failed with message: %s", ic$message) stop(ic) } c(attr(ll, "df"), ll, ic) }, structure(double(3L), names = c("df", lLName, ICname))) rval <- as.data.frame(t(rval), stringsAsFactors = TRUE) rval <- cbind(d, rval) o <- order(rval[, ICname], decreasing = FALSE) rval[, "delta"] <- rval[, ICname] - rval[o[1L], ICname] rval[, "weight"] <- Weights(rval[, ICname]) mode(rval[, "df"]) <- "integer" descrf <- modelDescr(models) descrf$model <- NULL if(nlevels(descrf$family) == 1L) descrf$family <- NULL if(ncol(descrf)) { i <- seq_len(length(all.terms)) rval <- cbind(rval[, i, drop = FALSE], descrf, rval[, -i, drop = FALSE], deparse.level = 0L) } if(!missing(extra) && length(extra) != 0L) { extra <- eval.parent(call(".get.extras", substitute(extra), r2nullfit = NULL)) res <- lapply(models, .applyExtras, extra = extra) extraResultNames <- unique(unlist(lapply(res, names))) nextra <- length(extraResultNames) i <- seq_len(length(all.terms)) rval <- cbind(rval[, i, drop = FALSE], do.call("rbind", lapply(res, function(x) { if(length(x) < nextra) { tmp <- rep(NA_real_, nextra) tmp[match(names(x), extraResultNames)] <- x tmp } else x })), rval[, -i, drop = FALSE]) } else { nextra <- 0L extra <- NULL } row.names(rval) <- names(models) rval <- structure( rval[o, , drop = FALSE], # TERMS terms = structure(all.terms, interceptLabel = unique(unlist(lapply(allTermsList, attr, "interceptLabel")))), model.calls = lapply(models, get_call)[o], model.family = lapply(models, function(x) tryCatch(family(x), error = function(e) NULL)), modelList = models[o], order = o, rank = rank, beta = strbeta, call = match.call(), nobs = nobs(models[[1L]]), coefTables = coefTables[o], vCols = colnames(descrf), column.types = { colTypes <- c(terms = length(all.terms), varying = ncol(descrf), extra = nextra, df = 1L, loglik = 1L, ic = 1L, delta = 1L, weight = 1L) column.types <- rep(1L:length(colTypes), colTypes) names(column.types) <- colnames(rval) lv <- 1L:length(colTypes) factor(column.types, levels = lv, labels = names(colTypes)[lv]) }, extra = extra, class = c("model.selection", "data.frame") ) if(!("class" %in% colnames(rval))) attr(rval, "model.class") <- class(models[[1L]])[1L] if (!all(sapply(random.terms, is.null))) attr(rval, "random.terms") <- random.terms[o] rval } MuMIn/R/class-gamm.R0000644000176200001440000000073715161443462013624 0ustar liggesusers# gamm/gamm4 support `update.gamm` <- function(object, ...) { # or, if call is as attribute: object$call <- attr(object, "call") update.default(object, ...) } `print.gamm` <- function(x, ...) { cat("\nCall:\n", paste(asChar(x$call, nlines = -1L), sep = "\n", collapse = "\n"), "\n\n", sep = "") cat("--- \n") print(x[[if(inherits(x, "gamm4")) "mer" else "lme"]]) cat("--- \n") print(x$gam) invisible(x) } `formula.gamm` <- function (x, ...) formula(x$gam, ...)MuMIn/R/extras.R0000644000176200001440000000076715161443462013111 0ustar liggesuserspredict.averaging.multinom <- function(object, ..., predict = function(model) as.matrix(predict(model, type = "prob", ...)) ) { models <- get.models(object, TRUE) pp <- lapply(models, predict, ...) pa <- array(dim = c(length(pp), dim(pp[[1L]]))) for(i in seq_along(models)) pa[i, , ] <- pp[[i]] # model-averaged predicted class probabilities: pavg <- apply(pa, c(2L, 3L), weighted.mean, weights = Weights(object)) models[[1L]]$lev[max.col(pavg)] }MuMIn/R/weights-bg.R0000644000176200001440000001025715161443462013636 0ustar liggesusers # TODO: common framework for glm.fit loops # TODO: pass data in formula environment BGWeights <- function(object, ..., data, force.update = FALSE) { models <- getModelArgs() M <- length(models) if(M < 2) stop("need more than one model") checkIsModelDataIdentical(models) no <- nrow(data) k <- sample.int(no, floor(no / 2)) dat_train <- data[k, ] dat_test <- data[-k, ] # TODO: allow user to specify offset and weights offset <- rep(0, no) weights <- rep(1, no) weights_train <- weights[k] weights_test <- weights[-k] offset_train <- offset[k] offset_test <- offset[-k] if(!force.update && all(vapply(models, inherits, FALSE, "glm"))) { # XXX: what about lm # XXX: here 'offset_train' DOES include offset specified in 'formula' py_test <- array(dim = c(nrow(dat_test), M)) for(i in seq.int(length(models))) { fit <- models[[i]] tf <- terms(fit) fit_train <- update_glm_fit(fit, dat_train, weights_train, offset_train) py_test[, i] <- predict_glm_fit(fit_train$coefficients, model.matrix(tf, dat_test), offset = offset_test, family = family(fit))[, 1L] } } else { # for non-glm models, use update (2x slower) if(any(!vapply(models, function(x) is.null(get_call(x)$offset), FALSE))) stop("use of 'offset' argument in model calls is not allowed. ", "Specify 'offset' term in the formula instead") # NOTE: better to update in `parent.frame` because of possible masking # of the variables in model's call by variables defined in this # function. For example: ## fm <- glm(y ~ X1, data = Cement) ## (function(x) { ## Cement <- NA ## update(x) # Error ## })(fm) ## Even better is to provide all variables in environment(formula) ## and rename the formula variables pf <- parent.frame() z_data <- tmpvarname(pf) z_weights <- tmpvarname(pf) assign(z_data, dat_train, pf) assign(z_weights, weights_train, pf) on.exit(rm(list = c(z_data, z_weights), envir = pf, inherits = FALSE)) nz_data <- as.name(z_data) nz_weights <- as.name(z_weights) # XXX: here 'offset_train' DOES NOT include offset specified in 'formula' py_test <- array(dim = c(nrow(dat_test), M)) for(i in seq.int(M)) { cl <- get_call(models[[i]]) cl$data <- nz_data cl$weights <- nz_weights #print(cl) py_test[, i] <- predict(eval(cl, pf), newdata = dat_test, type = "response") # XXX: weird behaviour of predict when offset= is given. # prediction always has length of the offset. a bug in predict.glm? #offset = `*tmp_dat*`[[3L]]), } # NOTE: No speed gain with *apply - more memory needed to store train_fits ## train_fits <- lapply(models, function(x) update(x, data = `*tmp_dat`[[1L]], weights = `*tmp_dat`[[2L]], offset = `*tmp_dat`[[3L]])) ## py_test <- vapply(train_fits, predict, numeric(nrow(dat_test)), newdata = dat_test, type = "response") } y_test <- get.response(models[[1L]], data = dat_test) if(is.matrix(y_test)) y_test <- y_test[, 1L] / rowSums(y_test) # binomial Sigma <- cov(y_test - py_test) # XXX: I want do avoid dependency on MASS #ginv <- if(use.MASS) getFrom("MASS", "ginv") else solve ones <- rep(1, M) #fn1 <- function(ones, Sigma, ginv) ginv(t(ones) %*% ginv(Sigma) %*% ones) %*% ones %*% ginv(Sigma) fn1 <- function(ones, Sigma, ginv) ginv(crossprod(ones, ginv(Sigma)) %*% ones) %*% ones %*% ginv(Sigma) rval <- tryCatch(fn1(ones, Sigma, solve), error = function(e) { if(length(find.package("MASS", quiet = TRUE)) == 1L) fn1(ones, Sigma, getFrom("MASS", "ginv")) else stop(e) })[1L, ] structure(rval, wt.type = "Bates-Granger", names = names(models), class = c("model.weights", class(rval))) } MuMIn/R/simulateData.R0000644000176200001440000000245015161443462014207 0ustar liggesusers.simulateData <- function(n = 10, k = 2, family = gaussian, beta = runif(k), intercept = TRUE, gamma.shape = 1, gaussian.sd = 1, binomial.n = 1, ...) { if(missing(k) && !missing(beta)) k <- length(beta) if (is.character(family)) family <- get(family, mode = "function", envir = parent.frame()) if (is.function(family)) family <- family() nv <- k - if(intercept) 1L else 0L tmp <- numeric(k) tmp[] <- beta beta <- tmp vs <- seq.int(nv) dat <- matrix(ncol = nv, nrow = n) if(k > 1) { colnames(dat) <- sprintf("X%d", vs) for(i in vs) dat[, i] <- runif(n, min = 0, max = 1) } eta <- ((if(intercept) cbind(1, dat, deparse.level = 0L) else dat) %*% beta)[, 1L] mu <- family$linkinv(eta) # y <- switch(family$family, gaussian = rnorm(n, mean = mu, sd = gaussian.sd), binomial = { if(is.function(binomial.n)) binomial.n <- binomial.n(length(mu)) binomial.n <- rep(binomial.n, length.out = length(mu)) y <- rbinom(n, size = binomial.n, mu) if(all(binomial.n == 1)) y else cbind(y, binomial.n - y, deparse.level = 0) }, poisson = rpois(n, lambda = mu), Gamma = rgamma(n, rate = gamma.shape / mu, shape = gamma.shape), stop("'family' not recognized") ) dat <- cbind(y = NA, as.data.frame(dat, stringsAsFactors = TRUE)) dat$y <- y dat }MuMIn/R/is.R0000644000176200001440000000054615161443462012211 0ustar liggesusers.isREMLFit <- isREML <- function (x) { if (inherits(x, "merMod")) return(lme4::isREML(x)) if (inherits(x, c("lme", "gls", "gam")) && is.character(x$method)) return(x$method[1L] %in% c("lme.REML", "REML")) return(FALSE) } isGEE <- function(object) inherits(object, c("geeglm", "geese", "gee", "geem", "wgee", "yagsResult")) MuMIn/R/predict.averaging.R0000644000176200001440000000746215161443462015176 0ustar liggesusers `predict.averaging` <- function(object, newdata = NULL, se.fit = FALSE, interval = NULL, type = NA, backtransform = FALSE, full = TRUE, ...) { ## XXX: backward compatibility: full <- .checkFull(object, full) if (!missing(interval)) .NotYetUsed("interval", error = FALSE) if(backtransform && !is.na(type) && type == "response") warning("back-transforming predictions already on response scale") models <- attr(object, "modelList") if(is.null(models)) stop("can predict only from 'averaging' object containing model list") if(is.null(names(models))) names(models) <- seq.int(length(models)) # If all models inherit from lm: if ( (missing(se.fit) || !se.fit) && (is.na(type) || type == "link") && !backtransform && all(linherits(models, c(gam = FALSE, lm = TRUE))) && !anyNA(object$coefficients[1L, ]) ) { coeff <- coef(object, full = full) X <- model.matrix(object) if (missing(newdata) || is.null(newdata)) { Xnew <- X } else { tt <- delete.response(terms(formula(object))) xlev <- unlist(unname(lapply(models, "[[", "xlevels")), recursive = FALSE, use.names = TRUE) Xnew <- model.matrix(tt, data = newdata, xlev = xlev) } colnames(Xnew) <- fixCoefNames(colnames(Xnew)) Xnew <- Xnew[, match(names(coeff), colnames(Xnew), nomatch = 0L)] ret <- (Xnew %*% coeff)[, 1L] #if (se.fit) { # scale <- 1 # covmx <- solve(t(X) %*% X) # se <- sqrt(diag(Xnew %*% covmx %*% t(Xnew))) * sqrt(scale) ## TODO: use matmult # return(list(fit = y, se.fit = se)) #} } else { # otherwise, use brute force: if(isFALSE(full)) warning("argument 'full' ignored") cl <- as.list(match.call()) cl$backtransform <- cl$full <- NULL cl[[1L]] <- as.name("predict") cl <- as.call(cl) pred <- lapply(models, function(x, pfr) { cl[[2L]] <- x y <- tryCatch({ y <- eval(cl, pfr) if(is.numeric(y)) y else structure(as.list(y[c(1L, 2L)]), names = c("fit", "se.fit")) }, error = function(e) e) }, pfr = parent.frame()) err <- sapply(pred, inherits, "condition") if (any(err)) { lapply(pred[err], warning) stop(sprintf(ngettext(sum(err), "'predict' for model %s caused error", "'predict' for models %s caused errors"), prettyEnumStr(names(models[err]), quote = "'") )) } .untransform <- function(fit, se.fit = NULL, models) { links <- tryCatch(vapply(models, function(m) family(m)[["link"]], ""), error = function(e) NULL) if (!is.null(links)) { if(any(links[1L] != links[-1L])) cry(-1L, "cannot inverse-transform averaged prediction of models using different link functions") fam1 <- family(models[[1L]]) if(is.null(se.fit)) return(fam1$linkinv(fit)) else return(list(fit = fam1$linkinv(fit), se.fit = se.fit * abs(fam1$mu.eta(fit)) )) } return(NULL) } if (all(sapply(pred, is.list))) { #if(all(sapply(pred, function(x) c("fit", "se.fit") %in% names(x)))) { fit <- do.call("cbind", lapply(pred, "[[", "fit")) se.fit <- do.call("cbind", lapply(pred, "[[", "se.fit")) revised.var <- attr(object, "revised.var") apred <- unname(vapply(seq(nrow(fit)), function(i) par.avg(fit[i, ], se.fit[i, ], weight = Weights(object), df = NA_integer_, revised.var = revised.var), FUN.VALUE = double(5L))) # TODO: ase! #no.ase <- all(is.na(object$coefTable[,3])) # if(no.ase) 2 else 3 ret <- if (backtransform) .untransform(apred[1L, ], apred[2L, ], models = models) else list(fit = apred[1L, ], se.fit = apred[2L, ]) } else { #tryCatch({ i <- !vapply(pred, is.numeric, FALSE) if(any(i)) pred[i] <- lapply(pred[i], "[[", 1L) ret <- apply(do.call("cbind", pred), 1L, weighted.mean, w = Weights(object)) if (backtransform) ret <- .untransform(ret, models = models) } } return(ret) } MuMIn/R/get.response.R0000644000176200001440000000220715161443462014206 0ustar liggesusers get.response <- function(x, data = NULL, ...) UseMethod("get.response") get.response.formula <- function(x, data = NULL, ...) { x <- terms(x) if(!inherits(attr(data, "terms"), "terms")) data <- model.frame(x, data = data, ...) data[, asChar(attr(x, "variables")[[attr(x, "response") + 1L]])] } get.response.lm <- function(x, data = NULL, ...) { if(missing(data) && (family(x)$family != "binomial") && !is.null(x$y)) x$y else #get.response.default(x, data = data, ...) NextMethod() } # NOTE: for 'binomial' 'y' is a vector not nmatrix2 get.response.averaging <- function(x, data = NULL, ...) { if(is.null(attr(x, "modelList"))) stop("'x' has no model list") get.response(attr(x, "modelList")[[1L]], data = data, ...) } get.response.default <- function(x, data = NULL, ...) { if(is.null(data)) { # model frame: if(is.data.frame(x) && !is.null(tf <- attr(x, "terms"))) { tf <- terms(x) return(x[, asChar(attr(tf, "variables")[[attr(tf, "response") + 1L]])]) } else data <- model.frame(x) } #model.frame(x)[, asChar(getResponseFormula(x))] if(is.null(data)) data <- model.frame(x) get.response(terms(x), data = data, ...) } MuMIn/R/updateable.R0000644000176200001440000000421515161443462013701 0ustar liggesusers`updateable` <- function (FUN, eval.args = NULL, Class) { FUN <- match.fun(FUN) env <- environment(FUN) if(!isNamespace(env) && all(c("Class", "eval.args", "FUN", "FUNV") %in% names(env))) { warning("it looks that 'FUN' is already a result of 'updateable'. Using the original function instead") FUN <- env[['FUN']] } rm(env, inherits = FALSE) FUNV <- function() { parentframe <- parent.frame() rval <- do.call(FUN, as.list(match.call())[-1L], envir = parentframe) cl <- match.call() for (i in eval.args) cl[[i]] <- eval(cl[[i]], parentframe) if (!isS4(rval) && is.list(rval)) rval$call <- cl else attr(rval, "call") <- cl class(rval) <- Class rval } .hasname <- function(body., name.) vapply(body., function(expr) any(name. %in% all.vars(expr)), FALSE) body(FUNV) <- body(FUNV)[!.hasname(body(FUNV), c(if (missing(eval.args)) "eval.args", if (missing(Class)) "Class"))] #body(FUNV)[c(if (missing(eval.args)) c(4L, 5L), if (missing(Class)) 7L)] <- NULL formals(FUNV) <- formals(FUN) FUNV } `get_call` <- function(x) { rval <- if(isS4(x)) { if(any(i <- (sln <- c("call", "CALL", "Call")) %in% methods::slotNames(x))) slot(x, sln[i][1L]) else if(!is.null(attr(x, "call"))) attr(x, "call") else NULL } else { if(!is.atomic(x) && (i <- match("call", names(x), nomatch = 0L)) != 0L) { x[[i]] } else if(!is.null(attr(x, "call"))) { attr(x, "call") } else NULL } if(is.null(rval)) stats::getCall(x) else rval } ##============================================================================== `uGamm` <- function(formula, random = NULL, ..., lme4 = inherits(random, "formula")) { pkg <- if(lme4) "gamm4" else "mgcv" if (!require(pkg, character.only = TRUE)) stop("cannot load package ", sQuote(pkg)) funcl <- call("get", if(lme4) "gamm4" else "gamm", ns <- asNamespace(pkg)) clx <- cl <- match.call() clx$lme4 <- NULL clx <- match.call(clx, definition = eval(funcl, envir = ns)) clx[[1L]] <- funcl res <- eval.parent(clx) res$call <- cl class(res) <- c(if(lme4) "gamm4", "gamm") res } `gamm` <- function(...) .Deprecated("uGamm", old = "MuMIn::gamm") MuMIn/R/formulas.R0000644000176200001440000000431715161443462013426 0ustar liggesusers# test for marginality constraints `formulaMargChk` <- function(frm, except = NULL) { if(isTRUE(except)) return(TRUE) factors <- attr(terms.formula(frm, simplify = FALSE), "factors") if(length(factors) == 0L) return(TRUE) #benchmark({ #X <- factors #n <- nrow(X) #res <- vector(mode = "logical", n) #for(i in 1L:n) res[i] <- any(X[i, ] > 1L) #}) #benchmark(rowSums(factors > 1L) != 0L) #benchmark(apply(factors > 1L, 1L, any)) #benchmark(apply(factors, 1L, function(x) any(x > 1L))) ex <- dimnames(factors)[[1L]][rowSums(factors > 1L) != 0L] if(is.character(except)) factors <- factors[!(dimnames(factors)[[1L]] %in% except), ] ret <- all(factors < 2L) attr(ret, "marg.ex") <- ex return(ret) } # slightly faster than stats::reformulate # response must be a character string #Reformulate <- function(termlabels, response = NULL, intercept = TRUE, envir = parent.frame()) { # res <- parse(text = paste(if(!is.null(response)) 'Y', "~", paste(termlabels, collapse = "+"), collapse = ""))[[1L]] # class(res) <- "formula" # environment(res) <- envir # res #} `.formulaEnv` <- function(object, env = .GlobalEnv) { res <- formula(object, env = baseenv()) environment(res) <- env res } `simplify.formula` <- function(x) { tt <- terms(as.formula(x)) fac <- attr(tt, "factors") if(length(fac) == 0L) { x[[length(x)]] <- if(attr(tt, "intercept")) 1 else -1 return(x) } if(ncol(fac) == 1L) { tnm <- attr(tt, "term.labels") } else { ord <- attr(tt, "order") k <- seq_along(colnames(fac)) names(k) <- colnames(fac) k <- k[order(ord, decreasing = TRUE)] ret <- sapply(k, function(i) sapply(k, function(j) if(ord[j] >= ord[i]) NA else !any(!(fac[, i] == 1L) & fac[, j]) )) i <- (!apply(ret, 1L, function(x) any(x, na.rm = TRUE))) j <- i & apply(fac[, k], 2L, function(x) all(x < 2L)) & ord[k] > 1 tnm <- rownames(ret) tnm[j] <- gsub(":", "*", tnm[j]) tnm <- tnm[i][order(ord[k][i])] } x[[length(x)]] <- reformulate(tnm, intercept = attr(tt, "intercept"))[[2L]] return(x) } `expand.formula` <- function(x) { x <- formula(x) env <- environment(x) tt <- terms(x) x[[length(x)]] <- reformulate(attr(tt, "term.labels"), intercept = attr(tt,"intercept"))[[2L]] environment(x) <- env x } MuMIn/R/ext.R0000644000176200001440000001475215161443462012402 0ustar liggesusers## Methods for standard generic functions (defined in package 'stats') ## for objects for which they are missing from original packages. ##------------------------------------------------------------------------------ # default 'family' method ##------------------------------------------------------------------------------ `family.default` <- function (object, ...) { cl <- get_call(object) 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(NA) switch(mode(fam), call = eval(fam), name =, character = match.fun(fam)()) } ##------------------------------------------------------------------------------ ## package 'glmmML' ##------------------------------------------------------------------------------ # this replaces the original method, 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 ##------------------------------------------------------------------------------ ## package 'nlme' ##------------------------------------------------------------------------------ `family.gls` <- `family.lme` <- function (object, ...) { if (inherits(object$family, "family")) object$family else gaussian() } `model.frame.lme` <- function (formula, random = FALSE, ...) { x <- formula frm <- formula(x) if(random) { for(reStruct in x$modelStruct$reStruct) frm[[3L]] <- call("+", frm[[3L]], attr(reStruct, "formula")[[2L]]) } mfArgs <- list(formula = frm, data = x$data[rownames(x$fitted), ], drop.unused.levels = TRUE) do.call("model.frame", mfArgs) #droplevels(do.call("model.frame", mfArgs)) } `model.matrix.lme` <- function (object, random = FALSE, ...) { mf <- model.frame(object, random = random) model.matrix(formula(terms(mf)), mf, contrasts.arg = object$contrasts) } ##------------------------------------------------------------------------------ ## package 'betareg' ##------------------------------------------------------------------------------ family.betareg <- function (object, ...) { ret <- binomial(object$link$mean) ret$family <- "Beta regression" for(a in c("variance", "dev.resids", "aic", "simulate")) body(ret[[a]]) <- quote({.NotImplemented()}) ret$initialize <- expression() ret$link.precision <- object$link$precision ret } ##------------------------------------------------------------------------------ ## package 'coxme' ##------------------------------------------------------------------------------ `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.parent(x$call$formula) ##------------------------------------------------------------------------------ ## package 'pscl' ##------------------------------------------------------------------------------ `family.zeroinfl` <- function(object, ...) binomial(link = object$link) ##------------------------------------------------------------------------------ ## package 'aod' ##------------------------------------------------------------------------------ `formula.glimML` <- function(x, ...) x@formula `family.glimML` <- function(object, ...) switch(object@method, "BB" = binomial(object@link), #"NB" = MASS::negative.binomial(theta = 1/object@param['phi.(Intercept)'], "NB" = get("negative.binomial", asNamespace("MASS"))( theta = 1 / object@param['phi.(Intercept)'], link = object@link)) `terms.glimML` <- function (x, ...) terms.formula(x@formula, ...) `model.frame.glimML` <- function (formula, ...) model.frame(formula@formula, data = formula@data, na.action = formula@na.action) ##------------------------------------------------------------------------------ ## package 'aod3' ##------------------------------------------------------------------------------ model.matrix.aodml <- function (object, ...) object$X.b `model.frame.aodml` <- function (formula, ...) model.frame(formula$formula, data = formula$dat) ##------------------------------------------------------------------------------ ## package 'geepack' ##------------------------------------------------------------------------------ `coef.geese` <- function (object, ...) object$beta ## What if 'data' changed in the meantime? # model.matrix.gee <- # function (object, ...) { # cl <- get_call(fgee) # cl[[1L]] <- as.name("model.matrix") # cl$object <- cl$formula # cl$id <- cl$corstr <- cl$formula <- NULL # eval.parent(cl) # } ##------------------------------------------------------------------------------ ## package 'yags' ##------------------------------------------------------------------------------ `coef.yagsResult` <- function (object, ...) structure(object@coefficients, names = object@varnames) `getCall.yagsResult` <- function(x, ...) x@Call `formula.yagsResult` <- function (x, ...) eval.parent(x@Call$formula) ##------------------------------------------------------------------------------ ## package 'MCMCglmm' ##------------------------------------------------------------------------------ `formula.MCMCglmm` <- function (x, ...) x$Fixed$formula `family.MCMCglmm` <- function (object, ...) object$family ##------------------------------------------------------------------------------ ## package 'caper' ##------------------------------------------------------------------------------ `formula.caic` <- function(x, ...) formula(x$mod) ##------------------------------------------------------------------------------ ## package 'asreml' ##------------------------------------------------------------------------------ #XXX: this is for fixed effects only (should sparse be included too?) `formula.asreml` <- function (x, ...) as.formula(x$fixed.formula) `family.asreml` <- function(object, ...) { fam <- object$family fam$linkfun <- fam$link fam$link <- fam$family[2L] fam$family <- fam$family[1L] fam$linkinv <- fam$inverse fam$inverse <- NULL class(fam) <- "family" fam } ##------------------------------------------------------------------------------ ## package 'maxlike' ##------------------------------------------------------------------------------ formula.maxlikeFit <- function (x, ...) as.formula(get_call(x)$formula, env = parent.frame()) ##------------------------------------------------------------------------------ ## package 'geeM' ##------------------------------------------------------------------------------ model.matrix.geem <- function (object, ...) object$X ## EOF MuMIn/R/class-glmmTMB.R0000644000176200001440000000702415161443462014176 0ustar liggesusers `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(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))") sortorder <- lapply(at, attr, "sortorder") sortorderl <- vapply(sortorder, length, 0, USE.NAMES = FALSE) sortorder <- unlist(sortorder, use.names = FALSE) + rep(c(0, sortorderl[-length(sortorderl)]), sortorderl) if(intercept) { rval <- c(intLabel, rval) sortorder <- c(seq.int(along.with = intLabel), sortorder + 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, "sortorder") <- sortorder 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 <- lapply(attr(opt$allTerms, "random.terms"), str2lang) 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 } # XXX: Why it was `as.symbol(opt$response)` ? rval$formula <- as.formula(call("~", opt$response, rval$formula[[2L]]), opt$gmFormulaEnv) rval } MuMIn/R/getModelArgs.R0000644000176200001440000000276715161443462014162 0ustar liggesusersgetModelArgs <- function() { .makemnames <- function(cl) { if(!is.null(names(cl))) { argnames <- names(formals(sys.function(-2L))) cl <- cl[! names(cl) %in% argnames[-c(1L, 2L)]] names(cl) <- names(cl)[names(cl) != argnames[1L]] } unlist(.makeListNames(cl[-1L])) } cl <- sys.call(-1L) pf <- parent.frame() missingObject <- evalq(missing(object), pf) if(missingObject) NULL else object <- get("object", pf, inherits = FALSE) models <- eval(call("list", as.name("...")), pf) if (missing(object) && length(models) > 0L) { object <- models[[1L]] names(models) <- .makemnames(cl) } else if (is.list(object) && !is.object(object)) { if(length(object) == 0L) stop("at least one model must be given") models <- object object <- models[[1L]] names(models) <- unlist(.makeListNames(models)) } else if (inherits(object, "averaging")) { modelList <- attr(object, "modelList") if(length(models)) cry(-1, "extra arguments ignored", warn = TRUE) if(is.list(modelList) && length(modelList)) { models <- modelList } else cry(-1, "'object' is an \"averaging\" object but has no model list", warn = FALSE) } else { models <- c(list(object), models) if(length(models) > 1L) { names(models) <- .makemnames(cl) } else { names(models)[1L] <- unlist(.makeListNames(list(substitute(object)))) } } if(length(models) == 0L) stop("at least one model must be given") invisible(models) } # TODO: #is.listOfCalls <- #function(x) is.list(x) && all(vapply(x, is.call, FALSE)) MuMIn/R/r.squaredLR.R0000644000176200001440000001254615161443462013743 0ustar liggesusers`null.fit` <- function(object, evaluate = FALSE, RE.keep = FALSE, envir = NULL, ...) { # backward compatibility: if("x" %in% ...names()) { object <- ...elt(match("x", ...names())) warning("the argument ", sQuote("x"), " has been removed. Use ", sQuote("object"), " instead") } # TODO: detect if RE.keep is TRUE and object is not a mixed model cl <- get_call(object) if(!is.environment(envir)) envir <- environment(as.formula(formula(object))) if(RE.keep) { if(inherits(object, c("mer", "merMod", "coxme", "lmekin"))) { cl$formula <- .nullREForm(as.formula(cl$formula)) environment(cl$formula) <- envir } else if(inherits(object, "gamm")) { mefm <- object[[if("lme" %in% names(object)) "lme" else "mer"]] if(inherits(mefm, "merMod")) { Fun <- if(inherits(mefm, "glmerMod")) "glmer" else if(inherits(mefm, "lmerMod")) { cl$family <- NULL "lmer" } cl$REML <- as.logical(object$mer@devcomp$dims[['REML']]) frm <- cl$formula frm[[3L]] <- call("+", 1, as.formula(cl$random)[[2L]]) cl$random <- NULL environment(cl$formula) <- envir } else if (inherits(mefm, "lme")) { Fun <- "lme" cl$fixed <- update.formula(as.formula(cl$formula), . ~ 1) cl$formula <- cl$family <- NULL cl$method <- object$lme$method environment(cl$fixed) <- envir } cl[[1L]] <- as.symbol(Fun) } else if(inherits(object, c("glmmML", "glimML"))) { cl$formula <- update.formula(as.formula(cl$formula), . ~ 1) environment(cl$formula) <- envir } else if(inherits(object, "lme")) { cl$fixed <- update.formula(as.formula(cl$fixed), . ~ 1) environment(cl$fixed) <- envir } else { stop("do not know (yet) how to construct a null model with RE for class ", prettyEnumStr(class(object), sep.last = ", ")) } return(if(evaluate) eval(cl, envir = envir) else cl) } mClasses <- c("glmmML", "lm", "lme", "gls", "mer", "merMod", "lmekin", "unmarkedFit", "coxph", "coxme", "zeroinfl", "gamm", "survreg") mClass <- mClasses[inherits(object, mClasses, which = TRUE) != 0L][1L] if(is.na(mClass)) mClass <- "default" formulaArgName <- "formula" Fun <- "glm" call2arg <- function(x) formals(match.fun(x[[1L]])) switch(mClass, glmmML = { if(is.null(cl$family)) cl$family <- as.name("binomial") }, gls = { formulaArgName <- "model" cl$weights <- NULL }, lme = { formulaArgName <- "fixed" cl$weights <- NULL }, lmekin =, merMod =, mer = { arg <- formals(match.fun(cl[[1L]])) }, unmarkedFit = { nm <- names(cl)[-1L] if("formula" %in% nm) { cl$formula <- ~1~1 } else { formula.arg <- nm[grep(".+formula$", nm[1L:7L])] for (i in formula.arg) cl[[i]] <- ~1 } cl$starts <- NULL Fun <- NA }, coxph =, coxme = { Fun <- "coxph" cl$formula <- update.formula(eval(cl$formula), . ~ 1) }, survreg = , zeroinfl =, lm = { Fun <- NA cl$formula <- update.formula(as.formula(cl$formula), . ~ 1) }, gamm = { Fun <- "gam" cl$formula <- update.formula(as.formula(cl$formula), . ~ 1) cl$random <- NULL }, { stop("do not know (yet) how to construct a null model for class ", sQuote(class(object))) } ) if(!is.na(Fun)) cl[[1L]] <- as.name(Fun) if(identical(Fun, "glm")) { if(formulaArgName != "formula") names(cl)[names(cl) == formulaArgName] <- "formula" cl$formula <- update(as.formula(cl$formula), . ~ 1) cl$method <- cl$start <- cl$offset <- contrasts <- NULL } cl <- cl[c(TRUE, names(cl)[-1L] %in% names(call2arg(cl)))] if(evaluate) eval(cl, envir = envir) else cl } # from lme4:::findbars: .findbars <- function (term) { if (is.name(term) || !is.language(term)) return(NULL) if (term[[1L]] == as.name("(")) return(.findbars(term[[2L]])) if (!is.call(term)) stop("term must be of class call") if (term[[1L]] == as.name("|")) return(term) if (length(term) == 2L) return(.findbars(term[[2L]])) c(.findbars(term[[2L]]), .findbars(term[[3L]])) } `.nullREForm` <- function(formula) { re <- lapply(.findbars(formula), function(x) call("(", x)) f <- 1 for(i in seq_along(re)) f <- call("+", f, re[[i]]) formula[[length(formula)]] <- f formula } .getLLML <- function(x) { cls <- class(x) llfun <- if(isS4(logLik)) selectMethod("logLik", cls) else logLik if(isS3stdGeneric(llfun)) for(cl in cls) if(is.function(llfun <- getS3method("logLik", cl, optional = TRUE))) break if(is.null(llfun)) stop("no 'logLik' method found for object of class ", prettyEnumStr(cls, sep.last = ", ")) arg <- list(object = x, REML = FALSE) do.call(llfun, arg[names(arg) %in% names(formals(llfun))]) } `r.squaredLR` <- function(object, null = NULL, null.RE = FALSE, ...) { if("x" %in% ...names()) { object <- ...elt(match("x", ...names())) warning("the argument ", sQuote("x"), " has been removed. Use ", sQuote("object"), " instead") } if(!missing(null) && !missing(null.RE)) warning("argument 'null.RE' ignored if 'null' is provided") if(is.null(null)) null <- null.fit(object, TRUE, null.RE, parent.frame()) L0 <- as.vector(.getLLML(null)) L1 <- .getLLML(object) n <- if(is.null(attr(L1, "nobs"))) nobs(object) else attr(L1, "nobs") #n <- sum(weights(object)) ret <- 1 - exp(-2 / n * (as.vector(L1) - L0)) max.r2 <- 1 - exp(2 / n * L0) attr(ret, "adj.r.squared") <- ret / max.r2 ret } MuMIn/R/formlist.R0000644000176200001440000000516515161443462013437 0ustar liggesusers formula.formlist <- function(x, env = parent.frame(), style = c("~", "|", "+", "tilde", "bar", "combined"), response = NULL, ...) { style <- if(inherits(x, "formlist") && !is.null(attr(x, "mform.style"))) attr(x, "mform.style") else match.arg(style) rhslist <- lapply(x, "[[", 2L) fexpr <- switch(style, "|" =, bar = { #"bar separated" ff <- Reduce(\(a,b) call("|", a, b), rhslist) addresponse(f = ff, y = response, env = env) }, "~" = , tilde =, { #"tilde separated" rhslist[[1L]] <- addresponse(f = rhslist[[1L]], y = response) Reduce(\(a, b) call("~", a, b), rhslist) }, "+" =, combined = { #"all model formulas combined togeter" ff <- str2lang(paste(vapply(rhslist, deparse1, ""), collapse = "+")) f <- addresponse(f = ff, y = response, env = env) }) formula(fexpr, env) } # IF tilde-separated formulas, response is only for the first model # IF bar-separated formulas, response is with all component models formlist <- function(x, env = environment(f)) { f <- formula(x) .op <- \(expr) if(is.call(expr)) expr[[1L]] else "" # decompose multi-sided (n > 2), i.e. [y] ~ a ~ b ~ c f1 <- f rval <- list() while(.op(f1) == "~") { rval[[length(rval) + 1L]] <- f1[[length(f1)]] f1 <- f1[[2L]] } response <- if(!identical(f1, rval[[length(rval)]])) f1 else NULL mform.tilde <- length(rval) != 1L # one or two-sided [y] ~ a + b if(length(rval) == 1L) { rhs <- rval[[1L]] # remove ~ rval <- list() # bar-split formula y ~ a | b while(.op(rhs) == "|") { rval[[length(rval) + 1L]] <- rhs[[3L]] rhs <- rhs[[2L]] } rval[[length(rval) + 1L]] <- rhs } rval <- rev(rval) if(is.null(response)) { noresp <- seq.int(1L, length(rval)) resp <- 0L } else { if(mform.tilde) { # has lhs and is ~-separated - attach the response to FIRST right-sided formula: resp <- 1L noresp <- seq.int(2L, length(rval)) # because length(rval) > 1L } else { # has lhs - attach the response to each right-sided formula: resp <- seq.int(1L, length(rval)) noresp <- 0L } } rval[resp] <- lapply(rval[resp], \(g) formula(call("~", response, g), env = env)) rval[noresp] <- lapply(rval[noresp], \(g) formula(call("~", g), env = env)) if(length(rval) != 1L) attr(rval, "mform.style") <- if(mform.tilde) "~" else "|" oldClass(rval) <- "formlist" rval } MuMIn/R/coefTable.R0000644000176200001440000001056715161443462013466 0ustar liggesusers`coefTable` <- function (model, ...) UseMethod("coefTable") .makeCoefTable <- function(x, se, df = NA_real_, coefNames = names(x)) { if(n <- length(x)) { xdefined <- !is.na(x) ndef <- sum(xdefined) if(ndef < n) { if(length(se) == ndef) { y <- rep(NA_real_, n); y[xdefined] <- se; se <- y } if(length(df) == ndef) { y <- rep(NA_real_, n); y[xdefined] <- df; df <- y } } } if(n && n != length(se)) stop("length(x) is not equal to length(se)") ret <- matrix(NA_real_, ncol = 3L, nrow = length(x), dimnames = list(coefNames, c("Estimate", "Std. Error", "df"))) if(n) ret[, ] <- cbind(x, se, rep(if(is.null(df)) NA_real_ else df, length.out = n), deparse.level = 0L) class(ret) <- c("coefTable", "matrix") ret } `print.coefTable` <- function (x, ...) stats::printCoefmat(x[, if(all(is.na(x[, 3L]))) -3L else TRUE, drop = FALSE], has.Pvalue = FALSE) summary.coefTable <- function (object, ...) { tvalue <- object[, 1L] / object[, 2L] if (all(is.na(object[, 3L]))) { pvalue <- 2 * pnorm(-abs(tvalue)) rval <- cbind(object, tvalue, pvalue) cn <- c("z value", "Pr(>|z|)") } else if (any(is.finite(tvalue))) { pvalue <- 2 * pt(-abs(tvalue), object[, 3L]) cn <- c("t value", "Pr(>|t|)") } else { pvalue <- tvalue <- NaN cn <- c("t value", "Pr(>|t|)") } rval <- cbind(object, tvalue, pvalue) colnames(rval)[4L:5L] <- cn class(rval) <- c("summary.coefTable", class(object)) rval } `print.summary.coefTable` <- function (x, signif.stars = getOption("show.signif.stars"), ...) { j <- if(all(is.na(x[, 3L]))) -3L else TRUE stats::printCoefmat(x[, j], has.Pvalue = any(is.finite(x[, 5L])), signif.stars = signif.stars, ...) } plot.mcoefTable <- function (x, y, labAsExpr = FALSE, n = 101, w = 5, ...) { lab_as_expr <- function(x) { x <- gsub(":", "%*%", x, perl = TRUE) x <- gsub("\\B_?(\\d+)(?![\\w\\._])", "[\\1]", x, perl = TRUE) str2lang(x) } xd <- function(z, n, w, x = NULL) { rval <- matrix(NA_real_, ncol = 3L, nrow = n) rval[, 1L] <- if(is.null(x)) seq(z[1L] - (w * z[2L]), z[1L] + (w * z[2L]), length.out = n) else x if(!is.na(z[3L])) rval[, 2L] <- dt((rval[, 1L] - z[1L]) / z[2L], z[3L]) / z[2L] rval[, 3L] <- dnorm(rval[, 1L], z[1L], z[2L]) rval } m <- nrow(x) lab <- if(labAsExpr) lab_as_expr(rownames(x)) else rownames(x) nmodels <- dim(x)[3L] col <- 1L:nmodels par(mfrow = n2mfrow(m), ...) for(i in 1L:m) { #cat("--", dimnames(x)[[1]][i], "--\n") mat <- matrix(0, n, 2L * nmodels + 1L) for(k in 1L:nmodels) { j <- seq.int(length.out = 2 + (k == 1), from = 1 + (k - 1)* 2 + (k != 1)) xlim <- c(min(x[i, 1L, ]) - w * min(x[i, 2L, ]), max(x[i, 1L,]) + w * max(x[i,2L,])) vx <- seq(xlim[1L], xlim[2L], length.out = n) v <- xd(x[i, , k], n = n, w = w, x = vx) mat[, j] <- v[, (2 - (k == 1)):3] } plot.new() plot.window(xlim = range(mat[, 1L]), ylim = range(mat[,-1L], na.rm = TRUE)) j <- seq.int(2, length.out = nmodels, by = 2) if(any(!is.na(mat[, j]))) matplot(mat[, 1], mat[, j], type = "l", lty = 2, add = TRUE, col = col) matplot(mat[, 1L], mat[, j + 1L], type = "l", lty = 1, add = TRUE, col = col) abline(v = x[i, 1L, ], lty = 1L, col = col) abline(v = 0, lty =3L, col = 8) axis(1L) axis(2L) box() title(lab[[i]]) } invisible() } plot.coefTable <- function (x, y, labAsExpr = FALSE, n = 101, w = 5, include.zero = TRUE, col = 2, lwd = par("lwd"), lty = 1, lend = par("lend"), ...) { xd <- function(z, n, w) { #rval <- matrix(NA_real_, ncol = 3L, nrow = n) rval <- matrix(NA_real_, ncol = 2L, nrow = n) x0 <- z[1L] - w * z[2L] x1 <- z[1L] + w * z[2L] if(include.zero) { x0 <- min(0, x0) x1 <- max(0, x1) } rval[, 1L] <- seq(x0, x1, length.out = n) rval[, 2L] <- if(!anyNA(z[3L])) { dt((rval[, 1L] - z[1L]) / z[2L], z[3L]) / z[2L] } else dnorm(rval[, 1L], z[1L], z[2L]) rval } m <- nrow(x) lab <- if(labAsExpr) .lab2expr(rownames(x)) else rownames(x) par(mfrow = n2mfrow(m)) for(i in 1L:m) { v <- xd(x[i, ], n = n, w = w) plot.new() plot.window(xlim = range(v[, 1L]), ylim = range(v[,-1L], na.rm = TRUE)) #lines(v[, 1L], v[, 2L]) lines(v[, 1L], v[, 2L], col = col, lwd = lwd, lty = lty, lend = lend) abline(v = c(x[i, 1L], 0), lty = c(1L, 3L)) axis(1L) axis(2L) box() title(substitute(A == B %+-% C, list(A = lab[[i]], B = round(x[i, 1L], 1L), C = round(x[i, 2L], 2L)))) } invisible() } MuMIn/R/loo.R0000644000176200001440000001027215161443462012364 0ustar liggesusers loo <- function(object, type = c("loglik", "rmse"), ...) UseMethod("loo") loo.default <- function(object, type = c("loglik", "rmse"), ...) .NotYetImplemented() # for other types of models use manipulated call - SLOW # lm, glm, mgcv::gam loo.lm <- function(object, type = c("loglik", "rmse"), start, etastart, mustart, control, intercept, ...) { if(!inherits(object, "lm")) stop("'object' must be a \"glm\" or \"lm\" object") ## TODO: pass other arguments: if(!missing(start) || !missing(etastart) || !missing(mustart) || !missing(control) || !missing(intercept)) { warning("arguments 'start', 'etastart', 'mustart', 'control', 'intercept' are ignored") } ## binary response: object$y is always a vector and weights(object) give size if(type != "rmse_t") type <- match.arg(type) # hidden option tt <- terms(object) beta <- coef(object) fam <- family(object) X <- model.matrix(object) y0 <- get.response(object) # model.frame(object)[, asChar(attr(tt, "variables")[-1L][[attr(tt, "response")]])] nobs <- NROW(y0) wt <- weights(object, "prior") if(is.null(wt)) wt <- rep(1, nobs) if(NCOL(y0) == 2L) { # binomial # NOTE: don't need to keep 'y' as 2-column matrix, but if also weights # are given, 'glm.fit' warns about "non-integer # of successes" n <- rowSums(y0) y <- y0[, 1L] / n wt0 <- wt / n # FUNFACT: 'x[1L] == x' more efficient than x[1L] == x[-1L] # If weights are equal, use y as proportion, otherwise a matrix if(all(wt == n)) { #if(all(wt0[1L] == wt0)) { y0 <- y wt0 <- wt } } else { n <- rep(1, nobs) y <- y0 wt0 <- wt } y0 <- as.matrix(y0) offset <- object$offset if(is.null(offset)) offset <- numeric(nobs) func <- switch(type, loglik = { dev <- function(y, mu, wt, fam) sum(fam$dev.resids(y, mu, wt)) llik <- function(y, X, beta, fam, n, wt = 1, off = NULL) { # wt : fit$prior.weights wt <- rep(wt, length.out = NROW(y)) mu <- predict_glm_fit(beta, X, off, fam)[, 1L] ep <- if (fam$family %in% c("gaussian", "Gamma", "inverse.gaussian")) 1 else 0 (fam$aic(y, n, mu, wt, dev(y, mu, wt, fam)) / 2) - ep # +LL } function(fit, z) { llik(z[["y"]], z[["X"]], fit$coefficients, fit$family, z[["n"]], z[["wt"]], z[["offset"]]) } }, rmse = function(fit, z) { # RMSE on response scale beta <- fit$coefficients py <- predict_glm_fit(beta, z[["X"]], z[["offset"]], fit$family)[, 1L] z[["y"]] - py # inefficient to '^2' here, do it later }, rmse_t = function(fit, z) { # alternatively: MSE on transformed data beta <- fit$coefficients py <- predict_glm_fit(beta, z[["X"]], z[["offset"]])[, 1L] # prediction on link scale z[["eta"]] - py # inefficient to '^2' here, do it later # XXX: problem with RMSE with binomial and y = 0 or 1 (= Inf on link scale) }) #.DebugPrint(type) #.Debug(if(type == "loglik") { # .DebugPrint(y0) # message("running test 1...") # # XXX: DEBUG test // lm has no $family # testLL1 <- llik(y, X, object$coefficients, family(object), n, wt, offset) # # .DebugPrint(testLL1) # .DebugPrint(logLik(object)) # .DebugPrint(testLL1 - logLik(object)) # .DebugPrint(rbind(n, wt, offset)) # # stopifnot(all.equal(-testLL1, c(logLik(object)), tolerance = 1e-5)) # message("OK") # message("running test 2...") # testFm <- glm.fit(y = y0, x = X, family = fam, offset = offset, weights = wt0) # .DebugPrint(rbind(testFm$coefficients, object$coefficients)) # stopifnot(all.equal(testFm$coefficients, object$coefficients)) # message("OK") # message("running test 3...") # testLL2 <- llik(y, X, testFm$coefficients, testFm$family, n, wt, offset) # .DebugPrint(c(testLL2, logLik(object))) # stopifnot(all.equal(-testLL2, c(logLik(object)), tolerance = 1e-5)) # message("OK") # .DebugPrint(testLL2) # .DebugPrint(logLik(object)) #}) fdat <- if(type == "loglik") { data.frame(X = 0, y = y, n = n, wt = wt, offset = offset) } else { data.frame(X = 0, y = y, eta = fam$linkfun(y), offset = offset) } fdat$X <- X rval <- numeric(nobs) for (i in seq.int(nobs)) { fm1 <- glm.fit(y = y0[-i, , drop = FALSE], x = X[-i, , drop = FALSE], family = fam, offset = offset[-i], weights = wt[-i]) rval[i] <- func(fm1, fdat[i, ]) } if(type == "loglik") mean(rval) else sqrt(mean(rval^2)) } MuMIn/R/model.selection.R0000644000176200001440000000750215161444373014663 0ustar liggesusers`coefTable.model.selection` <- function (model, ...) { rval <- attr(model, "coefTables") names(rval) <- rownames(model) rval } `coef.model.selection` <- function (object, ...) { ct <- attr(object, "coefTables") n <- length(ct) allcf <- unique(unlist(lapply(ct, rownames))) rval <- matrix(NA_real_, nrow = n, ncol = length(allcf), dimnames = list(rownames(object), allcf)) for(i in seq_len(n)) rval[i, match(rownames(ct[[i]]), allcf)] <- ct[[i]][, 1L] rval } `coeffs.model.selection` <- function (model) coef.model.selection(model) `coefArray` <- function(object) { coefNames <- fixCoefNames(unique(unlist(lapply(object, rownames), use.names = FALSE))) nCoef <- length(coefNames) nModels <- length(object) rval <- array(NA_real_, dim = c(nModels, 3L, nCoef), dimnames = list(names(object), c("Estimate", "Std. Error", "df"), coefNames)) for(i in seq_along(object)) { z <- object[[i]] rval[i, seq_len(ncol(z)), ] <- t(z[match(coefNames, fixCoefNames(rownames(z))), ]) } rval } `getCall.model.selection` <- function (x, i = NULL, ...) { if(is.null(i)) return(attr(x, "call", exact = TRUE)) if(length(i) == 1L) return(attr(x, "model.calls", exact = TRUE)[[i]]) return(attr(x, "model.calls", exact = TRUE)[i]) } getModelClass <- function(x) { if(inherits(x, "model.selection")) { if(!is.null(attr(x, "global"))) return(class(attr(x, "global"))[1L]) if("class" %in% colnames(x)) return(as.character(x[, "class"])) if(!is.null(attr(x, "model.class"))) return(attr(x, "model.class")) } return(NULL) } `update.model.selection` <- function (object, global.model, ..., evaluate = TRUE) { cl <- attr(object, "call") if (is.null(cl)) stop("need an object with call component") extras <- match.call(expand.dots = FALSE)$... if(!missing(global.model)) extras <- c(list(global.model = substitute(global.model)), extras) if (length(extras)) { existing <- !is.na(match(names(extras), names(cl))) for (a in names(extras)[existing]) cl[a] <- extras[a] if (any(!existing)) { cl <- c(as.list(cl), extras[!existing]) cl <- as.call(cl) } } if (evaluate) eval.parent(cl) else cl } `logLik.model.selection` <- function (object, ...) { nobs <- attr(object, "nobs") n <- nrow(object) rval <- vector(n, mode = "list") for(i in 1L:n) rval[[i]] <- structure(object[i, "logLik"], df = object[i, "df"], nobs = nobs, class = "logLik") rval } `family.model.selection` <- function (object, ...) { if(!is.null(attr(object, "global"))) { model.calls <- attr(object, "model.calls") if(!is.null(model.calls[[1L]][["family"]])) { fam <- lapply(model.calls, "[[", "family") rval <- lapply(unique(fam), eval)[ as.integer(as.factor(vapply(fam, asChar, ""))) ] names(rval) <- rownames(object) return(rval) } else return(family(attr(object, "global"))) } else { attr(object, "model.family") } } `nobs.model.selection` <- function (object, ...) attr(object, "nobs") ## internal: translate column type to column indices type2col <- function (x, type) { if (inherits(x, "model.selection")) x <- attr(x, "column.types") k <- match(x, type, nomatch = 0L) i <- k != 0 which(i)[order(k[i])] } ## internal: translate column type to column names type2colname <- function(x, type) names(x)[type2col(x, type)] `item<-` <- function(x, name, i, value) `[<-.data.frame`(x, i, name, value) `item` <- function(x, name, i, ...) `[.data.frame`(x, i, name, ...) `itemByType` <- function(x, type, i, ...) `[.data.frame`(x, i, type2col(x, type), ...) `itemByType<-` <- function(x, type, i, value) `[<-.data.frame`(x, i, type2col(x, type), value) duplicated.model.selection <- function (x, incomparables = FALSE, fromLast = FALSE, ...) { duplicated.data.frame(x[, type2col(x, c("loglik", "terms"))], incomparables = incomparables, fromLast = fromLast, ...) } MuMIn/R/matchCoef.R0000644000176200001440000000154115161443462013463 0ustar liggesusers`matchCoef` <- function(m1, m2, all.terms = getAllTerms(m2, intercept = TRUE), beta = 0L, terms1 = getAllTerms(m1, intercept = TRUE), coef1 = NULL, allCoef = FALSE, ... ) { if(is.null(coef1)) { ct <- if (beta != 0L) std.coef(m1, beta == 2L, ...) else coefTable(m1, ...) coef1 <- ct[, 1L] names(coef1) <- rownames(ct) } else if(allCoef) stop("'coef1' is given and 'allCoef' is not FALSE") if(any((terms1 %in% all.terms) == FALSE)) stop("'m1' is not nested within 'm2'") row <- structure(rep(NA_real_, length(all.terms)), names = all.terms) fxdCoefNames <- fixCoefNames(names(coef1)) row[terms1] <- NaN pos <- match(terms1, fxdCoefNames, nomatch = 0L) row[fxdCoefNames[pos]] <- coef1[pos] if(allCoef) { i <- match(names(coef1), rownames(ct)) j <- !is.na(i) rownames(ct)[i[j]] <- fxdCoefNames[j] attr(row, "coefTable") <- ct } row }MuMIn/R/getspecs.R0000644000176200001440000000245015161443462013407 0ustar liggesusers getspecs <- function(x, with.model = FALSE, fitType = x@fitType) { if(inherits(x, "unmarkedFit")) { #.modelspecs[[c("unmarked", class(x)[1L], x@fitType)]] cls <- class(x)[1L] i <- match("unmarked", names(.modelspecs)) j <- match(cls, names(.modelspecs[[i]]), nomatch = 0L) if(j == 0L) stop(gettextf("unknown \"unmarkedFit\" subclass: \"%s\"", cls)) k <- match(x@fitType[1L], names(.modelspecs[[c(i, j)]]), nomatch = 0L) if(k == 0L) stop(gettextf("unknown \"%s\" fit type: \"%s\"", cls, x@fitType[1L])) specs <- .modelspecs[[c(i, j, k)]] estid <- paste0(names(x@estimates@estimates), ":", sapply(x@estimates@estimates, "slot", "short.name")) specs <- specs[match(estid, paste0(specs$item.name, ":", specs$short.name)), , drop = FALSE] stopifnot(!anyDuplicated(specs$item.name)) specs } else { i <- match(class(x), names(.modelspecs), nomatch = 0L) if(all(i == 0L)) stop("unknown model class") .modelspecs[[i[i != 0L][1L]]] } } print.model.specs <- function (x, ...) { info <- attr(x, "object.info") cat(sprintf("Model specification table for class '%3$s' [%1$s::%2$s()]\n", info["package"], info["func"], info["className"])) print.data.frame(x, row.names = FALSE) } MuMIn/R/model.names.R0000644000176200001440000000256515161443462014003 0ustar liggesusersmodel.names <- function(object, ..., labels = NULL, use.letters = FALSE) { if (missing(object) && length(models <- list(...)) > 0L) { object <- models[[1L]] } else if (inherits(object, "list")) { if(length(object) == 0L) stop("at least one model must be given") models <- object object <- models[[1L]] } else models <- list(object, ...) if(length(models) == 0L) stop("at least one model must be given") .modelNames(models = models, uqTerms = labels, use.letters = use.letters) } .modelNames <- function(models = NULL, allTerms, uqTerms, use.letters = FALSE, ...) { if(missing(allTerms)) allTerms <- lapply(models, getAllTerms) if(missing(uqTerms) || is.null(uqTerms)) uqTerms <- unique(unlist(allTerms, use.names = FALSE)) n <- length(uqTerms) if(use.letters && n > length(LETTERS)) stop("more terms than there are letters") sep <- if(!use.letters && n > 9L) "+" else "" labels <- if (use.letters) LETTERS[seq_len(n)] else as.character(seq_len(n)) ret <- sapply(allTerms, function(x) paste(labels[sort(match(x, uqTerms))], collapse = sep)) dup <- table(ret) dup <- dup[dup > 1L] if(length(dup) > 0L) { idup <- which(ret %in% names(dup)) ret[idup] <- sapply(idup, function(i) paste0(ret[i], letters[sum(ret[seq.int(i)] == ret[i])])) } ret[!nzchar(ret)] <- "(Null)" attr(ret, "variables") <- structure(seq_along(uqTerms), names = uqTerms) ret } MuMIn/R/class-pkg-spatialreg.R0000644000176200001440000000040215161443462015602 0ustar liggesusersnobs.Spautolm <- function (object, ...) object$fit$N nobs.Sarlm <- function (object, ...) length(resid(object)) coefTable.Sarlm <- coefTable.Spautolm <- function (model, ...) { cf <- summary(model)$Coef .makeCoefTable(cf[, 1L], cf[, 2L]) } MuMIn/R/weights-jackknife.R0000644000176200001440000001557315161443462015201 0ustar liggesusers jackknifeWeights <- function(object, ..., data, type = c("loglik", "rmse"), family = NULL, weights = NULL, optim.method = "BFGS", maxit = 1000, # seed = NULL, optim.args = list(), start = NULL, force.update = FALSE, py.matrix = FALSE ) { models <- getModelArgs() M <- length(models) if(M < 2L) stop("need more than one model") checkIsModelDataIdentical(models) type <- match.arg(type)[1L] useWeightsArg <- !missing(weights) && !is.null(weights) hasPymat <- is.matrix(py.matrix) if(!is.null(start)) { if(length(start) != M) stop("length of 'start' should equal the number of models [", M, "]") start <- log(start) start <- (start - start[1L])[1L] } else { start <- runif(M - 1L) } if(type == "loglik") { if(is.null(family)) { famstr <- tryCatch(vapply(models, function(m) { f <- family(m) c(f[["link"]], f[["family"]]) }, character(2L)), error = function(e) NULL) if (is.null(famstr)) stop("cannot get 'family' function for some models") if (!all(famstr[1L, ] == famstr[1L, 1L]) && all(famstr[2L, ] == famstr[2L, 1L])) stop("models use different 'family' and 'family' argument is not specified") family <- stats::family(models[[1L]]) } else { # code from 'stats::glm' if (is.character(family)) family <- get(family, mode = "function", envir = parent.frame()) if (is.function(family)) family <- family() if (is.null(family$family)) { stop("'family' not recognized") } } } # generate matrix of predictions if(hasPymat) { pymat <- py.matrix Y <- as.matrix(get.response(models[[1L]], if(missing(data)) NULL else data)) } else if(!force.update && all(vapply(models, inherits, FALSE, "glm"))) { if (isTRUE(getOption("debug.MuMIn"))) message("using glm.fit") mf <- mergeMF(models, check = FALSE) tf <- terms(mf) if(!missing(data)) mf <- model.frame(tf, data = data) X <- model.matrix(tf, mf) Y <- as.matrix(get.response(mf)) no <- NROW(Y) colnames(X) <- fixCoefNames(colnames(X)) xil <- lapply(models, function(fit, allcn) { match(fixCoefNames(names(coef(fit))), allcn) }, colnames(X)) fitting_wts <- numeric(no) fitting_wts[] <- if(useWeightsArg) weights else 1 pymat <- array(dim = c(no, M)) xseq <- seq.int(no) for(j in seq.int(M)) { fit <- models[[j]] tf <- terms(fit) fam <- family(fit) off <- fit$offset if(!useWeightsArg) { fitting_wts <- fit$prior.weights if(fam$family == "binomial" && NCOL(Y) == 2L) fitting_wts <- fitting_wts / rowSums(Y) } if(is.null(off)) off <- rep(0, NROW(Y)) .Debug({# DEBUG message("testing glm.fit #", j) cf1 <- glm.fit(X[, xil[[j]], drop = FALSE], Y, family = family(fit), weights = fitting_wts, offset = off)$coefficients cf2 <- models[[j]]$coefficients names(cf2) <- fixCoefNames(names(cf2)) stopifnot(all.equal(cf1[names(cf2)], cf2)) }) # DEBUG for(i in xseq) { coef1 <- glm.fit(X[-i, xil[[j]], drop = FALSE], Y[-i, , drop = FALSE], family = family(fit), weights = fitting_wts[-i], offset = off[-i])$coefficients pymat[i, j] <- predict_glm_fit(coef1, X[i, xil[[j]], drop = FALSE], offset = off[i], family = fam)[, 1L] } } } else { if(isTRUE(getOption("debug.MuMIn"))) message("using update") if(any(!vapply(models, function(x) is.null(get_call(x)$offset), FALSE))) stop("use of 'offset' argument in model calls is not allowed. ", "Specify 'offset' term in the model formula instead") Y <- as.matrix(get.response(models[[1L]], data)) no <- NROW(Y) # TODO: check for prior weights consistency between models fitting_wts <- numeric(no) fitting_wts[] <- if(useWeightsArg) weights else 1 if(!useWeightsArg) { fitting_wts <- weights(models[[1L]], "prior") if(is.null(fitting_wts)) fitting_wts <- rep(1, no) else if(NCOL(Y) == 2L) fitting_wts <- fitting_wts / rowSums(Y) } pf <- parent.frame() # need some variable names unused in parent.frame z_data <- tmpvarname(pf) z_subset <- tmpvarname(pf) cll <- eval(substitute(lapply(models, function(x) { update(x, evaluate = FALSE, data = DATA[[1L]][INDEX, ], weights = DATA[[2L]][INDEX] )}), list(DATA = as.name(z_data), INDEX = as.name(z_subset)))) assign(z_data, list(data, fitting_wts), pf) on.exit(rm(list = c(z_data, z_subset), envir = pf, inherits = FALSE)) pymat <- array(dim = c(no, M)) for(i in 1L:no) { assign(z_subset, -i, pf) pymat[i, ] <- vapply(cll, function(x, newdata, envir) predict(eval(x, envir), newdata = newdata, type = "response"), newdata = data[i, , drop = FALSE], envir = pf, FUN.VALUE = numeric(1L)) } } ## produces pymat if(isTRUE(py.matrix)) { dimnames(pymat) <- list(NULL, names(models)) return(pymat) } if("control" %in% names(optim.args)) { optim.control <- optim.args$control if(is.numeric(optim.args$control$maxit) && missing(maxit)) maxit <- optim.args$control$maxit optim.args$control <- NULL } else optim.control <- list() optim.control$maxit <- maxit if(NCOL(Y) == 2) { ns <- rowSums(Y) y <- Y[, 1L] / ns } else { no <- NROW(Y) y <- c(Y) ns <- rep(1, no) } if("loglik" == type) { #if("loglik" %in% type) { llik <- function(y, mu, fam, n, wt) { wt <- rep(wt, length.out = NROW(y)) # wt : fit$prior.weights ep <- if (fam$family %in% c("gaussian", "Gamma", "inverse.gaussian")) 1 else 0 (fam$aic(y, n, mu, wt, sum(fam$dev.resids(y, mu, wt))) / 2) - ep # +LL } if(useWeightsArg) { prior_wts <- if(NCOL(Y) == 2) { fitting_wts * ns } else fitting_wts } else prior_wts <- weights(models[[1L]], "prior") optfun_loglik <- function(w1, y, pymat, fam, n, wt) { w <- c(1, exp(w1)) w <- w / sum(w) llik(y, pymat %*% w, fam, n, wt) } optres <- eval(as.call(c(alist(optim, optfun_loglik, y = y, pymat = pymat, fam = family, n = ns, wt = prior_wts, par = start, method = optim.method, control = optim.control), optim.args))) } else { #if("rmse" == type) { #if("rmse" %in% type) { # compute RMSE for a value of w, given J: optfun_rmse <- function(ww, pymat, y) { w <- c(1, exp(ww)) w <- w / sum(w) py <- pymat %*% w sqrt(mean((py - y)^2)) } optres <- eval(as.call(c(alist(optim, optfun_rmse, pymat = pymat, y = y, par = runif(M - 1L), method = optim.method, control = optim.control), optim.args))) } if (optres$convergence != 0) stop("not converged. 'optim' gave error code [", optres$convergence, "]") wts <- exp(optres$par) wts <- c(1, wts) wts <- wts / sum(wts) structure(wts, wt.type = paste0("jackknife [", type, "]"), names = names(models), class = c("model.weights", class(wts))) } # end jackknifeWeights #get_response_size_weigths <- #function(y, w = rep(1, NROW(y))) { # if(NCOL(y) == 2L) { # n <- rowSums(y) # y <- y[, 1L] / n # w <- w / n # } else { # n <- rep(1, NROW(y)) # } # list(y = y, n = n, weigths = w) #} MuMIn/R/arm.glm.R0000644000176200001440000001452015161443462013130 0ustar liggesusersarm.glm <- function(object, R = 250, weight.by = c("aic", "loglik"), trace = FALSE) { if(!inherits(object, c("glm", "lm"))) stop("'object' must be a \"glm\" or \"lm\" object") maxtrials <- 10L weight.by <- switch(match.arg(weight.by), aic = 1L, loglik = 2L) allterms <- getAllTerms(object) ordtrm <- attr(allterms, "sortorder") deps <- attr(allterms, "deps")[ordtrm, ordtrm] nterms <- length(allterms) mm <- model.matrix(object) n1 <- ceiling((nall <- nrow(mm))/2) n2 <- nall - n1 combinTerms <- lapply(seq.int(0L, 2^nterms - 1L), function(j) as.logical(intToBits(j)[1L:nterms])) combinTerms <- combinTerms[vapply(combinTerms, formula_margin_check, FALSE, deps)] ## combinPredictors combin <- vapply(combinTerms, function(x, assign) assign %in% c(0, which(x)), logical(ncol(mm)), assign = attr(mm, "assign")) combin <- combin[, i <- colSums(combin) < min(n1, n2) - 1L, drop = FALSE] combinTerms <- combinTerms[i] nModels <- ncol(combin) fam <- family(object) y <- object$y off <- object$offset if(is.null(y)) y <- get.response(object) prwt <- weights(object, "prior") if(is.null(prwt)) prwt <- rep(1, nall) if(fam$family == 'binomial') { y <- prwt * cbind(y, 1 - y, deparse.level = 0L) yvectorize <- function(y) y[, 1L] / rowSums(y) prwt <- rep(1, NROW(y)) jresp <- c(1L, 2L) } else { yvectorize <- function(y) y[, 1L] ## XXX === drop ? jresp <- 1L } Z <- cbind(y, mm, prwt, deparse.level = 0L) rownames(Z) <- NULL jprwts <- ncol(Z) jterms <- (1L:(ncol(Z) - 1L))[-jresp] traceinfo <- if(trace) { function(...) cat(..., sep = "") } else function(...) {} ## begin iteration wts <- matrix(NA_real_, ncol = nModels, nrow = R) for(iter in 1L:R) { traceinfo("iteration=", iter, "\n") for (u in seq.int(maxtrials)) { traceinfo(" trial=", u, "\n ") i <- sample.int(nall, n1) y1 <- Z[i, jresp, drop = FALSE] y2 <- Z[-i, jresp, drop = FALSE] vy2 <- yvectorize(y2) x1 <- Z[i, jterms, drop = FALSE] x2 <- Z[-i, jterms, drop = FALSE] prwts1 <- Z[i, jprwts] prwts2 <- Z[-i, jprwts] ic <- numeric(nModels) for (k in seq.int(nModels)) { traceinfo("k=", k, " ") fit1 <- glm.fit(x1[, combin[, k], drop = FALSE], y1, family = fam, weights = prwts1, offset = off) if (problem <- (anyNA(fit1$coefficients) || !fit1$converged)) { traceinfo("") break } ic[k] <- aicloglik_glm_fit(fit1, vy2, x2[, combin[, k], drop = FALSE], prwts2, off)[weight.by] } traceinfo("\n") if (!problem) break } d <- exp(-ic / 2) wts[iter, ] <- d/sum(d) } wts[!is.finite(wts)] <- NA_real_ wts <- wts[round(rowSums(wts, na.rm = TRUE)) == 1, ] wts <- wts/rowSums(wts, na.rm = TRUE) wtsmean <- colMeans(wts) cfnames <- colnames(Z[, jterms]) x <- Z[, jterms, drop = FALSE] y <- Z[, jresp, drop = FALSE] msTable <- matrix(NA_real_, nrow = nModels, ncol = 6L, dimnames = list(1L:nModels, c("df", "logLik", "AIC", "delta", "weight", "ARM weight"))) ## coefArray(model, c(coef, se, df), coefficients) coefArray <- array(NA_real_, dim = c(nModels, 3L, length(cfnames)), dimnames = list(1L:nModels, c("Estimate", "Std. Error", "df"), cfnames)) for (k in seq.int(nModels)) { fit1 <- glm.fit(x[, combin[, k], drop = FALSE], y, family = fam, offset = off) coefArray[k, , combin[, k]] <- rbind(t(summary.glm(fit1)$coefficients[, 1L:2L, drop = FALSE]), fit1$df.residual) msTable[k, c(3L, 2L, 1L)] <- aicloglik_glm_fit(fit1, fit1$y, x[, combin[, k], drop = FALSE], fit1$prior.weights, off) } msTable[, 4L] <- msTable[, 3L] - min(msTable[, 3L]) msTable[, 5L] <- Weights(msTable[, 3L]) msTable[, 6L] <- wtsmean cfmat <- coefArray[, 1L, ] cfmat[is.na(cfmat)]<- 0 coefMat <- array(dim = c(2L, ncol(cfmat)), dimnames = list(c("full", "subset"), colnames(cfmat))) coefMat[1L, ] <- drop(wtsmean %*% cfmat) #debug <- list(wtsmean = wtsmean, cfmat = cfmat, coefArray = coefArray) ass <- attr(mm, "assign") bp <- !is.na(coefArray[, 1L, ass != 0L & !duplicated(ass)]) tenm <- allterms[ordtrm] allmodelnames <- .modelNames(allTerms = apply(bp, 1L, function(z) tenm[z]), uqTerms = tenm) rownames(msTable) <- c(allmodelnames) ordmod <- order(msTable[,4L], decreasing = FALSE) rval <- list( msTable = structure(as.data.frame(msTable[ordmod, ]), term.codes = attr(allmodelnames, "variables")), coefficients = coefMat, coefArray = coefArray[ordmod, , ], sw = { structure(wtsmean %*% bp, n.models = structure(colSums(bp), names = tenm), names = tenm, class = "sw") }, formula = object$formula, call = match.call() #, debug = debug ) attr(rval, "rank") <- .getRank(AIC) ## TODO attr(rval, "nobs") <- nrow(x) attr(rval, "beta") <- "none" attr(rval, "revised.var") <- TRUE attr(rval, "arm") <- TRUE attr(rval, "model.weights") <- "ARM" class(rval) <- "averaging" rval } armWeights <- function(object, ..., data, weight.by = c("aic", "loglik"), R = 1000) { weight.by <- switch(match.arg(weight.by), aic = 1L, loglik = 2L) models <- getModelArgs() m <- length(models) if(m < 2) stop("need more than one model") p <- 0.5 if(!all(vapply(models, inherits, TRUE, "lm"))) stop("'models' must inherit from \"lm\" class") R <- as.integer(R[1L]) if(R <= 1) stop("'R' must be positive") n <- nrow(data) nt <- ceiling(n * p) maxtrials <- 3L wmat <- array(dim = c(R, m)) r <- counter <- 1L counterLimit <- R * maxtrials # mode(R) <- mode(counterLimit) <- "integer" while(counter < counterLimit && r <= R) { counter <- counter + 1L k <- sample.int(n, size = nt) data.test <- data[-k, , drop = FALSE] data.train <- data[k, , drop = FALSE] y.test <- get.response(models[[1L]], data.test) for(j in seq.int(m)) { fit <- models[[j]] tf <- terms(fit) fam <- family(fit) off <- fit$offset if(is.null(off)) off <- rep(0, n) wts <- fit$weights if(is.null(wts)) wts <- rep(1, n) fit1 <- do_glm_fit(tf, data.train, family = fam, weights = wts[k], offset = off[k]) if(!fit1$converged) break wmat[r, j] <- aicloglik_glm_fit(fit1, y.test, model.matrix(tf, data.test), wts[-k], off[-k])[weight.by] } if(!anyNA(wmat[r, ])) r <- r + 1L } wmat <- exp(-wmat / 2) wts <- colMeans(wmat) wts <- wts / sum(wts) structure(wts, wt.type = "ARM", names = names(models), class = c("model.weights", "numeric")) } MuMIn/R/init.R0000644000176200001440000000175215161443462012541 0ustar liggesusers.onLoad <- function(libname, pkgName) { # Ugly tricks to put own replacement methods on top (don't try this at home): asNeeded <- function(pkgName, fun) { if(paste("package", pkgName, sep = ":") %in% search()) fun() else setHook(packageEvent(pkgName, "attach"), fun) } regmethod <- function(funname, classname, s4 = FALSE, fun = get(paste0(funname, ".", classname), getNamespace(.packageName)), envir = .GlobalEnv) do.call(if(s4) methods::setMethod else "registerS3method", list(funname, classname, fun), envir = envir) regMethodsOnPkgAttach <- function(pkgName, funname, classname, s4 = FALSE) asNeeded(pkgName, function(...) for(a in classname) regmethod(funname, a, s4)) regMethodsOnPkgAttach("unmarked", "logLik", "unmarkedFit", TRUE) regMethodsOnPkgAttach("nlme", "predict", c("lme", "gls")) regMethodsOnPkgAttach("xtable", "xtable", c("summary.averaging", "averaging", "model.selection")) } MuMIn/R/coefTable-methods.R0000644000176200001440000001302215161443462015114 0ustar liggesusers `coefTable.default` <- function(model, ...) { dfs <- tryCatch(df.residual(model), error = function(e) NA_real_) cf <- summary(model, ...)$coefficients .makeCoefTable(cf[, 1L], cf[, 2L], dfs, coefNames = rownames(cf)) } `coefTable.lm` <- `coefTable.betareg` <- function(model, ...) .makeCoefTable(coef(model), sqrt(diag(vcov(model, ...))), df.residual(model)) `coefTable.survreg` <- function(model, ...) { .makeCoefTable( coeffs(model), sqrt(diag(vcov(model, ...))), NA, ) } `coefTable.coxph` <- function(model, ...) { .makeCoefTable(coef(model), if(all(is.na(model$var))) rep(NA_real_, length(coef(model))) else sqrt(diag(model$var)), model$df.residual) } `coefTable.glmmML` <- function(model, ...) .makeCoefTable(model$coefficients, model$coef.sd) `coefTable.gls` <- function (model, ...) .makeCoefTable(coef(model), sqrt(diag(as.matrix(model$varBeta))), model$dims$N - model$dims$p) `coefTable.lme` <- function(model, adjustSigma = TRUE, ...) { se <- sqrt(diag(as.matrix(model$varFix))) if (adjustSigma && model$method == "ML") se <- se * sqrt(model$dims$N / (model$dims$N - length(se))) .makeCoefTable(nlme::fixef(model), se, model$fixDF[["X"]]) } `coefTable.multinom` <- function (model, ...) { .makeCoefTable(coeffs(model), sqrt(diag(vcov(model, ...)))) } `coefTable.coxme` <- `coefTable.lmekin` <- function(model, ...) { # code from coxme:::print.coxme beta <- model$coefficients # for class coxme: if(is.list(beta) && !is.null(beta$fixed)) beta <- beta$fixed # for class lmekin and older coxme nvar <- length(beta) if(nvar) { nfrail <- nrow(model$var) - nvar se <- sqrt(get("diag", getNamespace("Matrix"))(model$var)[nfrail + 1L:nvar]) } else se <- NULL .makeCoefTable(beta, se) } `coefTable.rq` <- function(model, ...) .makeCoefTable(model$coefficients, rep(NA_real_, length(model$coefficients))) `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 <- paste0(rep(names(cts), vapply(cts, nrow, 1L)), "_", rownames(ct)) .makeCoefTable(ct[, 1L], ct[, 2L], coefNames = cfnames) #.makeCoefTable(coef(model), sqrt(diag(vcov(model, ...)))) } `coefTable.aodql` <- `coefTable.glimML` <- function(model, ...) .makeCoefTable(coef(model), sqrt(diag(vcov(model, ...)))) coefTable.unmarkedFit <- function (model, ...) { vcv <- umf_vcov(model, ...) cf <- coef(model) se <- if(is.null(vcv)) rep(NA_real_,length(cf)) else sqrt(diag(vcv)) .makeCoefTable(cf, se) } `coefTable.gee` <- `coefTable.geeglm` <- function(model, ..., type = c("naive", "robust")) { cf <- summary(model, ...)$coefficients j <- if(match.arg(type) == "naive") 2L else 4L .makeCoefTable(cf[, 1L], cf[, j], coefNames = rownames(cf)) } `coefTable.geem` <- function(model, ..., type = c("naive", "robust")) { smr <- summary(model) .makeCoefTable(smr$beta, smr[[if(match.arg(type) == "naive") "se.model" else "se.robust"]], coefNames = smr$coefnames) } `coefTable.geese` <- function(model, ..., type = c("naive", "robust")) { cf <- summary(model, ...)$mean type <- match.arg(type) j <- if(type == "naive") 2L else 4L .makeCoefTable(cf[, 1L], cf[, j], coefNames = rownames(cf)) } `coefTable.yagsResult` <- function(model, ..., type = c("naive", "robust")) { type <- match.arg(type) vcv <- slot(model, if(type == "naive") "naive.parmvar" else "robust.parmvar") .makeCoefTable(model@coefficients, sqrt(diag(vcv)), coefNames = model@varnames) } `coefTable.splm` <- function (model, ...) { cf <- sapply(c("coefficients", "arcoef", "errcomp"), function(i) if(is.matrix(model[[i]])) model[[i]][, 1L] else model[[i]], simplify = FALSE) ncf <- sapply(cf, length) vcovlab <- c(coefficients = "vcov", arcoef = "vcov.arcoef", errcomp = "vcov.errcomp") se <- sqrt(unlist(lapply(names(vcovlab), function(i) { vcv2 <- diag(model[[vcovlab[i]]]) c(vcv2, rep(NA_real_, ncf[[i]] - length(vcv2))) }))) .makeCoefTable(unlist(cf, use.names = FALSE), se, coefNames = unlist(lapply(cf, names), use.names = FALSE)) } `coefTable.MCMCglmm` <- function (model, ...) { cf <- coeffs(model) .makeCoefTable(cf, se = rep(NA_real_, length.out = length(cf))) } `coefTable.gamm` <- function (model, ...) coefTable.lm(model$gam, ...) `coefTable.mark` <- function (model, orig.names = FALSE, ...) { dfs <- model$results[['n']] - model$results[['npar']] beta <- model$results[['beta']] .makeCoefTable(beta[, 1L], beta[, 2L], dfs, coefNames = if(orig.names) rownames(beta) else gsub("^([a-zA-Z]+):(.*)$", "\\1(\\2)", rownames(beta), perl = TRUE)) } `coefTable.logistf` <- function (model, ...) .makeCoefTable(model$coefficients, sqrt(diag(model$var))) `coefTable.aodml` <- function (model, ...) { .makeCoefTable(coeffs(model), sqrt(diag(vcov(model)))) #.makeCoefTable(coeffs(model), sqrt(diag(model$varparam))) } ## XXX: fixed effects coefficients only `coefTable.asreml` <- function (model, ...) { .makeCoefTable( x = model$coefficients$fixed, se = sqrt(model$vcoeff$fixed * model$sigma2) ## ? ) } `coefTable.cplm` <- function (model, ...) .makeCoefTable(coef(model), sqrt(diag(vcov(model))), model@df.residual) `coefTable.cpglmm` <- function (model, ...) .makeCoefTable(coeffs(model), sqrt(diag(vcov(model)))) `coefTable.maxlikeFit` <- function (model, ...) .makeCoefTable(model$Est[, 1L], model$Est[, 2L]) coefTable.bic.glm <- function (model, ...) { .makeCoefTable(model$condpostmean, model$condpostsd, NA_integer_, dimnames(model$mle)[[2L]]) } MuMIn/R/print.model.selection.R0000644000176200001440000000705215161443462016014 0ustar liggesusers`print.model.selection` <- function(x, abbrev.names = TRUE, warnings = getOption("warn") != -1L, ...) { origx <- x class(x) <- "data.frame" xterms <- attr(origx, "terms") # TERMS if(is.null(xterms) || !all(xterms %in% colnames(x)[seq_along(xterms)])) { print.data.frame(x, ...) } else { if(abbrev.names) xterms <- abbreviateTerms(xterms, 6L, 3L, deflate = TRUE) colnames(x)[seq_along(xterms)] <- xterms globcl <- attr(origx, "global.call") if(!is.null(globcl)) { cat("Global model call: ") print(globcl) cat("---\n") random.terms <- attr(getAllTerms(attr(origx, "global")), "random.terms") if(!is.null(random.terms)) random.terms <- list(random.terms) } else random.terms <- attr(origx, "random.terms") dig <- c(terms = NA, varying = NA, extra = NA, df = 0L, loglik = 3L, ic = 1L, delta = 2L, weight = 3L) column.types <- attr(origx, "column.types") #stopifnot(names(dig) == levels(column.types)) ## DEBUG decprint <- dig[column.types[colnames(x)]] i <- vapply(x, is.numeric, FALSE) & is.na(decprint) x[, i] <- signif(x[, i], 4L) k <- which(!is.na(decprint)) for(i in k) x[, i] <- round(x[, i], digits = decprint[i]) vLegend <- NULL if(abbrev.names) { vCols <- type2colname(column.types, "varying") vCols <- vCols[(vCols %in% colnames(x)) & !(vCols %in% c("class"))] if(!is.null(vCols) && length(vCols) != 0L) { vlen <- nchar(vCols) vLegend <- vector(length(vCols), mode = "list") names(vLegend) <- vCols x[, vCols] <- droplevels(x[, vCols, drop = FALSE]) for(i in vCols) { if(!is.factor(x[, i])) next lev <- levels(x[, i]) lev <- lev[!(lev %in% c("", "NULL"))] shlev <- abbreviateTerms(lev, nchar(i), deflate = TRUE) x[, i] <- factor(x[, i], levels = lev, labels = shlev) if(any(j <- shlev != lev)) vLegend[[i]] <- paste(shlev[j], "=", sQuote(lev[j])) } vLegend <- vLegend[!vapply(vLegend, is.null, TRUE)] } } uqran <- unique(unlist(random.terms, use.names = FALSE)) abbran <- abbreviateTerms(gsub("1 | ", "", uqran, fixed = TRUE), 1L, deflate = TRUE) colran <- vapply(random.terms, function(s) paste(abbran[match(s, uqran)], collapse = "+"), "") if(addrandcol <- length(unique(colran)) > 1L) { k <- which(colnames(x) == "df")[1L] x <- cbind(x[, 1L:(k - 1L), drop = FALSE], random = colran, x[, k:ncol(x), drop = FALSE], deparse.level = 0L) } cat("Model selection table \n") if(nrow(x) == 0L) { print.default(colnames(x), quote = FALSE) cat("<0 rows>", "\n") } else print.default(as.matrix(x)[, !vapply(x, function(y) all(is.na(y)), FALSE), drop = FALSE], na.print = "", quote = FALSE, right = TRUE) indent <- " " if(abbrev.names && length(vLegend) != 0L) { cat("Abbreviations:", sep = "\n") lab <- format(paste0(indent, names(vLegend), ":")) for(i in seq_along(vLegend)) { cat(vLegend[[i]], sep = ", ", fill = TRUE, labels = c(lab[i], rep(paste0(rep(" ", nchar(lab[i])), collapse = ""), length(vLegend[[i]]) - 1L))) } } cat("Models ranked by", asChar(.getRankCall(attr(origx, "rank"))), "\n") if(!is.null(random.terms)) { if(addrandcol) { cat("Random terms: \n") cat(paste0(indent, format(abbran), ": ", uqran), sep = "\n") } else { cat("Random terms (all models): \n") cat(paste(uqran), sep = ", ", fill = TRUE, labels = indent) cat("\n") } } if (warnings && !is.null(attr(origx, "warnings"))) { cat("\n") print.warnings(attr(origx, "warnings")) } } invisible(origx) } MuMIn/R/getAllTerms.R0000644000176200001440000002170315161443462014017 0ustar liggesusers`getAllTerms.default` <- #function(x, ...) getAllTerms.formula(as.formula(formula(x)), ...) function(x, ...) getAllTerms.terms(terms(as.formula(formula(x))), ...) `getAllTerms.gam` <- function(x, intercept = FALSE, offset = TRUE, ...) getAllTerms.terms(terms(formula(x), ...), intercept = intercept, offset = offset) `getAllTerms.lm` <- function(x, intercept = FALSE, offset = TRUE, ...) getAllTerms.terms(terms(x, ...), intercept = intercept, offset = offset) `getAllTerms.terms` <- function(x, intercept = FALSE, offset = TRUE, ...) { interceptLabel <- "(Intercept)" variables <- attr(x, "variables")[-1L] if (!is.null(attr(x, "offset"))){ offs <- sapply(variables[attr(x, "offset")], deparse1) } else offs <- NULL ans <- attr(x, "term.labels") # Get term names, with higher order term components arranged alphabetically if (length(ans) > 0L) { factors <- attr(x, "factors") factors <- factors[order(rownames(factors)), , drop = FALSE] v <- rownames(factors) ans <- apply(factors != 0L, 2L, function(x) paste0(v[x], collapse = ":")) } # Leave out random terms (lmer type) .is.re <- function(x) { n <- length(x) if(n == 3L && x[[1L]] == "|") return(1L) if(n == 2 && is.call(x[[2L]]) && x[[2L]][[1L]] == "|") return(2L) return(0L) } reType <- vapply(variables, .is.re, 0L) # 1 -> (terms|group), 2 -> struc(terms|group) ran <- as.character(variables[reType != 0L]) ifx <- !(ans %in% ran) ans <- ans[ifx] # ifx - indexes of fixed terms # finally, sort by term order and then alphabetically ord <- order(attr(x, "order")[ifx], gsub("I\\((.*)\\)", "\\1", ans)) ans <- unname(ans[ord]) deps <- if (length(ans) > 0L) termdepmat(reformulate(ans)) else matrix(FALSE, 0L, 0L) dimnames(deps) <- list(ans, ans) diag(deps) <- NA if(intercept && attr(x, "intercept")) { ans <- c(interceptLabel, ans) ord <- c(1L, ord + 1L) } if (!is.null(offs[1L])) { if (offset) { ans <- c(ans, offs) ord <- c(ord, length(ord) + 1L) } attr(ans, "offset") <- offs } attr(ans, "intercept") <- attr(x, "intercept") attr(ans, "interceptLabel") <- interceptLabel if (length(ran) > 0L) { attr(ans, "random.terms") <- ran i <- reType[reType != 0L] == 1L ran1 <- ran ran1[i] <- paste0("(", ran1[i], ")") f.random <- reformulate(c(".", ran1), response = ".") environment(f.random) <- environment(x) attr(ans, "random") <- f.random } response <- attr(x, "response") response <- if(response == 0L) NULL else variables[[response]] attr(ans, "response") <- response attr(ans, "sortorder") <- order(ord) attr(ans, "deps") <- deps ans } `getAllTerms.formula` <- function(x, ...) getAllTerms.terms(terms.formula(x), ...) `getAllTerms.lme` <- function(x, ...) { termsobj <- if(inherits(x, "glmmPQL")) terms(formula(x), data = x$data) else terms(x) ret <- getAllTerms.terms(termsobj, ...) attr(ret, "random") <- . ~ . # Code from nlme:::print.reStruct, modified slightly reStruct <- x$modelStruct$reStruct nobj <- length(reStruct) if (is.null(namx <- names(reStruct))) names(reStruct) <- nobj:1L aux <- t(array(rep(names(reStruct), nobj), c(nobj, nobj))) aux[lower.tri(aux)] <- "" reStruct[] <- rev(reStruct) aux <- t(array(rep(names(reStruct), nobj), c(nobj, nobj))) aux[lower.tri(aux)] <- "" attr(ret, "random.terms") <- paste(lapply(lapply(reStruct, attr, "formula"), "[[", 2L), "|", rev(apply(aux, 1L, function(z) paste(z[nzchar(z)], collapse = " %in% ")))) return(ret) } # Apparently there is no (explicit) intercept in coxph, but 'terms' gives # attr(,"intercept") == 1. `getAllTerms.coxph` <- function (x, ...) { ret <- getAllTerms.default(x, ...) attr(ret, "intercept") <- 0L attr(ret, "interceptLabel") <- NULL return(ret) } `getAllTerms.glmmML` <- function (x, ...) { ret <- getAllTerms.terms(terms(x), ...) attr(ret, "random.terms") <- paste("1 |", x$call$cluster) return(ret) } split_formula_by_bar <- function(f) { n <- length(f) ans <- if(length(f[[n]]) != 1L && f[[n]][[1L]] == "|") { f1 <- vector("list", 2L) for(i in 1L:2L) { f1[[i]] <- f f1[[i]][[n]] <- f[[n]][[i + 1L]] } f1 } else list(f) ans } `getAllTerms.hurdle` <- `getAllTerms.zeroinfl` <- function(x, intercept = FALSE, ...) { formList <- split_formula_by_bar(formula(x)) formList <- lapply(lapply(formList, terms.formula, data = eval(x$call$data, environment(formula(x)))), formula) z <- lapply(formList, getAllTerms, intercept = TRUE) if(oneform <- length(formList) == 1L) z <- c(z, z) deps <- termdepmat_combine(lapply(z, attr, "deps")) ord <- unlist(lapply(z, attr, "sortorder")) n <- sapply(z, length) if(length(z) > 1L) ord[-j] <- ord[-(j <- seq_len(n[1L]))] + n[1L] zz <- unlist(z) interceptIdx <- zz == "(Intercept)" offsetIdx <- match(zz, unique(unlist(lapply(z, attr,"offset"))), nomatch = 0) != 0 termIdx <- !(offsetIdx | interceptIdx) zz <- paste0(rep(c("count", "zero")[seq_along(z)], sapply(z, length)), "_", zz) dimnames(deps) <- list(zz[termIdx], zz[termIdx]) if(oneform) { # dependency of count_X and zero_X k <- length(zz[termIdx]) / 2 deps[c(seq(k + 1L, by = 2L * k + 1L, length.out = k), seq((2L * k * k) + 1L, by = 2L * k + 1L, length.out = k))] <- TRUE } ret <- if(!intercept) zz[!interceptIdx] else zz if(any(offsetIdx)) attr(ret, "offset") <- zz[offsetIdx] attr(ret, "intercept") <- pmin(which(interceptIdx), 1) attr(ret, "interceptLabel") <- zz[interceptIdx] attr(ret, "response") <- attr(z[[1L]], "response") attr(ret, "sortorder") <- if(!intercept) order(ord[!interceptIdx]) else ord attr(ret, "deps") <- deps ret } ## TODO: test with offsets `getAllTerms.betareg` <- function(x, intercept = FALSE, ...) { formList <- split_formula_by_bar(formula(x)) formList <- lapply(lapply(formList, terms.formula, data = model.frame(x)), formula) oneform <- length(formList) == 1L z <- lapply(formList, getAllTerms, intercept = TRUE) deps <- termdepmat_combine(lapply(z, attr, "deps")) ord <- unlist(lapply(z, attr, "sortorder")) n <- sapply(z, length) if(length(z) > 1L) ord[-j] <- ord[-(j <- seq_len(n[1L]))] + n[1L] zz <- unlist(z) interceptIdx <- zz == "(Intercept)" offsetIdx <- match(zz, unique(unlist(lapply(z, attr,"offset"))), nomatch = 0) != 0 termIdx <- !(offsetIdx | interceptIdx) if(!oneform && n[2L] != 0L) { i.phi <- -seq.int(n[1L]) zz[i.phi] <- paste("(phi)", zz[i.phi], sep = "_") } dimnames(deps) <- list(zz[termIdx], zz[termIdx]) ret <- if(!intercept) zz[!interceptIdx] else zz if(any(offsetIdx)) attr(ret, "offset") <- zz[offsetIdx] attr(ret, "intercept") <- pmin(which(interceptIdx), 1) attr(ret, "interceptLabel") <- zz[interceptIdx] attr(ret, "response") <- attr(z[[1L]], "response") attr(ret, "sortorder") <- if(!intercept) order(ord[!interceptIdx]) else ord attr(ret, "deps") <- deps ret } `getAllTerms.glimML` <- function(x, intercept = FALSE, ...) { ret <- getAllTerms.default(x, intercept = intercept, ...) ttran <- terms.formula(x@random) ran <- attr(ttran, "term.labels") if(length(ran)) attr(ret, "random.terms") <- paste("1 |", ran) ret } `getAllTerms.coxme` <- function(x, ...) { ret <- 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 } `getAllTerms.MCMCglmm` <- function (x, ...) { res <- getAllTerms.default(x, ...) attr(res, "random") <- .formulaEnv(.~., environment(formula(x))) attr(res, "random.terms") <- asChar(x$Random$formula)[1L] res } `getAllTerms.gamm` <- function (x, ...) getAllTerms(x$gam, ...) `getAllTerms.mark` <- function (x, intercept = FALSE, ...) { f <- formula(x, expand = FALSE)[[2L]] formlist <- list() while(length(f) == 3L && f[[1L]] == "+") { formlist <- c(f[[3L]], formlist) f <- f[[2L]] } formlist <- append(f, formlist) wrapfunc <- function(x, func) if(length(x) == 0L) x else paste0(func, "(", x, ")") alltermlist <- lapply(formlist, function(x, intercept) { func <- asChar(x[[1L]]) at <- getAllTerms(terms(eval(call("~", x[[2L]]))), intercept = intercept) at[] <- wrapfunc(at, func) dn <- wrapfunc(rownames(attr(at, "deps")), func) attr(at, "interceptLabel") <- wrapfunc(attr(at, "interceptLabel"), func) dimnames(attr(at, "deps")) <- list(dn, dn) at }, intercept) retval <- unlist(alltermlist, recursive = TRUE) for(a in c("intercept", "interceptLabel")) { attr(retval, a) <- unlist(sapply(alltermlist, attr, a)) } attr(retval, "sortorder") <- order(rep(seq_along(alltermlist), vapply(alltermlist, length, 1L)), unlist(lapply(alltermlist, attr, "sortorder"))) attr(retval, "deps") <- termdepmat_combine(lapply(alltermlist, attr, "deps")) retval } `getAllTerms.asreml` <- function(x, intercept = FALSE, ...) getAllTerms.terms(terms(formula(x)), intercept = intercept, ...) `getAllTerms.cpglmm` <- function (x, intercept = FALSE, ...) getAllTerms(x@formula, intercept = intercept, ...) `getAllTerms` <- function(x, ...) UseMethod("getAllTerms") MuMIn/R/desaturate.R0000644000176200001440000000036515161443462013736 0ustar liggesusers desaturate <- function(x, f = 1) { r <- x[, 1L] g <- x[, 2L] b <- x[, 3L] L <- 0.3 * r + 0.6 * g + 0.1 * b #L <- 0.6 * r + 0.1 * g + 0.3 * b cbind(r + f * (L - r), g + f * (L - g), b + f * (L - b)) } MuMIn/R/weights-boot.R0000644000176200001440000000467615161443462014221 0ustar liggesusers bootWeights <- function(object, ..., R, rank = c("AICc", "AIC", "BIC") ) { models <- getModelArgs() M <- length(models) if(M < 2) stop("need more than one model") checkIsModelDataIdentical(models) for(fm in models) { if(anyNA(match("x", names(fm)))) { warning("for efficiency of the bootstrap procedure, 'glm' should be called with 'x = TRUE'") break } } rank <- match.arg(rank) ic <- switch(rank, AICc = AICc, AIC = AIC, BIC = BIC) mseq <- seq.int(M) if(all(vapply(models, inherits, FALSE, "glm"))) { ## !force.update && best <- integer(R) ics <- numeric(M) no <- nobs(models[[1L]]) # assuming nobs is the same across models r <- 1L while(r <= R) { g <- sample.int(no, replace = TRUE) for(j in mseq) { fit <- models[[j]] fit1 <- glm.fit(model.matrix(fit)[g, , drop = FALSE], fit$y[g], fit$prior.weights[g], offset = fit$offset[g], family = fit$family) ics[j] <- ic(loglik_glm_fit(fit1)) } best[r] <- which.min(ics) r <- r + 1L } } else stop("all model objects must be of class \"glm\"") wts <- tabulate(best, M) wts <- wts / sum(wts) structure(wts, wt.type = "bootstrap", names = names(models), class = c("model.weights", class(wts))) } bootWeights2 <- function(object, ..., R, rank = c("AICc", "AIC", "BIC") ) { models <- getModelArgs() M <- length(models) if(M < 2) stop("need more than one model") checkIsModelDataIdentical(models) for(fm in models) { if(anyNA(match("x", names(fm)))) { warning("for efficiency of the bootstrap procedure, 'glm' should be called with 'x = TRUE'") break } } rank <- match.arg(rank) ic <- switch(rank, AICc = AICc, AIC = AIC, BIC = BIC) mseq <- seq.int(M) if(all(vapply(models, inherits, FALSE, "glm"))) { ## !force.update && best <- integer(R) ics <- numeric(M) no <- nobs(models[[1L]]) # assuming nobs is the same across models r <- 1L while(r <= R) { g <- sample.int(no, replace = TRUE) for(j in mseq) { fit <- models[[j]] fit1 <- glm.fit(model.matrix(fit)[g, , drop = FALSE], fit$y[g], fit$prior.weights[g], offset = fit$offset[g], family = fit$family) ics[j] <- ic(loglik_glm_fit(fit1)) } best[r] <- which.min(ics) r <- r + 1L } } else stop("all model objects must be of class \"glm\"") wts <- tabulate(best, M) wts <- wts / sum(wts) structure(wts, wt.type = "bootstrap", names = names(models), class = c("model.weights", class(wts))) } MuMIn/R/makeArgs.R0000644000176200001440000001434515161443462013332 0ustar liggesusers# combination of term names (a character vector), additional list of arbitrary # options is accepted. This is much a reverse action to getAllTerms makeArgs <- function(obj, termNames, opt, ...) UseMethod("makeArgs", obj) # opt == argsOptions #argsOptions <- list( # response = attr(allTerms0, "response"), # intercept = nInts, ### ONLY .default # interceptLabel = interceptLabel, # random = attr(allTerms0, "random"), # gmCall = gmCall, ### ONLY .default # gmEnv = gmEnv, # allTerms = allTerms0, # gmCoefNames = gmCoefNames, # gmDataHead = if(!is.null(gmCall$data)) { # if(eval(call("is.data.frame", gmCall$data), gmEnv)) # eval(call("head", gmCall$data, 1L), gmEnv) else gmCall$data # } else NULL, # gmFormulaEnv = gmFormulaEnv # ) .getCoefNames <- function(formula, data, contrasts, envir = parent.frame()) { colnames(eval(call("model.matrix.default", object = formula, data = data, contrasts.arg = contrasts), envir = envir)) } makeArgs.default <- function(obj, termNames, opt, ...) { reportProblems <- character(0L) termNames[termNames %in% opt$interceptLabel] <- "1" ## XXX: what if length(opt$intercept) > 1 ??? f <- reformulate(c(if(!opt$intercept) "0" else if (!length(termNames)) "1", termNames), response = opt$response) environment(f) <- opt$gmFormulaEnv ret <- list(formula = f) if(!is.null(opt$gmCall$start)) { coefNames <- fixCoefNames(.getCoefNames(f, opt$gmDataHead, opt$gmCall$contrasts, envir = opt$gmEnv)) idx <- match(coefNames, opt$gmCoefNames) if(anyNA(idx)) reportProblems <- append(reportProblems, "cannot subset 'start' argument. Coefficients in the model do not exist in 'global.model'") else ret$start <- substitute(start[idx], list(start = opt$gmCall$start, idx = idx)) } #attr(ret, "formulaList") <- list(f) attr(ret, "problems") <- reportProblems ret } makeArgs.gls <- makeArgs.wgee <- function(obj, termNames, opt, ...) { ret <- makeArgs.default(obj, termNames, opt) names(ret)[1L] <- "model" ret } `makeArgs.asreml` <- makeArgs.MCMCglmm <- makeArgs.lme <- function(obj, termNames, opt, ...) { ret <- makeArgs.default(obj, termNames, opt) names(ret)[1L] <- "fixed" ret } `makeArgs.glmmadmb` <- `makeArgs.merMod` <- ## since lme4-0.99999911-0 `makeArgs.mer` <- function(obj, termNames, opt, ...) { ret <- makeArgs.default(obj, termNames, opt) if(!is.null(opt$random)) ret[['formula']] <- update.formula(ret[['formula']], opt$random) ret } # clmm needs explicit "1" if no other FX terms `makeArgs.clmm` <- ## Class 'clmm' from package 'ordinal': function(obj, termNames, opt, ...) { ret <- makeArgs.merMod(obj, termNames, opt, ...) if(length(termNames) == 1L && identical(termNames[1L], opt$interceptLabel)) ret$formula[[3L]] <- call("+", 1, ret$formula[[3L]]) ret } `makeArgs.coxph` <- function(obj, termNames, opt, ...) { ret <- makeArgs.default(obj, termNames, opt) ret$formula <- update.formula(ret$formula, . ~ . + 1) ret } `makeArgs.betareg` <- function(obj, termNames, opt, ...) { i <- termNames %in% opt$interceptLabel termNames[i] <- gsub("(Intercept)", "1", termNames[i], fixed = TRUE) j <- grepl("^\\(phi\\)_", termNames) # TODO: zero-length terms in reformulate zarg <- list(beta = formula(terms.formula(reformulate(termNames[!j]), simplify = TRUE))) if(any(j)) zarg$phi <- formula(terms.formula(reformulate(substring(termNames[j], 7L)), simplify = TRUE)) zarg <- lapply(zarg, `environment<-`, opt$gmFormulaEnv) fexpl <- zarg$beta[[2L]] if(!is.null(zarg$phi)) fexpl <- call("|", fexpl, zarg$phi[[2L]]) else zarg$phi <- NULL ret <- list(formula = call("~", opt$response, fexpl)) #attr(ret, "formulaList") <- zarg ret } `makeArgs.hurdle` <- `makeArgs.zeroinfl` <- function(obj, termNames, opt, ...) { intType <- substring(opt$interceptLabel, 0, regexpr("_", opt$interceptLabel, fixed = TRUE) - 1L) i <- termNames %in% opt$interceptLabel termNames[i] <- gsub("(Intercept)", "1", termNames[i], fixed = TRUE) pos <- regexpr("_", termNames, fixed = TRUE) fnames <- c("count", "zero") # TODO: zero-length terms in reformulate zarg <- split(substring(termNames, pos + 1L, 256L), substring(termNames, 1L, pos - 1L)) for(j in fnames) zarg[[j]] <- if(is.null(zarg[[j]])) { if(j %in% intType) ~1 else ~0 } else formula(terms.formula(reformulate(as.character(zarg[[j]]), intercept = j %in% intType), simplify = TRUE)) zarg <- lapply(zarg, `environment<-`, opt$gmFormulaEnv) zarg <- zarg[fnames] fexpl <- zarg$count[[2L]] if(!is.null(zarg$zero)) fexpl <- call("|", fexpl, zarg$zero[[2L]]) else zarg$zero <- NULL ret <- list(formula = call("~", opt$response, fexpl)) #attr(ret, "formulaList") <- zarg ret } `makeArgs.coxme` <- `makeArgs.lmekin` <- function(obj, termNames, opt, ...) { ret <- makeArgs.default(obj, termNames, opt) ret$formula <- update.formula(update.formula(ret$formula, . ~ . + 1), opt$random) ret } `makeArgs.mark` <- function(obj, termNames, opt, ...) { interceptLabel <- "(Intercept)" termNames <- sub(interceptLabel, "1", termNames, fixed = TRUE) rxres <- regexpr("^([a-zA-Z]+)\\((.*)\\)$", termNames, perl = TRUE) cs <- attr(rxres, "capture.start") cl <- attr(rxres, "capture.length") parname <- substring(termNames, cs[, 1L], cs[, 1L] + cl[,1L] - 1L) parval <- substring(termNames, cs[, 2L], cs[, 2L] + cl[,2L] - 1L) formulaList <- lapply(split(parval, parname), function(x) { int <- x == "1" x <- x[!int] res <- if(!length(x)) if(int) ~ 1 else ~ 0 else reformulate(x, intercept = any(int)) environment(res) <- opt$gmFormulaEnv res }) mpar <- if(is.null(obj$model.parameters)) eval(opt$gmCall$model$parameters) else obj$model.parameters for(i in names(mpar)) mpar[[i]]$formula <- formulaList[[i]] #ret <- list(model.parameters = mpar) if(opt$gmCall[[1L]] == "run.mark.model") { arg.model <- opt$gmCall$model arg.model$parameters <- mpar ret <- list(model = arg.model) } else { ret <- list(model.parameters = mpar) } #attr(ret, "formulaList") <- formulaList ret } `makeArgs.aodml` <- function(obj, termNames, opt, ...) { if(sys.nframe() > 2L && (parent.call <- sys.call(-2L))[[1L]] == "dredge" && !is.null(get_call(obj)$fixpar)) stop(simpleError("'aodml' models with constant parameters cannot be handled by 'dredge'", call = parent.call)) makeArgs.default(obj, termNames, opt, ...) } MuMIn/R/r.squaredGLMM-helper-fn.R0000644000176200001440000001024115161443462016026 0ustar liggesusers## Helper functions: # RE model matrix .remodmat <- function(object) UseMethod(".remodmat") #.remodmat.default <- function(object) model.matrix(.ranform(formula(object)), data = model.frame(object)) .remodmat.default <- function(object) { env <- environment(formula(object)) rval <- lapply(.findbars(formula(object)), function(f) model.matrix(as.formula(call("~", f[[2L]]), env = env), data = model.frame(object))) rval <- do.call("cbind", rval) rval[, !duplicated(colnames(rval)), drop = FALSE] } .remodmat.merMod <- function(object) { rval <- do.call("cbind", model.matrix(object, type = "randomListRaw")) rval[, !duplicated(colnames(rval)), drop = FALSE] } .remodmat.lme <- function(object) model.matrix(object$modelStruct$reStruct, data = object$data[rownames(object$fitted), , drop = FALSE]) .nullUpdateWarning <- function(message = "the null model is only correct if all the variables it uses are identical \nto those used in fitting the original model.", Call = NULL) { if(!isTRUE(getOption("MuMIn.noUpdateWarning"))) cry(Call, message, warn = TRUE) } # .nullFitRE: update `object` to intercept only model, keeping original RE terms. # TODO: reOnlyModelCall or reOnlyFormula .nullFitRE <- function(object, envir) UseMethod(".nullFitRE") .nullFitRE.default <- function(object, envir = parent.frame()) { cl <- get_call(object) if(! "formula" %in% names(cl)) stop("cannot create a null model for an object without a named \"formula\" argument in its call. ") if(any(grepl("^..\\d$", all.names(cl)))) stop("object's call contains dotted names: ", sQuote(deparse(cl, control = NULL)), "and cannot be evaluated. See '?updateable' for a workaround.") cl$formula <- .nullREForm(formula(object)) .nullUpdateWarning() eval(cl, envir) } .nullFitRE.lme <- function(object, envir = parent.frame()) { cl <- getCall(object) cl$fixed <- update.formula(cl$fixed, . ~ 1) if(inherits(object, "glmmPQL")) cl$verbose <- FALSE .nullUpdateWarning() eval(cl, envir) } # sum up RE variance using VarCorr list # For RE-intercept identical to a sum of diagonals of VC matrices. # sum(sapply(lapply(vc, diag), sum)) .varRESum <- function(vc, X) { if(is.null(vc)) return(0) n <- nrow(X) sum(sapply(vc, function(sig) { mm1 <- X[, rownames(sig), drop = FALSE] sum(matmultdiag(mm1 %*% sig, ty = mm1)) / n })) } ## extracts random effect formula. e.g: .ranform <- function (form) { ### XXX: would give an error: values must be length 1 ... ### for very long RE formulas ans <- reformulate(vapply(lapply(.findbars(form), "[[", 2L), deparse, "", width.cutoff = 500L)) # XXX: Why? #update.formula( , ~ . + 1) environment(ans) <- environment(form) ans } # update model adding an observation level RE term .OLREFit <- function(object) UseMethod(".OLREFit") .OLREFit.default <- function(object) .NotYetImplemented() .OLREFit.merMod <- function(object) { if (!any(sapply(object@flist, nlevels) == nobs(object))) { cl <- get_call(object) frm <- formula(object) nRowData <- eval(call("eval", as.expression(call("NROW", cl$formula[[2L]])), envir = cl$data), envir = environment(frm), enclos = parent.frame()) fl <- length(frm) frx <- . ~ . + 1 frx[[3L]][[3L]] <- call("(", call("|", 1, call("gl", nRowData, 1))) cl$formula <- update.formula(frm, frx) object <- tryCatch(eval(cl, envir = environment(frm), enclos = parent.frame()), error = function(e) { cry(conditionCall(e), conditionMessage(e), warn = TRUE) cry(cl, "fitting model with the observation-level random effect term failed. Add the term manually") }) .nullUpdateWarning("the result is correct only if all variables used by the model remain unchanged.") warnonce(simpleMessage("turn off these warnings by setting 'options(\"MuMIn.noUpdateWarning\") to FALSE.", call = NULL), show.instance = 3L) } object } .binomial.sample.size <- function(object) { tt <- terms(formula(object)) y <- model.frame(object)[, rownames(attr(tt, "factors"))[attr(tt, "response")]] if(is.null(dim(y))) mean(weights(object, type = "prior")) else mean(rowSums(y)) } MuMIn/R/sumofweights.R0000644000176200001440000000212415161443462014314 0ustar liggesusers`sw` <- function(x) UseMethod("sw") `sw.averaging` <- function(x) return(x$sw) `sw.model.selection` <- function(x) { if(nrow(x) <= 1L) stop("argument consists of only one model") tt <- attr(x, "terms") z <- x[, tt, drop = FALSE] z <- !is.na(z[, !apply(apply(z, 2L, is.na), 2, all) & !(tt %in% attr(tt, "interceptLabel")), drop = FALSE]) wt <- x[, type2col(x, "weight")] res <- apply(z, 2L, function(y) sum(wt[y])) o <- order(res, decreasing = TRUE) res <- res[o] attr(res, "n.models") <- colSums(z)[o] class(res) <- c("sw", "numeric") return(res) } `print.sw` <- function(x, ...) { print.default(format(matrix(c( format(ifelse(x < 0.01, "<0.01", zapsmall(x, 2L)), scientific = FALSE, justify = "r"), format(attr(x, "n.models"))), nrow = 2L, byrow = TRUE, dimnames = list(c("Sum of weights:", "N containing models:"), names(x))), justify = "r"), quote = FALSE) invisible(x) } #function(x) return(apply(x[, attr(x, "terms")], 2L, # function(z) sum(x[, "weight"][!is.na(z)]))) `sw.default` <- function(x) model.avg(x)$sw importance <- function(x) { .Defunct("sw") sw } MuMIn/R/methods-logLik.R0000644000176200001440000000716615161443462014465 0ustar liggesusers # replacement for stats:::logLik.logLik logLik.logLik <- function (object, ...) { if (!missing(...)) warning("extra arguments discarded") object } `logLik.glmmML` <- function(object, ...) { ret <- -object$deviance / 2 #ret <- df - object$aic / 2 n <- length(object$coefficients) attr(ret, "df") <- n + object$cluster.null.df - object$df.residual attr(ret, "nobs") <- n + object$cluster.null.df class(ret) <- "logLik" return(ret) } `logLik.glmmboot` <- function (object, ...) { ret <- object$logLik attr(ret, "nobs") <- object$n attr(ret, "df") <- object$n - object$df.residual class(ret) <- "logLik" return(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 } `logLik.unmarkedFit` <- function(object, ...) { ret <- -object@negLogLike attr(ret, "df") <- length(object@opt$par) attr(ret, "nobs") <- #get("sampleSize", asNamespace("unmarked"))(object) unmarked::sampleSize(object) class(ret) <- "logLik" return(ret) } `logLik.splm` <- function (object, ...) { ret <- object$logLik #if(is.null(ret)) return(NA) if(is.null(ret)) ret <- NA_real_ attr(ret, "nobs") <- length(resid(object)) attr(ret, "df") <- length(object$coefficients) + length(object$errcomp) + length(object$arcoef) + 1L class(ret) <- "logLik" ret } `logLik.MCMCglmm` <- function (object, ...) structure(-0.5 * mean(object$Deviance), df = sum(object$Fixed$nfl, object$Random$nfl, object$Residual$nfl), nobs = object$Residual$nrl, class = "logLik") `logLik.gamm` <- function (object, ...) logLik(object[[if(is.null(object$lme)) "mer" else "lme"]], ...) `logLik.mark` <- function (object, adjust = TRUE, ...) { res <- -0.5 * object$results$lnl attr(res, "df") <- object$results[[if(!adjust && !is.null(object$results$npar.unadjusted)) 'npar.unadjusted' else 'npar']] attr(res, "nobs") <- object$results$n class(res) <- "logLik" res } `logLik.logistf` <- function (object, ...) { res <- object$loglik[2L] attr(res, "nobs") <- object$n attr(res, "df") <- object$df + 1L class(res) <- "logLik" res } `logLik.asreml` <- function (object, ...) { res <- object$loglik ## 'df' here is the number of fixed effect coefficients + number of variance ## parameters (non-fixed and non-constained). This gives comparable numbers ## to respective lmer models. Note however that 'Asreml-R manual' only the ## number of variance components is used as K for AIC calculation (page 15). ## Also logLik values are far different from those from lmer(REML = TRUE), ## even though coefficients are very similar. mon <- object$monitor attr(res, "nobs") <- nobs <- length(resid(object)) attr(res, "df") <- (nobs - object$nedf) + sum(!is.na(mon$constraint) & !(mon$constraint %in% c("Fixed", "Constrained"))) # sum(!(summ$varcomp$constraint %in% c("Fixed", "Constrained"))) class(res) <- "logLik" res } `logLik.phylolm` <- function (object, ...) { res <- object$logLik attr(res, "df") <- object$p attr(res, "nobs") <- object$n class(res) <- "logLik" res } `logLik.cplm` <- ## based on stats:::logLik.glm function (object, ...) { if (!missing(...)) warning("extra arguments discarded") n <- sum(!is.na(resid(object))) p <- n - object@df.residual val <- p - object@aic / 2 attr(val, "nobs") <- sum(!is.na(resid(object))) attr(val, "df") <- p class(val) <- "logLik" val } logLik.maxlikeFit <- function (object, ...) { ll <- -object$optim$value attr(ll, "nobs") <- nrow(object[['points.retained']]) attr(ll, "df") <- nrow(object$Est) class(ll) <- "logLik" ll } MuMIn/R/utils-debug.R0000644000176200001440000000101015161443462014005 0ustar liggesusers`.DebugPrint` <- function (x) { if (isTRUE(getOption("debug.MuMIn"))) { fun <- asChar(sys.call(sys.parent())[[1L]]) name <- substitute(x) cat(sprintf("<%s> ~ ", fun)) if(is.language(name)) cat(asChar(name), "= \n") print(x) } } `.Debug` <- function(expr) { if(isTRUE(getOption("debug.MuMIn"))) { eval.parent(substitute(expr)) } } `srcc` <- function() { ret <- eval(expression(source("clipboard", local = TRUE)), .GlobalEnv) return(if(ret$visible) ret$value else invisible(ret$value)) } MuMIn/R/methods-predict.R0000644000176200001440000001037015161443462014665 0ustar liggesusers## Predict methods for objects for which they are not available in their ## original packages, or replacements. # Add 'se.fit' argument for predict: # https://stat.ethz.ch/pipermail/r-help/2004-April/050144.html # http://web.archiveorange.com/archive/v/rOz2zbtjRgntPMuIDoIl # based on the original 'predict.gls' in package 'nlme' `predict.gls` <- function (object, newdata, se.fit = FALSE, na.action = na.fail, ...) { if (missing(newdata) && !se.fit) { return(fitted(object)) } form <- getFrom("nlme", "getCovariateFormula")(object) mfArgs <- list(formula = form, data = newdata, na.action = na.action) mfArgs$drop.unused.levels <- TRUE dataMod <- do.call(model.frame, mfArgs) contr <- object$contrasts for (i in names(dataMod)) { if (inherits(dataMod[, i], "factor") && !is.null(contr[[i]])) { levs <- levels(dataMod[, i]) levsC <- dimnames(contr[[i]])[[1]] if (any(wch <- is.na(match(levs, levsC)))) { stop(sprintf(ngettext(sum(wch), "level %s not allowed for %s", "levels %s not allowed for %s"), paste(levs[wch], collapse = ",")), domain = NA) } attr(dataMod[, i], "contrasts") <- contr[[i]][levs, , drop = FALSE] } } N <- nrow(dataMod) if (length(all.vars(form)) > 0) { X <- model.matrix(form, dataMod) } else { X <- array(1, c(N, 1), list(row.names(dataMod), "(Intercept)")) } cf <- coef(object) val <- c(X[, names(cf), drop = FALSE] %*% cf) if(se.fit) { se <- sqrt(matmultdiag(X %*% vcov(object), ty = X)) val <- list(fit = val, se.fit = unname(se)) } lab <- "Predicted values" if (!is.null(aux <- attr(object, "units")$y)) { lab <- paste(lab, aux) } structure(val, label = lab) } `predict.lme` <- function (object, newdata, level, asList = FALSE, na.action = na.fail, se.fit = FALSE, ...) { cl <- match.call() cl$se.fit <- NULL cl[[1L]] <- call("get", "predict.lme", asNamespace("nlme")) res <- eval.parent(cl) if(se.fit && (missing(level) || any(level > 0))) warning("cannot calculate standard errors for level > 0") if(se.fit && !missing(level) && length(level) == 1L && all(level == 0)) { if (missing(newdata) || is.null(newdata)) { X <- model.matrix(object, data = object$data) } else { tt <- delete.response(terms(formula(object))) xlev <- .getXlevels(tt, model.frame(object, data = object$data)) X <- model.matrix(tt, data = newdata, contrasts.arg = object$contrasts, xlev = xlev) } se <- sqrt(matmultdiag(X %*% vcov(object), ty = X)) # se <- sqrt(rowSums((X %*% vcov(object)) * X)) # se <- sqrt(diag(X %*% vcov(object) %*% t(X))) ## TODO: use matmult names(se) <- names(res) list(fit = c(res), se.fit = se) } else res } .predict_glm <- function (object, newdata, type = c("link", "response"), se.fit = FALSE, trms, coeff, offset, ...) { type <- match.arg(type) if (!missing(newdata) && !is.null(newdata)) { xlev <- .getXlevels(trms, model.frame(trms, data = newdata)) X <- model.matrix(trms, data = newdata, contrasts.arg = attr(model.matrix(object), "contrasts"), xlev = xlev) offset <- rep(0, nrow(X)) if (!is.null(off.num <- attr(trms, "offset"))) for (i in off.num) offset <- offset + eval(attr(trms, "variables")[[i + 1L]], newdata) cl <- get_call(object) if (!is.null(cl$offset)) offset <- offset + eval(cl$offset, newdata) } else { X <- model.matrix(object) if (!length(offset)) offset <- NULL } y <- (X %*% coeff)[, 1L] if (!is.null(offset)) y <- y + offset fam <- family(object) if (se.fit) { # covmat <- as.matrix(vcov(object)) se <- sqrt(matmultdiag(X %*% as.matrix(vcov(object)), ty = X)) # se <- sqrt(rowSums((X %*% covmat) * X)) # se <- sqrt(diag(X %*% covmat %*% t(X))) if (type == "response" && inherits(fam, "family")) list(fit = fam$linkinv(y), se.fit = se * abs(fam$mu.eta(y))) else list(fit = y, se.fit = se) } else { if (type == "response" && inherits(fam, "family")) fam$linkinv(y) else y } } `predict.gamm` <- function (object, ...) mgcv::predict.gam(object[['gam']], ...) MuMIn/R/AICc.R0000644000176200001440000000434715161443462012340 0ustar liggesusers# AIC = -2 * LL + 2 * n # LL = -1/2 * log(dev) * n + C # AIC = log(dev) * n + C + 2 * n .get.nobs <- function(llik, error = FALSE) { no <- attr(llik, "nall") if(is.null(no)) no <- attr(llik, "nobs") if (error && is.null(no)) stop("'logLik' object must have a \"nobs\" attribute") no } .aic <- function(objectlist, chat, k, REML, ICFun, ICName) { if(chat < 1) { warning("'chat' given is < 1, increased to 1") chat <- 1 } npar.adj <- if(chat == 1) 0 else 1 llCall <- call("logLik", as.name("object")) if(!is.null(REML)) llCall$REML <- REML ll <- function(object) fixLogLik(NA, object) body(ll)[[2L]] <- llCall if(length(objectlist) > 1L) { lls <- lapply(objectlist, ll) val <- data.frame(df = vapply(lls, attr, 1, "df"), ic = sapply(lls, ICFun, chat = chat, k = k, npar.adj = npar.adj)) Call <- match.call(sys.function(sys.parent()), call = sys.call(sys.parent())) Call$chat <- Call$REML <- Call$k <- NULL dimnames(val) <- list(as.character(Call[-1L]), c("df", ICName)) return(val) } else { return(ICFun(ll(objectlist[[1L]]), chat = chat, k = k, npar.adj = npar.adj)) } } `QAICc` <- function(object, ..., chat, k = 2, REML = NULL) { .aic(list(object, ...), chat, k, REML, function(ll, chat, k, npar.adj) { no <- .get.nobs(ll, error = FALSE) # df is the number of parameters plus 1 for estimating c-hat df <- attr(ll, "df") + npar.adj #neg2ll <- log(deviance(object)) * n # + Constant... neg2ll <- -2 * c(ll) ret <- (neg2ll / chat) + (k * df) * (1 + ((df + 1) / (no - df - 1))) return (ret) }, "QAICc") } `QAIC` <- function(object, ..., chat, k = 2, REML = NULL) { .aic(list(object, ...), chat, k, REML, function(ll, chat, k, npar.adj) { df <- attr(ll, "df") + npar.adj neg2ll <- -2 * c(ll) #ret <- (neg2ll * no / chat) + k * df #ret <- -2 * ll / chat + k * df ret <- neg2ll / chat + k * df return (ret) }, "QAIC") } `AICc` <- function(object, ..., k = 2, REML = NULL) { .aic(list(object, ...), 1, k, REML, function(ll, chat, k, npar.adj) { no <- .get.nobs(ll, error = FALSE) df <- attr(ll, "df") ret <- (-2 * c(ll)) + (k * df) * (1 + ((df + 1) / (no - df - 1))) return (ret) }, "AICc") } #QAIC = -2log Likelihood/c-hat + 2K #QAICc = -2log Likelihood/c-hat + 2K + 2K(K + 1)/(n - K - 1) MuMIn/R/weights-cos2.R0000644000176200001440000000325515161443462014114 0ustar liggesusers cos2Weights <- function(object, ..., data, eps = 1E-6, maxit = 100, predict.args = list()) { models <- getModelArgs() M <- length(models) if(M < 2) stop("need more than one model") if(!all(vapply(models, inherits, TRUE, "lm"))) stop("'models' must inherit from \"lm\" class") #py <- sapply(models, predict, newdata = data, type = "response", ...) cl <- as.call(c(as.name("predict"), alist(models[[i]], newdata = data, type = "response"), predict.args)) # TODO: glm.fit version i <- 1L py1 <- eval(cl) if(is.array(py1)) { stop(">1-dimensional predictions cannot be handled yet") # assuming prediction is a matrix: (add some checking for it) py <- array(dim = c(dim(py1), M)) py[, , 1L] <- py1 for(i in seq.int(2L, M)) py[, , i] <- eval(cl) } else { py <- array(dim = c(length(py1), M)) py[, 1L] <- py1 for(i in seq.int(2L, M)) py[, i] <- eval(cl) } # if one model is constant: if (any(g <- apply(py, 2L, "sd") == 0)) py[, g] <- py[, g] + rnorm(NROW(py)) sqrtm <- getFrom("expm", "sqrtm") R <- cor(py) nR <- NCOL(R) D1 <- diag(rep(2, nR)) D2 <- diag(nR) counter <- 0L while (any(abs(diag(D1) - diag(D2)) > eps)) { ED <- eigen(D1 %*% R %*% D1) Q <- ED$vectors Lambda <- diag(ED$values) ## test: #Q %*% Lambda %*% solve(Q) # fine Lambda12 <- sqrtm(Lambda) E <- solve(D1) %*% Q %*% Lambda12 %*% solve(Q) D2 <- D1 D1 <- diag(diag(Re(E))) counter <- counter + 1L if (counter >= maxit) { warning("maximum number of iterations reached without convergence") break } } wts <- diag(D2)^2 / sum(diag(D2)^2) structure(wts, wt.type = "cos-squared", names = names(models), class = c("model.weights", class(wts))) } MuMIn/R/substitution.R0000644000176200001440000001044415161443462014350 0ustar liggesusers# evaluate 'expr' in 'env' after adding variables passed as '...' evalExprInEnv <- function(expr, env, enclos, ...) { list2env(list(...), env) eval(expr, envir = env, enclos = enclos) } # change `names[]` for varName[1], varName[2], ... in expression # Not using `substitute` anymore to omit function calls. # Ignore also expressions within I(), elements extracted with $ or @ `.subst.names.for.items` <- function(expr, names, varName, n = length(names), fun = "[") { exprApply(expr, names, symbols = TRUE, function(x, v, fun, varName, parent) { if(is.call(parent) && any(parent[[1L]] == c("I", "$", "@"))) return(x) if(length(x) == 1L) return(call(fun, varName, match(asChar(x), v))) x }, v = names, fun = fun, varName = as.name(varName)) } # like substitute, but does evaluate 'expr'. subst <- function(expr, envir = NULL, ...) { eval.parent(call("substitute", expr, c(envir, list(...)))) } asChar <- function(x, control = NULL, nlines = 1L, ...) if(is.character(x)) x[1L:nlines] else deparse(x, control = control, nlines = nlines, ...) ## .sub_* functions used with '.exprapply' as 'func' .subst.term <- function(x) { if(length(x) < 2L) cry(x, "'Term' needs one argument") as.name(asChar(x[[2L]])) } .subst.with <- function (x, fac, allTerms, vName, envir = parent.frame()) { if (length(x) > 4L) cry(x, "too many arguments [%d]", length(x) - 1L) if (length(x[[2L]]) == 2L && x[[2L]][[1L]] == "+") { fun <- "all" sx <- asChar(x[[2L]][[2L]], backtick = FALSE) } else { fun <- "any" sx <- asChar(x[[2L]], backtick = FALSE) } dn <- dimnames(fac) if (!(sx %in% dn[[2L]])) cry(x, "unknown variable name '%s'", sx) xorder <- if(length(x) >= 3L) as.integer(eval(x[[3L]], envir)) else unique(rowSums(fac)) i <- which(fac[, sx]) j <- which(is.element(rowSums(fac[i, , drop = FALSE]), xorder)) if(length(j) == 0L) cry(x, "no terms match the criteria") as.call(c(as.name(fun), call("[", vName, as.call(c(as.name("c"), match(dn[[1L]][i[j]], allTerms)))))) } ## dc(fun(a), x + y) --> dc(`fun(a)`, `x + y`) .subst.vars.for.args <- function(e) { for(i in 2L:length(e)) if(!is.name(e[[i]])) e[[i]] <- as.name(asChar(e[[i]])) e } .subst.has <- function(e) { n <- length(e) for(i in seq.int(2L, n)) { ex <- if(length(e[[i]]) == 2L && e[[i]][[1L]] == "!") call("is.na", e[[i]][[2L]]) else call("!", call("is.na", if(is.name(e[[i]])) e[[i]] else as.name(asChar(e[[i]])))) res <- if(i == 2L) ex else call("&", res, ex) } call("(", res) } .subst.has.dc <- function(e) { for(i in 2L:length(e)) e[[i]] <- call("has", e[[i]]) e } .subst.v <- function(x, cVar, fn) { if(length(x) > 2L) cry(x, "discarding extra arguments", warn = TRUE) i <- which(fn == x[[2L]])[1L] if(is.na(i)) cry(x, "'%s' is not a valid name of 'varying' element", as.character(x[[2L]]), warn = TRUE) call("[[", cVar, i) } # substitute function calls in 'e'. 'func' must take care of the substitution job. `exprapply0` <- function(e, name, func, ...) exprApply(e, name, func, ..., symbols = FALSE) `exprApply` <- function (expr, what, FUN, ..., symbols = FALSE) { FUN <- match.fun(FUN) if(all(names(formals(FUN)) != "parent")) formals(FUN)[["parent"]] <- NA .exprapply(expr, what, FUN, ..., symbols = symbols) } `.exprapply` <- function (expr, what, FUN, ..., symbols = FALSE, parent = NULL) { self <- sys.function() if((ispairlist <- is.pairlist(expr)) || is.expression(expr)) { for (i in seq_along(expr)) expr[i] <- list(self(expr[[i]], what, FUN, ..., symbols = symbols, parent = expr)) return(if(ispairlist) as.pairlist(expr) else expr) } n <- length(expr) if (n == 0L || !is.language(expr)) return(expr) if (n == 1L) { if (!is.call(expr)) { if (symbols && (anyNA(what) || any(expr == what))) expr <- FUN(expr, ..., parent = parent) return(expr) } } else { if(expr[[1L]] == "function") { if(n == 4L) { n <- 3L expr[[4L]] <- NULL ## remove srcref } } for (i in seq.int(2L, n)) { y <- self(expr[[i]], what, FUN, ..., symbols = symbols, parent = expr) if(!missing(y)) expr[i] <- list(y) } } if (anyNA(what) || (length(expr[[1L]]) == 1L && any(expr[[1L]] == what))) expr <- FUN(expr, ..., parent = parent) return(expr) } MuMIn/R/glm_fit.R0000644000176200001440000000446615161443462013224 0ustar liggesusers # helper function: prediction from matrix, coefficients and inverse link predict_glm_fit <- function(beta, x, offset, family = NULL) { if(is.null(offset)) offset <- 0 ok <- !is.na(beta) beta <- beta[ok] x <- x[, ok, drop = FALSE] if(inherits(family, "family")) return(family$linkinv(offset + (x %*% beta))) return(offset + (x %*% beta)) } update_glm_fit <- function(fit, data, weights, offset, nobs = nrow(data), y = NULL) { tf <- terms(fit) x <- model.matrix(tf, data = data) if(is.null(y)) { y <- get.response(tf, data) if(is.matrix(y)) { wts <- rowSums(y) y <- y[, 1L] / wts } else wts <- rep(1, nobs) weights <- weights * wts } glm.fit(x, y, weights, offset = offset, family = family(fit)) } do_glm_fit <- function(tf, data, family, weights, offset, nobs = nrow(data), y = NULL) { x <- model.matrix(tf, data = data) if(is.null(y)) { y <- get.response(tf, data) if(is.matrix(y)) { wts <- rowSums(y) y <- y[, 1L] / wts } else wts <- rep(1, nobs) weights <- weights * wts } glm.fit(x, y, weights, offset = offset, family = family) } aicloglik_glm_fit <- function(object, y, x, wt, offset = NULL) { fam <- object$family nobs <- NROW(x) n <- if (NCOL(y) == 1) rep.int(1, nobs) else rowSums(y) #mu <- fam$linkinv((x %*% object$coefficients)[, 1L]) mu <- predict_glm_fit(object$coefficients, x, offset, fam)[, 1L] dev <- sum(fam$dev.resids(y, mu, wt)) rank <- object$rank aic <- fam$aic(y, n, mu, wt, dev) + 2 * rank p <- rank if (fam$family %in% c("gaussian", "Gamma", "inverse.gaussian")) p <- p + 1 ll <- p - aic/2 # c(aic = aic, loglik = ll, nobs = nobs, df = p) c(aic, ll, p) } loglik_glm_fit <- function(object, aic = object$aic) { p <- object$rank if (object$family$family %in% c("gaussian", "Gamma", "inverse.gaussian")) p <- p + 1 structure(p - aic / 2, nobs = length(object$residuals), df = p, class = "logLik") } llik <- function(y, mu, fam, n, wt = 1, off = NULL) { # wt == fit$prior.weights no <- NROW(y) ep <- if (fam$family %in% c("gaussian", "Gamma", "inverse.gaussian")) 1 else 0 dev <- sum(fam$dev.resids(y, mu, wt)) (fam$aic(y, n, mu, wt, dev) / 2) - ep # +LL } # list(coefficients =, family =, rank=)MuMIn/R/class-gamlss.R0000644000176200001440000000472615161443462014173 0ustar liggesusers coeffs.gamlss <- function(model) { cf <- model[c('mu.coefficients', 'sigma.coefficients', 'nu.coefficients', 'tau.coefficients')] cf <- lapply(cf, function(x) x[!is.na(x)]) n <- vapply(cf, length, 0L) nm <- unlist(lapply(cf, names), recursive = FALSE, use.names = FALSE) nm[nm == "(Intercept)"] <- "(Int)" rval <- unlist(cf, use.names = FALSE, recursive = FALSE) pfx <- c("mu", "sigma", "nu", "tau") names(rval) <- paste0(rep(pfx, n), "(", nm, ")") rval } coefTable.gamlss <- function(model, ...) { cf <- coeffs(model) .makeCoefTable(cf, vcov(model, type = "se"), coefNames = names(cf)) } `makeArgs.gamlss` <- function(obj, termNames, opt, ...) { zarg <- umf_terms2formulalist(termNames, opt) formulanames <- c(mu = "formula", sigma = "sigma.formula", nu = "nu.formula", tau = "tau.formula")[ attr(opt$allTerms, "term.kind")] names(zarg) <- formulanames f <- zarg[[1L]][c(1L, NA, 2L)] f[[2L]] <- opt$response zarg[[1L]] <- f zarg } getAllTerms.gamlss <- function(x, intercept = FALSE, offset = TRUE, ...) { formlist <- list(mu = x$mu.formula, sigma = x$sigma.formula, nu = x$nu.formula, tau = x$tau.formula) formlist <- formlist[!vapply(formlist, is.null, logical(1L))] allterms <- lapply(formlist, getAllTerms.formula, intercept = FALSE, offset = offset, ...) attrint <- vapply(allterms, attr, 0L, "intercept") term.prefix <- names(allterms) n <- length(allterms) rval <- vector("list", n) for(i in which(sapply(allterms, length) != 0L)) { rval[[i]] <- paste0(term.prefix[i], "(", allterms[[i]], ")") } rval <- unlist(rval) attrint <- vapply(allterms, attr, 0L, "intercept") names(attrint) <- term.prefix[match(names(attrint), term.prefix)] ints <- paste0(names(attrint[attrint != 0L]), "(", unlist(lapply(allterms, "attr", "interceptLabel")), ")") ints <- sub("((Intercept))", "(Int)", ints, fixed = TRUE) depslist <- lapply(allterms, attr, "deps") deps <- termdepmat_combine(depslist) if(ncol(deps) != 0L) colnames(deps) <- rownames(deps) <- paste0(rep(term.prefix, sapply(depslist, ncol)), "(", colnames(deps), ")") #dimnames(deps) <- list(rval, rval) if(intercept) rval <- c(ints, rval) mode(rval) <- "character" attr(rval, "intercept") <- attrint attr(rval, "interceptLabel") <- ints attr(rval, "response") <- attr(allterms$mu, "response") attr(rval, "term.kind") <- names(formlist) if(intercept) attr(rval, "interceptIdx") <- seq_along(ints) attr(rval, "deps") <- deps return(rval) } MuMIn/R/class-mark.R0000644000176200001440000000266215161443462013634 0ustar liggesusers`deviance.mark` <- function(object, ...) object$results[['deviance']] `confint.mark` <- function (object, parm, level = 0.95, ...) { cf <- object$results$beta[, 1L] nm <- names(cf) <- rownames(object$results$beta) df.residual <- object$results$n - object$results$npar vcv <- object$results$beta.vcv dimnames(vcv) <- list(nm, nm) pnames <- names(cf) if (missing(parm)) parm <- pnames else if (is.numeric(parm)) parm <- pnames[parm] a <- (1 - level) / 2 a <- c(a, 1 - a) fac <- qt(a, df.residual) pct <- format_perc(a, 3L) ci <- array(NA, dim = c(length(parm), 2L), dimnames = list(parm, pct)) ses <- sqrt(diag(vcv))[parm] ci[] <- cf[parm] + ses %o% fac ci } `formula.mark` <- function (x, expand = TRUE, ...) { param <- if(is.null(x$model.parameters)) x$parameters else x$model.parameters f <- lapply(param, "[[", 'formula') f <- f[!vapply(f, is.null, FALSE)] npty <- length(f) z <- vector(npty, mode = "list") pty <- names(f) if(expand) { for(i in seq_len(npty)) z[[i]] <- paste0(pty[i], "(", getAllTerms(f[[i]], intercept = TRUE), ")") res <- reformulate(gsub("((Intercept))", "(1)", unlist(z), fixed = TRUE)) } else { for(i in seq_len(npty)) z[[i]] <- call(pty[i], f[[i]][[2L]]) res <- z[[1L]] if(npty > 1L) for(i in seq(2L, npty)) res <- call("+", res, z[[i]]) res <- eval(call("~", res)) } environment(res) <- environment(f[[1L]]) res } MuMIn/R/predict.R0000644000176200001440000000776615161443462013243 0ustar liggesusersterms.averaging <- function (x, ...) { terms(formula(x)) } ## helper function toarray <- function(x) array(unlist(x), dim = c(dim(x[[1L]]), length(x)), dimnames = c(dimnames(x[[1L]]), list(names(x)))) mergeContrasts <- function(models) { ctr <- lapply(models, get.contrasts) ctrnm <- unique(unlist(lapply(ctr, names))) ret <- structure(vector("list", length = length(ctrnm)), names = ctrnm) for(x in ctr) { for(i in names(x)) { if(is.null(ret[[i]])) { ret[[i]] <- x[[i]] } else if(!identical(ret[[i]], x[[i]])) stop(gettextf("inconsistent contrasts in '%s'", i) ) } } ret } mergeMF <- function(models, check = TRUE) { mf <- model.frame(models[[1L]]) mfNames <- colnames(mf) lhs <- asChar(getResponseFormula(mf)) f <- attr(fixTermsObject(terms(mf)), "term.labels") #m <- models[[2]] for(m in models[-1L]) { mf1 <- model.frame(m) if(check && !identical(lhs, lhs1 <- asChar(getResponseFormula(mf1)))) stop("response differs between models: ", sQuote(c(asChar(lhs), lhs1))) mf <- cbind(mf, mf1[, !(colnames(mf1) %in% mfNames), drop = FALSE]) tt1 <- fixTermsObject(terms(mf1)) f <- c(f, attr(tt1, "term.labels")) if(!is.null(attr(tt1,"offset"))) f <- c(f, sapply(as.list(attr(tt1,"variables")[attr(tt1,"offset") + 1L]), asChar)) } f <- reformulate(f[!duplicated(f)]) f <- as.formula(call("~", parse(text = lhs, keep.source = FALSE)[[1L]], f[[length(f)]])) environment(f) <- environment(formula(models[[1L]])) tt <- fixTermsObject(terms(f)) mf <- mf[, rownames(attr(tt, "factors"))] attr(tt, "dataClasses") <- vapply(mf, .MFclass, "") attr(mf, "terms") <- tt mf } offsetTermNames <- function(x) vapply(as.list(attr(x, "variables")[attr(x,"offset") + 1L]), deparse1, "", control = NULL) offsetWeights <- function(wts, Terms, models) { if(is.null(off <- attr(Terms, "offset"))) return(NULL) offnames <- rownames(attr(Terms, "factors"))[off] n <- length(offnames) v <- matrix(vapply(models, function(x) { offnames %in% offsetTermNames(terms(x)) }, logical(n)), nrow = n) offwts <- vapply(1L:n, function(i) sum(wts[v[i, ]]), 0) names(offwts) <- offnames offwts } ## orders terms alphabetically in 'terms' object fixTermsObject <- function(x, peel = TRUE) { peelfun <- function(z) if(is.call(z)) paste0(as.character(z[-1L]), collapse = " ") else as.character(z) factors <- attr(x, "factors") if (length(factors) != 0L) { z <- rep(1L, nrow(factors)) z[attr(x, "response")] <- 0L if(hasOff <- !is.null(attr(x, "offset"))) z[attr(x, "offset")] <- 2L charvar <- if (peel) sapply(as.list(attr(x, "variables")[-1L]), peelfun) else rownames(factors) ov <- order(z, charvar) factors <- factors[ov, , drop = FALSE] charvar <- charvar[ov] v <- rownames(factors) lab <- lab_ord <- character(ncol(factors)) lfac <- factors != 0L for(i in 1L:ncol(factors)) { j <- lfac[, i] lab[i] <- paste0(v[j], collapse = ":") lab_ord[i] <- paste0(charvar[j], collapse = ":") } o <- order(attr(x, "order"), lab_ord) lab <- lab[o] ans <- reformulate(c(lab, offsetTermNames(x)), intercept = attr(x, "intercept")) if(attr(x,"response") != 0) ans <- as.formula(call("~", attr(x, "variables")[[attr(x, "response") + 1L]], ans[[2L]])) attributes(ans) <- attributes(x) attr(ans, "factors") <- factors[, o, drop = FALSE] colnames(attr(ans,"factors")) <- attr(ans, "term.labels") <- lab if(hasOff) attr(ans, "offset") <- which(z[ov] == 2L) for(j in c("variables", "predvars")) if(!is.null(attr(ans, j))) attr(ans, j) <- attr(ans, j)[c(1L, ov + 1L)] if(!is.null(attr(ans, "dataClasses"))) attr(ans, "dataClasses") <- attr(ans, "dataClasses")[ov] ans } else x } get.contrasts <- function(x) UseMethod("get.contrasts") get.contrasts.lm <- function(x) x$contrasts get.contrasts.averaging <- function(x) { mergeContrasts(getModelList(x)) } getModelList <- function(object, error = TRUE) { if(is.null(models <- attr(object, "modelList"))) if(error) stop("component models not included in this 'averaging' object") invisible(models) } MuMIn/R/Weights.R0000644000176200001440000000511115161443462013201 0ustar liggesusers# Calculate Akaike weights `Weights` <- function(x) UseMethod("Weights") `Weights.model.selection` <- function(x) { i <- type2col(x, "weight") structure(item(x, i) / sum(item(x, i)), names = row.names(x), wt.type = colnames(x)[type2col(x, "ic")], class = c("model.weights", "numeric")) } `Weights.averaging` <- function(x) { rval <- x$msTable[, ncol(x$msTable)] class(rval) <- c("model.weights", "numeric") attr(rval, "wt.type") <- if(!is.null(attr(x, "model.weights"))) attr(x, "model.weights") else asChar(.getRankCall(attr(x, "rank"))[[1L]]) rval } `Weights.data.frame` <- function(x) { if(ncol(x) == 2L && colnames(x)[1L] == "df" && is.numeric(x[, 2L])) return(Weights(x[, 2L])) if(ncol(x) == 1L && is.numeric(x[, 1L])) return(Weights(x[, 1L])) return(NA) } `Weights.numeric` <- function(x) { x <- x - min(x) d <- exp(-x / 2) structure(d / sum(d), class = c("model.weights", "numeric")) } `Weights.default` <- function(x) { cry(, "cannot use \"%s\" as 'x'", class(x)[1L]) } `Weights<-` <- function(x, value) UseMethod("Weights<-") `Weights<-.default` <- function(x, value) { stop("'Weights' can assign weights only to an \"averaging\" object") } `Weights<-.averaging` <- function(x, value) { wi <- ncol(x$msTable) if(is.null(value)) { wts <- Weights(x$msTable[, wi - 1L]) x$msTable[, wi] <- wts colnames(x$msTable)[wi] <- "weight" attr(x, "model.weights") <- NULL } else { x$msTable[, wi] <- value wts <- x$msTable[, wi] wts <- wts / sum(wts) x$msTable[, wi] <- wts colnames(x$msTable)[wi] <- if(inherits(value, "model.weights") && is.character(attr(value, "wt.type")[1L])) { paste0(attr(value, "wt.type")[1L], " weight") } else "[weight]" attr(x, "model.weights") <- if(is.null(attr(value, "wt.type"))) "unknown" else attr(value, "wt.type") } rv <- attr(x, "revised.var") for(i in 1L:nrow(x$coefficients)) { full <- rownames(x$coefficients)[i] == "full" x$coefficients[i, ] <- .coefarr.avg(x$coefArray, wts, full = full, alpha = 0.05, revised.var = rv)[, 1L] } o <- order(wts, decreasing = TRUE) x$msTable <- x$msTable[o, ] x$coefArray <- x$coefArray[o,,] if(!is.null(attr(x, "modelList"))) attr(x, "modelList") <- attr(x, "modelList")[o] x } `[.model.weights` <- function (x, ...) { wt.type <- attr(x, "wt.type") x <- NextMethod() attr(x, "wt.type") <- wt.type class(x) <- c("model.weights", class(x)) x } print.model.weights <- function (x, ...) { cat(attr(x, "wt.type"), "model weights", "\n") print(format(round(x, 3L), scientific = FALSE), quote = FALSE, right = TRUE) invisible(x) } MuMIn/R/coeffs.R0000644000176200001440000000414515161443462013042 0ustar liggesusers`coeffs` <- function (model) UseMethod("coeffs") `coeffs.gls` <- function (model) summary(model)$coefficients `coeffs.lme` <- function(model) model$coefficients$fixed `coeffs.merMod` <- function (model) lme4::fixef(model) `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 } `coeffs.unmarkedFit` <- function(model) { ret <- lapply(model@estimates@estimates, coef, altNames = FALSE) pfx <- rep(vapply(model@estimates@estimates, slot, "", "short.name"), vapply(ret, length, 1L)) ret <- unlist(unname(ret)) Ints <- which(names(ret) == "Int") names(ret) <- paste0(pfx, "(", names(ret), ")") attr(ret, "Intercept") <- Ints ret } `coeffs.splm` <- function (model) { c(model$coefficients, model$arcoef, if(is.matrix(model$errcomp)) model$errcomp[, 1L] else model$errcomp) } `coeffs.MCMCglmm` <- function (model) #summary(model)$solutions[, 1L] colMeans(model$Sol[, seq.int(model$Fixed$nfl), drop = FALSE]) `coeffs.gamm` <- function (model) coef(model$gam) `coeffs.mark` <- function(model) { cf <- model$results$beta[, 1L] names(cf) <- gsub("^([a-zA-Z]+):(.*)$", "\\1(\\2)", rownames(model$results$beta), perl = TRUE) cf } `coeffs.multinom` <- function (model) { cf <- coef(model) if (!is.vector(cf)) { cf <- t(as.matrix(cf)) cfnames <- expand.grid(dimnames(cf), stringsAsFactors = FALSE) cfnames <- sprintf("%s(%s)", cfnames[,2L], cfnames[,1L]) structure(as.vector(cf), names = cfnames) } else cf } `coeffs.asreml` <- function (model) { coef(model)$fixed ## should include also '$sparse' ? } `coeffs.cpglmm` <- function (model) model@fixef `coeffs.survreg` <- function (model) { rval <- coef(model) if (nrow(vcov(model)) > length(rval)) { # scale was estimated lgsc <- log(model$scale) names(lgsc) <- if(is.null(names(lgsc))) "Log(scale)" else paste0("Log(scale):", names(lgsc)) rval <- c(rval, lgsc) } rval } `coeffs.default` <- #function(model) (if(isS4(model)) coef else coef)(model) function(model) coef(model) MuMIn/R/modify.model.selection.R0000644000176200001440000001252115161443462016144 0ustar liggesusers`row.names<-.model.selection` <- function (x, value) { oldnames <- dimnames(x)[[1L]] x <- NextMethod() newnames <- dimnames(x)[[1L]] rowattrib <- c("model.calls", "coefTables", "random.terms", "order", # if(!is.null(attr(x, "modelList"))) "modelList") for(i in rowattrib) if(!is.null(attr(x, i))) names(attr(x, i)) <- newnames x } `names<-.model.selection` <- function (x, value) { oldnames <- names(x) if(any(attr(x, "column.types")[oldnames[oldnames != value]] %in% c('df', 'loglik', 'ic', 'delta', 'weight', 'terms'))) { class(x) <- "data.frame" attributes(x)[-match(names(attributes(x)), c("names", "row.names", "class"), nomatch = 0)] <- NULL } NextMethod() } subset_model_selection <- function(x, attrib, modif = NULL, rowchange = TRUE) { excludeattr <- c("names", "row.names", "class") column.types <- attrib[["column.types"]] keepattr <- names(attrib)[!(names(attrib) %in% excludeattr)] .setattr <- function(x, newattr = NULL, which = keepattr) { attributes(x)[which] <- if(is.null(newattr)) NULL else newattr[which] x } if(inherits(x, "model.selection")) { protectedcoltypes <- c("df", "loglik", "ic", "delta", "weight", "terms") if(!is.null(modif) && modif %in% type2colname(column.types, protectedcoltypes)) { class(x) <- "data.frame" return(.setattr(x)) } else { s <- dimnames(x)[[2L]] k <- match(names(column.types), colnames(x), nomatch = 0L) if(any(column.types[k == 0L] %in% protectedcoltypes)) { class(x) <- "data.frame" return(.setattr(x)) } else { if(any(column.types[k == 0L] %in% c("varying", "extra"))) { column.types <- column.types[k != 0L] attrib[["column.types"]] <- column.types } } } oldrownames <- attrib[['row.names']] newrownames <- dimnames(x)[[1L]] if(rowchange && (length(oldrownames) != length(newrownames) || any(oldrownames != newrownames))) { rowattrib <- c("model.calls", "coefTables", "random.terms", "order", if(!is.null(attr(x, "modelList"))) "modelList") k <- match(newrownames, oldrownames) attrib[rowattrib] <- lapply(attrib[rowattrib], `[`, k) } x <- .setattr(x, attrib) if(!is.null(warningList <- attrib$warnings)) attr(x, "warnings") <- warningList[sapply(warningList, attr, "id") %in% newrownames] } else { return(.setattr(x)) } x } `[<-.model.selection` <- function (x, i, j, value) { if (missing(j)) j <- TRUE subset_model_selection(NextMethod("[<-"), attributes(x), if(is.character(j)) j else colnames(x)[j]) } `[[<-.model.selection` <- function (x, i, j, value) { subset_model_selection(NextMethod(), attributes(x), { if(missing(j)) j <- i if(is.character(j)) j else colnames(x)[j] }, rowchange = FALSE) } `$<-.model.selection` <- function (x, name, value) { subset_model_selection(NextMethod("$<-"), attributes(x), name, rowchange = FALSE) } `[.model.selection` <- function (x, i, j, recalc.weights = TRUE, recalc.delta = FALSE, ...) { x <- subset_model_selection(item(x, j, i, ...), origattrib <- attributes(x)) if(inherits(x, "model.selection")) { ic <- itemByType(x, "ic") if(recalc.weights) itemByType(x, "weight") <- Weights(ic) if(recalc.delta) itemByType(x, "delta") <- ic - min(ic) } else { k <- type2colname(origattrib$column.types, c("weight", "delta")) hasdeltaweight <- k %in% colnames(x) recalc <- c(if(recalc.delta && hasdeltaweight[2L]) "delta", if(recalc.weights && hasdeltaweight[1L]) "weights") if(!is.null(recalc)) cry(, "cannot recalculate %s on an incomplete object", prettyEnumStr(recalc), warn = TRUE) } x } `[[.model.selection` <- function (x, ..., exact = TRUE) { `[[.data.frame`(x, ..., exact = exact) } subset_rework <- function(subset, object, objectname = substitute(object)) { if(!is.language(subset) && is.na(subset)) return(TRUE) subset <- exprapply0(exprapply0(exprapply0(subset, "dc", .subst.has.dc), c("{", "Term"), .subst.term), "has", .subst.has) objectname <- as.name(objectname) subset <- exprApply(subset, names(object), symbols = TRUE, function(x, v, cl, parent) { if(is.call(parent) && any(parent[[1L]] == c("I", "$", "@"))) return(x) if(length(x) == 1L) { cl[[3L]] <- match(asChar(x), v) return(cl) } x }, v = names(object), call("[[", objectname, 0L)) subset <- exprApply(subset, "I", function(x) x[[2L]]) subset <- subst(subset, . = objectname) subset } subset_eval <- function(subset, x, envir) { eval(subset_rework(subset, x, "tmp_data_"), list(tmp_data_ = x, dc = .subset_vdc), envir ) } `subset.model.selection` <- function(x, subset, select, recalc.weights = TRUE, recalc.delta = FALSE, ...) { if(missing(subset) && missing(select)) return(x) #ss <- eval(subset_rework(substitute(subset), x, "tmpdat"), # list(tmpdat = x, .subset_vdc = .subset_vdc), # parent.frame() # ) # eval.parent(subset_rework(substitute(subset), x, substitute(x))) return(`[.model.selection`(x, subset_eval(substitute(subset), x, parent.frame()), recalc.weights = recalc.weights, recalc.delta = recalc.delta, ...)) } `model.sel<-` <- function(x, value) { if(!inherits(x, "model.selection")) stop("'x' is not a \"model.selection\" object") y <- model.sel(value, rank = attr(x, "rank"), beta = attr(x, "beta"), extra = attr(x, "extra")) if(nrow(y) == 1L && rownames(y) == "value") rownames(y) <- deparse1(substitute(value)) rbind(x, y) } MuMIn/R/stdize.R0000644000176200001440000002031215161443462013071 0ustar liggesusersisFALSE <- function(x) identical(FALSE, x) stdize <- function(x, ...) UseMethod("stdize") rootmeansq <- function(v) { v <- as.numeric(v[!is.na(v)]) sqrt(sum(v^2) / max(1, length(v) - 1L)) } stdize.default <- stdize.numeric <- function(x, center = TRUE, scale = TRUE, ...) { if(is.function(scale)) { scaleFunc <- scale scale <- TRUE } else scaleFunc <- function(x) sd(x, na.rm = TRUE) #if(!missing(...)) warning("additional arguments ignored") for(i in c("scale", "center")) { if(length(v <- get(i, inherits = FALSE)) > 1L) cry(, "only first element of '%s' is used", i) assign(i, v[1L]) } if(is.logical(scale)) scale <- if(scale) scaleFunc(x) else 1 if(is.logical(center)) center <- if(center) mean(x, na.rm = TRUE) else 0 if(scale == 0) scale <- 1 if(!anyNA(scale)) { x <- (x - center) / scale attr(x, "scaled:center") <- center attr(x, "scaled:scale") <- scale } x } stdize.matrix <- function(x, center = TRUE, scale = TRUE, ...) { if(!is.numeric(x)) return(x) #if(!missing(...)) warning("additional arguments ignored") if(is.function(scale)) { scaleFunc <- scale scale <- TRUE } else scaleFunc <- function(x) sd(x, na.rm = TRUE) for(i in c("scale", "center")) if((nv <- length(v <- get(i, inherits = FALSE))) > 1L && nv != ncol(x)) cry(, "length of '%s' (%d) not equal to number of columns in 'x' (%d)", i, nv, ncol(x)) if(is.logical(scale)) scale <- if(scale) apply(x, 2L, scaleFunc) else 1 if(is.logical(center)) center <- if(center) colMeans(x, na.rm = TRUE) else 0 nc <- ncol(x) center <- rep(center, length.out = nc) scale <- rep(scale, length.out = nc) ok <- which(scale != 0) scale[-ok] <- center[-ok] <- NA for(i in ok) x[, i] <- (x[, i] - center[i]) / scale[i] attr(x, "scaled:center") <- center attr(x, "scaled:scale") <- scale x } stdize.factor <- function(x, binary = c("center", "scale", "binary", "half", "omit"), center = TRUE, scale = FALSE, ...) { #if(!missing(...)) warning("additional arguments ignored") if(nlevels(x) == 2L) { stdize.logical(as.numeric(x) - 1, binary, center, scale) } else x } stdize.logical <- function(x, binary = c("center", "scale", "binary", "half", "omit"), center = TRUE, scale = FALSE, ...) { #if(!missing(...)) warning("additional arguments ignored") binary <- if(is.null(binary) || anyNA(binary)) "" else match.arg(binary) switch(binary, center = stdize.numeric(x, center = TRUE, scale = 1), scale = stdize.numeric(x, center = TRUE, scale = TRUE), half = stdize.numeric(x, center = 0.5, scale = 1), binary = stdize.numeric(x, center = 0, scale = 1), omit = x, stdize.numeric(as.numeric(x), center = center, scale = scale) ) } stdize.data.frame <- function(x, binary = c("center", "scale", "binary", "half", "omit"), center = TRUE, scale = TRUE, omit.cols = NULL, source = NULL, prefix = TRUE, append = FALSE, ...) { if(is.function(scale)) { scaleFunc <- scale scale <- TRUE } else scaleFunc <- function(x) sd(x, na.rm = TRUE) for(i in c("scale", "center")) if((nv <- length(v <- get(i, inherits = FALSE))) > 1L && nv != ncol(x)) cry(, "length of '%s' (%d) not equal to number of columns in 'x' (%d)", i, nv, ncol(x)) if(!is.null(source)) { if(!missing(center) || !missing(scale) || !missing(binary)) warning("arguments 'center', 'scale' and 'binary' ignored if 'source' is given") j <- match(colnames(x), attr(source, "orig.names"), nomatch = 0L) if(all(j == 0L)) stop("no columns in 'source' match columns in 'x'") x <- x[, j != 0L, drop = FALSE] center <- attr(source, "scaled:center")[j] scale <- attr(source, "scaled:scale")[j] binary <- "" if(is.null(center) || is.null(scale)) stop("invalid 'source' object") } else binary <- if(is.null(binary) || anyNA(binary)) "" else match.arg(binary) dataClasses <- vapply(x, function(x) { if (is.logical(x)) return("logical") if (is.factor(x)) if(nlevels(x) == 2L) return("factor2") else return("other") if (is.matrix(x) && is.numeric(x)) return("nmatrix") if (is.numeric(x)) return("numeric") return("other") }, "") origx <- x if(is.character(omit.cols)) dataClasses[colnames(x) %in% omit.cols] <- "omit" else if(is.numeric(omit.cols)) dataClasses[omit.cols] <- "omit" numData <- dataClasses == "numeric" if(binary == "omit") { binaryData <- FALSE } else { binaryData <- dataClasses == "factor2" | dataClasses == "logical" for (i in which(binaryData)) x[, i] <- as.numeric(x[, i]) - if(dataClasses[i] == "factor2") 1 else 0 } nc <- ncol(x) f <- function(x, bin) { if(is.numeric(x)) { calc <- isTRUE(bin) & binaryData x <- rep(x, length.out = nc) do <- !is.na(x) & (numData | calc | (binaryData & (is.na(bin) | !isFALSE(bin)))) x[!calc & do & binaryData & !is.na(bin)] <- bin return(list(num = x, calc = calc, do = do)) } else { calc <- (numData & x) | (binaryData & ((is.na(bin) & x) | isTRUE(bin))) do <- calc | (binaryData & (!is.na(bin) & !isFALSE(bin))) num <- numeric(nc) num[!calc & do & binaryData & !is.na(bin)] <- bin return(list(num = num, calc = calc, do = do)) } } ctr <- f(center, switch(binary, center = TRUE, scale = TRUE, half = .5, binary = 0, omit = FALSE, NA)) scl <- f(scale, switch(binary, center = FALSE, scale = TRUE, half = 1, binary = FALSE, omit = FALSE, NA)) center <- ctr$num scale <- scl$num center[ctr$calc] <- colMeans(x[, ctr$calc, drop = FALSE], na.rm = TRUE) scale[scl$calc] <- apply(x[, scl$calc, drop = FALSE], 2L, scaleFunc) #dp(center) #dp(scale) scl$do[scl$do & scale == 0] <- FALSE jTransformed <- ctr$do | scl$do center[jTransformed & !ctr$do] <- 0 scale[jTransformed & !scl$do] <- 1 for (i in which(jTransformed)) x[, i] <- (x[, i] - center[i]) / scale[i] doprefix <- FALSE if(is.character(prefix) || (doprefix <- (is.logical(prefix) && isTRUE(prefix)))) { prefix <- if(doprefix) c("z.", "c.") else rep(prefix, length.out = 2L) Dcenter<- as.data.frame(ctr) Dscale <- as.data.frame(scl) #dp(Dcenter) #dp(Dscale) #dp(jTransformed) #dp(paste0(prefix[jTransformed + (ctr$do & !scl$do)], # colnames(x)[jTransformed])) #dp(jTransformed + (ctr$do & !scl$do)) colnames(x)[jTransformed] <- paste0(prefix[jTransformed + (ctr$do & !scl$do)], colnames(x)[jTransformed]) } if(append) x <- cbind(origx, x[,!(colnames(x) %in% names(origx)), drop = FALSE], deparse.level = 0L) attr(x, "scaled:center") <- ifelse(jTransformed, center, NA) attr(x, "scaled:scale") <- ifelse(jTransformed, scale, NA) attr(x, "orig.names") <- colnames(origx) x } stdize.formula <- function(x, data = NULL, response = FALSE, binary = c("center", "scale", "binary", "half", "omit"), center = TRUE, scale = TRUE, omit.cols = NULL, prefix = TRUE, append = FALSE, ...) { mf <- model.frame(x, data = data, drop.unused.levels = TRUE, ...) if(!is.null(omit.cols)) omit.cols <- if(is.character(omit.cols)) which(colnames(mf) %in% omit.cols) else stop("'omit.cols' must be a character vector") if(!response) omit.cols <- unique(c(omit.cols, 1L)) attr(mf, "terms") <- NULL stdize.data.frame(mf, center = center, scale = scale, omit.cols = omit.cols, binary = binary, prefix = prefix, append = append) } stdizeFit <- function(object, newdata, which = c("formula", "subset", "offset", "weights", "fixed", "random", "model"), evaluate = TRUE, quote = NA) { thiscall <- match.call() if(is.na(quote)) quote <- is.call(thiscall$object) && !is.primitive(match.fun(thiscall$object[[1L]])) cl <- if(quote) thiscall$object else if(is.expression(object)) object[[1L]] else if(is.call(object)) object else get_call(object) cl <- match.call(Fun <- match.fun(cl[[1L]]), cl) if(!("data" %in% (formalnames <- names(formals(Fun))))) warning(gettextf("%s does not have a formal argument 'data', which is required", as.character(cl[[1L]]))) which <- which[which %in% formalnames] i <- names(newdata) != attr(newdata, 'orig.names') env <- structure(lapply(names(newdata)[i], as.name), names = attr(newdata, 'orig.names')[i]) if(isTRUE(which)) cl <- subst(cl, env) else for(i in which) if(!is.null(cl[[i]])) cl[[i]] <- subst(cl[[i]], env) cl[['data']] <- thiscall[['newdata']] #substitute(data) if(evaluate) eval.parent(cl) else cl } MuMIn/R/get.models.R0000644000176200001440000000423615161443462013637 0ustar liggesusers`get.models` <- function(object, subset, cluster = NA, ...) { if (!any(ok <- inherits(object, c("model.selection", "averaging"), which = TRUE))) stop("'object' must be a \"model.selection\" or \"averaging\" object") hasModelList <- is.list(attr(object, "modelList")) isAveraging <- ok[2L] == 1L if(isAveraging && !hasModelList) stop("need \"averaging\" object with a model list") calls <- attr(object, "model.calls") if((hasNoCalls <- is.null(calls)) && !hasModelList) stop("'object' has no \"model.calls\" attribute") if(!missing(subset)) { r <- subset_eval(substitute(subset), if(isAveraging) object$msTable else object, parent.frame()) if(!isTRUE(r) && !anyNA(r)) { if(is.character(r)) r <- match(r, dimnames(object)[[1L]]) } else r <- TRUE } else { stop("'subset' is missing (use subset=TRUE to evaluate all models)") } newargs <- match.call() newargs[[1L]] <- NULL newargs[c('object', 'subset', 'cluster')] <- NULL naNames <- names(newargs) if(hasModelList) { .DebugPrint(hasModelList) if(length(newargs) == 0L) { models <- attr(object, "modelList")[r] attr(models, "rank") <- attr(object, "rank") return(models) } .DebugPrint("refitting...") if(hasNoCalls) calls <- lapply(attr(object, "modelList")[r], get_call) } else calls <- calls[r] if(length(newargs)) for(i in seq_along(calls)) calls[[i]][naNames] <- newargs doParallel <- inherits(cluster, "cluster") if(doParallel) { .parallelPkgCheck() # all this is to trick the R-check clusterCall <- get("clusterCall") clusterApply <- get("clusterApply") models <- clusterApply(cluster, calls, "eval", envir = .GlobalEnv) } else { glo <- attr(object, "global") if(is.null(glo)) { models <- lapply(calls, function(cl) { eval(cl, envir = environment(formula(cl))) }) } else { env <- attr(tryCatch(terms(glo), error = function(...) terms(formula(glo))), ".Environment") models <- lapply(calls, eval, envir = env) } } for(i in c("rank", "beta")) attr(models, i) <- attr(object, i) return(models) } `pget.models` <- function(object, cluster = NA, subset, ...) { .Deprecated("get.models") get.models(object, subset, cluster, ...) } MuMIn/R/class-cplm.R0000644000176200001440000000076115161443462013633 0ustar liggesusers `nobs.cplm` <- function (object, ...) sum(!is.na(resid(object))) family.cplm <- function (object, ...) { getFrom("statmod", "tweedie")(var.power = object@p, link.power = object@link.power) #lambda <- object@link.power #link <- c("log", "identity", "sqrt", "inverse")[match(lambda, c(0, 1, 0.5, -1), nomatch = 0L)] #if(length(link) == 0L) link <- paste0("mu^", as.character(lambda)) #rval <- list(family = "CpPoisson", link = link) #class(rval) <- "family" #rval } MuMIn/R/par.avg.R0000644000176200001440000000313015161443462013124 0ustar liggesusers`par.avg` <- function(x, se, weight, df = NULL, level = 1 - alpha, alpha = 0.05, revised.var = TRUE, adjusted = TRUE) { if (!(is.numeric(x) && is.numeric(se) && is.numeric(weight))) stop("'x', 'se' and 'weight' must be numeric vectors") n <- length(x) if(length(weight) != n || length(se) != n) stop("'x', 'se' and 'weight' are not of the same length: ", sprintf("x: %d, weight: %d, se: %d", n, length(weight), length(se))) weight[is.na(weight)] <- 0 # not really necessary wx <- weighted.mean(x, weight, na.rm = TRUE) x.sqdiff <- (x - wx)^2 xvar <- se^2 do.ase <- adjusted && !(missing(df) || is.null(df) || anyNA(df[!is.na(x)])) # Note: pdistr(qdistr(x)) == x a <- 1 - ((1 - level) / 2) if(do.ase) { z <- c(qt(a, df) / qnorm(a))^2 i <- is.na(df) & !is.na(x) if (length(i) > 0L) z[i] <- 0 } if(revised.var) { # Unconditional sqrt-Variance, revised in B&A2004 use <- sqrt(weighted.mean(xvar + x.sqdiff, weight, na.rm = TRUE)) if (do.ase) # Adjusted std. error - formula modified by analogy to the previous ase <- sqrt(weighted.mean((xvar * z) + x.sqdiff, weight, na.rm = TRUE)) } else { # Unconditional sqrt-Variance, original formula (B&A2002, eqn 4.7) use <- weighted.mean(sqrt(xvar + x.sqdiff), weight, na.rm = TRUE) if (do.ase) # Adjusted std. error (B&A2002, ch.4.3.3/p164): ase <- weighted.mean(sqrt((xvar * z) + x.sqdiff), weight, na.rm = TRUE) } ci <- qnorm(a, lower.tail = TRUE) * (if (do.ase) ase else use) return(c(`Coefficient` = wx, `SE` = use, `Adjusted SE` = if(do.ase) ase else NA, `Lower CI` = wx - ci, `Upper CI` = wx + ci)) } MuMIn/R/nsubsets.R0000644000176200001440000000276515161443462013451 0ustar liggesusers# `asscount` stands, obviously, for "all-subsets count". asscount <- function(object) { .isssmat <- \(x) is.matrix(x) && { d <- dim(x) d[1L] == d[2L] } && is.logical(x) && !any(x[lower.tri(x)]) ssmat <- if(.isssmat(object)) object else if(is.character(object)) attr(object,"deps") else if(is.object(object)) attr(getAllTerms(object),"deps") if(!.isssmat(ssmat)) stop("cannot get subset matrix from 'object'") diag(ssmat) <- TRUE numcombin(ssmat) } numcombin <- function(subsetmatrix) { storedresults <- new.env(parent = emptyenv()) makekey <- function(idx) paste0(sort(idx), collapse = "_") # counter <- integer(2L) .countideals <- function(idx) { # counter[1L] <<- counter[1L] + 1L if (length(idx) == 0L) return(1L) key <- makekey(idx) if (exists(key, storedresults, inherits = FALSE)) return(storedresults[[key]]) #counter[2L] <<- counter[2L] + 1L submat <- subsetmatrix[idx, idx, drop = FALSE] # Find maximal elements correctly: # maximal = no STRICT superset in idx M.idx <- idx[match(TRUE, rowSums(submat & upper.tri(submat)) == 0L)] # Case 1: exclude M idx1 <- idx[idx != M.idx] # Case 2: include M -> remove all its subsets idx2 <- setdiff(idx, idx[subsetmatrix[idx, M.idx]]) res <- Recall(idx1) + Recall(idx2) assign(key, res, envir = storedresults) return(res) } .countideals(seq_len(ncol(subsetmatrix))) } MuMIn/demo/0000755000176200001440000000000015161443462012171 5ustar liggesusersMuMIn/demo/gees.R0000644000176200001440000000353012730246630013235 0ustar liggesusers### # Example of model selection with GEE ranked by QIC ### library(MuMIn) require(geepack) require(gee) require(yags) options(na.action = na.pass) data(dietox, package = 'geepack') dietox$Cu <- as.factor(dietox$Cu) # Compare GEE fits from alternative implementations: fggm <- geeglm(Weight ~ Cu * (Time + I(Time^2)), id = Pig, data = dietox, family = gaussian, corstr = "exchangeable") fgee <- gee(Weight ~ Cu * (Time + I(Time^2)), id = Pig, data = dietox, family = gaussian, corstr = "exchangeable") fygs <- yags(Weight ~ Cu * (Time + I(Time^2)), id = Pig, data = dietox, family = gaussian, corstr = "exchangeable", alphainit = 0.01) model.sel(fggm, fgee, fygs, rank = QIC) QIC(fggm, fgee, fygs, typeR = TRUE) QIC(fggm, fgee, fygs, typeR = FALSE) system.time(dd.ggm <- dredge(fggm, rank = QIC, ct.args = list(type = "robust"), fixed = ~Cu)) system.time(dd.gee <- dredge(fgee, rank = QIC, ct.args = list(type = "robust"), fixed = ~Cu)) system.time(dd.ygs <- dredge(fygs, rank = QIC, ct.args = list(type = "robust"), fixed = ~Cu)) # 'geeglm' seems to be the slowest, and the fitted models stand out slightly # from the other two. dd.ggm dd.gee dd.ygs (dd.gee.n <- dredge(fgee, rank = QIC, ct.args = list(type = "naive"), fixed = ~Cu, typeR = T)) (dd.gee.n <- dredge(fgee, rank = QIC, ct.args = list(type = "naive"), fixed = ~Cu, typeR = F)) # model averaged parameters (with naive covariance) # note use of ct.args argument model.avg(dd.gee.n) # model averaged parameters (with robust covariance) model.avg(dd.gee) # the same result, but re-fitting the models models <- get.models(dd.gee, subset = NA) summary(mavg <- model.avg(models, rank = QIC, ct.args = list(type = "naive"))) summary(mavg <- model.avg(models, rank = QIC, ct.args = list(type = "robust"))) MuMIn/demo/00Index0000644000176200001440000000070412730246630013321 0ustar liggesusersgees Model selection with Generalized Estimating Equations dredge.distsamp Model selection with 'distsamp' models from 'unmarked' package pdredge.pcount Model selection with 'pcount' models from 'unmarked' package and using parallel execution dredge.subset Generating a subset of a full model excluding collinear variables dredge.varying Varying model formulations (other than formulas). Using and subsetting the 'varying' variables MuMIn/demo/dredge.subset.R0000644000176200001440000000344514010507677015061 0ustar liggesusers### # Generating a subset of a full model excluding collinear variables ### library(MuMIn) options(na.action = na.fail) # Fit the 'global model' fm <- lm(y ~ (X1 + X2 + X3 + X4)^2, data = Cement) # Suppose we want to have a set of models excluding combinations of collinear # variables that are significantly (p < 0.05) correlated, with Pearson # correlation coefficient r > 0.5 is.correlated <- function(i, j, data, conf.level = 0.95, cutoff = 0.5, ...) { if(j >= i) return(NA) ct <- cor.test(data[, i], data[, j], conf.level = conf.level, ...) ct$p.value > (1 - conf.level) || abs(ct$estimate) <= cutoff } # Need vectorized function to use with 'outer' vCorrelated <- Vectorize(is.correlated, c("i", "j")) # Create logical matrix smat <- outer(1:4, 1:4, vCorrelated, data = Cement) nm <- colnames(Cement[-1]) dimnames(smat) <- list(nm, nm) ### A simpler case: exclude only pairs of variables having cor. coefficient ### r > 0.5 # smat <- abs(cor(Cement[, -5])) <= .5 # smat[!lower.tri(smat)] <- NA # Alternatively, use logical expression of form: # !((V1 && V2) || (V3 && V4)) # where V1 is collinear with V2, and V3 with V4. # Rather than doing it by hand, we can generate it from the above matrix: i <- as.vector(smat == FALSE & !is.na(smat)) sexpr <-parse(text = paste("!(", paste("(", nm[col(smat)[i]], " && ", nm[row(smat)[i]], ")", sep = "", collapse = " || "), ")")) smat sexpr ## ============================================================================= system.time(dd2 <- dredge(fm, subset = smat)) system.time(dd1 <- dredge(fm, subset = sexpr)) # Using the argument 'subset' in a form of matrix is usually faster. # The results are identical: dd1 dd2 ## =============================================================================MuMIn/demo/dredge.distsamp.R0000644000176200001440000000211713162171557015374 0ustar liggesusers### # Example of model selection with models from 'unmarked' package ### require(MuMIn) require(unmarked) opt <- options(width = 110) # from example(distsamp) ltUMF <- local({ data(linetran) dbreaksLine <- c(0, 5, 10, 15, 20) lengths <- linetran$Length * 1000 with(linetran, { unmarkedFrameDS(y = cbind(dc1, dc2, dc3, dc4), siteCovs = data.frame(Length, area, habitat), dist.breaks = dbreaksLine, tlength = lengths, survey = "line", unitsIn = "m") }) }) # global model - probably nonsensical: fmUnmDS <- distsamp( ~ Length + area ~ area + habitat, ltUMF) # The default null model used for calculating R^2 has a formula ~ 1 ~ 1 msUnmDS <- dredge(fmUnmDS, rank = AIC, extra = "adjR^2") subset(msUnmDS, delta < 4 | df == min(df)) # Compare with the model selection table from unmarked - the statistics should # be identical. # fit the models from the 'top' and a null model. models <- get.models(msUnmDS, delta < 4 | df == min(df)) modSel(fitList(fits = structure(models, names = model.names(models, labels = getAllTerms(fmUnmDS)))), nullmod = "(Null)") options(opt) ########################MuMIn/demo/pdredge.pcount.R0000644000176200001440000000277414772507071015253 0ustar liggesusers### # Example of model selection with models from 'unmarked' package # with parallel execution ### require(parallel) library(MuMIn) library(unmarked) # Set up the cluster ncores <- if(exists("detectCores", mode = "function")) detectCores() else getOption("cl.cores", 2) clust <- try(makeCluster(getOption("cl.cores", 2), type = "PSOCK")) if(!inherits(clust, "cluster")) stop("Could not set up the cluster") data(mallard) mallardUMF <- unmarkedFramePCount(mallard.y, siteCovs = mallard.site, obsCovs = mallard.obs) # Fit the global model (ufm.mallard <- pcount(~ ivel + date + I(date^2) ~ length + elev + forest, mallardUMF, K = 30)) invisible(clusterEvalQ(clust, library(unmarked, logical = TRUE))) clusterExport(clust, "mallardUMF") # For comparison, single-threaded run: #system.time(print(pdd1 <- pdredge(ufm.mallard, # subset = `p(date)` | !`p(I(date^2))`, rank = AIC))) system.time(pdd2 <- dredge(ufm.mallard, cluster = clust, subset = (`p(date)` || !`p(I(date^2))`), rank = AIC, extra = "adjR^2", eval = TRUE)) # select the top models and null model subset(pdd2, delta < 2 | df == min(df)) # Remove the warnings permanently attr(pdd2, "warnings") <- NULL # Compare with the model selection table from 'unmarked'. # The statistics should be identical: models <- get.models(pdd2, delta < 2 | df == min(df), cluster = clust) modSel(fitList(fits = structure(models, names = model.names(models, labels = getAllTerms(ufm.mallard)))), nullmod = "(Null)") stopCluster(clust) ######################## MuMIn/demo/dredge.varying.R0000644000176200001440000000213012730246630015215 0ustar liggesusers### # Varying model formulations (other than formulas). Using and subsetting the # 'varying' variables. ### library(nlme) library(MuMIn) # from example(corSpher) fm1BW.lme <- lme(weight ~ Time * Diet, BodyWeight, random = ~ Time) # generate model selection table: fm1BW.dd <- dredge(fm1BW.lme, # fix all terms in all models: fixed = TRUE, varying = list( # vary correlation structure: correlation = alist(exp = corExp(form = ~ Time), spher = corSpher(form = ~ Time), NULL ), # vary heteroscedasticity structure: weights = alist(vPower = varPower(), none = NULL ) ), # additional constraint (regardless of whether it makes sense or not): # include either heteroscedasticity or correlation structure (but not both). # Note use of 'is.null' for unnamed item, and "none" when named. subset = xor(is.null(V(correlation)), V(weights) == "none"), # global model was fitted with method = "REML" (the default), but for model # selection we use AICc of a ML model. This additional argument is passed to # AICc. REML = FALSE) print(fm1BW.dd)MuMIn/NEWS0000644000176200001440000014761315161443075011760 0ustar liggesusersMuMIn package news: Changes in version 1.48.19 (2026-03-27): - backward compatibility in printing "model.selection" and "model.averaging" objects. Changes in version 1.48.17 (2026-03-21) - (fixed) error when using `dredge` with certain 'unmarkedFit' model types due to missing values in some model specs entries (noted by unmarked's Ken Kellner). Changes in version 1.48.15 (2026-01-29) - adaptations to changes in 'unmarkedFit' structure introduced in 'unmarked' v. 1.5.1 (thanks to Tash Harrison for information). As a result, 'MuMIn's functions are no longer compatible with older versions of 'unmarked'. Changes in version 1.48.14 (2026-01-12) - (fixed) fixCoefNames: warning "match limit exceeded" with some coefficient names e.g. "xx(aaaaaa:bbbbbbbbb:ccc(I(d)))" - (fixed) error with comparision of rank functions, when combining model selection tables Changes in version 1.48.12 (2025-06-03) - (fixed) rank function wrapper function is simplified, and its environment no longer contains the unnecessary global model object which resulted in larger memory use and file size when saving Changes in version 1.48.11 (2025-03-31) - removed more references to archived and undeclared packages Changes in version 1.48.10 (2025-03-25) - (fixed) obscure problem in `exprApply` Changes in version 1.48.9 (2024-12-12) - (fixed) restored support for some 'unmarkedFit' models, broken since the previous version (spotted by Tash Harrison). Changes in version 1.48.8 (2024-12-03) - small code improvements and documentation changes - (fixed) extra functions for `dredge` now can return a result coercible to a numeric value (as documented), as not strictly numeric as it was before. Changes in version 1.48.7 (2024-08-25) - (added) methods for class 'fitdistr' (MASS package), which can now be used with `model.sel`. Changes in version 1.48.6 (2024-07-02) - (fixed) problem with model specification of 'unmarkedFitPCount' Changes in version 1.48.5 (2024-06-23) - minor improvements in the manual Changes in version 1.48.4 (2024-06-21) - (fixed) DESCRIPTION issues causing R check problems. - registered previously omitted methods and supplemented package references in the documentation. Changes in version 1.48.2 (2024-06-08) - support for "unmarkedFit" has been reworked, with more models included (all except the ones not using formulas as arguments, i.e. "occuMS" and "occuMulti"), and random effects and offset terms now being recognized (the latter reported by Jonathan Dinkins). Changes in version 1.47.12 (2024-06-02) - (removed) links to archived packages in the manual and included some new suggested packages to satisfy R Check. Changes in version 1.47.10 (2024-03-21) - (fixed) `r.squaredGLMM` now returns correct values for non-Bernoulli binomial models with response as proportion and weights specifying the number of trials. The result is now identical as for a model with response as a 2-column matrix (thanks to Emma Neigel for reporting this). - (removed) `logLik.coxme` as the package "coxme" now provides its own method. Changes in version 1.47.8 (2023-07-07) - (added) `duplicated` method for "model.selection" object. - (added) replacement version of `model.sel` that appends new models to an existing "model.selection" object. Changes in version 1.47.6 (2023-05-30) - (fixed) problem with matching interaction terms, affecting mostly `model.sel` (spotted by Francis van Oordt). - removed backward compatibility with pre-0.15.0 "averaging" objects. Changes in version 1.47.5 (2023-03-15) - r.squaredGLMM: added support for additional families using `insight::get_variance`. This requires the addition of 'insight' to the package dependencies, albeit very reluctantly, as in principle new dependencies are only added as a very last resort. - `null.fit` and hence `r.squaredLR` now work also with "survreg" class (reported by Caroline Zanchi). Changes in version 1.47.4 (2023-03-13) - (fixed) removed remaining references to `stats:::format.perc`. Changes in version 1.47.3 (2023-02-27) - (fixed) model.avg.default: duplicated interaction coefficients were returned when the main effect coefficients appeared in different order in the component models (spotted by Derek Corcoran). Changes in version 1.47.2 (2023-01-06) - updated methods for models of class 'Sarlm' and 'Spautolm' from the package 'spatialreg' (reported by Iwona Dembicz). Changes in version 1.47.1 (2022-08-31) - pleasing RCheck: updated NEWS file so that it can be parsed by the `news` function. Changes in version 1.47.0 (2022-08-30) - (changed) plot.model.selection: Most notable change is the way the 'col' argument is interpreted. The default colours use now `hcl.palette` and differ from the previous version. There is no backward compatibility. - Long defunct `mod.sel`, `tTable` and `updateable2` have been removed. `importance` is now defunct (use `sw` instead). Changes in version 1.46.7 (2022-08-24) - Rd files have been updated to meet changes in the HTML R help system, starting with R 4.2.0. Hence, the minimum required version of R is now 4.2.0. Changes in version 1.46.6 (2022-07-31) - (fixed) print.model.selection: Abbreviations now only include existing values (i.e. after subsetting). - (fixed) merge.model.selection: "modelList" attributes are now preserved. Changes in version 1.46.5 (2022-06-07) - (fixed) getAllTerms.gamlss: error with intercept only models and formulas containing offset (reported multiple times on Stackoverflow) Changes in version 1.46.4 (2022-06-07) - (fixed) dredge: in a rare case when intercept terms were passed as "fixed", some variable combinations were erroneously dropped from the result. Changes in version 1.46.0 (2022-02-23) - (fixed) r.squaredGLMM: now gives correct values for negative binomial models (thanks to Shuang Zhang for research) Changes in version 1.45.1 (2021-12-08) - (added) .vcov a wrapper for vcov returning result in a consistent format (a matrix) Changes in version 1.45.0 (2021-11-25) - pdredge is deprecated in favour of `dredge` with "cluster" argument. Changes in version 1.44.6 (2021-05-19) - added stringsAsFactors=TRUE to most 'as.data.frame' occurences to bring back the desired behaviour (which changed in R 4.0.0). Changes in version 1.44.5 (2021-05-11) - std.coef: now matches coefficient names with model matrix column names. Changes in version 1.44.4 (2021-04-20) - coefTable.betareg - now includes residual df. Changes in version 1.44.3 (2021-03-05) - (fixed) getAllTerms.zeroinfl: error when the function was called from non-global environment (spotted by Richard Shefferson) Changes in version 1.44.2 (2020-07-14) - (fixed) error with makeArgs (and hence dredge) with glmmTMB with non-symbol response Changes in version 1.44.1 (2020-06-25) - importance: is now formally deprecated with a warning. Use `sw` instead. Changes in version 1.44.0 (2020-05-28) - (added) plot method for the class "averaging" produces a dot-and-whisker plot of coefficients. This uses a new general function `coefplot` that can be used to make plots for arbitrary model types. Changes in version 1.43.19 (2020-05-22) - (fixed) plot titles in plot.coefTable Changes in version 1.43.18 (2020-05-18) - r.squaredGLMM: issues a warning about zero-inflation and dispersion model being ignored in the calculation of R2 rather than an error as before (request from Alexander Bruckner, inspired by the code by Ben Bolker: https://github.com/glmmTMB/glmmTMB/blob/master/glmmTMB/inst/misc/rsqglmm.R) - (fixed) some issues with evaluating in non-global environment (`updateable` and 'na.action' checking) Changes in version 1.43.17 (2020-04-14) - Merely refreshing date stamp to please CRAN policies. Changes in version 1.43.16 (2020-03-12) - (added) specs for 'unmarkedFitPCount' with mixture = "ZIP" (spotted by Hannah Clyde) - (fixed) r.squaredGLMM for binomial family models with N > 1 trials. The fixed effects variance now accounts for trial number (thanks to Daniel Schlaepfer) Changes in version 1.43.15 (2019-12-19) - (fixed) fatal error with QIC.geem introduced in the previous version (reported by Lee McDaniel) Changes in version 1.43.14 (2019-12-18) - (fixed) example(QIC) causing an error after recent update of 'geepack'. - Added quasiLik/QIC for the negative binomial family (reportedly supported only by 'geeM::geem'). Changes in version 1.43.13 (2019-12-14) - (fixed) get.models: in the absence of a 'global model', the argument 'subset' was ignored and a list of all models was returned. Changes in version 1.43.12 (2019-12-11) - (fixed) [p]dredge: error while formatting the error message about an overlarge number of predictors (found by a certain 89_Simple on Stackoverflow). Changes in version 1.43.11 (2019-12-09) - (fixed) getAllTerms now recognizes structured terms of form `struc(terms|group)` properly as random effect terms; - (fixed) dredge, model.sel: delta was not calculated if any rank was NA. Changes in version 1.43.10 (2019-12-05) - (removed) conflicting methods which are now defined in their 'survival' package (nobs.coxph, nobs.survreg). Because of that, MuMIn now depends on survival >= 3.1.0. Changes in version 1.43.9 (2019-06-21) - (fixed) 'r.squaredGLMM' failed when order of interaction components in RE part of model formula were not in order of appearance (found by Gabriel Baud-Bovy) - (removed) 'predict.merMod' replacement to avoid the conflict of registered methods. Note that the original method does not calculate 'se.fit', so currently there is no out-of-box way to produce averaged predictions with standard errors. Changes in version 1.43.8 (2019-04-15) - (fixed) methods for 'gamlss' (reported by Andras Farkas) Changes in version 1.43.6 (2019-04-08) - (fixed) if conditions with "length > 1 in coercion to logical" error produced by the new Rcheck. - (fixed) updated 'tests' to make up for 'spautolm' moved from 'spdep' to 'spatialreg'. Changes in version 1.43.4 (2019-04-04) - (fixed) minor changes to the quasi-likelihood function Changes in version 1.43.3 (2019-03-19) - (added) methods for 'gamlss' (suggested by Anne Loosen) - (fixed) QIC,quasiLik: now gives results compatible with those of wgeesel::QIC.gee. Changes in version 1.43.2 (2019-03-16) - 'sw' (for "Sum of Weights") is now preferred to 'importance' (which is still available, but is going to be deprecated in future). This is because of the controversies about SoW being a valid measure of actual variable importance. - [p]dredge: max. number of predictors is now correctly calculated (depending on the number of variants) Changes in version 1.43.1 (2019-03-06) - (added) new model structure for unmarkedFitGDS (gdistsamp) with alpha parameter (thanks to Alba Estrada) Changes in version 1.43.0 (2019-02-28) - (fixed) in QICu, the number of parameters was mistaken for number of observations (reported by Richard Fredrickson) - (added) some methods for wgeesel::wgee objects. Changes in version 1.42.5 (2019-01-02) - r.squaredGLMM: added the argument "envir" which is passed to `.nullFitRE`. This can be used in case of issues with model data not being found (reported by Eliot McIntire) Changes in version 1.42.4 (2018-12-05) - (fixed) r.squaredGLMM.merMod: error when the function was called in an environment different than .GlobalEnv (spotted by a certain Martin on Stackoverflow) Changes in version 1.42.3 (2018-07-31) - (added) dredge: the subset expression `.(x)` now accepts an additional argument for the allowed term orders. For example `.(X, 2:10)` means "at least one 2nd or 3rd order interaction of 'X'". The `.` pseudo-function has also a new alias: "with", e.g. `with(X, 2:10)`. Changes in version 1.42.2 (2018-07-27) - (fixed) r.squaredGLMM: handle the case when some coefficients are not estimated and NA Changes in version 1.42.1 (2018-07-21) - tests have been modified to prevent CRAN check errors on some systems. - (fixed) arm.glm, armWeights: now use a random sample to select a training set. armWeights: no longer give a warning about "longer object length" Changes in version 1.42.0 (2018-07-17) - (updated) methods for "unmarkedFit" models have been rewritten and should work properly with all subclasses. Added missing support for "unmarked::unmarkedFitOccuFP" (reported by Tara Hohoff) - R2GLMM added an option to disable "null fit warning" - (fixed) getAllTerms.lme: now gives a correct value for response in "binomial" glmmPQL ("zz" previously) - (fixed) testSmoothKConsistency: (used by `model.avg` with 'gam' models) works now with 'gam's including no smooth terms. Changes in version 1.41.1 (2018-07-13) - (fixed) workaround for clmm's (package "ordinal") annoyance: it needs explicit "1" in the formula if there are no other fixed terms. That resulted in intercept-only model calls generated by `dredge` being rejected. (kindly reported by Jrg Albrecht) Changes in version 1.41.0 (2018-07-12) - (updated) r.squaredGLMM: revised to incorporate new developments in Nakagawa et al (2017). Methods exist for merMod, glmmTMB, glmmADMB, glmmPQL, cpglmm, and lm classes. Changes in version 1.40.8 (2018-06-18) - Model description - simplified handling of the model's family description in the model selection tables, so it does not require `family()$family` string being an existing function name. The drawback is that now a default link function is not detected and its name always appears in the column (before e.g. "binomial(logit)" appeared as "binomial()"). Changes in version 1.40.7 (2018-06-14) - Addad a workaround to accommodate glmmTMB specific families (which do not have a matching function) (reported by a certain Gitu on Stackoverflow) Changes in version 1.40.6 (2018-05-16) - (fixed) makeArgs, getAllTerms: compatibility with glmmTMB - random terms in formulas other than cond have not been handled properly (discovered via Mollie Brooks on GitHub) Changes in version 1.40.5 (2018-05-14) - `.checkNAAction` now handles a case of 'na.action' formal argument being a call (e.g. `getOption(na.action)` in glmmTMB) (spotted by Ben Bolker) Changes in version 1.40.4 (2018-01-30) - Elaborated the Description field. Changes in version 1.40.3 (2018-01-29) - Removed superfluous method replacements for models from package "survival". `predict` functions for "gls" and "lme" are no longer registered as S3 methods in NAMESPACE. Changes in version 1.40.2 (2018-01-19) - (fixed) getAllTerms.glmmTMB: error with models including offset term (spotted by Kate Plummer) Changes in version 1.40.1 (2017-11-30) - (added) Support for "glmmTMB" models (incentive from Kaitlyn Zerr) Changes in version 1.40.0 (2017-09-30) - (fixed) long broken support for "unmarkedFit" models has been restored (because of the utterly inconsistent structure of these objects it is not guaranteed to work in all cases). - (fixed) R.squaredGLMM: error with very long RE formulas (reported by Siti Binte Faizal) Changes in version 1.16.7 (2017-08-10) - A few minor things fixed. Changes in version 1.16.6 (2017-07-11) - (fixed) print.summary.averaging: warning when fitting function name was a call rather than a symbol, e.g. lme4::lme (reported by Chen Lei). Changes in version 1.16.5 (2017-05-24) - (fixed) predict.gls updated to match current version in nlme (reported by a certain Asteraceae on Stackoverflow) Changes in version 1.16.4 (2016-11-21) - (fixed) makeArgs.mark: reverted to a working version (this bug was introduced in 1.15.2/rev. 373. Reported by Jay Rotella) Changes in version 1.16.3 (2016-09-14) - (fixed) dredge: recognizes when global model's data is a function in a smarter way Changes in version 1.16.2 (2016-09-01) - (fixed) plot.model.selection: problem in case with only one model in the table (reported by Ryan Rothman on Stackoverflow) - dredge: recognizes when global model's data is a function (which is not allowed as it may cause sub-models being fitted to different datasets) Changes in version 1.16.1 (2016-07-29) - New suite of functions to support model averaging. It is based on original code developed by Carsten Dormann, as an outcome of the model-averaging workshop held in Freiburg in 2015. - (added) cos2Weights, BGWeights, jackknifeWeights, stackingWeights: calculate various types of model weights. - (added) loo: RMSE/log-likelihood based on leave-one-out cross-validation - (added) armWeights: similar to `arm.glm` but produces model weights. - (fixed) model.avg/model.sel: problems with intercept only models (spotted by a certain Teresa on Stackoverflow) Changes in version 1.15.8 (2016-07-05) - (fixed) dredge: no longer produces an error in the rare case when dependency matrix was an empty matrix [0x0]. - (fixed) r.squaredGLMM: error with naming of variance components in 'lmer' models. (both problems reported by a certain Teresa on Stackoverflow) - (added) Weights: has an assignment version, so weights can be applied to an "averaging" object. - get.models: now can extract models also from an "averaging" object (only when it was created with model objects). Changes in version 1.15.7 (2016-01-21) - (fixed) dredge: number of variables is limited to 30 to avoid integer overflow (reported by Sarah Grogan). Changes in version 1.15.6 (2015-12-21) - (fixed) get.models, dredge, subset.model.selection: enclosure for the subset expression evaluation is now `parent.frame()` rather than `.GlobalEnv` as it was before (incentive from Philipp Maier). - (fixed) coeffs.survreg, coefTable.survreg: log(scale) added to coefficients, when it is estimated (suggested by Nicolas Rode). Changes in version 1.15.5 (2015-11-25) - (fixed) [p]dredge: error with model with offsets in formula when 'subset' expression was given (reported by Adam Cummings) - (fixed) [p]dredge: in some cases the generated combinations did not obey the subset matrix (reported by Ben Augustine) - (fixed) model.selection column assignment "[<-" was broken when (spotted by a certain abmiller8 on Stackoverflow) - model.avg: warns when averaged 'gam' models have smooths with different dimension for the same variable. Changes in version 1.15.4 (2015-10-16) - (fixed) rbind, merge methods for "model.selection": wrong order of names of columns and rows (spotted by Ben Augustine) Changes in version 1.15.3 (2015-09-06) - (fixed) Weights: bug that caused that NaN's were returned (reported by Carles Alcaraz) Changes in version 1.15.2 (2015-07-07) - (added) summary.coefTable: tries to calculate p-values for coefficients, nicer printing using printCoefmat Changes in version 1.15.1 (2015-07-02) - added imports from all the default packages added to NAMESPACE in order to satisfy CRAN's new stricter RCheck. Changes in version 1.15.0 (2015-07-01) - (added) arm.glm: implements model averaging with weights calculated via ARM ("adaptive regression by mixing") algorithm. - "averaging" object: the elements "coef.shrinkage" and "coefTable" are replaced by matrix named "coefficients". The "Pval-tables" are accessed via summary(averaging)'s elements "coefmat.full" and "coefmat.subset". Objects created with previous versions will be automatically converted if needed. - [p]dredge: argument 'm.lim' replaces 'm.min' and 'm.max' (which are still present, but deprecated). - "model.selection" object: changing or removing essential columns (i.e. everything except 'varying' and 'extra') converts the object to a plain "data.frame" and drops all additional attributes. - (added) rbind.model.selection: combine multiple "model.selection" objects. - (added) 'xtable' methods for "averaging" and "model.selection" objects. - (fixed) updateable: does not cause infinite recursion when the resulting wrapper has the same name as the wrapped function. - (fixed) exprApply: now can deal with function expressions and 'expression's longer than one. Changes in version 1.14.1 (2015-06-12) - (fixed) [p]dredge no longer gives coefficient values as NA with [g]lmer (reported by Aitor Cevidanes). - Some tidying-up of manual and data (response in 'Cement' and 'Beetle' moved to first column so that formula(data) is correct). Changes in version 1.14.0 (2015-06-03) - (added) partial.sd, std.coef: calculate partial std. deviation and standardize model coefficients. 'beta.weights' is now deprecated in favour of 'std.coef'. - dredge, model.avg, model.sel: argument 'beta' is modified to allow for standardizing with SD or partial SD. - coefTable, coeffs: method for class 'aodml' (package 'aod3') no longer return 'phi' coefficients. This is for consistency with results of 'vcov' and 'coef', as well as their counterparts for 'glimML' models. - Removed all methods for 'mer' objects (used in lme4 < 1.0.0) Changes in version 1.13.10 (2015-06-01) - (fixed) compatibility with lme4-1.1.8, 'null.fit' now works properly with 'gamm' objects. Changes in version 1.13.9 (2015-05-28) - stdize: improved interpretation of the argument "scale". - new dataset "GPA" ("First-year college Grade Point Average" referred in Burnham & Anderson (2002)). Changes in version 1.13.8 (2015-05-22) - (added) QIC support for 'geem' models (request from Lee McDaniel). Changes in version 1.13.7 (2015-05-14) - coefTable: method for 'averaging' objects gains new arguments "full" and "adjust.se". - (fixed) getAllTerms: now correctly names coefficients of 'unmarked::gdistsamp' models (reported by Nathan Hostetter) Changes in version 1.13.6 (2015-05-01) - (fixed) model.avg, model.sel: now better distinguish model objects from lists of objects. Changes in version 1.13.5 (2015-04-15) - (fixed) r.squaredGLMM: method for 'lme' class with a multilevel grouping structure (reported by Alex Gunderson) Changes in version 1.13.4 (2015-02-24) - coefTable.coxph: added workaround for the case when variance-covariance matrix is NA (as in results of 'intcox') (reported by Vanessa Boukili) Changes in version 1.13.3 (2015-02-19) - get.models+subset.model.selection: unified 'subset' expression interpretation - dredge: no longer exceeds memory limit with very complex models, and its efficiency has somewhat improved. With trace=2 a progress bar is displayed. - model.sel: has new attribute 'fit'. - "averaging" object now stores component models. - model.sel,subset,get.models: unified interpretation of the "subset" expression - (fixed) extracting random effects formula (affected 'r.squaredGLMM' for 'lmer', reported by Yevgen Matusevych) - (fixed) makeArgs (and hence 'dredge'): formulas with no intercept are now handled correctly in 'zeroinfl' models. Changes in version 1.13.2 (2015-01-08) - (fixed) makeArgs (and hence 'dredge'): gave error if no random effects was specified in 'glmmadmb' model (reported by Szymek Drobniak). Changes in version 1.13.1 (2015-01-06) - (fixed) getAllTerms: now properly handles single formula in 'hurdle' and 'zeroinfl' models (package 'pscl'). Changes in version 1.13.0 (2015-01-03) - (added) get.response: utility to extract response variable. Changes in version 1.12.4 (2014-12-26) - (added) stdizeFit: utility to modify model object or a call to modelling function to use standardized data. Changes in version 1.12.3 (2014-12-23) - (fixed) checkModels: workaround for the "dotted argument identity" issue (namely sometimes equal "..1"s are not identical). Changes in version 1.12.2 (2014-12-19) - (fixed) [Q]AICc: previously they ignored REML argument for some model classes. The code has been rewritten so that most of the core calculation is done by a common internal function. Changes in version 1.12.1 (2014-12-16) - minor corrections to the documentation Changes in version 1.12.0 (2014-12-16) - (added) exprApply: new function to manipulate expressions (with example of use with 'dredge' to manipulate terms inside formula). - dredge, subset.model.selection: curly braces can be used to indicate complex terms (e.g. {I(x)} or {s(x,k=2}) instead of backtick quotes. Spacing in these expressions is irrelevant (as both whitespace and backticks seem to be a problem for some users). Changes in version 1.11.3 (2014-12-10) - (added) stdize: new function for standardizing data - (fixed) smarter sorting of interaction terms in coefficient names - print.model.selection: rank function call is added to the output Changes in version 1.11.2 (2014-12-01) - (fixed) r.squaredGLMM: in "binomial" family models the residual variance is used for additive dispersion (thanks to Paul Johnson). There is still issue with 'lmer' with 'subset' argument, and observation-level random term has to be specified manually. - (fixed) some formula-decomposition related functions (that sometimes caused problems with 'r.squaredGLMM' for 'lmer', reported by Yevgen Matusevych) - dredge: warns about potentially misspecified arguments - (added) predict method for 'gamm' class Changes in version 1.11.1 (2014-11-19) - dredge: more efficient checking for marginality in model terms (~10x faster in case of 4-way interaction). The argument 'marg.ex' is removed (exceptions to marginality rule are inferred from the global model). - getAllTerms: result has a new attribute 'deps' with a "term dependency matrix". - nested: new function listing nested models (suggested by Giacomo Assandri). - updateable: added new argument 'eval.args' Changes in version 1.10.8 (2014-11-14) - dredge, subset.model.selection: improved interpretation of 'subset' expressions. "Term(x)" notation can be used instead of backtick quotes for complex term names. Changes in version 1.10.7 (2014-09-24) - (fixed) coef.multinom: gave a wrong order of coefficients for multiple level responses (thanks to Alistair Senior who spotted this) Changes in version 1.10.6 (2014-08-17) - (added) methods for 'maxlike' (from package with the same name) - lazy loading of datasets - plot.model.selection: improved and documented Changes in version 1.10.5 (2014-08-08) - get.models: can now use parallel computation if a valid 'cluster' is provided. It takes over the functionality of 'pget.models', which is now deprecated. Also, the argument 'subset' must be now explicitely provided (so all models are no longer fitted by default). Changes in version 1.10.4 (2014-08-02) - (fixed) importance, model.avg: wrong order of 'N containing models' attribute (bug reported by Alba Estrada) - r.squaredGLMM: should be considerably faster and memory efficient due to improved calculation of random effects variance (slow performance with large datasets reported by Daniel Ezra Johnson). Changes in version 1.10.3 (2014-06-27) - (fixed) dredge: no longer drops random term in 'glmmadmb' models (spotted by Carlos Len) Changes in version 1.10.2 - mystery update Changes in version 1.10.1 (2014-05-19) - dredge: more meaningful warning message about misspecified 'fixed' argument - pdredge: synchronized code with 'dredge' - documentation: improved formatting Changes in version 1.10.0 (2014-05-02) - r.squaredGLMM: throws an error if contrasts that have been used for random factors in the "merMod" model do not match the ones in model matrix. This happens if there are factors in random slope formula and user has changed relevant 'options(contrasts)' since the model was fitted. - dredge: 'na.action' checking now allows "option(na.action)" to be a function and not only character string. Changes in version 1.9.26 (2014-03-16) - (fixed) dredge: when columns/rows in a subset matrix were in different order than model terms, the values became wrongly rearranged (spotted by a certain Frank on Stackoverflow). Changes in version 1.9.25 (2014-03-13) - (added) methods for 'cpglm' and 'cpglmm' (from package 'cplm') (suggested by Andrew Cooper) Changes in version 1.9.24 (2014-02-26) - (fixed) 'getAllTerms.unmarkedFit' gave error when 'alpha' was estimated in pcount model (reported by Lindsey Garner) Changes in version 1.9.23 (2014-02-24) - (added) methods 'model.matrix' and 'model.frame' for 'lme', because the default ones give wrong results when there is 'subset' or 'contrasts' set, or 'na.omit'ting. Changes in version 1.9.22 (2014-02-20) - r.squaredGLMM: can be now applied to models with random slopes (based on idea and R code by Paul Johnson). Added calculation of conditional R^2 for Poisson family models. Changes in version 1.9.21 (2014-02-17) - logLik.asreml: number of estimated parameters ('df') is now calculated as the number of fixed effect coefficients + number of variance parameters (non-fixed and non-constained). This gives comparable numbers to similar lmer models. In 'Asreml-R manual', however, only the number of variance components is used as K for AIC calculation (page 15). The log-likelihood values of asreml are far different from those from lmer(REML = TRUE), even though coefficients are very close. Note also that REstricted-likelihood is returned, so model comparisions based on it are invalid. - r.squaredGLMM: checks if it is applied to a random intercepts model, otherwise error is given. This is a limitation of the original formula by Nakagawa and Schiezlich. Changes in version 1.9.20 (2014-02-12) - (added) methods for 'phylolm' (suggestion by Rafael Maia) Changes in version 1.9.19 (2013-12-21) - (added) 'merge.model.selection' combines two 'model.selection' tables. Note that this is different than 'merge' for 'data.frame's (requested by Rafael Maia) Changes in version 1.9.18 (2013-12-18) - (added) methods for 'asreml' model (in commercial package 'asreml'). Note this has not been tested extensively (thanks to Emeline Mourocq for an incentive and testing) Changes in version 1.9.17 (2013-12-14) - full-averaged coefficients and standard errors are now calculated by 'model.avg' and relevant methods (argument full = TRUE) (suggested by Candan Soykan) - importance: result gives now also number of models containg each variable. Changes in version 1.9.16 (2013-11-24) - model.sel: now accepts arguments 'extra' and 'beta', like 'dredge' (requested by D. Duro on R-Forge). Changes in version 1.9.15 (2013-11-17) - [p]dredge: improved checking for whether the global model removes missing data (na.action = "na.omit" or "na.exclude"). Note that code working with previous versions may give you an error now, setting options(na.action = "na.fail") prevents it. Changes in version 1.9.14 (2013-11-03) - (added) support for 'betareg' (from package 'betareg') (suggested by Marie-Line Gentes) - (added) support for 'aodml' and 'aodql' (from package 'aods3') (suggested by Renaud Lancelot) [p]dredge: fixed a bug that occurred when there was 'na.action=na.omit' in global model (spotted by Laura Busia on R-help). Changes in version 1.9.13 (2013-10-28) - (fixed) handling response variables with more than two levels in 'nnet::multinom' models (reported by Ludo Duvaux on Stackoverflow) Changes in version 1.9.12 (2013-10-21) - further adjustments to deal with unavailability of 'lme4' on CRAN Changes in version 1.9.11 (2013-09-30) - Documentation: examples that depend on suggested packages have been made conditional on availability of the package - getCall method for 'model.selection' can retrieve a component model call if index is given as a second argument. Changes in version 1.9.10 (2013-08-27) - pdredge: removed global assignments (within cluster nodes). Changes in version 1.9.9 (2013-05-21) - (fixed) beta.weights: bug with dimensions dropped (spotted by Dennis Duro, thanks to Ben Bolker for tracking it down) Changes in version 1.9.8 (2013-05-02) - (fixed) handling bar in formulas for 'hurdle' class of models (reported by Jean-Yves Barnagaud) Changes in version 1.9.7 (2013-04-19) - dredge: 'subset' expression now recognizes ".(x)" notation to indicate a variable rather than a model term. Error message from within a 'rank' function gives now a more meaningfull call (apparently it is a common mistake to have some misspelled arguments that get passed to 'rank' function through '...'). Changes in version 1.9.6 (2013-04-12) - model.sel: better model naming in the result table - (fixed) logLik.coxme: 'nobs' attribute now uses a correct number of observations (model$n[2]). "penalized" log-lik. is the default type now (Note that "logLik.coxme"'s argument "type" is undocumented). Changes in version 1.9.5 (2013-04-04) - (fixed) AICc: now takes number of observations from "nall" (if it is available) attribute of the 'logLik' object. If not present, "nobs" attribute is used. - r.squaredGLMM: current implementation does not calculate the marginal variant correctly for Poisson family models, so until it is resolved 'NA' is returned, with a warning. Changes in version 1.9.4 (2013-04-01) - (fixed) pdredge: bug with wrong number of updated rows. - Replaced all calls to the soon-to-be deprecated ".find.package" with "find.package". Changes in version 1.9.3 (2013-02-21) - (fixed) method registration for 'getAllTerms.gam' was missing (reported by Steven Delean). Changes in version 1.9.2 (2013-02-01) - updateable: new function to create a wrapper for functions returning non-updateable objects (adds a 'call' element to the function's result). - (renamed) removed 'gamm' wrapper, which is now replaced by 'uGamm'. - (added) 'predict' method replacement for 'gls' models (adds 'se.fit' argument). - model.avg: no longer returns residuals (this is because residuals for models other than 'lm' can be calculated in several different ways - with different results). Changes in version 1.9.1 (2013-01-24) - (fixed) bugs with 'MCMCglmm' models and 'varying' lists in 'dredge'. Changes in version 1.9.0 (2013-01-23) - This version brings in more elaborated subsetting of models in 'dredge' and 'model.selection' object, and a new variant of pseudo-R^2. - [p]dredge: 'subset' can use 'varying' variables (as "V(varying.variable)") and number of model terms (as `*nvar*`). This allows for better fine-tuning of the selection table. 'fixed' argument can be set to TRUE to fix all terms of 'global.model'. [p]dredge, subset.model.selection: 'subset' expressions can now make use of a new function 'dc' ("dependency chain") to make inclusion of variables conditional on other variables. - r.squaredGLMM: new function to calculate R^2 statistic for mixed effect models, described by Nakagawa & Schiezlich (2012). - (added) support for 'splm' (from package 'splm'), and 'logistf' models (from package 'logistf'). - Cp: now accepts more than one model (like 'AIC'). - New demos "dredge.varying", "dredge.subset" and "gees". Changes in version 1.8.2 (2012-12-07) - (added) support for models of class 'mark' (from package 'RMark'). 'dredge' can currently only manipulate 'formula' element of argument 'model.parameters'. - simplify.formula, expand.formula: new functions to convert formula between expanded and shorthand notation (i.e. between 'a+b+a:b' and 'a*b'). - model.names: has new argument "use.letters". Changes in version 1.8.1 (2012-11-23) - (added) methods for class 'merMod' to accommodate recent changes in lme4_0.99999911-0. - getAllTerms: now recognizes random effects in 'MCMCglmm'. Changes in version 1.8.0 (2012-11-21) - This version introduces support for GEE models ('gee','geeglm' and 'yags') ranked by QIC (note that 'yags' seems to be still quite buggy). Also 'clmm' and 'clm' from package 'ordinal' are now handled properly. - QIC, quasiLik: new functions for use with GEE models. - [p]dredge: argument 'subset' can be now a logical matrix representing allowed parameter combinations. Some improvements for speed have been made. - [p]dredge, model.avg: new argument 'ct.args' for passing extra arguments to 'coefTable'. Changes in version 1.7.12 (2012-11-11) - tests/classes.R: fixed compatibility spdep-0.5.53. (spdep::spautolm now uses method = "eigen", was "full") Changes in version 1.7.11 (2012-07-13) - coefTable.multinom: fixed an error when coefficients and standard errors were matrices. - get.models: now checks for the object class of the passed arguments. Changes in version 1.7.10 (2012-06-07) - (fixed) dredge: bug with an error message when number of predictor exceeded maximum (thanks to Corina Logan for spotting this). - manual: added 'glmmADMB' to the list of supported classes (reported by Rocio Jana). - 'coxme' moved from 'Suggested' to 'Enhances' (to avoid build error when the dependency is missing). Changes in version 1.7.9 (2012-04-03) - (added) 'predict' methods for 'lme' and 'lmer' (both can calculate 'se.fit'). 'predict.lme' is a wrapper for its namesake from 'nlme' package (it is not exported, so it's visibility depends on the order the packages were loaded - but is always visible from MuMIn namespace). Changes in version 1.7.8 (2012-04-01) - (fixed) 'coef.model.selection' returns now proper coefficients Changes in version 1.7.7 (2012-04-01) - (fixed) dependencies in tests Changes in version 1.7.6 (2012-04-01) - dredge: with nested formula designs, 'marg.ex' is now found automatically - predict.averaging: is now more flexible in how the predictions from generalized models are calculated (new attribute "backtransform"). Changes in version 1.7.5 (2012-03-27) - (added) methods for 'MCMCglmm' class, and function 'DIC': works with 'model.sel' and 'dredge' (but not 'model.avg'). - 'unmarked' is removed from 'Suggested' packages (recently it is often unavailable on CRAN and causes errors during R CHECK). Added workarounds to pass (or trick) the R CHECK. Changes in version 1.7.3 (2012-02-01) - (added) methods for 'glimML' class from package 'aod' Changes in version 1.7.2 (2012-01-30) - (fixed) 'nobs.coxme' returned the number of events was returned rather than the number of observations. - (fixed) 'coefTable' gave an error for 'coxph' null model. - (fixed) 'r.squaredLR' was evaluating the null model for 'lme' in a wrong environment. - (fixed) 'getAllTerms' method for 'zeroinfl' was not registered. - dredge: checks each generated model for the correct number of observations. Changes in version 1.7.1 (2012-01-26) - (added) methods for 'hurdle' and 'zeroinfl' classes (package 'pscf'). - coef, coefTable: new methods to extract coefficients from model selection tables. - Documentation: list of supported models put into a separate page. Changes in version 1.7.0 (2012-01-25) - This version adds possibility to model average and re-rank (with another IC) a model selection table without recreating the fitted models. Models from package 'coxme' are now supported. Model selection tables include now extra columns showing differences in attributes of the modelling function call. - model.avg: use 'model.selection' without refitting the models. Fixed a problem with averaging different types of models together (happened when 'df's were available only for some of component models). - dredge: coefficient tables added to the result (attribute "coefTables"). The code has been simplified. - print.model.selection: now reports random terms also for objects generated by 'model.sel'. - get.models: can handle 'model.selection' objects from 'model.sel' - model.sel: re-ranking 'model.selection' without recreating original models (works only if the IC can be applied to logLik). Output has additional columns showing differences between models (based on call's arguments) - (added) generic methods for 'coxme' and 'lmekin' classes (package 'coxme'). Changes in version 1.6.6 (2012-01-07) - model.avg: fixed error occurring when non-estimable coefficients existed in the component models (problem reported by Annabel Smith) Changes in version 1.6.5 (2011-11-28) - pdredge example changed to use SOCK cluster type (portability issue). Changes in version 1.6.4 (2011-11-26) - coefTable: replaces 'tTable' (which still exists, but is deprecated), it accepts an argument 'dispersion'. The dispersion parameter can be also passed from 'model.avg'. - pdredge: collects all the warnings and errors which occur during fitting, and stores them. They are printed below the table. The function does more thorough checking of the cluster nodes' environment, for possible missing variables and functions. - get.models: "subset" argument can be now a character vector giving model names. - (added) demos for model selection with models from 'unmarked' package using 'dredge' and 'pdredge'. Changes in version 1.6.3 (2011-11-15) - pget.models: new function, parallel version of 'get.models'. - (p)get.models: important change of the default behaviour: without the 'subset' argument, ALL models are returned. Also the '...' arguments were not used to update the returned models - this is corrected now. Changes in version 1.6.2 (2011-11-13) - pdredge: new function, a parallel version of dredge (experimental). Changes in version 1.6.1 (2011-11-11) - dredge: added generic support for all 'unmarked' models, and fixed some bugs with it. - model.names: new function (previously was internal only) - CAICF: adds to the collection of rarely used information criteria. Changes in version 1.6.0 (2011-11-07) - dredge: most important change (although invisible to the user) is in the way the model objects are updated. The new function 'makeArgs' is used to generate the updated call. This results in a very flexible interface to the modelling functions. The default method updates the 'formula' argument, other methods can be used to deal with more problematic calls (the models from package 'unmarked' were a challenge). Apart from the model classes previously supported by 'dredge', support for 'unmarkedFitOccu', 'unmarkedFitColExt' and several other 'unmarkedFit' objects has been added. - dredge: has new argument 'extra' to add additional statistics into the model selection table. - r.squared: new function to calculate likelihood-ratio based pseudo-R-squared - subset method for 'model.selection': accepts a shorthand notation "has(x)" to select rows where a variable is present. - (added) support for 'survreg' and 'rq' models (packages 'survival' and 'quantreg') Changes in version 1.5.2 (2011-10-21) - dredge: fixed a bug with wrong ordering of column names in the returned data.frame (thanks to Staffan Roos for reporting this). Changes in version 1.5.1 (2011-10-20) - compatibility with R prior to 2.13.0: added workarounds for missing generic function 'nobs'. Changes in version 1.5.0 (2011-10-18) - model.avg: removed the argument "method", the standard errors and confidence intervals are calculated only for coefficients averaged within a subset of models where they are present (method = "NA"). The "full" coefficients are also returned, but without std. errors. - plot.model.selection: new function to visualize the model selection table - manuals expanded, examples revised - getAllTerms: should work for most of the classes derived from 'unmarkedFit' - a load of small improvements, polishings and fixes, generally invisible to the user. Changes in version 1.4.4 (2011-10-16) - QAIC: no longer uses model deviance, as it gave biased values. - ICOMP, Cp: new information criteria - model.avg: now performs a smarter check for duplicate models, fixed calculation of importance values - model.sel: new alias to 'mod.sel' (eventually will replace 'mod.sel'). Changes in version 1.4.3 (2011-10-13) - Beetle: new data - beetle mortality, with examples from B&A's book - dredge: new arguments 'varying', 'm.min' and 'evaluate' - manuals modified and corrected - tests/gamm.R: tests for 'gamm'/'gamm4' support. Changes in version 1.4.2 (2011-10-11) - support for 'gamm' and 'gamm4' - gamm: added a wrapper for gamm, that allows for updating the object (hopefully needed only temporarily) Changes in version 1.4.1 (2011-10-10) - A few changes to vignette 'gamm' Changes in version 1.4.0 (2011-10-05) - importance: new function - mod.sel: added method for a 'model.selection' object Changes in version 1.3.10 (2011-09-23) - Reverted changes made in previous version (package dependencies) to pass R check. Changes in version 1.3.9 (2011-09-17) - removed *.lmer *.glmer methods, added dependency on lme4 >= 0.999375-16 - tTable.mer: minor change Changes in version 1.3.8 (2011-09-17) - Restored compatibility with R 2.12.2 - getAllTerms: new attribute 'intercept' Changes in version 1.3.7 (2011-09-16) - handling double intercept (phi(Int) and p(Int)) in 'unmarked' Changes in version 1.3.6 (2011-09-12) - changes in the documentation and vignette Changes in version 1.3.5 (2011-08-05) - mod.sel: new function - added methods for 'unmarkedFit' objects (package 'unmarked'), to provide (limited) support in 'model.avg' Changes in version 1.3.4 (2011-08-03) - Added vignette document on model selection with 'gamm' and 'gamm4' (thanks to Graham MacDonald for an incentive) Changes in version 1.3.3 (2011-08-01) - dredge: small improvements, no longer dependent on 'bitops' - Polished the documentation Changes in version 1.3.2 (2011-08-01) - nobs: updated methods Changes in version 1.3.1 (2011-07-31) - dredge: bugs fixed Changes in version 1.3.0 (2011-07-29) - model.avg: now may be used directly with 'model.selection' object - summary.averaging: gives now more information Changes in version 1.2.4 (2011-07-29) - fixed handling of spatial parameters (lambda, rho) in models from package 'spdep' - dredge: modified for better performance - dredge, get.models: can deal with glms with starting values provided ('start' argument) - QAIC: added a note in documentation stating that is uses deviance rather than logLik in the calculation Changes in version 1.2.3 (2011-04-07) - fixed some REML/ML issues, AICc rewritten (based on the new AIC code in stats) Changes in version 1.2.2 (2011-04-06) - nobs: corrected methods for mixed models, added documentation page Changes in version 1.2.1 (2011-04-05) - .GetLogLik - hidden helper function (returns the proper logLik to use) Changes in version 1.2.0 (2011-04-04) - AICc has new argument REML used with mixed models. Thanks to Benjamin Augustine for suggestion. Changes in version 1.1.2 (2011-03-19) - removed arguments 'alpha' and 'level' from model.avg. 'confint' is used instead to obtain CI. Changes in version 1.1.1 (2011-03-18) - the printed output of 'averaging' has been made consistent with that of lm and glm: 'print' gives concise information and 'summary' gives more details. - confint.averaging: new function. - print.summary.averaging: new function. Changes in version 1.1.0 (2011-03-10) - added z-statistic, p-values (with significance stars) to model.avg output Changes in version 1.0.0 (2011-02-10) - get.models: fixed - arguments in ... were not passed to updated models - predict.averaging: predictions on response scale can be calculated (type=response) - new functions (not exported): nobs, coefDf - model.avg: now makes use of correct DF from component models in calculation of adjusted SE - par.avg: calculates ASE if df are provided, example(QAIC) now demonstrates predictions with confidence intervals Changes in version 0.14.2 (2011-02-05) - dredge: small changes, slightly faster - manual corrected Changes in version 0.14.1 (2011-02-04) - vcov.averaging, logLik.averaging: new methods, - revised formula for unconditional variance - manual reworked Changes in version 0.14.0 (2011-01-19) - TODO: model.avg: added npar to the selection table - predict.averaging: now can return averaged SE - par.avg: may use revised formula for calculating averaged SE Changes in version 0.13.21 (2011-01-16) - dredge: handling of update'd lmer models improved - QAICc: new function Changes in version 0.13.20 (2011-01-16) - Namespace exports updated (coxph methods) - dredge: uses now QAIC for glms with 'quasi*' family, and if no rank is specified Changes in version 0.13.19 (2011-01-15) - model.avg: fixed wrong ordering of model names (thanks to Dennis Jonason for noticing this) Changes in version 0.13.18 (2010-10-16) - Support for coxph (package survival) Changes in version 0.13.17 (2010-09-13) - model.avg: fixed a bug with models with binary response; - dredge: added checking for na.omit'ting in the global model. - new tests: varia.R Changes in version 0.13.16 (2010-09-07) - dredge, model.avg: broken support for several types of models was fixed Changes in version 0.13.15 (2010-09-06) - support for 'MASS::multinom' Changes in version 0.13.14 (2010-09-03) - print.model.selection: empty columns are not printed now Changes in version 0.13.13 (2010-09-02) - dredge: handling of models with no intercept, added "call" attribute - update.model.selection: new function Changes in version 0.13.12 (2010-08-29) - dredge, getAllTerms, dredge.Rd: small modifications Changes in version 0.13.11 (2010-08-28) - getAllTerms: improved handling of interactions, random terms (lmer) and "offset()" - formulaAllowed: now allows for exceptions in margins presence checking (new argument: "except") - dredge: now tries to call fitting function directly rather than through update (more effective in case when model not passed as a variable). New arguments: "trace", and "marg.ex" - marginality checking exceptions. Changes in version 0.13.10 (2010-08-26) - getAllTerms: fixed a bug with with wrong ordering of interaction terms (resulted with a:b or b:a depending on the set of terms). Improved handling of random terms in lme. Changes in version 0.13.9 (2010-08-24) - dredge: fixed bugs introduced in the previous version Changes in version 0.13.8 (2010-08-03) - QAIC: examples expanded Changes in version 0.13.7 (2010-08-02) - dredge: prints errors generated by models as warnings (previously these were skipped silently) Changes in version 0.13.6 (2010-08-01) - print.model.selection: improved column abbreviation. Changes in version 0.13.5 (2010-07-31) - dredge: fixed a bug causing interaction coefficients to be stripped from model.selection table, new function 'fixCoefNames' (not exported) handles proper ordering of interaction components in coefficient names. Changes in version 0.13.4 (2010-07-21) - 'beta.weights' now uses 'tTable' (support for more model types), 'dredge' with beta=TRUE tries out if it can get beta.weights working. - Manual: added gls and rlm to the list of supported models Changes in version 0.13.3 (2010-07-15) - Bug fixed in print.averaging Changes in version 0.13.2 (2010-07-14) - Attributes for custom rank function in "dredge" and "model.avg" are now evaluated model-wise, if provided as expressions. Changes in version 0.13.0-1 (2010-07-12) - Fixed compatibility issues with models of class "lme" and "sarlm". - "model.avg" does now some checking whether all models were fitted to the same data and have the same response. Changes in version 0.12.13 (2010-07-09) - 'recalc.weights' argument added to "subset.model.selection". - Small bug fixed in dredge. Changes in version 0.12.12 (2010-07-08) - New in "dredge": Subsetting models a priori according to a formula Changes in version 0.12.11 (2010-07-07) - Subset/extract methods for 'model.selection' object Changes in version 0.12.10 (2010-07-05) - Fixed "predict.averaging" for missing 'newdata' handling; Table returned by "dredge" now has factors for terms with more than one level (they were previously shown as '1') Changes in version 0.12.9 (2010-07-03) - Finally fixed problems with variable exporting and hidden methods Changes in version 0.12.7-8 (2010-07-02) - Small changes in namespace and documentation Changes in version 0.12.6 (2010-06-26) - Tidying up the code, small changes. Changes in version 0.12.4 (2010-06-21) - added: "predict.averaging" and "coef.averaging", 'averaging' object contains - additional elements, so that several default methods work with it. Changes in version 0.12.2 (2009-06-14) - fixed: 'alpha' in "model.avg" was not passed to "par.avg" Changes in version 0.12.1 (2009-04-20) - fixed: method="NA" in model.avg, par.avg now accepts NA's in 'weight' Changes in version 0.12.0 (2009-03-24) - Change in version number only. Had to make this jump in numbering, as there was a typo in DESCRIPTION file of an early version, (0.11.2 instead of 0.1.0), and since then R-forge mechanism seemed to ignore actual newer versions, as they had lower number. Changes in version 0.1.1 (2009-03-22) - Modified: dredge: added "fixed" and "m.max" arguments. Changes in version 0.1.1 (2009-03-17) - Fixed: par.avg: Variance estimate corrected (previous estimate was square root of variance). Thanks to Mick Wu. - Fixed: dredge: Apparently "expand.grid" cannot handle too many combinations, so now dredge stops with a more explanatory message Changes in version 0.1.0 - dRedging (0.11.2) moved to R-Forge. - Since model averaging is now the main focus of the package, the name changed to MuMIn (from MUlti Model INference). MuMIn/data/0000755000176200001440000000000015161444537012162 5ustar liggesusersMuMIn/data/GPA.rda0000644000176200001440000000102715161444537013261 0ustar liggesusers]R=hA\ ū$̥ "%E#p?qJ+%l: E[mLӓ9y7oڭBqma %K2K.0 DRg\ߨ|/m9N[jEg/QI}rGܟϻW'KPW2_H]ʮr$U{*+PC?4a>m_+o/}6kb @;m;']'yl/f>R(h,_GmTe>G~4L_(2U}/=p-p=C.hKxe5N7s` #n:X\-䪞bF'h7a2ʐeG9=j'IwioX|ue3 IVk;,ifoX[~fIYřMuMIn/data/Beetle.rda0000644000176200001440000000066415161444537014060 0ustar liggesusers r0b```b`aeb`b2Y# 'fsJM-Ie``X yHAl! b 6b[ bm b<7T#œ 5$Qp%PuNaaIMr9K2ˀ| s|*C1c@,ٿߜ 06}HC:>%U׉8eM|`:mCXC:mJ C !4 mrb8 ,E/*I,IB;O$@>4hlII,JI,IK+:M9gQ~an=9?775dc"$pT{@!D!53=DԲԜb4x#h MuMIn/data/Cement.rda0000644000176200001440000000046615161444537014073 0ustar liggesusers r0b```b`aeb`b2Y# 'fsNM+a``Xy0CdcpС@!L s:DA }nu1Pu!!c!tt$Xd] P*r(.$R@, @,&@lP; ^6 b(A!#b@, 2 s 鵁%5_d r@0J%2VBLpe gX 3 &ȕXVM9gQ~ 05R@`N?MuMIn/NAMESPACE0000644000176200001440000002375114723675052012501 0ustar liggesusers# Exports: export( "dredge", "pdredge", "get.models", "pget.models", "model.avg", "par.avg", "model.sel", "model.sel<-", "getAllTerms", "coeffs", "coefTable", "sw", "importance", "Weights", "Weights<-", "AICc", "QAIC", "QAICc", "Cp", "ICOMP", "CAICF", "DIC", "r.squaredLR", "null.fit", "r.squaredGLMM", "QIC", "QICu", "quasiLik", "model.names", "simplify.formula", "expand.formula", "updateable", "uGamm", "nested", "stdize", "stdizeFit", "exprApply", "get.response", "get_call", "std.coef", "beta.weights", "partial.sd", "arm.glm", "armWeights", "BGWeights", "cos2Weights", "jackknifeWeights", "stackingWeights", "bootWeights", "loo", fitdistr2, "coefplot", ".get.extras" ) # Imports: importFrom("graphics", "axis", "box", "mtext", "par", "plot.new", "plot.window", "rect", "strheight", "strwidth", "title", "abline", "lines", "matplot", "grconvertX", "grconvertY", "points", "segments") importFrom("grDevices", "n2mfrow", "col2rgb", "hcl.colors", "hcl.pals", "rgb") importFrom("methods", ".hasSlot", "isGeneric", "slot", "slotNames", "is", "selectMethod") importFrom("stats", ".checkMFClasses", ".getXlevels", ".MFclass", "AIC", "as.formula", "BIC", "delete.response", "deviance", "df.residual", "family", "fitted", "formula", "getCall", "glm.fit", "make.link", "median", "model.frame", "model.matrix", "model.response", "na.fail", "nobs", "power", "predict", "printCoefmat", "reformulate", "resid", "sigma", "sd", "var", "summary.glm", "terms", "terms.formula", "update", "update.default", "update.formula", "weighted.mean", "weights", "gaussian", "binomial", "Gamma", "inverse.gaussian", "quasi", "quasibinomial", "quasipoisson", "dnorm", "pnorm", "qnorm", "dt", "pt", "qt", "rbinom", "rgamma", "rpois", # for .simulateData "cor", "cov", "rnorm", "runif", "optim", "confint" ) importFrom("stats4", "logLik", "coef", "vcov") importFrom("utils", "capture.output", "getS3method", "isS3stdGeneric") importFrom("Matrix", "t", "rowSums", "det", "diag", "solve") importFrom("nlme", fixef, VarCorr) # Methods: S3method(getCall, yagsResult) S3method(print, averaging) S3method(print, summary.averaging) S3method(summary, averaging) S3method(predict, averaging) S3method(coef, averaging) S3method(fitted, averaging) S3method(logLik, averaging) S3method(confint, averaging) S3method(vcov, averaging) S3method(model.matrix, averaging) S3method(formula, averaging) S3method(print, model.selection) S3method(subset, model.selection) S3method(nobs, model.selection) S3method("[", model.selection) S3method("[[", model.selection) S3method("[<-", model.selection) S3method("[[<-", model.selection) S3method("$<-", model.selection) S3method("names<-", model.selection) S3method("row.names<-", model.selection) S3method(merge, model.selection) S3method(rbind, model.selection) S3method(update, model.selection) S3method(coef, model.selection) S3method(logLik, model.selection) S3method(duplicated, model.selection) S3method(model.sel, model.selection) S3method(model.sel, averaging) S3method(model.sel, default) S3method(model.avg, model.selection) S3method(model.avg, default) S3method(plot, model.selection) S3method(plot, averaging) S3method(sw, averaging) S3method(sw, model.selection) S3method(sw, default) S3method(print, sw) S3method(Weights, model.selection) S3method(Weights, averaging) S3method(Weights, data.frame) S3method(Weights, numeric) S3method(Weights, default) S3method("Weights<-", averaging) S3method("Weights<-", default) S3method(getAllTerms, default) S3method(coeffs, default) S3method(coefTable, default) S3method(coefTable, averaging) S3method(coef, model.selection) S3method(coeffs, model.selection) S3method(coefTable, model.selection) S3method(print, coefTable) S3method(plot, coefTable) S3method(summary, coefTable) S3method(print, summary.coefTable) S3method(getAllTerms, formula) S3method(getAllTerms, terms) S3method(getAllTerms, lm) S3method(coefTable, lm) S3method(getAllTerms, gam) S3method(nobs, Sarlm) S3method(coefTable, Sarlm) S3method(coefTable, Spautolm) S3method(nobs, Spautolm) S3method(logLik, glmmML) S3method(coefTable, glmmML) S3method(nobs, glmmML) S3method(getAllTerms, glmmML) S3method(summary, glmmML) S3method(getAllTerms, coxph) S3method(coefTable, coxph) S3method(coeffs, survreg) S3method(coefTable, survreg) S3method(getAllTerms, lme) S3method(coeffs, lme) S3method(coefTable, lme) S3method(model.frame, lme) S3method(model.matrix, lme) S3method(coeffs, merMod) S3method(coefTable, multinom) S3method(coeffs, multinom) S3method(nobs, multinom) S3method(coeffs, gls) S3method(coefTable, gls) S3method(formula, unmarkedFit) S3method(getAllTerms, unmarkedFit) S3method(coeffs, unmarkedFit) S3method(coefTable, unmarkedFit) S3method(nobs, unmarkedFit) # S3method(getAllTerms, unmarkedFitDS) # this is done by setting S4 method with an .onLoad hook: # S3method(logLik, unmarkedFit) S3method(update, gamm) S3method(print, gamm) S3method(logLik, gamm) S3method(formula, gamm) S3method(nobs, gamm) S3method(coeffs, gamm) S3method(getAllTerms, gamm) S3method(coefTable, gamm) S3method(predict, gamm) S3method(makeArgs, default) S3method(makeArgs, gls) S3method(makeArgs, lme) S3method(makeArgs, unmarkedFit) S3method(makeArgs, coxph) S3method(makeArgs, clmm) S3method(makeArgs, merMod) S3method(makeArgs, mer) # for 'cpglmm' S3method(makeArgs, glmmadmb) S3method(family, default) S3method(family, gls) S3method(family, lme) S3method(nobs, rq) S3method(coefTable, rq) S3method(coefTable, coxme) S3method(makeArgs, coxme) S3method(formula, coxme) S3method(getAllTerms, coxme) S3method(nobs, coxme) S3method(coeffs, coxme) S3method(coeffs, lmekin) S3method(makeArgs, lmekin) S3method(coefTable, lmekin) S3method(formula, lmekin) S3method(nobs, lmekin) S3method(logLik, lmekin) S3method(coefTable, zeroinfl) S3method(coefTable, hurdle) S3method(getAllTerms, hurdle) S3method(getAllTerms, zeroinfl) S3method(nobs, hurdle) S3method(nobs, zeroinfl) S3method(makeArgs, zeroinfl) S3method(family, zeroinfl) S3method(nobs, glimML) S3method(formula, glimML) S3method(coefTable, glimML) S3method(family, glimML) S3method(getAllTerms, glimML) S3method(terms, glimML) S3method(model.frame, glimML) S3method(formula, MCMCglmm) S3method(nobs, MCMCglmm) S3method(family, MCMCglmm) S3method(logLik, MCMCglmm) S3method(coeffs, MCMCglmm) S3method(coefTable, MCMCglmm) S3method(makeArgs, MCMCglmm) S3method(getAllTerms, MCMCglmm) S3method(extractDIC, merMod) S3method(extractDIC, MCMCglmm) S3method(extractDIC, lme) S3method(coef, geese) S3method(coefTable, gee) S3method(coefTable, geeglm) S3method(coefTable, geese) S3method(coefTable, geem) S3method(coefTable, yagsResult) S3method(getQIC, default) S3method(getQIC, gee) S3method(getQIC, geeglm) S3method(getQIC, yagsResult) S3method(getQIC, geem) S3method(getQIC, wgee) S3method(print, quasiLik) S3method(quasiLik, gee) S3method(quasiLik, geem) S3method(quasiLik, geeglm) S3method(quasiLik, yagsResult) S3method(quasiLik, wgee) S3method(nobs, yagsResult) S3method(nobs, geem) S3method(model.matrix, geem) S3method(coef, wgee) S3method(coefTable, wgee) S3method(nobs, wgee) S3method(formula, wgee) S3method(makeArgs, wgee) S3method(coeffs, mark) S3method(coefTable, mark) S3method(confint, mark) S3method(deviance, mark) S3method(formula, mark) S3method(getAllTerms, mark) S3method(logLik, mark) S3method(makeArgs, mark) S3method(nobs, mark) S3method(coefTable, splm) S3method(coeffs, splm) S3method(nobs, splm) S3method(logLik, splm) S3method(coefTable, logistf) S3method(nobs, logistf) S3method(logLik, logistf) S3method(coefTable, aodml) #S3method(coeffs, aodml) S3method(coefTable, aodml) S3method(makeArgs, aodml) S3method(nobs, aodql) S3method(coefTable, aodql) S3method(model.frame, aodml) S3method(model.matrix, aodml) S3method(getAllTerms, betareg) S3method(makeArgs, betareg) S3method(coefTable, betareg) S3method(family, betareg) S3method(getCall, model.selection) S3method(nobs, caic) S3method(formula, caic) S3method(nobs, pgls) S3method(nobs, asreml) S3method(coefTable, asreml) S3method(family, asreml) S3method(formula, asreml) S3method(getAllTerms, asreml) S3method(logLik, asreml) S3method(makeArgs, asreml) S3method(coeffs, asreml) S3method(nobs, phylolm) S3method(logLik, phylolm) S3method(coefTable, cplm) S3method(coefTable, cpglmm) S3method(nobs, cplm) S3method(nobs, cpglmm) S3method(logLik, cplm) S3method(coeffs, cpglmm) S3method(getAllTerms, cpglmm) S3method(logLik, maxlikeFit) S3method(nobs, maxlikeFit) S3method(formula, maxlikeFit) S3method(coefTable, maxlikeFit) S3method(coefTable, fitdistr) S3method(family, fitdistr) S3method(formula, fitdistr) S3method(nobs, fitdistr) S3method(stdize, default) S3method(stdize, numeric) S3method(stdize, logical) S3method(stdize, factor) S3method(stdize, data.frame) S3method(stdize, formula) S3method(stdize, matrix) S3method(get.response, default) S3method(get.response, lm) S3method(get.response, averaging) S3method(get.response, formula) S3method(coefTable, bic.glm) S3method(coefTable, glmmTMB) S3method(coeffs, glmmTMB) S3method(getAllTerms, glmmTMB) S3method(makeArgs, glmmTMB) S3method(loo, default) S3method(loo, lm) S3method(print, model.weights) S3method("[", model.weights) S3method(r.squaredGLMM, cplm) S3method(r.squaredGLMM, glmmadmb) S3method(r.squaredGLMM, glmmML) S3method(r.squaredGLMM, glmmTMB) S3method(r.squaredGLMM, lm) S3method(r.squaredGLMM, lme) S3method(r.squaredGLMM, merMod) S3method(.numfixef, default) S3method(.numfixef, glmmTMB) S3method(.OLREFit, default) S3method(.OLREFit, merMod) S3method(.remodmat, default) S3method(.remodmat, lme) S3method(.remodmat, merMod) S3method(.nullFitRE, default) S3method(.nullFitRE, lme) S3method(.varcorr, default) S3method(.varcorr, glmmadmb) S3method(.varcorr, glmmTMB) S3method(.varcorr, lme) S3method(sigma2, default) S3method(sigma2, glmmPQL) S3method(sigma2, glmmTMB) S3method(sigma2, glmerMod) S3method(.vcov, default) S3method(.vcov, glmmTMB) S3method(family, cplm) S3method(family, glmmadmb) S3method(sigma, glmmadmb) S3method(coeffs, gamlss) S3method(coefTable, gamlss) S3method(getAllTerms, gamlss) S3method(makeArgs, gamlss) MuMIn/man/0000755000176200001440000000000015161443462012020 5ustar liggesusersMuMIn/man/r.squaredLR.Rd0000644000176200001440000001061715161443462014456 0ustar liggesusers\name{r.squaredLR} \alias{r.squaredLR} \alias{null.fit} \encoding{utf-8} %% \newcommand{\mydequation}{\ifelse{latex}{\deqn{#1}{#3}}{\ifelse{html}{\enc{\deqn{#1}}{#3}}{#3}}} %% \newcommand{\myequation}{\ifelse{latex}{\eqn{#1}{#3}}{\ifelse{html}{\enc{\eqn{#1}}{#3}}{#3}}} %% \newcommand{\logLik}{\myequation{\log\mathcal{L}(#1)}{XXXX}{logL(#1)}} %% \newcommand{\Rsq}{\myequation{R^{2}}{XXXX}{R^2}} %% \newcommand{\Rsqx}{\myequation{R_{#1}^{2}}{XXXX}{R_#1^2}} \title{Likelihood-ratio based pseudo-R-squared} \description{ Calculate a coefficient of determination based on the likelihood-ratio test (\Rsqx{LR}). } \usage{ r.squaredLR(object, null = NULL, null.RE = FALSE, ...) null.fit(object, evaluate = FALSE, RE.keep = FALSE, envir = NULL, ...) } \arguments{ \item{object}{a fitted model object. } \item{null}{a fitted \emph{null} model. If not provided, \code{null.fit} will be used to construct it. \code{null.fit}'s capabilities are limited to only a few model classes, for others the \emph{null} model has to be specified manually. } \item{null.RE}{ logical, should the null model contain random factors? Only used if no \emph{null} model is given, otherwise omitted, with a warning. } \item{evaluate}{if \code{TRUE} evaluate the fitted model object else return the call. } \item{RE.keep}{if \code{TRUE}, the random effects of the original model are included. } \item{envir}{the environment in which the \emph{null} model is to be evaluated, defaults to the environment of the original model's formula. } \item{\dots}{further arguments, of which only \code{x} would be used, to maintain compatibility with older versions (\code{x} has been replaced with \code{object}).} } \value{ \code{r.squaredLR} returns a value of \Rsqx{LR}, and the attribute \code{"adj.r.squared"} gives the Nagelkerke's modified statistic. Note that this is not the same as nor equivalent to the classical \sQuote{adjusted R squared}. \code{null.fit} returns the fitted \emph{null} model object (if \code{evaluate = TRUE}) or an unevaluated call to fit a \emph{null} model. } \details{ This statistic is is one of the several proposed pseudo-\Rsq's for nonlinear regression models. It is based on an improvement from \emph{null} (intercept only) model to the fitted model, and calculated as \mydequation{ R_{LR}^{2}=1-\exp(-\frac{2}{n}(\log\mathcal{L}(x)-\log\mathcal{L}(0))) }{R² = 1 - exp(-2/n * ㏒ℓ(x) - ㏒ℓ(0)) }{R^2 = 1 - exp(-2/n * logL(x) - logL(0)) } where \logLik{x} and \logLik{0} are the log-likelihoods of the fitted and the \emph{null} model respectively. \acronym{ML} estimates are used if models have been fitted by \acronym{RE}stricted \acronym{ML} (by calling \code{logLik} with argument \code{REML = FALSE}). Note that the \emph{null} model can include the random factors of the original model, in which case the statistic represents the \sQuote{variance explained} by fixed effects. For \acronym{OLS} models the value is consistent with classical \Rsq. In some cases (e.g. in logistic regression), the maximum \Rsqx{LR} is less than one. The modification proposed by Nagelkerke (1991) adjusts the \Rsqx{LR} to achieve 1 at its maximum: \myequation{\bar{R}^{2} = R_{LR}^{2} / \max(R_{LR}^{2}) }{R̅² = R² / max(R²) }{Radj^2 = R^2 / max(R^2) } where \myequation{\max(R_{LR}^{2}) = 1 - \exp(\frac{2}{n}\log\mathcal{L}(\textrm{0})) }{max(R²) = 1 - exp(2 / n * ㏒ℓ(0)) }{max(R^2) = 1 - exp(2 / n * logL(0)) }. \code{null.fit} tries to guess the \emph{null} model call, given the provided fitted model object. This would be usually a \code{glm}. The function will give an error for an unrecognised class. } \note{ \Rsq is a useful goodness-of-fit measure as it has the interpretation of the proportion of the variance \sQuote{explained}, but it performs poorly in model selection, and is not suitable for use in the same way as the information criteria. } \references{ Cox, D. R. and Snell, E. J. 1989 \emph{The analysis of binary data}, 2nd ed. London, Chapman and Hall. Magee, L. 1990 \Rsq measures based on Wald and likelihood ratio joint significance tests. \emph{Amer. Stat.} \bold{44}, 250--253. Nagelkerke, N. J. D. 1991 A note on a general definition of the coefficient of determination. \emph{Biometrika} \bold{78}, 691--692. } \seealso{ \lcode{summary.lm}, \lcode{r.squaredGLMM} \lxcode{r2}{performance} from package \CRANpkg{performance} calculates many different types of \Rsq. } \keyword{models} MuMIn/man/QAIC.Rd0000644000176200001440000000556715161443462013041 0ustar liggesusers\name{QAIC} \alias{QAIC} \alias{QAICc} \encoding{utf-8} \title{Quasi AIC or AICc} \description{ Calculate a modification of Akaike's Information Criterion for overdispersed count data (or its version corrected for small sample, \emph{quasi-}\AICc), for one or several fitted model objects. } \usage{ QAIC(object, ..., chat, k = 2, REML = NULL) QAICc(object, ..., chat, k = 2, REML = NULL) } \arguments{ \item{object}{a fitted model object.} \item{\dots}{ optionally, more fitted model objects.} \item{chat}{ \eqn{\hat{c}}{c-hat}, the variance inflation factor. } \item{k}{the \sQuote{penalty} per parameter. } \item{REML}{ optional logical value, passed to the \code{logLik} method indicating whether the restricted log-likelihood or log-likelihood should be used. The default is to use the method used for model estimation. } } \value{ If only one object is provided, returns a numeric value with the corresponding \QAIC or \QAICc; otherwise returns a \code{data.frame} with rows corresponding to the objects. } \note{ \eqn{\hat{c}}{c-hat} is the dispersion parameter estimated from the global model, and can be calculated by dividing model's deviance by the number of residual degrees of freedom. In calculation of \QAIC, the number of model parameters is increased by 1 to account for estimating the overdispersion parameter. Without overdispersion, \eqn{\hat{c} = 1}{c-hat = 1} and \QAIC is equal to \AIC. Note that \code{glm} does not compute maximum-likelihood estimates in models within the \emph{quasi-} family. In case it is justified, it can be worked around by \sQuote{borrowing} the \code{aic} element from the corresponding \sQuote{non-quasi} family (see \sQuote{Example}). Consider using negative binomial family with overdispersed count data. } \seealso{ \lcode{AICc}, \lxcode{quasi}{stats:family} family used for models with over-dispersion. Tests for overdispersion in GLM[M]: \lxcode{check_overdispersion}{performance}. } \author{Kamil Barto\enc{ń}{n}} \examples{ \dontshow{oop <- } options(na.action = "na.fail") # Based on "example(predict.glm)", with one number changed to create # overdispersion budworm <- data.frame( ldose = rep(0:5, 2), sex = factor(rep(c("M", "F"), c(6, 6))), numdead = c(10, 4, 9, 12, 18, 20, 0, 2, 6, 10, 12, 16)) budworm$SF = cbind(numdead = budworm$numdead, numalive = 20 - budworm$numdead) budworm.lg <- glm(SF ~ sex*ldose, data = budworm, family = binomial) (chat <- deviance(budworm.lg) / df.residual(budworm.lg)) dredge(budworm.lg, rank = "QAIC", chat = chat) dredge(budworm.lg, rank = "AIC") \dontrun{ # A 'hacked' constructor for quasibinomial family object that allows for # ML estimation hacked.quasibinomial <- function(...) { res <- quasibinomial(...) res$aic <- binomial(...)$aic res } QAIC(update(budworm.lg, family = hacked.quasibinomial), chat = chat) } \dontshow{options(oop)} } \keyword{models} MuMIn/man/manip-formula.Rd0000644000176200001440000000166215161443462015063 0ustar liggesusers\name{Formula manipulation} \alias{simplify.formula} \alias{expand.formula} \encoding{utf-8} \title{Manipulate model formulas} \description{ \code{simplify.formula} rewrites a \code{formula} into shorthand notation. Currently only the factor crossing operator \code{*} is applied, so an expanded expression such as \code{a+b+a:b} becomes \code{a*b}. \code{expand.formula} does the opposite, additionally expanding other expressions, i.e. all nesting (\code{/}), grouping and \code{^}. } \usage{ simplify.formula(x) expand.formula(x) } \arguments{ \item{x}{a \code{formula} or an object from which it can be extracted (such as a fitted model object). } } \author{Kamil Barto\enc{ń}{n}} \seealso{ \lxcode{formula}{stats} \lcode{delete.response}, \lcode{drop.terms}, and \lcode{reformulate} } \examples{ simplify.formula(y ~ a + b + a:b + (c + b)^2) simplify.formula(y ~ a + b + a:b + 0) expand.formula(~ a * b) } \keyword{manip} MuMIn/man/model.avg.Rd0000644000176200001440000002014515161443462014165 0ustar liggesusers\name{model.avg} \alias{model.avg} \alias{model.avg.default} \alias{model.avg.model.selection} \alias{print.averaging} \encoding{utf-8} \title{Model averaging} \description{ Model averaging based on an information criterion. } \usage{ model.avg(object, ..., revised.var = TRUE) \method{model.avg}{default}(object, ..., beta = c("none", "sd", "partial.sd"), rank = NULL, rank.args = NULL, revised.var = TRUE, dispersion = NULL, ct.args = NULL) \method{model.avg}{model.selection}(object, subset, fit = FALSE, ..., revised.var = TRUE) } \arguments{ \item{object}{ a fitted model object or a list of such objects, or a \code{"model.selection"} object. See \sQuote{Details}. } \item{\dots}{ for default method, more fitted model objects. Otherwise, arguments that are passed to the default method. } \item{beta}{ indicates whether and how the component models' coefficients should be standardized. See the argument's description in \lcode{dredge}. } \item{rank}{ optionally, a rank function (returning an information criterion) to use instead of \code{AICc}, e.g. \code{BIC} or \code{QAIC}, may be omitted if \code{object} is a model list returned by \code{get.models} or a \code{"model.selection"} object. See \sQuote{Details}. } \item{rank.args}{ optional \code{list} of arguments for the \code{rank} function. If one is an expression, an \code{x} within it is substituted with a current model. } \item{revised.var}{ logical, indicating whether to use the revised formula for standard errors. See \lcode{par.avg}. } \item{dispersion}{ the dispersion parameter for the family used. See \lcode{summary.glm}. This is used currently only with \code{glm}, is silently ignored otherwise. } \item{ct.args}{ optional list of arguments to be passed to \lcode{coefTable} (besides \code{dispersion}). } \item{subset}{ see \lxcode{subset}{=subset.model.selection} method for \code{"model.selection"} object. } \item{fit}{ if \code{TRUE}, the component models are fitted using \code{get.models}. See \sQuote{Details}. } } \value{ An object of class \code{"averaging"} is a list with components: \item{msTable}{ a \code{data.frame} with log-likelihood, \emph{IC}, \ifelse{latex}{\eqn{\Delta_{IC}}}{\enc{Δ}{Delta}_IC} and \sQuote{Akaike weights} for the component models. Its attribute \code{"term.codes"} is a named vector with numerical representation of the terms in the row names of \code{msTable}. } \item{coefficients}{a \code{matrix} of model-averaged coefficients. \dQuote{full} coefficients in the first row, \dQuote{subset} coefficients in the second row. See \sQuote{Note} } \item{coefArray}{ a 3-dimensional \code{array} of component models' coefficients, their standard errors and degrees of freedom. } \item{sw}{ object of class \code{sw} containing per-model term sum of model weights over all of the models in which the term appears. } \item{formula}{ a formula corresponding to the one that would be used in a single model. The formula contains only the averaged (fixed) coefficients. } \item{call}{ the matched call. } The object has the following attributes: \item{rank}{the rank function used. } \item{modelList}{ optionally, a list of all component model objects. Only if the object was created with model objects (and not model selection table).} \item{beta}{ Corresponds to the function argument. } \item{nobs}{number of observations. } \item{revised.var}{ Corresponds to the function argument. } } \details{ \code{model.avg} may be used either with a list of models or directly with a \code{model.selection} object (e.g. returned by \code{dredge}). In the latter case, the models from the model selection table are not evaluated unless the argument \code{fit} is set to \code{TRUE} or some additional arguments are present (such as \code{rank} or \code{dispersion}). This results in a much faster calculation, but has certain drawbacks, because the fitted component model objects are not stored, and some methods (e.g. \code{predict}, \code{fitted}, \code{model.matrix} or \code{vcov}) would not be available with the returned object. Otherwise, \code{get.models} is called prior to averaging, and \dots are passed to it. For a list of model types that are accepted see \link[=MuMIn-models]{list of supported models}. \code{rank} is found by a call to \lxcode{match.fun}{base} and typically is specified as a function or a symbol or a character string specifying a function to be searched for from the environment of the call to lapply. \code{rank} must be a function able to accept model as a first argument and must always return a numeric scalar. Several standard methods for fitted model objects exist for class \code{averaging}, including \code{summary}, \lxcode{predict}{=predict.averaging}, \code{coef}, \code{confint}, \lcode{formula}, and \lcode{vcov}. \code{coef}, \code{vcov}, \code{confint} and \code{coefTable} accept argument \code{full} that if set to \code{TRUE}, the full model-averaged coefficients are returned, rather than subset-averaged ones (when \code{full = FALSE}, being the default). % \code{ % coef(object, full = FALSE, ...) % confint(object, parm, level = 0.95, full = FALSE, ...) % vcov(object, full = FALSE, ...) % coefTable(model, full = FALSE, ...) % } \code{logLik} returns a list of \lxcode{logLik}{stats} objects for the component models. } \note{ The \sQuote{subset} (or \sQuote{conditional}) average only averages over the models where the parameter appears. An alternative, the \sQuote{full} average assumes that a variable is included in every model, but in some models the corresponding coefficient (and its respective variance) is set to zero. Unlike the \sQuote{subset average}, it does not have a tendency of biasing the value away from zero. The \sQuote{full} average is a type of shrinkage estimator, and for variables with a weak relationship to the response it is smaller than \sQuote{subset} estimators. Averaging models with different contrasts for the same factor would yield nonsense results. Currently, no checking for contrast consistency is done. \code{print} method provides a concise output (similarly as for \code{lm}). To print more details use \code{summary} function, and \lcode{confint} to get confidence intervals. } \references{ Burnham, K. P. and Anderson, D. R. 2002 \emph{Model selection and multimodel inference: a practical information-theoretic approach}. 2nd ed. New York, Springer-Verlag. Lukacs, P. M., Burnham K. P. and Anderson, D. R. 2009 Model selection bias and Freedman’s paradox. \emph{Annals of the Institute of Statistical Mathematics} \bold{62}, 117–125. } \author{Kamil Barto\enc{ń}{n}} \seealso{ See \lcode{par.avg} for more details of model-averaged parameter calculation. \lcode{dredge}, \lcode{get.models} \cr \lcode{AICc} has examples of averaging models fitted by REML. \code{modavg} in package \pkg{AICcmodavg}, and \code{coef.glmulti} in package \pkg{glmulti} also perform model averaging. } \examples{ # Example from Burnham and Anderson (2002), page 100: fm1 <- lm(y ~ ., data = Cement, na.action = na.fail) (ms1 <- dredge(fm1)) # Use models with Delta AICc < 4 summary(model.avg(ms1, subset = delta < 4)) #or as a 95\% confidence set: avgmod.95p <- model.avg(ms1, cumsum(weight) <= .95) confint(avgmod.95p) \dontrun{ # The same result, but re-fitting the models via 'get.models' confset.95p <- get.models(ms1, cumsum(weight) <= .95) model.avg(confset.95p) # Force re-fitting the component models model.avg(ms1, cumsum(weight) <= .95, fit = TRUE) # Models are also fitted if additional arguments are given model.avg(ms1, cumsum(weight) <= .95, rank = "AIC") } \dontrun{ # using BIC (Schwarz's Bayesian criterion) to rank the models BIC <- function(x) AIC(x, k = log(length(residuals(x)))) model.avg(confset.95p, rank = BIC) # the same result, using AIC directly, with argument k # 'x' in a quoted 'rank' argument is substituted with a model object # (in this case it does not make much sense as the number of observations is # common to all models) model.avg(confset.95p, rank = AIC, rank.args = alist(k = log(length(residuals(x))))) } } \keyword{models} MuMIn/man/Weights.Rd0000644000176200001440000000615515161443462013730 0ustar liggesusers\name{Weights} \alias{Weights} \alias{Weights<-} \encoding{utf-8} \title{Akaike weights} \description{ Calculate, extract or set normalized model likelihoods (\sQuote{Akaike weights}). } \usage{ Weights(x) Weights(x) <- value } \arguments{ \item{x}{a numeric vector of any information criterion (such as \AIC, \AICc, \QAIC, \BIC) values, or objects returned by functions like \code{AIC}. There are also methods for extracting \sQuote{Akaike weights} from \code{"model.selection"} or \code{"averaging"} objects. } \item{value}{numeric, the new weights for the \code{"averaging"} object or \code{NULL} to reset the weights based on the original \IC used. The assigned \code{value} need not sum to one, but if they are all zero, the result will be invalid (\code{NaN}). } } \details{ \sQuote{Akaike weights}, \myequation{\omega_{i}}{X}{w_i}, of a model \var{i} can be interpreted as the probability that the model is the best (approximating) model given the data and the set of all models considered. The weights are calculated as: \mydequation{ \omega_i = \frac{\exp(\Delta_i/2)}{\sum_{r=1}^{R}\exp(\Delta_r/2)} }{X}{ w_i = exp(Delta_i / 2) / (sum(exp(Delta_r / 2)) } where \DeltaIC{i} is the \IC difference of the \var{i}-th model relative to the smallest \IC value in the set of \var{R} models. The replacement version of \code{Weights} can assign new weights to an \code{"averaging"} object, affecting coefficient values and the order of component models. Upon assignment, the weights are normalised to sum to one. } \value{ For the extractor, a numeric vector of normalized likelihoods. } \note{ Assigning new weights changes the model order accordingly, so reassigning weights to the same object must take this new order into account, otherwise the averaged coefficients will be calculated incorrectly. To avoid this, either re-set the model weights by assigning \code{NULL}, or sort the new weights using the (decreasing) order of the previously assigned weights. } \author{Kamil Barto\enc{ń}{n}} \seealso{ \lcode{sw}, \lcode{weighted.mean} \lcode{armWeights}, \lcode{bootWeights}, \lcode{BGWeights}, \lcode{cos2Weights}, \lcode{jackknifeWeights} and \lcode{stackingWeights} can be used to produce various kinds of model weights. Not to be confused with \lcode{weights}, which extracts fitting weights from model objects. } \examples{ fm1 <- glm(Prop ~ dose, data = Beetle, family = binomial) fm2 <- update(fm1, . ~ . + I(dose^2)) fm3 <- update(fm1, . ~ log(dose)) fm4 <- update(fm3, . ~ . + I(log(dose)^2)) round(Weights(AICc(fm1, fm2, fm3, fm4)), 3) am <- model.avg(fm1, fm2, fm3, fm4, rank = AICc) coef(am) # Assign equal weights to all models: Weights(am) <- rep(1, 4) # assigned weights are rescaled to sum to 1 Weights(am) coef(am) # Assign dummy weights: wts <- c(2,1,4,3) Weights(am) <- wts coef(am) # Component models are now sorted according to the new weights. # The same weights assigned again produce incorrect results! Weights(am) <- wts coef(am) # wrong! # Weights(am) <- NULL # reset to original model weights Weights(am) <- wts coef(am) # correct } \keyword{models} MuMIn/man/nested.Rd0000644000176200001440000000544215161443462013576 0ustar liggesusers\name{nested} \alias{nested} \encoding{utf-8} \title{Identify nested models} \description{ Find models that are \sQuote{nested} within each model in the model selection table. } \usage{ nested(x, indices = c("none", "numeric", "rownames"), rank = NULL) } \arguments{ \item{x}{a \code{"model.selection"} object (result of \code{dredge} or \code{model.sel}). } \item{indices}{if omitted or \code{"none"} then the function checks if, for each model, there are any higher ranked models nested within it. If \code{"numeric"} or \code{"rownames"}, indices or names of all nested models are returned. See \dQuote{Value}. } \item{rank}{the name of the column with the ranking values (defaults to the one before \dQuote{delta}). Only used if \code{indices} is \code{"none"}. } } \value{ A vector of length equal to the number of models (table rows). If \code{indices = "none"} (the default), it is a vector of logical values where \emph{i}-th element is \code{TRUE} if any model(s) higher up in the table are nested within it (i.e. if simpler models have lower IC pointed by \code{rank}). For \code{indices} other than \code{"none"}, the function returns a list of vectors of numeric indices or names of models nested within each \emph{i}-th model. } \details{ In model comparison, a model is said to be \dQuote{nested} within another model if it contains a subset of parameters of the latter model, but does not include other parameters (e.g. model \sQuote{A+B} is nested within \sQuote{A+B+C} but not \sQuote{A+C+D}). This function can be useful in a model selection approach suggested by Richards (2008), in which more complex variants of any model with a lower IC value are excluded from the candidate set. } \note{ This function determines nesting based only on fixed model terms, within groups of models sharing the same \sQuote{varying} parameters (see \lcode{dredge} and example in \lcode{Beetle}). } \author{Kamil Barto\enc{ń}{n}} \references{ Richards, S. A., Whittingham, M. J., Stephens, P. A. 2011 Model selection and model averaging in behavioural ecology: the utility of the IT-AIC framework. \emph{Behavioral Ecology and Sociobiology} \bold{65}, 77--89. Richards, S. A. 2008 Dealing with overdispersed count data in applied ecology. \emph{Journal of Applied Ecology} \bold{45}, 218--227. } \seealso{ \lcode{dredge}, \lcode{model.sel} } \examples{ fm <- lm(y ~ X1 + X2 + X3 + X4, data = Cement, na.action = na.fail) ms <- dredge(fm) # filter out overly complex models according to the # "nesting selection rule": subset(ms, !nested(.)) # dot represents the ms table object # print model "4" and all models nested within it nst <- nested(ms, indices = "row") ms[c("4", nst[["4"]])] ms$nested <- sapply(nst, paste, collapse = ",") ms } \keyword{models} MuMIn/man/ICs.Rd0000644000176200001440000000712615161443462012773 0ustar liggesusers\name{Information criteria} \alias{IC} \alias{Mallows' Cp} \alias{Cp} \alias{ICOMP} \alias{CAICF} \alias{DIC} \encoding{utf-8} \title{Various information criteria} \description{ Calculate Mallows' \emph{Cp} and Bozdogan's \acronym{ICOMP} and \acronym{CAIFC} information criteria. Extract or calculate Deviance Information Criterion from \code{MCMCglmm} and \code{merMod} object. } \usage{ Cp(object, ..., dispersion = NULL) ICOMP(object, ..., REML = NULL) CAICF(object, ..., REML = NULL) DIC(object, ...) } \arguments{ \item{object}{a fitted model object (in case of \code{ICOMP} and \code{CAICF}, \code{logLik} and \code{vcov} methods must exist for the object). For \code{DIC}, an object of class \code{"MCMCglmm"} or \code{"merMod"}. } \item{\dots}{optionally more fitted model objects. } \item{dispersion}{the dispersion parameter. If \code{NULL}, it is inferred from object. } \item{REML}{optional logical value, passed to the \code{logLik} method indicating whether the restricted log-likelihood or log-likelihood should be used. The default is to use the method used for model estimation. } } \value{ If just one object is provided, the functions return a numeric value with the corresponding \IC; otherwise a \code{data.frame} with rows corresponding to the objects is returned. } \details{ Mallows' \emph{Cp} statistic is the residual deviance plus twice the estimate of \eqn{\sigma^{2}}{sigma^2} times the residual degrees of freedom. It is closely related to \AIC (and a multiple of it if the dispersion is known). \acronym{ICOMP} (I for informational and COMP for complexity) penalizes the covariance complexity of the model, rather than the number of parameters directly. % \deqn{\mbox{ICOMP}=-2\log\mathit{Lik}(\hat{\theta})+k(\log(n)+2)+2C(\hat{\Sigma}_{model})} %\deqn{\mbox{ICOMP}=-2\log L+k\,\log(\frac{tr(\Sigma)}{k})-\log\mid\Sigma\mid} % %where log\emph{L} is the log-likelihood, \eqn{\Sigma} is the variance-covariance %matrix of parameters, \emph{k} is the number of parameters, and \emph{tr} is the %trace of the matrix. CAICF (C is for \sQuote{consistent} and F denotes the use of the Fisher information matrix) includes with penalty the natural logarithm of the determinant of the estimated Fisher information matrix. % deqn{\mbox{CAICF}=-2\log\mathit{Lik}(\hat{\theta})+k(\log(n)+2)+ % \log|\mathit{I}(\hat{\theta})|} } % Bozdogan, H (1990) On the information-based measure of covariance complexity % and its application to the evaluation of multivariate linear models. \emph{Comm. % Stat. Theory and Methods} 19: 221-278 % Bozdogan, H. (2000). Akaike's Information Criteria and recent developments in % Information Complexity. \emph{J. Math. Psych.} 44: 62-91 \references{ Mallows, C. L. 1973 Some comments on \emph{Cp}. \emph{Technometrics} \bold{15}, 661–675. Bozdogan, H. and Haughton, D. M. A. (1998) Information complexity criteria for regression models. \emph{Comp. Stat. & Data Analysis} \bold{28}, 51--76. Anderson, D. R. and Burnham, K. P. 1999 Understanding information criteria for selection among capture-recapture or ring recovery models. \emph{Bird Study} \bold{46}, 14--21. Spiegelhalter, D. J., Best, N. G., Carlin, B. R., van der Linde, A. 2002 Bayesian measures of model complexity and fit. \emph{Journal of the Royal Statistical Society Series B-Statistical Methodology} \bold{64}, 583--616. } \seealso{ \lcode{AIC} and \lcode{BIC} in \pkg{stats}, \lcode{AICc}. \lcode{QIC} for GEE model selection. \code{extractDIC} in package \pkg{arm}, on which the (non-visible) method \code{extractDIC.merMod} used by \code{DIC} is based. } % \examples{} \keyword{models} MuMIn/man/dredge.Rd0000644000176200001440000004155515161443462013553 0ustar liggesusers\name{dredge} \alias{dredge} \alias{dc} \alias{V} \alias{print.model.selection} \encoding{utf-8} \title{Automated model selection} \description{ Generate a model selection table of models with combinations (subsets) of fixed effect terms in the global model, with optional model inclusion rules. } \usage{ dredge(global.model, beta = c("none", "sd", "partial.sd"), evaluate = TRUE, rank = "AICc", fixed = NULL, m.lim = NULL, m.min, m.max, subset, trace = FALSE, varying, extra, ct.args = NULL, deps = attr(allTerms0, "deps"), cluster = NULL, ...) \method{print}{model.selection}(x, abbrev.names = TRUE, warnings = getOption("warn") != -1L, ...) } \arguments{ \item{global.model}{a fitted \sQuote{global} model object. See \sQuote{Details} for a list of supported types. } \item{beta}{indicates whether and how the coefficients are standardized, and must be one of \code{"none"}, \code{"sd"} or \code{"partial.sd"}. You can specify just the initial letter. \code{"none"} corresponds to unstandardized coefficients, \code{"sd"} and \code{"partial.sd"} to coefficients standardized by \acronym{SD} and Partial \acronym{SD}, respectively. For backwards compatibility, logical value is also accepted, \code{TRUE} is equivalent to \code{"sd"} and \code{FALSE} to \code{"none"}. See \lcode{std.coef}. } \item{evaluate}{whether to evaluate and rank the models. If \code{FALSE}, a list of unevaluated \code{call}s is returned. } \item{rank}{optionally, the rank function returning a sort of an information criterion, to be used instead \code{AICc}, e.g. \code{AIC}, \code{QAIC} or \code{BIC}. See \sQuote{Details}. } \item{fixed}{optional, either a single-sided formula or a character vector giving names of terms to be included in all models. Not to be confused with fixed effects. See \sQuote{Subsetting}. } \item{m.lim, m.max, m.min}{optionally, the limits \code{c(lower, upper)} for the number of terms in a single model (excluding the intercept). An \code{NA} means no limit. See \sQuote{Subsetting}. Specifying limits as \code{m.min} and \code{m.max} is allowed for backward compatibility. } \item{subset}{logical expression or a \code{matrix} describing models to be kept in the resulting set. \code{NULL} or \code{TRUE} disables subsetting. For details, see \sQuote{Subsetting}. } \item{trace}{if \code{TRUE} or \code{1}, all calls to the fitting function are printed before actual fitting takes place. If \code{trace > 1}, a progress bar is displayed. } \item{varying}{optionally, a named list describing the additional arguments to vary between the generated models. Item names correspond to the arguments, and each item provides a list of choices (i.e. \code{list(arg1 = list(choice1, choice2, ...), ...)}). Complex elements in the choice list (such as \code{family} objects) should be either named (uniquely) or quoted (unevaluated, e.g. using \lcode{alist}, see \lcode{quote}), otherwise the result may be visually unpleasant. See example in \lcode{Beetle}. } \item{extra}{optional additional statistics to be included in the result, provided as functions, function names or a list of such (preferably named or quoted). As with the \code{rank} argument, each function must accept as an argument a fitted model object and return (a value coercible to) a numeric vector. This could be, for instance, additional information criteria or goodness-of-fit statistics. The character strings \code{"R^2"} and \code{"adjR^2"} are treated in a special way and add a likelihood-ratio based \Rsq and modified-\Rsq to the result, respectively (this is more efficient than using \lcode{r.squaredLR} directly). } \item{x}{a \code{model.selection} object, returned by \code{dredge}. } \item{abbrev.names}{Should term names in the table header be abbreviated when printed? This is the default. If full names are required, use \code{print()} explicitly with this argument set to \code{FALSE}. } \item{warnings}{if \code{TRUE}, errors and warnings issued during the model fitting are printed below the table (only with \code{pdredge}). To permanently remove the warnings, set the object's attribute \code{"warnings"} to \code{NULL}. } \item{ct.args}{optional list of arguments to be passed to \lcode{coefTable} (e.g. \code{dispersion} parameter for \code{glm} affecting standard errors used in subsequent \lxcode{model averaging}{=model.avg}).} \item{deps}{a \dQuote{dependency matrix} as returned by \code{getAllTerms}, attribute \code{"deps"}. Can be used to fine-tune marginality exceptions. } \item{cluster}{if a valid \code{"cluster"} object is given, it is used for parallel execution. If \code{NULL} or omitted, execution is single-threaded. With parallel calculation, an extra argument \code{check} is accepted. See \lcode{pdredge} for details and examples. } \item{\dots}{optional arguments for the \code{rank} function. Any can be an unevaluated expression, in which case any \code{x} within it will be substituted with the current model. } } \details{ Models are fitted through repeated evaluation of the modified call extracted from the \code{global.model} (in a similar fashion to \code{update}). This approach, while having the advantage that it can be applied to most model types through the usual formula interface, can have a considerable computational overhead. Note that the number of combinations grows exponentially with the number of predictors (\ifelse{latex}{\eqn{2^{N}}}{\ifelse{html}{\eqn{2^{N}}}{2^N}}, less when interactions are present, see below). The fitted model objects are not stored in the result. To get (a subset of) the models, use \lcode{get.models} on the object returned by \code{dredge}. Another way to get all the models is to run \code{lapply(dredge(..., evaluate = FALSE), eval)}, which avoids fitting models twice. For a list of model types that can be used as a \code{global.model} see \link[=MuMIn-models]{the list of supported models}. Modelling functions that do not store a \code{call} in their result should be run \emph{via} a wrapper function created by \lcode{updateable}. \subsection{Information criterion}{ \code{rank} is found by a call to \code{match.fun} and may be specified as a function, a symbol, or as a character string specifying a function to be searched for from the environment of the call to \code{dredge}. It can be also a one-element named list, where the first element is taken as the rank function. The function \code{rank} must accept a model object as its first argument and always return a scalar. } \subsection{Interactions}{ By default, marginality constraints are respected, so that \dQuote{all possible combinations} include only those that contain interactions with their respective main effects and all lower order terms, unless the \code{global.model} makes an exception to this principle (e.g. due to a nested design such as \code{a / b}). } \subsection{Subsetting}{ The resulting set of models can be constrained with three methods: (1) set limits on the number of terms in a model with \code{m.lim}, (2) bind term(s) to all models with \code{fixed}, and (3) use \code{subset} for more complex rules. To be included in the selection table, the formulation of a model must satisfy all these conditions. %%Terms in \code{fixed} argument are applied before the combinations are %%generated, therefore more efficient than \code{subset}. \code{subset} can be an \emph{expression} or a \emph{matrix}. If a matrix, it should be a logical, lower triangular matrix, with rows and columns corresponding to \code{global.model} terms. If this matrix has \code{dimnames}, they must match the term names (as returned by \code{getAllTerms}). Unmatched names are silently ignored. Otherwise, if rows or columns are unnamed, they are matched positionally to the model terms, and \code{dim(subset)} must be equal to the number of terms. For example, \code{subset["a", "b"] == FALSE} excludes models with both \var{a} and \var{b} terms; and if unnamed, \code{subset}, \code{subset[2, 3] == FALSE} will prevent the second and third terms of the global model from being both in the same model. \cr \code{demo(dredge.subset)} has examples of using the \code{subset} matrix in conjunction with correlation matrices to exclude models containing collinear predictors. In the form of an \code{expression}, the argument \code{subset} acts similarly to that of \code{subset()} for \code{data.frame}s. Model terms can be referred to by name as variables in the expression, except that they are interpreted as logical values indicating the presence of a term in the model. The expression can contain any of the \code{global.model} term names, as well as names of the \code{varying} list items. \code{global.model} term names take precedence when identical to names of \code{varying}, so to avoid ambiguity \code{varying} variables in \code{subset} expression should be enclosed in \code{V()} (e.g. \code{V(family) == "Gamma"}) assuming that \code{varying} is something like \code{list(family =} \code{c("Gamma", ...))}). If elements of \code{varying} are unnamed, they are coerced into names. Calls and symbols are represented as character values (via "deparse"), and everything except numeric, logical, character and NULL values is represented by element numbers (e.g. \code{subset = V(family) == 2} points to \code{Gamma} family in \code{varying =}\code{list(family =}\code{list(gaussian, Gamma)}). This can easily become obscure, so using named lists in \code{varying} is recommended. Examples can be found in \code{demo(dredge.varying)}. Term names appearing in \code{fixed} and \code{subset} must be given exactly as they are returned by \code{getAllTerms(global.model)}, which may differ from the original term names (e.g. the interaction term components are ordered alphabetically). The \code{with(x)} and \code{with(+x)} notation indicates, respectively, any and all interactions including the main effect term \code{x}. This is only effective with marginality exceptions. The extended form \code{with(x, order)} allows to specify the order of interaction of terms of which \code{x} is a part. For instance, \code{with(b, 2:3)} selects models with at least one second- or third-order interaction of variable \code{b}. The second (positional) argument is coerced to an integer vector. The \dQuote{dot} notation \code{.(x)} is an alias for \code{with}. The special variable \ifelse{latex}{\bq{*nvar*}}{\code{`*nvar*`}} (backtick-quoted), in the \code{subset} expression is equal to the number of terms in the model (\bold{not} the number of parameters). To include a model term conditionally on the presence of another term, use \code{dc} (\dQuote{\bold{d}ependency \bold{c}hain}) in the \code{subset} expression. \code{dc} takes any number of term names as arguments, and allows a term to be included only if all preceding ones are also present (e.g. \code{subset = dc(a, b, c)} allows for models \code{a}, \code{a+b} and \code{a+b+c} but not \code{b}, \code{c}, \code{b+c} or \code{a+c}). \code{subset} expression can have a form of an unevaluated \code{call}, \code{expression} object, or a one-sided \code{formula}. See \sQuote{Examples}. Compound model terms (such as interactions, \sQuote{as-is} expressions within \code{I()} or smooths in \code{gam}) should be enclosed within curly brackets (e.g. \code{{s(x,k=2)}}), or \link[=Quotes]{backticks} (like non-syntactic names, e.g. \ifelse{latex}{ \bq{s(x, k = 2)} }{ \code{`s(x, k = 2)`} }), except when they are arguments to \code{with} or \code{dc}. Backtick-quoted names must match exactly (including whitespace) the term names as returned by \code{getAllTerms}. \subsection{\code{subset} expression syntax summary}{ \describe{ \item{\code{a & b}}{ indicates that model terms \var{a} and \var{b} must be present (see \link[=Logic]{Logical Operators}) } \item{\code{{log(x,2)}} or \bq{log(x, 2)}}{ represent a complex model term \code{log(x, 2)}} \item{\code{V(x)}}{ represents a \code{varying} item \var{x} } \item{\code{with(x)}}{ indicates that at least one term containing the main effect term \var{x} must be present } \item{\code{with(+x)}}{ indicates that all the terms containing the main effect term \var{x} must be present } \item{\code{with(x, n:m)}}{ indicates that at least one term containing an \var{n}-th to \var{m}-th order interaction term of \var{x} must be present } \item{\code{dc(a, b, c,...)}}{ \sQuote{dependency chain}: \var{b} is allowed only if \var{a} is present, and \var{c} only if both \var{a} and \var{b} are present, etc. } \item{\code{`*nvar*`}}{ the number of terms in the model. } } } To simply keep certain terms in all models, it is much more efficient to use the \code{fixed} argument. The \code{fixed} formula is interpreted in the same manner as model formula, so the terms must not be quoted. } \subsection{Missing values}{ Use of \code{na.action = "na.omit"} (\R's default) or \code{"na.exclude"} in \code{global.model} must be avoided, as it results with sub-models fitted to different data sets if there are missing values. An error is thrown if it is detected. It is a common mistake to give \code{na.action} as an argument in the call to \code{dredge} (typically resulting in an error from the \code{rank} function to which the argument is passed through \sQuote{\dots}), while the correct way is either to pass \code{na.action} in the call to the global model or to set it as a \link[=options]{global option}. } \subsection{Intercept}{ If present in the \code{global.model}, the intercept will be included in all sub-models. } \subsection{Methods}{ There are \lxcode{subset}{=subset.model.selection} and \lxcode{plot}{=plot.model.selection} methods, the latter creates a graphical representation of model weights and per-model term sum of weights. Coefficients can be extracted with \code{coef} or \lcode{coefTable}. } } \value{ An object of class \code{c("model.selection", "data.frame")}, being a \code{data.frame}, where each row represents one model. See \lcode{model.selection.object} for its structure. } \author{Kamil Barto\enc{ń}{n}} \note{ Users should keep in mind the hazards that a \dQuote{thoughtless approach} of evaluating all possible models poses. Although this procedure is in certain cases useful and justified, it may result in selecting a spurious \dQuote{best} model, due to the model selection bias. \emph{\dQuote{Let the computer find out} is a poor strategy and usually reflects the fact that the researcher did not bother to think clearly about the problem of interest and its scientific setting} (Burnham and Anderson, 2002). } \seealso{ \lcode{get.models}, \lcode{model.avg}. \lcode{model.sel} for manual model selection tables. Possible alternatives: \code{glmulti} in package \pkg{glmulti} and \code{bestglm} (\pkg{bestglm}). %% \lxcode{regsubsets}{leaps} in package \pkg{leaps} also performs all-subsets \code{regsubsets} in package \pkg{leaps} also performs all-subsets regression. Variable selection through regularization provided by various packages, e.g. \pkg{glmnet}, \pkg{lars} or \pkg{glmmLasso}. } \examples{ # Example from Burnham and Anderson (2002), page 100: # prevent fitting sub-models to different datasets \dontshow{oop <- } options(na.action = "na.fail") fm1 <- lm(y ~ ., data = Cement) dd <- dredge(fm1) subset(dd, delta < 4) # Visualize the model selection table: \dontshow{ if(require(graphics)) \{ } par(mar = c(3,5,6,4)) plot(dd, labAsExpr = TRUE) \dontshow{ \} } # Model average models with delta AICc < 4 model.avg(dd, subset = delta < 4) #or as a 95\% confidence set: model.avg(dd, subset = cumsum(weight) <= .95) # get averaged coefficients #'Best' model summary(get.models(dd, 1)[[1]]) \dontrun{ # Examples of using 'subset': # keep only models containing X3 dredge(fm1, subset = ~ X3) # subset as a formula dredge(fm1, subset = expression(X3)) # subset as expression object # the same, but more effective: dredge(fm1, fixed = "X3") # exclude models containing both X1 and X2 at the same time dredge(fm1, subset = !(X1 && X2)) # Fit only models containing either X3 or X4 (but not both); # include X3 only if X2 is present, and X2 only if X1 is present. dredge(fm1, subset = dc(X1, X2, X3) && xor(X3, X4)) # the same as above, without "dc" dredge(fm1, subset = (X1 | !X2) && (X2 | !X3) && xor(X3, X4)) # Include only models with up to 2 terms (and intercept) dredge(fm1, m.lim = c(0, 2)) } # Add R^2 and F-statistics, use the 'extra' argument dredge(fm1, m.lim = c(NA, 1), extra = c("R^2", F = function(x) summary(x)$fstatistic[[1]])) # with summary statistics: dredge(fm1, m.lim = c(NA, 1), extra = list( "R^2", "*" = function(x) { s <- summary(x) c(Rsq = s$r.squared, adjRsq = s$adj.r.squared, F = s$fstatistic[[1]]) }) ) # Add other information criteria (but rank with AICc): dredge(fm1, m.lim = c(NA, 1), extra = alist(AIC, BIC, ICOMP, Cp)) \dontshow{options(oop)} } \keyword{models} MuMIn/man/data-Beetle.Rd0000644000176200001440000000753015161443462014423 0ustar liggesusers\name{Beetle} \alias{Beetle} \encoding{utf-8} \docType{data} \title{Flour beetle mortality data} \description{ Mortality of flour beetles (\emph{Tribolium confusum}) due to exposure to gaseous carbon disulfide CS\eqn{_{2}}{2}, from Bliss (1935). } \usage{ Beetle } \format{ \code{Beetle} is a data frame with 5 elements. \describe{ \item{Prop}{a matrix with two columns named \bold{nkilled} and \bold{nsurvived}} \item{mortality}{observed mortality rate} \item{dose}{the dose of CS\eqn{_{2}}{2} in mg/L} \item{n.tested}{number of beetles tested} \item{n.killed}{number of beetles killed.} } } \source{ Bliss, C. I. 1935 The calculation of the dosage-mortality curve. \emph{Annals of Applied Biology} \bold{22}, 134--167. } \references{ Burnham, K. P. and Anderson, D. R. 2002 \emph{Model selection and multimodel inference: a practical information-theoretic approach}. 2nd ed. New York, Springer-Verlag. } \examples{ # "Logistic regression example" # from Burnham & Anderson (2002) chapter 4.11 # Fit a global model with all the considered variables globmod <- glm(Prop ~ dose + I(dose^2) + log(dose) + I(log(dose)^2), data = Beetle, family = binomial, na.action = na.fail) # A logical expression defining the subset of models to use: # * either log(dose) or dose # * the quadratic terms can appear only together with linear terms msubset <- expression(xor(dose, `log(dose)`) & dc(dose, `I(dose^2)`) & dc(`log(dose)`, `I(log(dose)^2)`)) # Table 4.6 # Use 'varying' argument to fit models with different link functions # Note the use of 'alist' rather than 'list' in order to keep the # 'family' objects unevaluated varying.link <- list(family = alist( logit = binomial("logit"), probit = binomial("probit"), cloglog = binomial("cloglog") )) (ms12 <- dredge(globmod, subset = msubset, varying = varying.link, rank = AIC)) # Table 4.7 "models justifiable a priori" (ms3 <- subset(ms12, has(dose, !`I(dose^2)`))) # The same result, but would fit the models again: # ms3 <- update(ms12, update(globmod, . ~ dose), subset =, # fixed = ~dose) mod3 <- get.models(ms3, 1:3) # Table 4.8. Predicted mortality probability at dose 40. # calculate confidence intervals on logit scale logit.ci <- function(p, se, quantile = 2) { C. <- exp(quantile * se / (p * (1 - p))) p /(p + (1 - p) * c(C., 1/C.)) } mavg3 <- model.avg(mod3, revised.var = FALSE) # get predictions both from component and averaged models pred <- lapply(c(component = mod3, list(averaged = mavg3)), predict, newdata = list(dose = 40), type = "response", se.fit = TRUE) # reshape predicted values pred <- t(sapply(pred, function(x) unlist(x)[1:2])) colnames(pred) <- c("fit", "se.fit") # build the table tab <- cbind( c(Weights(ms3), NA), pred, matrix(logit.ci(pred[,"fit"], pred[,"se.fit"], quantile = c(rep(1.96, 3), 2)), ncol = 2) ) colnames(tab) <- c("Akaike weight", "Predicted(40)", "SE", "Lower CI", "Upper CI") rownames(tab) <- c(as.character(ms3$family), "model-averaged") print(tab, digits = 3, na.print = "") # Figure 4.3 newdata <- list(dose = seq(min(Beetle$dose), max(Beetle$dose), length.out = 25)) # add model-averaged prediction with CI, using the same method as above avpred <- predict(mavg3, newdata, se.fit = TRUE, type = "response") avci <- matrix(logit.ci(avpred$fit, avpred$se.fit, quantile = 2), ncol = 2) \dontshow{ if(require(graphics)) \{ } matplot(newdata$dose, sapply(mod3, predict, newdata, type = "response"), type = "l", xlab = quote(list("Dose of" ~ CS[2],(mg/L))), ylab = "Mortality", col = 2:4, lty = 3, lwd = 1 ) matplot(newdata$dose, cbind(avpred$fit, avci), type = "l", add = TRUE, lwd = 1, lty = c(1, 2, 2), col = 1) legend("topleft", NULL, c(as.character(ms3$family), expression(`averaged` \%+-\% CI)), lty = c(3, 3, 3, 1), col = c(2:4, 1)) \dontshow{ \} } } \keyword{datasets} %% MuMIn/man/par.avg.Rd0000644000176200001440000000401015161443462013640 0ustar liggesusers\name{par.avg} \alias{par.avg} \encoding{utf-8} \title{Parameter averaging} \description{ Average a coefficient with standard errors based on provided weights. This function is intended chiefly for internal use. } \usage{ par.avg(x, se, weight, df = NULL, level = 1 - alpha, alpha = 0.05, revised.var = TRUE, adjusted = TRUE) } \arguments{ \item{x}{vector of parameters. } \item{se}{vector of standard errors. } \item{weight}{vector of weights. } \item{df}{optional vector of degrees of freedom. } \item{alpha, level}{significance level for calculating confidence intervals. } \item{revised.var}{logical, should the revised formula for standard errors be used? See \sQuote{Details}. } \item{adjusted}{logical, should the inflated standard errors be calculated? See \sQuote{Details}. } } \value{ \code{par.avg} returns a vector with named elements: \item{Coefficient}{model coefficients} \item{SE}{unconditional standard error} \item{Adjusted SE}{adjusted standard error} \item{Lower CI, Upper CI}{unconditional confidence intervals.} } \details{ Unconditional standard errors are square root of the variance estimator, calculated either according to the original equation in Burnham and Anderson (2002, equation 4.7), or a newer, revised formula from Burnham and Anderson (2004, equation 4) (if \code{revised.var = TRUE}, this is the default). If \code{adjusted = TRUE} (the default) and degrees of freedom are given, the adjusted standard error estimator and confidence intervals with improved coverage are returned (see Burnham and Anderson 2002, section 4.3.3). } \references{ Burnham, K. P. and Anderson, D. R. 2002 \emph{Model selection and multimodel inference: a practical information-theoretic approach}. 2nd ed. Burnham, K. P. and Anderson, D. R. 2004 Multimodel inference - understanding AIC and BIC in model selection. \emph{Sociological Methods & Research} \bold{33}, 261--304. } \author{Kamil Barto\enc{ń}{n}} \seealso{ \lcode{model.avg} for model averaging. } %% \examples{} \keyword{models} MuMIn/man/cos2weights.Rd0000644000176200001440000000404315161443462014551 0ustar liggesusers\encoding{utf-8} \name{cos2Weights} \alias{cos2Weights} \title{Cos-squared model weights} \usage{ cos2Weights(object, ..., data, eps = 1e-06, maxit = 100, predict.args = list()) } \arguments{ \item{object, \dots}{two or more fitted \lcode{glm} objects, or a \code{list} of such, or an \lxcode{"averaging"}{=model.avg} object. Currently only \code{lm} and \code{glm} objects are accepted.} \item{data}{a test data frame in which to look for variables for use with \link[=predict]{prediction}. If omitted, the fitted linear predictors are used.} \item{eps}{tolerance for determining convergence.} \item{maxit}{maximum number of iterations.} \item{predict.args}{optionally, a \code{list} of additional arguments to be passed to \code{predict}.} } \value{ A numeric vector of model weights. } \description{ Calculate the cos-squared model weights, following the algorithm outlined in the appendix to Garthwaite & Mubwandarikwa (2010). } \examples{ \dontshow{ if(length(find.package("expm", quiet = TRUE)) == 1) \{ } fm <- lm(y ~ X1 + X2 + X3 + X4, Cement, na.action = na.fail) # most efficient way to produce a list of all-subsets models models <- lapply(dredge(fm, evaluate = FALSE), eval) ma <- model.avg(models) test.data <- Cement Weights(ma) <- cos2Weights(models, data = test.data) predict(ma, data = test.data) \dontshow{ \} else message("Need CRAN package 'expm' to run this example") } } \references{ Garthwaite, P. H. and Mubwandarikwa, E. 2010 Selection of weights for weighted model averaging. \emph{Australian & New Zealand Journal of Statistics} \strong{52}, 363–382. Dormann, C. et al. 2018 Model averaging in ecology: a review of Bayesian, information-theoretic, and tactical approaches for predictive inference. \emph{Ecological Monographs} \strong{88}, 485–504. } \seealso{ \lcode{Weights}, \lcode{model.avg} Other model weights: \code{\link{BGWeights}()}, \code{\link{bootWeights}()}, \code{\link{jackknifeWeights}()}, \code{\link{stackingWeights}()} } \author{ Carsten Dormann, adapted by Kamil Barto\enc{ń}{n} } \concept{model weights} \keyword{models} MuMIn/man/stackingWeights.Rd0000644000176200001440000000554615161443462015457 0ustar liggesusers\encoding{utf-8} \name{stackingWeights} \alias{stackingWeights} \title{Stacking model weights} \usage{ stackingWeights(object, ..., data, R, p = 0.5) } \arguments{ \item{object, \dots}{two or more fitted \lcode{glm} objects, or a \code{list} of such, or an \lxcode{"averaging"}{=model.avg} object.} \item{data}{a data frame containing the variables in the model, used for fitting and prediction.} \item{R}{the number of replicates.} \item{p}{the proportion of the \code{data} to be used as training set. Defaults to 0.5.} } \value{ A matrix with two rows, containing model weights calculated using \code{mean} and \code{median}. } \description{ Compute model weights based on a cross-validation-like procedure. } \details{ Each model in a set is fitted to the training data: a subset of \code{p * N} observations in \code{data}. From these models a prediction is produced on the remaining part of \code{data} (the test or hold-out data). These hold-out predictions are fitted to the hold-out observations, by optimising the weights by which the models are combined. This process is repeated \code{R} times, yielding a distribution of weights for each model (which Smyth & Wolpert (1998) referred to as an \sQuote{empirical Bayesian estimate of posterior model probability}). A mean or median of model weights for each model is taken and re-scaled to sum to one. } \note{ This approach requires a sample size of at least \eqn{2\times}{2x} the number of models. } \examples{ #simulated Cement dataset to increase sample size for the training data fm0 <- glm(y ~ X1 + X2 + X3 + X4, data = Cement, na.action = na.fail) dat <- as.data.frame(apply(Cement[, -1], 2, sample, 50, replace = TRUE)) dat$y <- rnorm(nrow(dat), predict(fm0), sigma(fm0)) # global model fitted to training data: fm <- glm(y ~ X1 + X2 + X3 + X4, data = dat, na.action = na.fail) # generate a list of *some* subsets of the global model models <- lapply(dredge(fm, evaluate = FALSE, fixed = "X1", m.lim = c(1, 3)), eval) wts <- stackingWeights(models, data = dat, R = 10) ma <- model.avg(models) Weights(ma) <- wts["mean", ] predict(ma) } \references{ Wolpert, D. H. 1992 Stacked generalization. \emph{Neural Networks} \strong{5}, 241--259. Smyth, P. and Wolpert, D. 1998 \emph{An Evaluation of Linearly Combining Density Estimators via Stacking. Technical Report No. 98--25.} Information and Computer Science Department, University of California, Irvine, CA. Dormann, C. et al. 2018 Model averaging in ecology: a review of Bayesian, information-theoretic, and tactical approaches for predictive inference. \emph{Ecological Monographs} \strong{88}, 485--504. } \seealso{ \lcode{Weights}, \lcode{model.avg} Other model weights: \code{\link{BGWeights}()}, \code{\link{bootWeights}()}, \code{\link{cos2Weights}()}, \code{\link{jackknifeWeights}()} } \author{ Carsten Dormann, Kamil Barto\enc{ń}{n} } \concept{model weights} \keyword{models} MuMIn/man/QIC.Rd0000644000176200001440000000526015161443462012726 0ustar liggesusers\name{QIC} \alias{QIC} \alias{QICu} \alias{quasiLik} \encoding{utf-8} \title{QIC and quasi-Likelihood for GEE} \description{ Calculate quasi-likelihood under the independence model criterion (\QIC) for Generalized Estimating Equations. } \usage{ QIC(object, ..., typeR = FALSE) QICu(object, ..., typeR = FALSE) quasiLik(object, ...) } \arguments{ \item{object}{a fitted model object of class \code{"gee"}, \code{"geepack"}, \code{"geem"}, \code{"wgee"}, or \code{"yags"}.} \item{\dots}{ for \QIC and \QICu, optionally more fitted model objects. } \item{typeR}{ logical, whether to calculate \QIC(R). \QIC(R) is based on quasi-likelihood of a working correlation \eqn{R} model. Defaults to \code{FALSE}, and \QIC(I) based on independence model is returned. } } \value{ If just one object is provided, returns a numeric value with the corresponding \QIC; if more than one object are provided, returns a \code{data.frame} with rows corresponding to the objects and one column representing \QIC or \QICu. } \note{ This implementation is based partly on (revised) code from packages \pkg{yags} (R-Forge) and \pkg{ape}. } \references{ Pan, W. 2001 Akaike's Information Criterion in Generalized Estimating Equations. \emph{Biometrics} \bold{57}, 120--125 Hardin J. W., Hilbe, J. M. 2003 \emph{Generalized Estimating Equations}. Chapman & Hall/CRC } \author{Kamil Barto\enc{ń}{n}} \seealso{ Methods exist for \lxcode{gee}{gee} (package \pkg{gee}), \lxcode{geeglm}{geepack} (\pkg{geepack}), \lxcode{geem}{geeM} (\pkg{geeM}), \code{wgee} (\unCRANpkg{wgeesel}, the package's \code{QIC.gee} function is used), and \code{yags} (\pkg{yags} on R-Forge). There is also a \code{QIC} function in packages \pkg{MESS} and \pkg{geepack}, returning some extra information (such as \acronym{CIC} and \acronym{QICc}). \code{yags} and \code{compar.gee} from package \pkg{ape} both provide \acronym{QIC} values. } \keyword{models} \examples{ \dontshow{ if(require(geepack)) \{ } data(ohio) fm1 <- geeglm(resp ~ age * smoke, id = id, data = ohio, family = binomial, corstr = "exchangeable", scale.fix = TRUE) fm2 <- update(fm1, corstr = "ar1") fm3 <- update(fm1, corstr = "unstructured") # QIC function is also defined in 'geepack' but is returns a vector[6], so # cannot be used as 'rank'. Either use `MuMIn::QIC` syntax or make a wrapper # around `geepack::QIC` QIC <- MuMIn::QIC \dontrun{ QIC <- function(x) geepack::QIC(x)[1] } model.sel(fm1, fm2, fm3, rank = QIC) ##### library(geepack) library(MuMIn) \dontrun{ # same result: dredge(fm1, m.lim = c(3, NA), rank = QIC, varying = list( corstr = list("exchangeable", "unstructured", "ar1") )) } \dontshow{ \} } } MuMIn/man/model.selection.object.Rd0000644000176200001440000000572415161443462016650 0ustar liggesusers\name{model.selection.object} \alias{model.selection.object} \title{Description of Model Selection Objects} \description{ An object of class \code{"model.selection"} holds a table of model coefficients and ranking statistics. It is produced by \lcode{dredge} or \lcode{model.sel}. } \value{ The object is a \code{data.frame} with additional attributes. Each row represents one model. The models are ordered by the information criterion value specified by \code{rank} (lowest on top). Data frame columns: \item{}{For numeric covariates these columns hold coefficent value, for factors their presence in the model. If the term is not present in a model, value is \code{NA}. } \item{}{Optional. If any arguments differ between the modelling function calls (except for formulas and some other arguments), these will be held in additional columns (of class \code{"factor"}).} \item{df}{Number of model parameters} \item{logLik}{Log-likelihood (or quasi-likelihood for \acronym{GEE})} \item{}{Information criterion value} \item{delta}{the \IC difference, i.e. the the relative difference to the best model, \ifelse{latex}{\eqn{\Delta_{IC} = IC_i - IC_{min}}}{\enc{Δ}{Delta}_IC = IC_i - IC_min}, } \item{weight}{\sQuote{Akaike weights}, i.e. \link[=Weights]{normalized model likelihoods}.} Attributes: \item{model.calls}{A list containing model calls (arranged in the same order as in the table). A model call can be retrieved with \code{getCall(*, i)} where \var{i} is a vector of model index or name (if given as character string). } \item{global}{The \code{global.model} object } \item{global.call}{Call to the \code{global.model} } \item{terms}{A character string holding all term names. Attribute \code{"interceptLabel"} gives the name of the intercept term. } \item{rank}{The \code{rank} function used } \item{beta}{A character string, representing the coefficient standardizing method used. Either \code{"none"}, \code{"sd"} or \code{"partial.sd"} } \item{coefTables}{List of matrices of class \code{"coefTable"} containing each model's coefficients with std. errors and associated \var{df}s } \item{nobs}{Number of observations } \item{warnings}{optional (\code{pdredge} only). A list of errors and warnings issued by the modelling function during the fitting, with a model number appended to each. } It is not recommended to directly access the attributes. Instead, use extractor functions if possible. These include \code{getCall} for retrieving model calls, \code{coefTable} and \code{coef} for coefficients, and \code{nobs}. \code{logLik} extracts list of model log-likelihoods (as \code{"logLik"} objects), and \code{Weights} extracts \sQuote{Akaike weights}. The object has class \code{c("model.selection", "data.frame")}. } \seealso{ \lcode{dredge}, \lcode{model.sel}. } \keyword{models}MuMIn/man/model.sel.Rd0000644000176200001440000000724415161443462014200 0ustar liggesusers\name{model.sel} \alias{mod.sel} \alias{model.sel} \alias{model.sel.default} \alias{model.sel.model.selection} \alias{model.sel<-} \encoding{utf-8} \title{model selection table} \description{ Build a model selection table. } \usage{ model.sel(object, ...) \method{model.sel}{default}(object, ..., rank = NULL, rank.args = NULL, beta = c("none", "sd", "partial.sd"), extra) \method{model.sel}{model.selection}(object, rank = NULL, rank.args = NULL, fit = NA, ..., beta = c("none", "sd", "partial.sd"), extra) model.sel(x) <- value } \arguments{ \item{object,value}{a fitted model object, a list of such objects, or a \code{"model.selection"} object.} \item{\dots}{more fitted model objects. } \item{rank}{optional, custom rank function (returning an information criterion) to use instead of the default \code{AICc}, e.g. \code{QAIC} or \code{BIC}, may be omitted if \code{object} is a model list returned by \code{get.models}. } \item{rank.args}{optional \code{list} of arguments for the \code{rank} function. If one is an expression, an \code{x} within it is substituted with a current model. } \item{fit}{logical, stating whether the model objects should be re-fitted if they are not stored in the \code{"model.selection"} object. Set to \code{NA} to re-fit the models only if this is needed. See \sQuote{Details}. } \item{beta}{indicates whether and how the component models' coefficients should be standardized. See the argument's description in \lcode{dredge}. } \item{extra}{optional additional statistics to include in the result, provided as functions, function names or a list of such (best if named or quoted). See \lcode{dredge} for details. } \item{x}{a \code{"model.selection"} object.} } \value{ An object of class \code{c("model.selection", "data.frame")}, being a \code{data.frame}, where each row represents one model and columns contain useful information about each model: the coefficients, \emph{df}, log-likelihood, the value of the information criterion used, \DeltaIC{IC} and \sQuote{Akaike weight}. If any arguments differ between the modelling function calls, the result will include additional columns showing them (except for formulas and some other arguments). See \lcode{model.selection.object} for its structure. } \details{ \code{model.sel} used with \code{"model.selection"} object will re-fit model objects, unless they are stored in \code{object} (in attribute \code{"modelList"}), if argument \code{extra} is provided, or the requested \code{beta} is different than object's \code{"beta"} attribute, or the new \code{rank} function cannot be applied directly to \code{logLik} objects, or new \code{rank.args} are given (unless argument \code{fit = FALSE}). The replacement function appends new models to the existing \code{"model.selection"} object. } \author{Kamil Barto\enc{ń}{n}} \seealso{ \lcode{dredge}, \lcode{AICc}, \link[=MuMIn-models]{list of supported models}. Possible alternatives: \code{ICtab} (in package \pkg{bbmle}), or \code{aictab} (\pkg{AICcmodavg}). } \examples{ Cement$X1 <- cut(Cement$X1, 3) Cement$X2 <- cut(Cement$X2, 2) fm1 <- glm(formula = y ~ X1 + X2 * X3, data = Cement) fm2 <- update(fm1, . ~ . - X1 - X2) fm3 <- update(fm1, . ~ . - X2 - X3) ## ranked with AICc by default (msAICc <- model.sel(fm1, fm2, fm3)) ## ranked with BIC model.sel(fm1, fm2, fm3, rank = AIC, rank.args = alist(k = log(nobs(x)))) # or # model.sel(msAICc, rank = AIC, rank.args = alist(k = log(nobs(x)))) # or # update(msAICc, rank = AIC, rank.args = alist(k = log(nobs(x)))) # appending new models: model.sel(msAICc) <- update(fm1, . ~ 1) } \keyword{models} MuMIn/man/arm.glm.Rd0000644000176200001440000000536515161443462013655 0ustar liggesusers\name{arm.glm} \alias{arm.glm} \alias{armWeights} \encoding{utf-8} \title{Adaptive Regression by Mixing} \description{ Combine all-subsets GLMs using the ARM algorithm. Calculate ARM weights for a set of models. } \usage{ arm.glm(object, R = 250, weight.by = c("aic", "loglik"), trace = FALSE) armWeights(object, ..., data, weight.by = c("aic", "loglik"), R = 1000) } \arguments{ \item{object}{for \code{arm.glm}, a fitted \dQuote{global} \code{glm} object. For \code{armWeights}, a fitted \lcode{glm} object, or a \code{list} of such, or an \lxcode{"averaging"}{=model.avg} object. } \item{\dots}{more fitted model objects. } \item{R}{number of permutations. } \item{weight.by}{indicates whether model weights should be calculated with \AIC or log-likelihood. } \item{trace}{if \code{TRUE}, information is printed during the running of \code{arm.glm}. } \item{data}{a data frame in which to look for variables for use with \link[=predict]{prediction}. If omitted, the fitted linear predictors are used.} %% \item{seed}{optionally, the random seed. See \lcode{set.seed}.} } \details{ For each of all-subsets of the \dQuote{global} model, parameters are estimated using randomly sampled half of the data. Log-likelihood given the remaining half of the data is used to calculate \AIC weights. This is repeated \code{R} times and mean of the weights is used to average all-subsets parameters estimated using complete data. } \note{ Number of parameters is limited to \code{floor(nobs(object) / 2) - 1}. All-subsets satisfy the marginality constraints. } \value{ \code{arm.glm} returns an object of class \code{"averaging"} contaning only \dQuote{full} averaged coefficients. See \lcode{model.avg} for object description. \code{armWeights} returns a numeric vector of model weights. } \references{ Yang, Y. 2001 Adaptive Regression by Mixing. \emph{Journal of the American Statistical Association} \bold{96}, 574–588. Yang, Y. 2003 Regression with multiple candidate models: selecting or mixing? \emph{Statistica Sinica} \bold{13}, 783–810. } \author{Kamil Barto\enc{ń}{n}} \seealso{ \lcode{model.avg}, \lcode{par.avg} \lcode{Weights} for assigning new model weights to an \code{"averaging"} object. Other implementation of ARM algorithm: \code{arms} in (archived) package \bold{MMIX}. Other kinds of model weights: \lcode{BGWeights}, \lcode{bootWeights}, \lcode{cos2Weights}, \lcode{jackknifeWeights}, \lcode{stackingWeights}. } \examples{ fm <- glm(y ~ X1 + X2 + X3 + X4, data = Cement) summary(am1 <- arm.glm(fm, R = 15)) mst <- dredge(fm) am2 <- model.avg(mst, fit = TRUE) Weights(am2) <- armWeights(am2, data = Cement, R = 15) # differences are due to small R: coef(am1, full = TRUE) coef(am2, full = TRUE) } \keyword{models} MuMIn/man/sumofweights.Rd0000644000176200001440000000271715161443462015042 0ustar liggesusers\name{sw} \alias{importance} \alias{sum.of.weights} \alias{sw} \encoding{utf-8} \title{Per-variable sum of model weights} \description{ Sum of model weights over all models including each explanatory variable. } \usage{ sw(x) importance(x) } \arguments{ \item{x}{either a list of fitted model objects, or a \code{"model.selection"} or \code{"averaging"} object. } } \value{ a named numeric vector of so called relative importance values, for each predictor variable. } \author{Kamil Barto\enc{ń}{n}} \seealso{ \lcode{Weights} \lcode{dredge}, \lcode{model.avg}, \lcode{model.sel} } \examples{ # Generate some models fm1 <- lm(y ~ ., data = Cement, na.action = na.fail) ms1 <- dredge(fm1) # Sum of weights can be calculated/extracted from various objects: sw(ms1) \dontrun{ sw(subset(model.sel(ms1), delta <= 4)) sw(model.avg(ms1, subset = delta <= 4)) sw(subset(ms1, delta <= 4)) sw(get.models(ms1, delta <= 4)) } # Re-evaluate SW according to BIC # note that re-ranking involves fitting the models again # 'nobs' is not used here for backwards compatibility lognobs <- log(length(resid(fm1))) sw(subset(model.sel(ms1, rank = AIC, rank.args = list(k = lognobs)), cumsum(weight) <= .95)) # This gives a different result than previous command, because 'subset' is # applied to the original selection table that is ranked with 'AICc' sw(model.avg(ms1, rank = AIC, rank.args = list(k = lognobs), subset = cumsum(weight) <= .95)) } \keyword{models} MuMIn/man/data-GPA.Rd0000644000176200001440000000174315161443462013632 0ustar liggesusers\name{GPA} \alias{GPA} \encoding{utf-8} \docType{data} \title{Grade Point Average data} \description{ First-year college Grade Point Average (\acronym{GPA}) from Graybill and Iyer (1994). } \usage{ GPA } \format{ \code{GPA} is a data frame with 5 variables. \var{y} is the first-year college Grade Point Average (\acronym{GPA}) and \var{x1}-\var{x4} are four predictor variables from standardized tests (\acronym{SAT}) administered before matriculation. \describe{ \item{y}{\acronym{GPA}} \item{x1}{math score on the \acronym{SAT}} \item{x2}{verbal score on the \acronym{SAT}} \item{x3}{high school math} \item{x4}{high school English} }} \source{ Graybill, F.A. and Iyer, H.K. (1994). \emph{Regression analysis: concepts and applications}. Duxbury Press, Belmont, CA. } \references{ Burnham, K. P. and Anderson, D. R. 2002 \emph{Model selection and multimodel inference: a practical information-theoretic approach}. 2nd ed. New York, Springer-Verlag. } \keyword{datasets} MuMIn/man/pdredge.Rd0000644000176200001440000001246315161443462013727 0ustar liggesusers\name{pdredge} \alias{pdredge} \encoding{utf-8} \title{Automated model selection using parallel computation} \description{ Parallelized version of \code{dredge}. } \usage{ pdredge(global.model, cluster = NULL, beta = c("none", "sd", "partial.sd"), evaluate = TRUE, rank = "AICc", fixed = NULL, m.lim = NULL, m.min, m.max, subset, trace = FALSE, varying, extra, ct.args = NULL, deps = attr(allTerms0, "deps"), check = FALSE, ...) } \arguments{ \item{global.model, beta, rank, fixed, m.lim, m.max, m.min, subset, varying, extra, ct.args, deps, ...}{ see \lcode{dredge}. } \item{evaluate}{whether to evaluate and rank the models. If \code{FALSE}, a list of unevaluated \code{call}s is returned and \code{cluster} is not used. } \item{trace}{ displays the generated calls, but may not work as expected since the models are evaluated in batches rather than one by one. } \item{cluster}{ either a valid \code{"cluster"} object, or \code{NULL} for a single threaded execution. } \item{check}{ either integer or logical value controlling how much checking for existence and correctness of dependencies is done on the cluster nodes. See \sQuote{Details}. } } \details{ All the dependencies for fitting the \code{global.model}, including the data and any objects that the modelling function will use must be exported to the cluster worker nodes (e.g. \emph{via} \code{clusterExport}). The required packages must be also loaded thereinto (e.g. \emph{via} \code{clusterEvalQ(..., library(package))}, before the cluster is used by \code{pdredge}. If \code{check} is \code{TRUE} or positive, \code{pdredge} tries to check whether all the variables and functions used in the call to \code{global.model} are present in the cluster nodes' \code{.GlobalEnv} before proceeding further. This will cause false errors if some arguments of the model call (other than \code{subset}) would be evaluated in the \code{data} environment. In that case is desirable to use \code{check = FALSE} (the default). If \code{check} is \code{TRUE} or greater than one, \code{pdredge} will compare the \code{global.model} updated on the cluster nodes with the one given as an argument. } \note{ As of version 1.45.0, using \code{pdredge} directly is deprecated. Use \code{dredge} instead and provide \code{cluster} argument. } \value{ See \lcode{dredge}. } \author{Kamil Barto\enc{ń}{n}} \seealso{ \code{makeCluster} and other cluster related functions in packages \pkg{parallel} or \pkg{snow}. } \examples{ \dontshow{ # Normally this should be simply "require(parallel) || require(snow)", # but here we resort to an (ugly) trick to avoid MuMIn's dependency on one of # these packages and still pass R-check: if(MuMIn:::.parallelPkgCheck(quiet = TRUE)) \{ } # One of these packages is required: \dontrun{require(parallel) || require(snow)} # From example(Beetle) Beetle100 <- Beetle[sample(nrow(Beetle), 100, replace = TRUE),] fm1 <- glm(Prop ~ dose + I(dose^2) + log(dose) + I(log(dose)^2), data = Beetle100, family = binomial, na.action = na.fail) msubset <- expression(xor(dose, `log(dose)`) & (dose | !`I(dose^2)`) & (`log(dose)` | !`I(log(dose)^2)`)) varying.link <- list(family = alist(logit = binomial("logit"), probit = binomial("probit"), cloglog = binomial("cloglog") )) # Set up the cluster clusterType <- if(length(find.package("snow", quiet = TRUE))) "SOCK" else "PSOCK" clust <- try(makeCluster(getOption("cl.cores", 2), type = clusterType)) \dontshow{if(inherits(clust, "cluster")) \{ } clusterExport(clust, "Beetle100") # noticeable gain only when data has about 3000 rows (Windows 2-core machine) print(system.time(dredge(fm1, subset = msubset, varying = varying.link))) print(system.time(dredge(fm1, cluster = FALSE, subset = msubset, varying = varying.link))) print(system.time(pdd <- dredge(fm1, cluster = clust, subset = msubset, varying = varying.link))) print(pdd) \dontrun{ # Time consuming example with 'unmarked' model, based on example(pcount). # Having enough patience you can run this with 'demo(pdredge.pcount)'. library(unmarked) data(mallard) mallardUMF <- unmarkedFramePCount(mallard.y, siteCovs = mallard.site, obsCovs = mallard.obs) (ufm.mallard <- pcount(~ ivel + date + I(date^2) ~ length + elev + forest, mallardUMF, K = 30)) clusterEvalQ(clust, library(unmarked)) clusterExport(clust, "mallardUMF") # 'stats4' is needed for AIC to work with unmarkedFit objects but is not # loaded automatically with 'unmarked'. require(stats4) invisible(clusterCall(clust, "library", "stats4", character.only = TRUE)) #system.time(print(pdd1 <- dredge(ufm.mallard, # subset = `p(date)` | !`p(I(date^2))`, rank = AIC))) system.time(print(pdd2 <- dredge(ufm.mallard, cluster = clust, subset = `p(date)` | !`p(I(date^2))`, rank = AIC, extra = "adjR^2"))) # best models and null model subset(pdd2, delta < 2 | df == min(df)) # Compare with the model selection table from unmarked # the statistics should be identical: models <- get.models(pdd2, delta < 2 | df == min(df), cluster = clust) modSel(fitList(fits = structure(models, names = model.names(models, labels = getAllTerms(ufm.mallard)))), nullmod = "(Null)") } stopCluster(clust) \dontshow{ \} else # if(! inherits(clust, "cluster")) message("Could not set up the cluster") \} } } \keyword{models} MuMIn/man/MuMIn-package.Rd0000644000176200001440000000647115161443462014675 0ustar liggesusers\name{MuMIn-package} \alias{MuMIn-package} \alias{MuMIn} \docType{package} \encoding{utf-8} \title{Multi-model inference} \description{ The package \pkg{MuMIn} contains functions to streamline information-theoretic model selection and carry out model averaging based on information criteria. } \details{ The suite of functions includes: \describe{ \item{\lcode{dredge}}{performs automated model selection by generating subsets of the supplied \sQuote{global} model and optional choices of other model properties (such as different link functions). The set of models can be generated with \sQuote{all possible} combinations or tailored according to specified conditions. } \item{\lcode{model.sel}}{creates a model selection table from selected models. } \item{\lcode{model.avg}}{calculates model-averaged parameters, along with standard errors and confidence intervals. The \lxcode{predict}{=predict.averaging} method produces model-averaged predictions. } \item{\lcode{AICc}}{calculates the second-order Akaike information criterion. Some other criteria are provided, see below. } \item{\lcode{stdize}, \lcode{stdizeFit}, \lcode{std.coef}, \lcode{partial.sd}}{can be used to standardise data and model coefficients by standard deviation or partial standard deviation. } } For a complete list of functions, use \code{library(help = "MuMIn")}. By default, \AICc is used to rank models and obtain model weights, although any information criterion can be used. At least the following are currently implemented in \R: \lcode{AIC} and \lcode{BIC} in package \pkg{stats}, and \lcode{QAIC}, \lcode{QAICc}, \lcode{ICOMP}, \lcode{CAICF}, and \link{Mallows' Cp} in \pkg{MuMIn}. There is also a \lcode{DIC} extractor for \acronym{MCMC} models and a \lcode{QIC} for \acronym{GEE}. \pkg{MuMIn} works with many model fitting functions available in \R. For a complete list, see \link[=MuMIn-models]{the list of supported models}. In addition to \dQuote{regular} information criteria, model averaging can be performed using various types of model weighting algorithms: \link[=BGWeights]{Bates-Granger}, \link[=BGWeights]{bootstrapped}, \link[=cos2Weights]{cos-squared}, \link[=jackknifeWeights]{jackknife}, \link[=stackingWeights]{stacking}, or \link[=armWeights]{ARM}. These weighting functions are mainly applicable to \code{glm}s. } \author{ Kamil Barto\enc{ń}{n} } \references{ Burnham, K. P. and Anderson, D. R. 2002 \emph{Model selection and multimodel inference: a practical information-theoretic approach}. 2nd ed. New York, Springer-Verlag. } \seealso{ \lcode{AIC}, \lcode{step} or \lxcode{stepAIC}{MASS} for stepwise model selection by \AIC. } \examples{ \dontshow{oop <- } options(na.action = "na.fail") # change the default "na.omit" to prevent models # from being fitted to different datasets in # case of missing values. fm1 <- lm(y ~ ., data = Cement) ms1 <- dredge(fm1) # Visualize the model selection table: \dontshow{ if(require(graphics)) \{ } par(mar = c(3,5,6,4)) plot(ms1, labAsExpr = TRUE) \dontshow{ \} } model.avg(ms1, subset = delta < 4) confset.95p <- get.models(ms1, cumsum(weight) <= .95) avgmod.95p <- model.avg(confset.95p) summary(avgmod.95p) confint(avgmod.95p) \dontshow{options(oop)} } \keyword{package} \keyword{models} MuMIn/man/predict.averaging.Rd0000644000176200001440000001366615161443462015717 0ustar liggesusers\name{predict.averaging} \alias{predict.averaging} \encoding{utf-8} \title{Predict method for averaged models} \description{ Model-averaged predictions, optionally with standard errors. } \usage{ \method{predict}{averaging}(object, newdata = NULL, se.fit = FALSE, interval = NULL, type = NA, backtransform = FALSE, full = TRUE, ...) } \arguments{ \item{object}{an object returned by \code{model.avg}. } \item{newdata}{ optional \code{data.frame} in which to look for variables with which to predict. If omitted, the fitted values are used. } \item{se.fit}{logical, indicates if standard errors should be returned. This has any effect only if the \code{predict} methods for each of the component models support it. } \item{interval}{currently not used. } \item{type}{the type of predictions to return (see documentation for \code{predict} appropriate for the class of used component models). If omitted, the default type is used. See \sQuote{Details}. } \item{backtransform}{if \code{TRUE}, the averaged predictions are back-transformed from link scale to response scale. This makes sense provided that all component models use the same \code{family}, and the prediction from each of the component models is calculated on the link scale (as specified by \code{type}. For \code{glm}, use \code{type = "link"}). See \sQuote{Details}. } \item{full}{ if \code{TRUE}, the full model-averaged coefficients are used (only if \code{se.fit = FALSE} and the component objects are a result of \code{lm}). } \item{\dots}{arguments to be passed to respective \code{predict} method (e.g. \code{level} for \lxcode{lme}{nlme} model). } } \value{ If \code{se.fit = FALSE}, a vector of predictions, otherwise a list with components: \code{fit} containing the predictions, and \code{se.fit} with the estimated standard errors. } \details{ \code{predict}ing is possible only with \code{averaging} objects with \code{"modelList"} attribute, i.e. those created \emph{via} \code{model.avg} from a model list, or from \code{model.selection} object with argument \code{fit = TRUE} (which will recreate the model objects, see \lcode{model.avg}). If all the component models are ordinary linear models, the prediction can be made either with the full averaged coefficients (the argument \code{full = TRUE} this is the default) or subset-averaged coefficients. Otherwise the prediction is obtained by calling \code{predict} on each component model and weighted averaging the results, which corresponds to the assumption that all predictors are present in all models, but those not estimated are equal zero (see \sQuote{Note} in \lcode{model.avg}). Predictions from component models with standard errors are passed to \code{par.avg} and averaged in the same way as the coefficients are. Predictions on the response scale from generalized models can be calculated by averaging predictions of each model on the link scale, followed by inverse transformation (this is achieved with \code{type = "link"} and \code{backtransform = TRUE}). This is only possible if all component models use the same family and link function. Alternatively, predictions from each model on response scale may be averaged (with \code{type = "response"} and \code{backtransform = FALSE}). Note that this leads to results differing from those calculated with the former method. See also \lxcode{predict.glm}{stats}. } \note{ This method relies on availability of the \code{predict} methods for the component model classes (except when all component models are of class \code{lm}). The package \pkg{MuMIn} includes \code{predict} methods for \code{lme}, and \code{gls} that calculate standard errors of the predictions (with \code{se.fit = TRUE}). They enhance the original predict methods from package \pkg{nlme}, and with \code{se.fit = FALSE} they return identical result. \pkg{MuMIn}'s versions are always used in averaged model predictions (so it is possible to predict with standard errors), but from within global environment they will be found only if \pkg{MuMIn} is before \pkg{nlme} on the \link[=search]{search list} (or directly extracted from namespace as \code{MuMIn:::predict.lme}). } \author{Kamil Barto\enc{ń}{n}} \seealso{ \lcode{model.avg}, and \lcode{par.avg} for details of model-averaged parameter calculation. \lxcode{predict.lme}{nlme}, \lxcode{predict.gls}{nlme} } \examples{ \dontshow{ oop <- options(na.action="na.fail") if(require(graphics)) \{ } # Example from Burnham and Anderson (2002), page 100: fm1 <- lm(y ~ X1 + X2 + X3 + X4, data = Cement) ms1 <- dredge(fm1) confset.95p <- get.models(ms1, subset = cumsum(weight) <= .95) avgm <- model.avg(confset.95p) nseq <- function(x, len = length(x)) seq(min(x, na.rm = TRUE), max(x, na.rm=TRUE), length = len) # New predictors: X1 along the range of original data, other # variables held constant at their means newdata <- as.data.frame(lapply(lapply(Cement[, -1], mean), rep, 25)) newdata$X1 <- nseq(Cement$X1, nrow(newdata)) n <- length(confset.95p) # Predictions from each of the models in a set, and with averaged coefficients pred <- data.frame( model = sapply(confset.95p, predict, newdata = newdata), averaged.subset = predict(avgm, newdata, full = FALSE), averaged.full = predict(avgm, newdata, full = TRUE) ) opal <- palette(c(topo.colors(n), "black", "red", "orange")) matplot(newdata$X1, pred, type = "l", lwd = c(rep(2,n),3,3), lty = 1, xlab = "X1", ylab = "y", col=1:7) # For comparison, prediction obtained by averaging predictions of the component # models pred.se <- predict(avgm, newdata, se.fit = TRUE) y <- pred.se$fit ci <- pred.se$se.fit * 2 matplot(newdata$X1, cbind(y, y - ci, y + ci), add = TRUE, type="l", lty = 2, col = n + 3, lwd = 3) legend("topleft", legend=c(lapply(confset.95p, formula), paste(c("subset", "full"), "averaged"), "averaged predictions + CI"), lty = 1, lwd = c(rep(2,n),3,3,3), cex = .75, col=1:8) palette(opal) \dontshow{ \} options(oop) } } \keyword{models} MuMIn/man/supported-classes.Rd0000644000176200001440000000744215161443462015776 0ustar liggesusers%% \newcommand{\lcode}{\code{\link{#1}}} \name{MuMIn-models} \alias{MuMIn-models} \encoding{utf-8} \title{List of supported models} \description{ List of model classes accepted by \code{model.avg}, \code{model.sel}, and \code{dredge}. } \details{ Fitted model objects that can be used with model selection and model averaging functions include those produced by: \itemize{ \item \lcode{lm}, \lcode{glm} (package \pkg{stats}); \item \lxcode{rlm}{MASS}, \lxcode{glm.nb}{MASS} and \lxcode{polr}{MASS} (\CRANpkg{MASS}); \item \lxcode{multinom}{nnet} (\CRANpkg{nnet}); \item \lxcode{lme}{nlme}, \lxcode{gls}{nlme} (\CRANpkg{nlme}); \item \lxcode{lmer}{lme4}, \lxcode{glmer}{lme4} (\CRANpkg{lme4}); \item \lxcode{cpglm}{cplm}, \lxcode{cpglmm}{cplm} (\CRANpkg{cplm}); \item \lxcode{gam}{mgcv}, \lxcode{gamm}{mgcv}* (\CRANpkg{mgcv}); \item \lxcode{gamm4}{gamm4}* (\CRANpkg{gamm4}); \item \lxcode{gamlss}{gamlss} (\CRANpkg{gamlss}); \item \lxcode{glmmML}{glmmML} (\CRANpkg{glmmML}); \item \code{glmmadmb} (\href{http://glmmadmb.r-forge.r-project.org/}{\pkg{glmmADMB}} from R-Forge); \item \lxcode{glmmTMB}{glmmTMB} (\CRANpkg{glmmTMB}); \item \lxcode{MCMCglmm}{MCMCglmm}* (\CRANpkg{MCMCglmm}); \item \code{asreml} (non-free commercial package \pkg{asreml}; allows only for \acronym{REML} comparisons); \item \lxcode{hurdle}{pscl}, \lxcode{zeroinfl}{pscl} (\CRANpkg{pscl}); \item \lxcode{negbin}{aod}, \lxcode{betabin}{aod} (class \code{"glimML"}), package \CRANpkg{aod}); \item \unlxcode{aodml}{aods3}, \unlxcode{aodql}{aods3} (\unCRANpkg{aods3}); \item \lxcode{betareg}{betareg} (\CRANpkg{betareg}); \item \lxcode{brglm}{brglm} (\CRANpkg{brglm}); \item \code{*sarlm} models, \lxcode{spautolm}{spatialreg} (\CRANpkg{spatialreg}); \item \lxcode{spml}{splm}* (if fitted by \acronym{ML}, \CRANpkg{splm}); \item \lxcode{coxph}{survival}, \lxcode{survreg}{survival} (\CRANpkg{survival}); \item \lxcode{coxme}{coxme}, \lxcode{lmekin}{coxme} (\CRANpkg{coxme}); \item \lxcode{rq}{quantreg} (\CRANpkg{quantreg}); \item \lxcode{clm}{ordinal} and \lxcode{clmm}{ordinal} (\CRANpkg{ordinal}); \item \lxcode{logistf}{logistf} (\CRANpkg{logistf}); %% Bias-reduced logistic regression \item \lxcode{crunch}{caper}*, \lxcode{pgls}{caper} (\CRANpkg{caper}); \item \lxcode{maxlike}{maxlike} (\CRANpkg{maxlike}); \item most \code{"unmarkedFit"} objects from package \CRANpkg{unmarked}); \item \lxcode{mark}{RMark} and related functions (class \code{mark} from package \CRANpkg{RMark}). Currently \code{dredge} can only manipulate \code{formula} element of the argument \code{model.parameters}, keeping its other elements intact; \item \lxcode{fitdistr}{MASS} mostly useful for model selection with \code{model.sel}. Use of \lxcode{fitdistr2}{=updateable} wrapper function is recommended. } Generalized Estimation Equation model implementations: \lxcode{geeglm}{geepack} from package \CRANpkg{geepack}, \lxcode{gee}{gee} from \CRANpkg{gee}, \lxcode{geem}{geeM} from \CRANpkg{geeM}, \unlxcode{wgee}{wgeesel} from \unCRANpkg{wgeesel}, and \code{yags} from \href{http://yags.r-forge.r-project.org/}{\pkg{yags}} (on R-Forge) can be used with \lcode{QIC} as the selection criterion. Further classes may also be supported, in particular if they inherit from one of the classes listed above. In general, models averaged using \code{model.avg} can belong to different types (e.g. \code{glm} and \code{gam}), provided they use the same data and response, and, obviously, if it is valid to do so. This also applies to the construction of model selection tables using \code{model.sel}. } \note{ * In order to use \code{gamm}, \code{gamm4}, \code{spml (> 1.0.0)}, \code{crunch} or \code{MCMCglmm} with \code{dredge}, an \lcode{updateable} wrapper for these functions should be created. } \seealso{ \lcode{model.avg}, \lcode{model.sel} and \lcode{dredge}. } \keyword{package} MuMIn/man/macros/0000755000176200001440000000000015161443462013304 5ustar liggesusersMuMIn/man/macros/macros.Rd0000644000176200001440000000217514772511110015055 0ustar liggesusers\newcommand{\href}{#2} \newcommand{\bq}{\verb{`}\code{#1}\verb{`}} \newcommand{\mydequation}{\ifelse{latex}{\deqn{#1}{#3}}{\ifelse{html}{\enc{\deqn{#1}}{#3}}{#3}}} \newcommand{\myequation}{\ifelse{latex}{\eqn{#1}{#3}}{\ifelse{html}{\enc{\eqn{#1}}{#3}}{#3}}} %% \newcommand{\CRANpkg}{\href{https://cran.r-project.org/package=#1}{\pkg{#1}}} \newcommand{\unCRANpkg}{\code{#1}} \newcommand{\lcode}{\code{\link{#1}}} \newcommand{\lxcode}{\code{\link[#2]{#1}}} \newcommand{\unlxcode}{\code{#1}\ifelse{FALSE}{#2}{}} \newcommand{\logLik}{\myequation{\log\mathcal{L}(#1)}{XXXX}{logL(#1)}} \newcommand{\Rsq}{\myequation{R^{2}}{XXXX}{R^2}} \newcommand{\Rsq}{\myequation{R^{2}}{XXXX}{R^2}} \newcommand{\Rsqx}{\myequation{R_{#1}^{2}}{XXXX}{R_#1^2}} \newcommand{\AICc}{\acronym{AIC\eqn{_{c}}{c}}} \newcommand{\QAICc}{\acronym{QAIC\eqn{_{c}}{c}}} \newcommand{\QICu}{\acronym{QIC\eqn{_{u}}{u}}} \newcommand{\AIC}{\acronym{AIC}} \newcommand{\QIC}{\acronym{QIC}} \newcommand{\QAIC}{\acronym{QAIC}} \newcommand{\BIC}{\acronym{BIC}} \newcommand{\IC}{\acronym{IC}} \newcommand{\DeltaIC}{\myequation{\Delta_{#1}}{}{Delta_#1}} MuMIn/man/coefplot.Rd0000644000176200001440000001153215161443462014124 0ustar liggesusers\encoding{utf-8} \name{coefplot} \alias{coefplot} \alias{plot.averaging} \title{Plot model coefficients} \usage{ coefplot( x, lci, uci, labels = NULL, width = 0.15, shift = 0, horizontal = TRUE, main = NULL, xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL, labAsExpr = TRUE, mar.adj = TRUE, lab.line = 0.5, lty = par("lty"), lwd = par("lwd"), pch = 21, col = par("col"), bg = par("bg"), dotcex = par("cex"), dotcol = col, staplelty = lty, staplelwd = lwd, staplecol = col, zerolty = "dotted", zerolwd = lwd, zerocol = "gray", las = 2, ann = TRUE, axes = TRUE, add = FALSE, type = "p", ... ) \method{plot}{averaging}( x, full = TRUE, level = 0.95, intercept = TRUE, parm = NULL, labels = NULL, width = 0.1, shift = max(0.2, width * 2.1 + 0.05), horizontal = TRUE, xlim = NULL, ylim = NULL, main = "Model-averaged coefficients", xlab = NULL, ylab = NULL, add = FALSE, ... ) } \arguments{ \item{x}{either a (possibly named) vector of coefficients (for \code{coefplot}), or an \lxcode{"averaging"}{=model.avg} object.} \item{lci, uci}{vectors of lower and upper confidence intervals. Alternatively a two-column matrix with columns containing confidence intervals, in which case \code{uci} is ignored.} \item{labels}{optional vector of coefficient names. By default, names of \code{x} are used for labels.} \item{width}{width of the staples (= end of whisker).} \item{shift}{the amount of perpendicular shift for the dots and whiskers. Useful when adding to an existing plot.} \item{horizontal}{logical indicating if the plots should be horizontal; defaults to \code{TRUE}.} \item{main}{an overall title for the plot: see \code{title}.} \item{xlab, ylab}{x- and y-axis annotation. Can be suppressed by \code{ann=FALSE}.} \item{xlim, ylim}{optional, the \emph{x} and \emph{y} limits of the plot.} \item{labAsExpr}{logical indicating whether the coefficient names should be transformed to expressions to create prettier labels (see \lcode{plotmath})} \item{mar.adj}{logical indicating whether the (left or lower) margin should be expanded to fit the labels} \item{lab.line}{margin line for the labels} \item{lty, lwd, pch, col, bg}{default line type, line width, point character, foreground colour for all elements, and background colour for open symbols.} \item{dotcex, dotcol}{dots point size expansion and colour.} \item{staplelty, staplelwd, staplecol}{staple line type, width, and colour.} \item{zerolty, zerolwd, zerocol}{zero-line type, line width, colour. Setting \code{zerolty} to \code{NA} suppresses the line.} \item{las}{the style of labels for coefficient names. See \lcode{par}.} \item{ann}{\code{logical} indicating if axes should be annotated (by \code{xlab} and \code{ylab}).} \item{axes}{a logical value indicating whether both axes should be drawn on the plot.} \item{add}{logical, if true \emph{add} to current plot.} \item{type}{if \code{"n"}, the plot region is left empty, any other value causes the plot being drawn.} \item{...}{additional arguments passed to \code{coefplot} or more \link[=par]{graphical parameters}.} \item{full}{a logical value specifying whether the \dQuote{full} model-averaged coefficients are plotted. If \code{FALSE}, the \dQuote{subset}-averaged coefficients are plotted, and both types if \code{NA}. See \lcode{model.avg}.} \item{level}{the confidence level required.} \item{intercept}{logical indicating if intercept should be included in the plot} \item{parm}{a specification of which parameters are to be plotted, either a vector of numbers or a vector of names. If missing, all parameters are considered.} } \value{ An invisible \code{matrix} containing coordinates of points and whiskers, or, a two-element list of such, one for each coefficient type in \code{plot.averaging} when \code{full} is \code{NA}. } \description{ Produce dot-and-whisker plot of the model(-averaged) coefficients, with confidence intervals } \details{ Plot model(-averaged) coefficients with confidence intervals. } \examples{ fm <- glm(Prop ~ dose + I(dose^2) + log(dose) + I(log(dose)^2), data = Beetle, family = binomial, na.action = na.fail) ma <- model.avg(dredge(fm)) # default coefficient plot: plot(ma, full = NA, intercept = FALSE) # Add colours per coefficient type # Replicate each colour n(=number of coefficients) times clr <- c("black", "red2") i <- rep(1:2, each = length(coef(ma)) - 1) plot(ma, full = NA, intercept = FALSE, pch = 22, dotcex = 1.5, col = clr[i], bg = clr[i], lwd = 6, lend = 1, width = 0, horizontal = 0) # Use `type = "n"` and `add` argument to e.g. add grid beneath the figure plot(ma, full = NA, intercept = FALSE, width = 0, horizontal = FALSE, zerolty = NA, type = "n") grid() plot(ma, full = NA, intercept = FALSE, pch = 22, dotcex = 1.5, col = clr[i], bg = clr[i], lwd = 6, lend = 1, width = 0, horizontal = FALSE, add = TRUE) } \author{ Kamil Barto\enc{ń}{n} } \keyword{hplot} MuMIn/man/updateable.Rd0000644000176200001440000001317015161443462014417 0ustar liggesusers\name{updateable} \alias{updateable} \alias{updateable2} \alias{get_call} \alias{uGamm} \alias{fitdistr2} \alias{MuMIn-gamm} \alias{gamm-wrapper} \encoding{utf-8} \title{Make a function return updateable result} \description{ Creates a function wrapper that stores a call in the object returned by its argument \code{FUN}. } \usage{ updateable(FUN, eval.args = NULL, Class) get_call(x) ## updateable wrapper for mgcv::gamm and gamm4::gamm4 uGamm(formula, random = NULL, ..., lme4 = inherits(random, "formula")) ## updateable wrapper for MASS::fitdistr fitdistr2(x, densfun, start, ...) } \arguments{ \item{FUN}{function to be modified, found \emph{via} \lcode{match.fun}. } \item{eval.args}{optionally a character vector of function arguments' names to be evaluated in the stored call. See \sQuote{Details}. } \item{Class}{optional character vector naming class(es) to be set onto the result of \code{FUN} (not possible if the result is an S4 object). } \item{x}{for \code{get_call}, an object from which the call should be extracted. For \code{fitdistr2}, a numeric vector passed to \lxcode{fitdistr}{MASS}. } \item{formula, random}{arguments to be passed to \code{gamm} or \code{gamm4}} \item{lme4}{if \code{TRUE}, \code{gamm4} is called, \code{gamm} otherwise. } \item{densfun, start}{Arguments passed to \lxcode{fitdistr}{MASS}. } \item{\dots}{Arguments passed to respective wrapped functions. } } \details{ Most model fitting functions in \R return an object that can be updated or re-fitted \emph{via} \lcode{update}. This is possible thanks to the function call stored in the object, which can be used (possibly modified) later on. It is also used by \code{dredge} to generate submodels. Some functions (such as \code{mgcv::gamm} or \code{MCMCglmm::MCMCglmm}) do not provide their result with the \code{call} element. To work around this, \code{updateable} can be used on such a function to store the call. The resulting \dQuote{wrapper} should be used in exactly the same way as the original function. \code{updateable} can also be used to repair an existing \code{call} element, e.g. if it contains \link[=dots]{dotted names} that prevent re-evaluation of a call. The \code{eval.args} argument specifies the names of the function arguments to be evaluated in the stored call. This is useful if, for example, the model object does not have a \code{formula} element or does not store the formula in any other way, and the modelling function has been called with the formula specified as the variable name. In this case, the default \code{formula} method will try to retrieve the formula from the stored \code{call}, which does not guarantee that the variable will be available at the time of retrieval, or that the value of that variable will be the same as that used to fit the model (this is demonstrated in the last \sQuote{example}). } \value{ \code{updateable} returns a function with the same arguments as \code{FUN}, wrapping a call to \code{FUN} and adding an element named \code{call} to its result if possible, otherwise an attribute \code{"call"} (if the returned value is atomic or an S4 object). } \note{ \code{get_call} is similar to \lcode{getCall} (defined in package \pkg{stats}), but it can also extract the \code{call} when it is an \lxcode{attribute}{=attr} (and not an element of the object). Because the default \code{getCall} method cannot do that, the default \code{update} method will not work with atomic or S4 objects resulting from \code{updateable} wrappers. \code{uGamm} sets also an appropriate class onto the result (\code{"gamm4"} and/or \code{"gamm"}), which is needed for some generics defined in \pkg{MuMIn} to work (note that unlike the functions created by \code{updateable} it has no formal arguments of the original function). As of version 1.9.2, \code{MuMIn::gamm} is no longer available. } \author{Kamil Barto\enc{ń}{n}} \seealso{ \lcode{update}, \lcode{getCall}, \lcode{getElement}, \lcode{attributes} \lxcode{gamm}{mgcv}, \lxcode{gamm4}{gamm4} } \examples{ # Simple example with cor.test: # From example(cor.test) x <- c(44.4, 45.9, 41.9, 53.3, 44.7, 44.1, 50.7, 45.2, 60.1) y <- c( 2.6, 3.1, 2.5, 5.0, 3.6, 4.0, 5.2, 2.8, 3.8) ct1 <- cor.test(x, y, method = "kendall", alternative = "greater") uCor.test <- updateable(cor.test) ct2 <- uCor.test(x, y, method = "kendall", alternative = "greater") getCall(ct1) # --> NULL getCall(ct2) #update(ct1, method = "pearson") --> Error update(ct2, method = "pearson") update(ct2, alternative = "two.sided") ## predefined wrapper for 'gamm': \dontshow{ if(require(mgcv)) \{ } set.seed(0) dat <- gamSim(6, n = 100, scale = 5, dist = "normal") fmm1 <- uGamm(y ~s(x0)+ s(x3) + s(x2), family = gaussian, data = dat, random = list(fac = ~1)) getCall(fmm1) class(fmm1) \dontshow{ \} } ### \dontrun{ library(caper) data(shorebird) shorebird <- comparative.data(shorebird.tree, shorebird.data, Species) fm1 <- crunch(Egg.Mass ~ F.Mass * M.Mass, data = shorebird) uCrunch <- updateable(crunch) fm2 <- uCrunch(Egg.Mass ~ F.Mass * M.Mass, data = shorebird) getCall(fm1) getCall(fm2) update(fm2) # Error with 'fm1' dredge(fm2) } ### \dontrun{ # "lmekin" does not store "formula" element library(coxme) uLmekin <- updateable(lmekin, eval.args = "formula") f <- effort ~ Type + (1|Subject) fm1 <- lmekin(f, data = ergoStool) fm2 <- uLmekin(f, data = ergoStool) f <- wrong ~ formula # reassigning "f" getCall(fm1) # formula is "f" getCall(fm2) formula(fm1) # returns the current value of "f" formula(fm2) } } \keyword{utils} MuMIn/man/plot.model.selection.Rd0000644000176200001440000001005015161443462016344 0ustar liggesusers\encoding{utf-8} \name{plot.model.selection} \alias{plot.model.selection} \title{Visualize model selection table} \usage{ \method{plot}{model.selection}( x, ylab = NULL, xlab = NULL, main = "Model selection table", labels = NULL, terms = NULL, labAsExpr = TRUE, vlabels = rownames(x), mar.adj = TRUE, col = NULL, col.mode = 2, bg = "white", border = par("col"), par.lab = NULL, par.vlab = NULL, axes = TRUE, ann = TRUE, ... ) } \arguments{ \item{x}{a \code{"model.selection"} object.} \item{xlab, ylab, main}{labels for the \emph{x} and \emph{y} axes, and the main title for the plot.} \item{labels}{optional, a character vector or an expression containing model term labels (to appear on top side of the plot). Its length must be equal to number of displayed model terms. Defaults to the model term names.} \item{terms}{which terms to include (default \code{NULL} means all terms).} \item{labAsExpr}{logical, indicating whether the term names should be interpreted (\lcode{parse}d) as \R expressions for prettier labels. See also \lcode{plotmath}.} \item{vlabels}{alternative labels for the table rows (i.e. model names)} \item{mar.adj}{logical indicating whether the top and right margin should be enlarged if necessary to fit the labels.} \item{col}{vector or a \code{matrix} of colours for the non-empty grid cells. See 'Details'. If \code{col} is given as a matrix, the colours are applied to rows and columns. How it is done is governed by the argument \code{col.mode}.} \item{col.mode}{either numeric or \code{"value"}, specifies cell colouring mode. See 'Details'.} \item{bg}{background colour for the empty cells.} \item{border}{border colour for cells and axes.} \item{par.lab, par.vlab}{optional lists of arguments and \link[=par]{graphical parameters} for drawing term labels (top axis) and model names (right axis), respectively. Items of \code{par.lab} are passed as arguments to \lcode{mtext}, and those of \code{par.vlab} are passed to \lcode{axis}.} \item{axes, ann}{logical values indicating whether the axis and annotation should appear on the plot.} \item{\dots}{further \link[=par]{graphical parameters} to be set for the plot.} } \description{ Produces a graphical representation of model weights and terms. } \details{ \subsection{Colours}{ If \code{col.mode = 0}, the colours are recycled: if \code{col} is a matrix, recycling takes place both per row and per column. If \code{col.mode > 0}, the colour values in the columns are interpolated and assigned according to the model weights. Higher values shift the colours for models with lower model weights more forward. See also \lcode{colorRamp}. If \code{col.mode < 0} or \code{"value"} (partially matched, case-insensitive) and \code{col} has two or more elements, colours are used to represent coefficient values: the first element in \code{col} is used for categorical predictors, the rest for continuous values. The default is \code{grey} for factors and \link[=hcl.colors]{HCL palette} \code{"Blue-Red 3"} otherwise, ranging from blue for negative values to red for positive ones. } The following arguments are useful for adjusting label size and position in \code{par.lab} and \code{par.vlab} : \code{cex}, \code{las} (see \lcode{par}), \code{line} and \code{hadj} (see \lcode{mtext} and \lcode{axis}). } \examples{ \dontshow{if (require(graphics)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} ms <- dredge(lm(formula = y ~ ., data = Cement, na.action = na.fail)) plot(ms, # colours by coefficient value: col.mode = "value", par.lab = list(las = 2, line = 1.2, cex = 1), bg = "gray30", # change labels for the models to Akaike weights: vlabels = parse(text = paste("omega ==", round(Weights(ms), 2))) ) plot(ms, col = 2:3, col.mode = 0) # colour recycled by row plot(ms, col = cbind(2:3, 4:5), col.mode = 0) # colour recycled by row and column plot(ms, col = 2:3, col.mode = 1) # colour gradient by model weight \dontshow{\}) # examplesIf} } \seealso{ \lcode{plot.default}, \lcode{par}, \code{\link{MuMIn-package}} } \author{ Kamil Barto\enc{ń}{n} } \keyword{hplot} MuMIn/man/get.models.Rd0000644000176200001440000000567215161443462014362 0ustar liggesusers\name{get.models} \alias{get.models} \alias{pget.models} \encoding{utf-8} \title{Retrieve models from selection table} \description{ Generate or extract a list of fitted model objects from a \code{"model.selection"} table or component models from the averaged model (\code{"averaging"} object), optionally using parallel computation in a cluster. } \usage{ get.models(object, subset, cluster = NA, ...) } \arguments{ \item{object}{ object returned by \lcode{dredge}, \lcode{model.sel} or \lcode{model.avg}. } \item{subset}{subset of models, an expression evaluated within the model selection table (see \sQuote{Details}).} \item{cluster}{optionally, a \code{"cluster"} object. If it is a valid cluster, models are evaluated using parallel computation. } \item{\dots}{additional arguments to update the models. For example, one may want to fit models with \acronym{REML} (e.g. argument \code{REML = TRUE} in some modelling functions) while using \acronym{ML} for model selection.} } \value{ \lcode{list} of fitted model objects. } \details{ The argument \code{subset} must be explicitely provided. This is to assure that a potentially long list of models is not fitted unintentionally. To evaluate all models, set \code{subset} to \code{NA} or \code{TRUE}. If \code{subset} is a character vector, it is interpreted as names of rows to be selected. } \note{ \code{"model.selection"} tables created by \code{model.sel} or averaged models created by \code{model.avg} from a list of model objects (as opposed to those created with model selection tables) store the component models as part of the object - in these cases \code{get.models} simply extracts the items from these lists. Otherwise the models have to be fitted. Therefore, using \code{get.models} following \code{dredge} is not efficient as the requested models are fitted twice. If the number of generated models is reasonable, consider using \code{lapply(dredge(..., evaluate = FALSE), eval)}, which generates a list of all model calls and evaluates them into a list of model objects. Alternatively, \code{getCall} and \code{eval} can be used to compute a model out of the \code{"model.selection"} table (e.g. \code{eval(getCall(, i))}, where \code{i} is the model index or name). \code{pget.models} is still available, but is deprecated. } \author{Kamil Barto\enc{ń}{n}} \seealso{ \lcode{dredge} and \lcode{pdredge}, \lcode{model.avg} \lcode{makeCluster} in packages \pkg{parallel} and \pkg{snow} } \examples{ # Mixed models: \dontshow{ if(require(nlme)) \{ } fm2 <- lme(distance ~ age + Sex, data = Orthodont, random = ~ 1 | Subject, method = "ML") ms2 <- dredge(fm2) # Get top-most models, but fitted by REML: (confset.d4 <- get.models(ms2, subset = delta < 4, method = "REML")) \dontrun{ # Get the top model: get.models(ms2, subset = 1)[[1]] } \dontshow{ \} } } \keyword{models} MuMIn/man/r.squaredGLMM.Rd0000644000176200001440000001676415161443462014706 0ustar liggesusers\name{r.squaredGLMM} \alias{r.squaredGLMM} \alias{r.squaredGLMM.merMod} \encoding{utf-8} %% \newcommand{\CRANpkg}{\href{https://cran.r-project.org/package=#1}{\pkg{#1}}} %% \newcommand{\mydequation}{\ifelse{latex}{\deqn{#1}{#3}}{\ifelse{html}{\enc{\deqn{#1}}{#3}}{#3}}} %% \newcommand{\myequation}{\ifelse{latex}{\eqn{#1}{#3}}{\ifelse{html}{\enc{\eqn{#1}}{#3}}{#3}}} %% %% \newcommand{\logLik}{\myequation{\log\mathcal{L}(#1)}{XXXX}{logL(#1)}} %% \newcommand{\Rsq}{\myequation{R^{2}}{XXXX}{R^2}} %% \newcommand{\Rsqx}{\myequation{R_{#1}^{2}}{XXXX}{R_#1^2}} \title{Pseudo-R-squared for Generalized Mixed-Effect models} \description{ Calculate conditional and marginal coefficient of determination for Generalized mixed-effect models (\Rsqx{GLMM}). } \usage{ r.squaredGLMM(object, null, ...) \method{r.squaredGLMM}{merMod}(object, null, envir = parent.frame(), pj2014 = FALSE, ...) } \arguments{ \item{object}{a fitted linear model object. } \item{null}{optionally, a null model, including only random effects. See \sQuote{Details}. } \item{envir}{optionally, the \code{environment} in which the null model is to be evaluated. Defaults to the current frame. See \lcode{eval}. } \item{pj2014}{logical, if \code{TRUE} and \code{object} is of \code{poisson} family, the result will include \Rsqx{GLMM} using original formulation of Johnson (2014). This requires fitting \code{object} with an observation-level random effect term added. } \item{\dots}{additional arguments, ignored.} } \value{ \code{r.squaredGLMM} returns a two-column numeric \code{matrix}, each (possibly named) row holding values for marginal and conditional \Rsqx{GLMM} calculated with different methods, such as \dQuote{delta}, \dQuote{log-normal}, \dQuote{trigamma}, or \dQuote{theoretical} for models of \code{binomial} family. } \details{ There are two types of \Rsqx{GLMM}: marginal and conditional. \emph{Marginal \Rsqx{GLMM}} represents the variance explained by the fixed effects, and is defined as: \mydequation{R_{GLMM(m)}^{2}= \frac{\sigma_f^2}{\sigma_f^2 + \sigma_{\alpha}^2 + \sigma_{\varepsilon }^2} }{R_GLMM(m)² = (\sigma_f²) / (\sigma_f² + \sigma_\alpha² + \sigma_\epsilon²) }{R_GLMM(m)^2 = (sigma_f^2) / (sigma_f^2 + sigma_alpha^2 + sigma_epsilon^2) } \emph{Conditional \Rsqx{GLMM}} represents the variance explained by the entire model, including both fixed and random effects. It is calculated by the equation: \mydequation{R_{GLMM(c)}^{2}= \frac{\sigma_f^2 + \sigma_{\alpha}^2}{\sigma_f^2 + \sigma_{\alpha}^2 + \sigma_{\varepsilon }^2} }{R_GLMM(c)² = (\sigma_f² + \sigma_\alpha²) / (\sigma_f² + \sigma_\alpha² + \sigma_\epsilon²) }{R_GLMM(c)^2 = (sigma_f^2 + sigma_alpha^2) / (sigma_f^2 + sigma_alpha^2 + sigma_epsilon^2) } where \myequation{\sigma_f^2}{\sigma_f²}{sigma_f^2} is the variance of the fixed effect components, \myequation{\sigma_{\alpha}}{\sigma_\alpha²}{sigma_alpha^2} is the variance of the random effects, and \myequation{\sigma_\epsilon^2}{\sigma_\epsilon²}{sigma_epsilon^2} is the \dQuote{observation-level} variance. Three methods are available for deriving the observation-level variance \eqn{\sigma_\varepsilon}: the delta method, lognormal approximation and using the trigamma function. The delta method can be used with for all distributions and link functions, while lognormal approximation and trigamma function are limited to distributions with logarithmic link. Trigamma-estimate is recommended whenever available. Additionally, for binomial distributions, theoretical variances exist specific for each link function distribution. \emph{Null model}. Calculation of the observation-level variance involves in some cases fitting a \emph{null} model containing no fixed effects other than intercept, otherwise identical to the original model (including all the random effects). When using \code{r.squaredGLMM} for several models differing only in their fixed effects, in order to avoid redundant calculations, the null model object can be passed as the argument \code{null}. Otherwise, a null model will be fitted \emph{via} updating the original model. This assumes that all the variables used in the original model call have the same values as when the model was fitted. The function warns about this when fitting the null model is required. This warnings can be disabled by setting \code{options(MuMIn.noUpdateWarning = TRUE)}. } \note{ \strong{Important}: as of \pkg{MuMIn} version 1.41.0, \code{r.squaredGLMM} returns a revised statistics based on Nakagawa et al. (2017) paper. The returned value's format also has changed (it is a \code{matrix} rather than a numeric vector as before). Pre-1.41.0 version of the function calculated the \dQuote{theoretical} \Rsqx{GLMM} for \code{binomial} models. \Rsqx{GLMM} can be calculated also for fixed-effect only models. In the simpliest case of \acronym{OLS} it reduces to \myequation{\frac{Var({\hat{\mu}})}{Var({\hat{\mu}}) + D/2}}{}{Var(mu) / (Var(mu) + D(y, mu) / 2)}, where \myequation{Var({\hat{\mu}})}{}{Var(mu)} is the variance of fitted values, and \var{D} is the model deviance. Unlike likelihood-ratio based \Rsq for \acronym{OLS}, value of this statistic differs from that of the classical \Rsq. Currently methods exist for classes: \code{merMod}, \code{lme}, \code{glmmTMB}, \code{glmmADMB}, \code{glmmPQL}, \code{cpglm}(\code{m}) and (\code{g})\code{lm}. For families other than gaussian, Gamma, Poisson, binomial and negative binomial, the residual variance is obtained using \lxcode{get_variance}{insight} from package \CRANpkg{insight}. See note in \lcode{r.squaredLR} help page for comment on using \Rsq in model selection. } \author{ Kamil Barto\enc{ń}{n}. This implementation is based on the \sQuote{Supporting Information} for Nakagawa et al. (2014), (the extension for random-slopes) Johnson (2014), and includes developments from Nakagawa et al. (2017). } \references{ Nakagawa, S., Schielzeth, H. 2013 A general and simple method for obtaining \Rsq from Generalized Linear Mixed-effects Models. \emph{Methods in Ecology and Evolution} \bold{4}, 133--142. Johnson, P. C. D. 2014 Extension of Nakagawa & Schielzeth’s \Rsqx{GLMM} to random slopes models. \emph{Methods in Ecology and Evolution} \bold{5}, 44--946. Nakagawa, S., Johnson, P. C. D., Schielzeth, H. 2017 The coefficient of determination \Rsq and intra-class correlation coefficient from generalized linear mixed-effects models revisited and expanded. \emph{J. R. Soc. Interface} \bold{14}, 20170213. } \seealso{ \lcode{summary.lm}, \lcode{r.squaredLR} \lxcode{r2}{performance} from package \CRANpkg{performance} calculates \Rsqx{GLMM} also for variance at different levels, with optional confidence intervals. \CRANpkg{r2glmm} has functions for \Rsq and partial \Rsq. } \examples{ \dontshow{ if(require(nlme)) \{ } data(Orthodont, package = "nlme") fm1 <- lme(distance ~ Sex * age, ~ 1 | Subject, data = Orthodont) fmnull <- lme(distance ~ 1, ~ 1 | Subject, data = Orthodont) r.squaredGLMM(fm1) r.squaredGLMM(fm1, fmnull) r.squaredGLMM(update(fm1, . ~ Sex), fmnull) r.squaredLR(fm1) r.squaredLR(fm1, null.RE = TRUE) r.squaredLR(fm1, fmnull) # same result \dontrun{ if(require(MASS)) { fm <- glmmPQL(y ~ trt + I(week > 2), random = ~ 1 | ID, family = binomial, data = bacteria, verbose = FALSE) fmnull <- update(fm, . ~ 1) r.squaredGLMM(fm) # Include R2GLMM (delta method estimates) in a model selection table: # Note the use of a common null model dredge(fm, extra = list(R2 = function(x) r.squaredGLMM(x, fmnull)["delta", ])) } } \dontshow{ \} } } \keyword{models} MuMIn/man/jackknifeWeights.Rd0000644000176200001440000000671415161443462015577 0ustar liggesusers\encoding{utf-8} \name{jackknifeWeights} \alias{jackknifeWeights} \title{Jackknifed model weights} \usage{ jackknifeWeights( object, ..., data, type = c("loglik", "rmse"), family = NULL, weights = NULL, optim.method = "BFGS", maxit = 1000, optim.args = list(), start = NULL, force.update = FALSE, py.matrix = FALSE ) } \arguments{ \item{object, \dots}{two or more fitted \lcode{glm} objects, or a \code{list} of such, or an \link[=model.avg]{"averaging"} object.} \item{data}{a data frame containing the variables in the model. It is optional if all models are \code{glm}.} \item{type}{a character string specifying the function to minimize. Either \code{"rmse"} or \code{"loglik"}.} \item{family}{used only if \code{type = "loglik"}, a \lcode{family} object to be used for likelihood calculation. Not needed if all models share the same \code{family} and link function.} \item{weights}{an optional vector of \sQuote{\link[=weights.glm]{prior weights}} to be used in the model fitting process. Should be \code{NULL} or a numeric vector.} \item{optim.method}{optional, optimisation method, passed to \lcode{optim}.} \item{maxit}{optional, the maximum number of iterations, passed to \lcode{optim}.} \item{optim.args}{optional list of other arguments passed to \lcode{optim}.} \item{start}{starting values for model weights. Numeric of length equal the number of models.} \item{force.update}{for \code{glm}, the \code{glm.fit} function is used for fitting models to the train data, which is much more efficient. Set to \code{TRUE} to use \code{update} instead.} \item{py.matrix}{either a boolean value, then if \code{TRUE} a jackknifed prediction matrix is returned and if \code{FALSE} a vector of jackknifed model weights, or a \var{N}×\var{M} matrix (\emph{number of cases} × \emph{number of models}) that is interpreted as a jackknifed prediction matrix and it is used for optimisation (i.e. the jackknife procedure is skipped).} } \value{ The function returns a numeric vector of model weights. } \description{ Compute model weights optimized for jackknifed model fits. } \details{ Model weights are chosen (using \lcode{optim}) to minimise \acronym{RMSE} or log-likelihood of the prediction for data point \var{i}, of a model fitted omitting that data point \var{i}. The jackknife procedure is therefore run for all provided models and for all data points. } \note{ This procedure can give variable results depending on the \link[=optim]{optimisation method} and starting values. It is therefore advisable to make several replicates using different \code{optim.method}s. See \lcode{optim} for possible values for this argument. } \examples{ fm <- glm(Prop ~ mortality * dose, binomial(), Beetle, na.action = na.fail) fits <- lapply(dredge(fm, eval = FALSE), eval) amJk <- amAICc <- model.avg(fits) set.seed(666) Weights(amJk) <- jackknifeWeights(fits, data = Beetle) coef(amJk) coef(amAICc) } \references{ Hansen, B. E. and Racine, J. S. 2012 Jackknife model averaging. \emph{Journal of Econometrics} \strong{979}, 38–46 Dormann, C. et al. 2018 Model averaging in ecology: a review of Bayesian, information-theoretic, and tactical approaches for predictive inference. \emph{Ecological Monographs} \strong{88}, 485–504. } \seealso{ \lcode{Weights}, \lcode{model.avg} Other model weights: \code{\link{BGWeights}()}, \code{\link{bootWeights}()}, \code{\link{cos2Weights}()}, \code{\link{stackingWeights}()} } \author{ Kamil Barto\enc{ń}{n}. Carsten Dormann } \concept{model weights} \keyword{models} MuMIn/man/std.coef.Rd0000644000176200001440000001043215161443462014014 0ustar liggesusers\name{std.coef} \alias{std.coef} \alias{beta.weights} \alias{partial.sd} \encoding{utf-8} %% \newcommand{\myequation}{\ifelse{latex}{\eqn{#1}{#3}}{\ifelse{html}{\enc{\eqn{#1}}{#3}}{#3}}} \title{Standardized model coefficients} \description{ Standardize model coefficients by Standard Deviation or Partial Standard Deviation. } \usage{ std.coef(x, partial.sd, ...) partial.sd(x) # Deprecated: beta.weights(model) } \arguments{ \item{x, model}{a fitted model object. } \item{partial.sd}{logical, if set to \code{TRUE}, model coefficients are multiplied by partial \acronym{SD}, otherwise they are multiplied by the ratio of the standard deviations of the independent variable and dependent variable. } \item{\dots}{additional arguments passed to \lcode{coefTable}, e.g. \code{dispersion}. } } \details{ Standardizing model coefficients has the same effect as centring and scaling the input variables. \dQuote{Classical} standardized coefficients are calculated as \myequation{\beta^{*}_i = \beta_i\frac{s_{X_{i}}}{s_{y}} }{\betaᵢ* = \betaᵢ (sₓᵢ / Sᵧ) }{Bi* = Bi * (SXi / Sy)} , where \myequation{\beta}{\beta}{B} is the unstandardized coefficient, \myequation{s_{X_{i}}}{sₓᵢ}{SXi} is the standard deviation of associated dependent variable \myequation{X_i}{Xᵢ}{Xi} and \myequation{s_{y}}{Sᵧ}{Sy} is \acronym{SD} of the response variable. If variables are intercorrelated, the standard deviation of \myequation{X_i}{Xᵢ}{Xi} used in computing the standardized coefficients \myequation{\beta_i^{*}}{\betaᵢ*}{Bi*} should be replaced by the partial standard deviation of \myequation{X_i}{Xᵢ}{Xi} which is adjusted for the multiple correlation of \myequation{X_i}{Xᵢ}{Xi} with the other \eqn{X} variables included in the regression equation. The partial standard deviation is calculated as \myequation{s_{X_{i}}^{*}=s_{X_{i}} VIF(X_i)^{-0.5} (\frac{n-1}{n-p} )^{0.5} }{s*ₓᵢ = sₓᵢ √(VIFₓᵢ⁻¹) √((n-1)/(n-p)) }{sXi* = SXi * sqrt(1/VIF(Xi)) * sqrt((n-1)/(n-p))}, where \var{VIF} is the variance inflation factor, \var{n} is the number of observations and \var{p}, the number of predictors in the model. The coefficient is then transformed as \myequation{\beta^{*}_i = \beta_i s_{X_{i}}^{*} }{\betaᵢ* = \betaᵢ s*ₓᵢ }{Bi* = Bi * SXi*}. } \value{ A matrix with at least two columns for the standardized coefficient estimate and its standard error. Optionally, the third column holds degrees of freedom associated with the coefficients. } \author{Kamil Barto\enc{ń}{n}. Variance inflation factors calculation is based on function \code{vif} from package \pkg{car} written by Henric Nilsson and John Fox. } \references{ Cade, B.S. 2015 Model averaging and muddled multimodel inferences. \emph{Ecology} \bold{96}, 2370-2382. Afifi, A., May, S., Clark, V.A. 2011 \emph{Practical Multivariate Analysis}, Fifth Edition. CRC Press. Bring, J. 1994 How to standardize regression coefficients. \emph{The American Statistician} \bold{48}, 209--213. } \seealso{ \code{partial.sd} can be used with \lcode{stdize}. \lcode{coef} or \lcode{coeffs} and \lcode{coefTable} for unstandardized coefficients. } \examples{ # Fit model to original data: fm <- lm(y ~ x1 + x2 + x3 + x4, data = GPA) # Partial SD for the default formula: y ~ x1 + x2 + x3 + x4 psd <- partial.sd(lm(data = GPA))[-1] # remove first element for intercept # Standardize data: zGPA <- stdize(GPA, scale = c(NA, psd), center = TRUE) # Note: first element of 'scale' is set to NA to ignore the first column 'y' # Coefficients of a model fitted to standardized data: zapsmall(coefTable(stdizeFit(fm, newdata = zGPA))) # Standardized coefficients of a model fitted to original data: zapsmall(std.coef(fm, partial = TRUE)) # Standardizing nonlinear models: fam <- Gamma("inverse") fmg <- glm(log(y) ~ x1 + x2 + x3 + x4, data = GPA, family = fam) psdg <- partial.sd(fmg) zGPA <- stdize(GPA, scale = c(NA, psdg[-1]), center = FALSE) fmgz <- glm(log(y) ~ z.x1 + z.x2 + z.x3 + z.x4, zGPA, family = fam) # Coefficients using standardized data: coef(fmgz) # (intercept is unchanged because the variables haven't been # centred) # Standardized coefficients: coef(fmg) * psdg } \keyword{models} MuMIn/man/BGweights.Rd0000644000176200001440000000541215161443462014174 0ustar liggesusers\encoding{utf-8} \name{BGWeights} \alias{BGWeights} \title{Bates-Granger minimal variance model weights} \usage{ BGWeights(object, ..., data, force.update = FALSE) } \arguments{ \item{object, \dots}{two or more fitted \lcode{glm} objects, or a \code{list} of such, or an \lxcode{"averaging"}{=model.avg} object.} \item{data}{a data frame containing the variables in the model.} \item{force.update}{if \code{TRUE}, the much less efficient method of updating \code{glm} function will be used rather than directly \emph{via} \lcode{glm.fit}. This only applies to \code{glm}s, in case of other model types \code{update} is always used.} } \value{ A numeric vector of model weights. } \description{ Compute empirical weights based on out of sample forecast variances, following Bates and Granger (1969). } \details{ Bates-Granger model weights are calculated using prediction covariance. To get the estimate of prediction covariance, the models are fitted to randomly selected half of \code{data} and prediction is done on the remaining half. These predictions are then used to compute the variance-covariance between models, \eqn{\Sigma}. Model weights are then calculated as \myequation{w_{BG} = (1' \Sigma^{-1} 1)^{-1} 1 \Sigma^{-1} }{w_BG = (1' \Sigma{^-1} 1){^-1} 1 \Sigma{^-1} }{w_BG = (1' Sigma^-1 1)^-1 1 \ Sigma^-1}, where \eqn{1} a vector of 1-s. Bates-Granger model weights may be outside of the \eqn{[0,1]} range, which may cause the averaged variances to be negative. Apparently this method works best when data is large. } \note{ For matrix inversion, \lxcode{MASS::ginv()}{MASS:ginv} is more stable near singularities than \lcode{solve}. It will be used as a fallback if \code{solve} fails and \pkg{MASS} is available. } \examples{ fm <- glm(Prop ~ mortality + dose, family = binomial, Beetle, na.action = na.fail) models <- lapply(dredge(fm, evaluate = FALSE), eval) ma <- model.avg(models) # this produces warnings because of negative variances: set.seed(78) Weights(ma) <- BGWeights(ma, data = Beetle) coefTable(ma, full = TRUE) # SE for prediction is not reliable if some or none of coefficient's SE # are available predict(ma, data = test.data, se.fit = TRUE) coefTable(ma, full = TRUE) } \references{ Bates, J. M. and Granger, C. W. J. 1969 The combination of forecasts. \emph{Journal of the Operational Research Society} \strong{20}, 451-468. Dormann, C. et al. (2018) Model averaging in ecology: a review of Bayesian, information-theoretic, and tactical approaches for predictive inference. \emph{Ecological Monographs} \strong{88}, 485–504. } \seealso{ \lcode{Weights}, \lcode{model.avg} Other model weights: \lcode{bootWeights}, \lcode{cos2Weights}, \lcode{jackknifeWeights}, \lcode{stackingWeights} } \author{ Carsten Dormann, Kamil Barto\enc{ń}{n} } \concept{model weights} \keyword{models} MuMIn/man/model-utils.Rd0000644000176200001440000001027015161443462014545 0ustar liggesusers\name{Model utilities} \alias{MuMIn-model-utils} \alias{coeffs} \alias{model.names} \alias{tTable} \alias{coefTable} \alias{coefTable.default} \alias{coefTable.lme} \alias{coefTable.gee} \alias{coefTable.averaging} \alias{getAllTerms} \alias{getAllTerms.terms} \alias{get.response} \alias{.get.extras} \encoding{utf-8} %% \newcommand{\href}{#2} \title{Model utility functions} \description{ These functions extract or calculate various values from provided fitted model objects(s). They are mainly meant for internal use. \code{coeffs} extracts model coefficients; \code{getAllTerms} extracts independent variable names from a model object; \code{coefTable} extracts a table of coefficients, standard errors and associated degrees of freedom when possible; \code{get.response} extracts response variable from fitted model object; \code{model.names} generates shorthand (alpha)numeric names for one or several fitted models. \code{.get.extras} is used by \code{model.sel} and \code{dredge} to process the \code{"extra"} argument. It is exported and documented for technical reasons only and is not useful outside that context. } \usage{ coeffs(model) getAllTerms(x, ...) \method{getAllTerms}{terms}(x, intercept = FALSE, offset = TRUE, ...) coefTable(model, ...) \method{coefTable}{averaging}(model, full = FALSE, adjust.se = TRUE, ...) \method{coefTable}{lme}(model, adjustSigma, ...) \method{coefTable}{gee}(model, ..., type = c("naive", "robust")) get.response(x, data = NULL, ...) model.names(object, ..., labels = NULL, use.letters = FALSE) .get.extras(extra, r2nullfit = NULL) } \arguments{ \item{model}{a fitted model object. } \item{object}{a fitted model object or a list of such objects. } \item{x}{a fitted model object or a \code{formula}. } \item{offset}{should \sQuote{offset} terms be included? } \item{intercept}{should terms names include the intercept?} \item{full, adjust.se}{logical, apply to \code{"averaging"} objects. If \code{full} is \code{TRUE}, the full model-averaged coefficients are returned, and subset-averaged ones otherwise. If \code{adjust.se} is \code{TRUE}, inflated standard errors are returned. See \sQuote{Details} in \lcode{par.avg}. } \item{adjustSigma}{ See \lxcode{summary.lme}{nlme}. } \item{type}{ for \acronym{GEE} models, the type of covariance estimator to calculate returned standard errors on. Either \code{"naive"} or \code{"robust"} (\sQuote{sandwich}). } \item{labels}{optionally, a character vector with names of all the terms, e.g. from a global model. \code{model.names} enumerates the model terms in order of their appearance in the list and in the models. Therefore changing the order of the models leads to different names. Providing \code{labels} prevents that. } \item{\dots}{in \code{model.names}, more fitted model objects. In \code{coefTable} arguments that are passed to appropriate \lcode{vcov} or \code{summary} method (e.g. \code{dispersion} parameter for \code{glm} may be used here). In \code{get.response}, if \code{data} is given, arguments to be passed to \lcode{model.frame}. In other functions may be silently ignored. } \item{data}{a \code{data.frame}, \code{list} or \code{environment} (or object coercible to a \code{data.frame}), containing the variables in \code{x}. Required only if \code{x} is a \code{formula}, otherwise it can be used to get the response variable for a different data set. } \item{use.letters}{logical, whether letters should be used instead of numeric codes. } \item{extra,r2nullfit}{list of unary functions; optional null model object.} } \details{ The functions \code{coeffs}, \code{getAllTerms} and \code{coefTable} provide interface between the model object and \code{model.avg} (and \code{dredge}). Custom methods can be written to provide support for additional classes of models. } \note{ \code{coeffs}'s value is in most cases identical to that returned by \lcode{coef}, the only difference being it returns fixed effects' coefficients for mixed models, and the value is always a named numeric vector. Use of \code{tTable} is deprecated in favour of \code{coefTable}. } \author{Kamil Barto\enc{ń}{n}} \keyword{models} \keyword{manip} MuMIn/man/merge.model.selection.Rd0000644000176200001440000000344015161443462016472 0ustar liggesusers\name{merge.model.selection} \alias{merge.model.selection} \alias{rbind.model.selection} \alias{append.model.selection} \encoding{utf-8} \title{Combine model selection tables} \description{Combine two or more model selection tables. } \usage{ \method{merge}{model.selection}(x, y, suffixes = c(".x", ".y"), ...) \method{rbind}{model.selection}(..., deparse.level = 1, make.row.names = TRUE) } \arguments{ \item{x, y, \dots}{\code{model.selection} objects to be combined. (\dots ignored in \code{merge})} \item{suffixes}{a character vector with two elements that are appended respectively to row names of the combined tables.} \item{make.row.names}{logical indicating if unique and valid \code{row.names} should be constructed from the arguments. } \item{deparse.level}{ignored. } } \value{ A \lxcode{"model.selection" object}{=model.selection.object} containing models (rows) from all provided tables. } \note{ Both \ifelse{latex}{\eqn{\Delta_{IC}}}{\enc{Δ}{Delta}_IC} values and \emph{Akaike weights} are recalculated in the resulting tables. Models in the combined model selection tables must be comparable, i.e. fitted to the same data, however only very basic checking is done to verify that. The models must also be ranked by the same information criterion. Unlike the \code{merge} method for \code{data.frame}, this method appends second table to the first (similarly to \code{rbind}). } \author{Kamil Barto\enc{ń}{n}} \seealso{ \lcode{dredge}, \lcode{model.sel}, \lcode{merge}, \lcode{rbind}. } \examples{ \dontrun{ require(mgcv) ms1 <- dredge(glm(Prop ~ dose + I(dose^2) + log(dose) + I(log(dose)^2), data = Beetle, family = binomial, na.action = na.fail)) fm2 <- gam(Prop ~ s(dose, k = 3), data = Beetle, family = binomial) merge(ms1, model.sel(fm2)) } } \keyword{manip} MuMIn/man/exprApply.Rd0000644000176200001440000001035415161443462014276 0ustar liggesusers\name{exprApply} \alias{exprApply} \encoding{utf-8} \title{Apply a function to calls inside an expression} \description{ Apply function \code{FUN} to each occurence of a call to \code{what()} (or a symbol \code{what}) in an unevaluated expression. It can be used for advanced manipulation of expressions. Intended primarily for internal use. } \usage{ exprApply(expr, what, FUN, ..., symbols = FALSE) } \arguments{ \item{expr}{an unevaluated expression. } \item{what}{character string giving the name of a function. Each call to \code{what} inside \code{expr} will be passed to \code{FUN}. \code{what} can be also a character representation of an operator or parenthesis (including \link[=Paren]{curly} and \link[=Extract]{square} brackets) as these are primitive functions in \R. Set \code{what} to \code{NA} to match all names. } \item{FUN}{a function to be applied. } \item{symbols}{logical value controlling whether \code{FUN} should be applied to symbols as well as calls.} \item{\dots}{optional arguments to \code{FUN}.} } \value{ A (modified) expression. } \details{ \code{FUN} is found by a call to \lcode{match.fun} and can be either a function or a symbol (e.g., a backquoted name) or a character string specifying a function to be searched for from the environment of the call to \code{exprApply}. } \note{ If \code{expr} has a \link[=srcfile]{source reference} information (\code{"srcref"} attribute), modifications done by \code{exprApply} will not be visible when printed unless \code{srcref} is removed. However, \code{exprApply} does remove source reference from any \code{function} expression inside \code{expr}. } \author{Kamil Barto\enc{ń}{n}} \seealso{ Expression-related functions: \lcode{substitute}, \lcode{expression}, \lcode{quote} and \lcode{bquote}. Similar function \code{walkCode} exists in package \pkg{codetools}. Functions useful inside \code{FUN}: \lcode{as.name}, \lcode{as.call}, \lcode{call}, \lcode{match.call} etc. } \examples{ ### simple usage: # print all Y(...) terms in a formula (note that symbol "Y" is omitted): # Note: if `print` is defined as S4 "standardGeneric", we need to use # 'print.default' rather than 'print', or put the call to 'print' inside a # function, i.e. as `function(x) print(x)`: exprApply(~ X(1) + Y(2 + Y(4)) + N(Y + Y(3)), "Y", print.default) # replace X() with log(X, base = n) exprApply(expression(A() + B() + C()), c("A", "B", "C"), function(expr, base) { expr[[2]] <- expr[[1]] expr[[1]] <- as.name("log") expr$base <- base expr }, base = 10) ### # TASK: fit lm with two poly terms, varying the degree from 1 to 3 in each. # lm(y ~ poly(X1, degree = a) + poly(X2, degree = b), data = Cement) # for a = {1,2,3} and b = {1,2,3} # First we create a wrapper function for lm. Within it, use "exprApply" to add # "degree" argument to all occurences of "poly()" having "X1" or "X2" as the # first argument. Values for "degree" are taken from arguments "d1" and "d2" lmpolywrap <- function(formula, d1 = NA, d2 = NA, ...) { cl <- origCall <- match.call() cl[[1]] <- as.name("lm") cl$formula <- exprApply(formula, "poly", function(e, degree, x) { i <- which(e[[2]] == x)[1] if(!is.na(i) && !is.na(degree[i])) e$degree <- degree[i] e }, degree = c(d1, d2), x = c("X1", "X2")) cl$d1 <- cl$d2 <- NULL fit <- eval(cl, parent.frame()) fit$call <- origCall # replace the stored call fit } # global model: fm <- lmpolywrap(y ~ poly(X1) + poly(X2), data = Cement) # Use "dredge" with argument "varying" to generate calls of all combinations of # degrees for poly(X1) and poly(X2). Use "fixed = TRUE" to keep all global model # terms in all models. # Since "dredge" expects that global model has all the coefficients the # submodels can have, which is not the case here, we first generate model calls, # evaluate them and feed to "model.sel" modCalls <- dredge(fm, varying = list(d1 = 1:3, d2 = 1:3), fixed = TRUE, evaluate = FALSE ) model.sel(models <- lapply(modCalls, eval)) # Note: to fit *all* submodels replace "fixed = TRUE" with: # "subset = (d1==1 || {poly(X1)}) && (d2==1 || {poly(X2)})" # This is to avoid fitting 3 identical models when the matching "poly()" term is # absent. } \keyword{manip} MuMIn/man/AICc.Rd0000644000176200001440000000536715161443462013061 0ustar liggesusers\name{AICc} \alias{AICc} \encoding{utf-8} \title{Second-order Akaike Information Criterion} \description{ Calculate Second-order Akaike Information Criterion for one or several fitted model objects (\AICc, \AIC for small samples). } \usage{ AICc(object, ..., k = 2, REML = NULL) } \arguments{ \item{object}{a fitted model object for which there exists a \code{logLik} method, or a \code{"logLik"} object. } \item{\dots}{optionally more fitted model objects. } \item{k}{the \sQuote{penalty} per parameter to be used; the default \code{k = 2} is the classical \AIC. } \item{REML}{ optional logical value, passed to the \code{logLik} method indicating whether the restricted log-likelihood or log-likelihood should be used. The default is to use the method used for model estimation. } } \value{ If just one object is provided, returns a numeric value with the corresponding \AICc; if more than one object are provided, returns a \code{data.frame} with rows corresponding to the objects and columns representing the number of parameters in the model (\emph{df}) and \AICc. } \note{ \AICc should be used instead \AIC when sample size is small in comparison to the number of estimated parameters (Burnham & Anderson 2002 recommend its use when \eqn{n / K < 40}). } \references{ Burnham, K. P. and Anderson, D. R. 2002 \emph{Model selection and multimodel inference: a practical information-theoretic approach}. 2nd ed. New York, Springer-Verlag. Hurvich, C. M. and Tsai, C.-L. 1989 Regression and time series model selection in small samples, \emph{Biometrika} \bold{76}, 297–307. } \author{Kamil Barto\enc{ń}{n}} \seealso{ Akaike's An Information Criterion: \lcode{AIC} Some other implementations: %% \lxcode{AICc}{AICcmodavg} in package \pkg{AICcmodavg}, %% \lxcode{AICc}{bbmle:BIC-methods} in package \pkg{bbmle}, %% \lxcode{aicc}{glmulti:aic} in package \pkg{glmulti} \code{AICc} in package \pkg{AICcmodavg}, \code{AICc} in package \pkg{bbmle}, \code{aicc} in package \pkg{glmulti} } \examples{ #Model-averaging mixed models \dontshow{ if(require(nlme)) \{ oop <- } options(na.action = "na.fail") data(Orthodont, package = "nlme") # Fit model by REML fm2 <- lme(distance ~ Sex*age, data = Orthodont, random = ~ 1|Subject / Sex, method = "REML") # Model selection: ranking by AICc using ML ms2 <- dredge(fm2, trace = TRUE, rank = "AICc", REML = FALSE) (attr(ms2, "rank.call")) # Get the models (fitted by REML, as in the global model) fmList <- get.models(ms2, 1:4) # Because the models originate from 'dredge(..., rank = AICc, REML = FALSE)', # the default weights in 'model.avg' are ML based: summary(model.avg(fmList)) \dontrun{ # the same result: model.avg(fmList, rank = "AICc", rank.args = list(REML = FALSE)) } \dontshow{ \} } } \keyword{models} MuMIn/man/data-Cement.Rd0000644000176200001440000000167215161443462014437 0ustar liggesusers\name{Cement} \alias{Cement} \encoding{utf-8} \docType{data} \title{Cement hardening data} \description{ Cement hardening data from Woods et al (1932). } \usage{ Cement } \format{ \code{Cement} is a data frame with 5 variables. \var{x1}-\var{x4} are four predictor variables expressed as a percentage of weight. \describe{ \item{y}{calories of heat evolved per gram of cement after 180 days of hardening} \item{X1}{calcium aluminate} \item{X2}{tricalcium silicate} \item{X3}{tetracalcium alumino ferrite} \item{X4}{dicalcium silicate.} }} \source{ Woods H., Steinour H.H., Starke H.R. (1932) Effect of composition of Portland cement on heat evolved during hardening. \emph{Industrial & Engineering Chemistry} 24, 1207--1214. } \references{ Burnham, K. P. and Anderson, D. R. 2002 \emph{Model selection and multimodel inference: a practical information-theoretic approach}. 2nd ed. New York, Springer-Verlag. } \keyword{datasets} MuMIn/man/subset.model.selection.Rd0000644000176200001440000001011715161443462016677 0ustar liggesusers\name{subset.model.selection} \alias{subset.model.selection} \alias{[.model.selection} \alias{[[.model.selection} \alias{has} %% \newcommand{\bq}{\verb{`}\code{#1}\verb{`}} \encoding{utf-8} \title{Subsetting model selection table} \description{Extract a subset of a model selection table. } \usage{ \method{subset}{model.selection}(x, subset, select, recalc.weights = TRUE, recalc.delta = FALSE, ...) \method{[}{model.selection}(x, i, j, recalc.weights = TRUE, recalc.delta = FALSE, ...) \method{[[}{model.selection}(x, ..., exact = TRUE) } \arguments{ \item{x}{a \code{model.selection} object to be subsetted.} \item{subset,select}{logical expressions indicating columns and rows to keep. See \lcode{subset}. } \item{i,j}{indices specifying elements to extract. } \item{recalc.weights}{logical value specyfying whether Akaike weights should be normalized across the new set of models to sum to one. } \item{recalc.delta}{logical value specyfying whether \ifelse{latex}{\eqn{\Delta_{IC}}}{\enc{Δ}{Delta}_IC} should be calculated for the new set of models (not done by default). } \item{exact}{logical, see \lxcode{[}{=Extract}.} \item{\dots}{further arguments passed to \code{\link{[.data.frame}} (\code{drop}). } } \value{ A \code{model.selection} object containing only the selected models (rows). If columns are selected (\emph{via} argument \code{select} or the second index \code{x[, j]}) and not all essential columns (i.e. all except "varying" and "extra") are present in the result, a plain \code{data.frame} is returned. Similarly, modifying values in the essential columns with \code{[<-}, \code{[[<-} or \code{$<-} produces a regular data frame. } \details{ Unlike the method for \code{data.frame}, single bracket extraction with only one index \code{x[i]} selects rows (models) rather than columns. To select rows according to presence or absence of the variables (rather than their value), a pseudo-function \code{has} may be used with \code{subset}, e.g. \code{subset(x, has(a, !b))} will select rows with \emph{a} \bold{and} without \emph{b} (this is equivalent to \code{!is.na(a) & is.na(b)}). \code{has} can take any number of arguments. Complex model terms need to be enclosed within curly brackets (e.g \code{{s(a,k=2)}}), except for within \code{has}. Backticks-quoting is also possible, but then the name must match exactly (including whitespace) the term name as returned by \code{getAllTerms}. Enclosing in \code{I} prevents the name from being interpreted as a column name. To select rows where one variable can be present conditional on the presence of other variables, the function \code{dc} (\bold{d}ependency \bold{c}hain) can be used. \code{dc} takes any number of variables as arguments, and allows a variable to be included only if all the preceding arguments are also included (e.g. \code{subset = dc(a, b, c)} allows for models of form \code{a}, \code{a+b} and \code{a+b+c} but not \code{b}, \code{c}, \code{b+c} or \code{a+c}). } \author{Kamil Barto\enc{ń}{n}} \seealso{ \lcode{dredge}, \lcode{subset} and \code{\link{[.data.frame}} for subsetting and extracting from \code{data.frame}s. } \examples{ fm1 <- lm(formula = y ~ X1 + X2 + X3 + X4, data = Cement, na.action = na.fail) # generate models where each variable is included only if the previous # are included too, e.g. X2 only if X1 is there, and X3 only if X2 and X1 dredge(fm1, subset = dc(X1, X2, X3, X4)) # which is equivalent to # dredge(fm1, subset = (!X2 | X1) & (!X3 | X2) & (!X4 | X3)) # alternatively, generate "all possible" combinations ms0 <- dredge(fm1) # ...and afterwards select the subset of models subset(ms0, dc(X1, X2, X3, X4)) # which is equivalent to # subset(ms0, (has(!X2) | has(X1)) & (has(!X3) | has(X2)) & (has(!X4) | has(X3))) # Different ways of finding a confidence set of models: # delta(AIC) cutoff subset(ms0, delta <= 4, recalc.weights = FALSE) # cumulative sum of Akaike weights subset(ms0, cumsum(weight) <= .95, recalc.weights = FALSE) # relative likelihood subset(ms0, (weight / weight[1]) > (1/8), recalc.weights = FALSE) } \keyword{manip} MuMIn/man/stdize.Rd0000644000176200001440000002171715161443462013621 0ustar liggesusers\name{stdize} \alias{stdize} \alias{stdize.default} \alias{stdize.logical} \alias{stdize.formula} \alias{stdize.data.frame} \alias{stdizeFit} \encoding{utf-8} \title{Standardize data} \description{ \code{stdize} standardizes variables by centring and scaling. \code{stdizeFit} modifies a model call or existing model to use standardized variables. } \usage{ \method{stdize}{default}(x, center = TRUE, scale = TRUE, ...) \method{stdize}{logical}(x, binary = c("center", "scale", "binary", "half", "omit"), center = TRUE, scale = FALSE, ...) ## also for two-level factors \method{stdize}{data.frame}(x, binary = c("center", "scale", "binary", "half", "omit"), center = TRUE, scale = TRUE, omit.cols = NULL, source = NULL, prefix = TRUE, append = FALSE, ...) \method{stdize}{formula}(x, data = NULL, response = FALSE, binary = c("center", "scale", "binary", "half", "omit"), center = TRUE, scale = TRUE, omit.cols = NULL, prefix = TRUE, append = FALSE, ...) stdizeFit(object, newdata, which = c("formula", "subset", "offset", "weights", "fixed", "random", "model"), evaluate = TRUE, quote = NA) } \arguments{ \item{x}{a numeric or logical vector, factor, numeric matrix, \code{data.frame} or a formula. } \item{center, scale}{ either a logical value or a logical or numeric vector of length equal to the number of columns of \code{x} (see \sQuote{Details}). \code{scale} can be also a function to use for scaling. } \item{binary}{specifies how binary variables (logical or two-level factors) are scaled. Default is to \code{"center"} by subtracting the mean assuming levels are equal to 0 and 1; use \code{"scale"} to both centre and scale by \acronym{SD}, \code{"binary"} to centre to 0 / 1, \code{"half"} to centre to -0.5 / 0.5, and \code{"omit"} to leave binary variables unmodified. This argument has precedence over \code{center} and \code{scale}, unless it is set to \code{NA} (in which case binary variables are treated like numeric variables). } \item{source}{a reference \code{data.frame}, being a result of previous \code{stdize}, from which \code{scale} and \code{center} values are taken. Column names are matched. This can be used for scaling new data using statistics of another data. } \item{omit.cols}{ column names or numeric indices of columns that should be left unaltered. } \item{prefix}{ either a logical value specifying whether the names of transformed columns should be prefixed, or a two-element character vector giving the prefixes. The prefixes default to \dQuote{z.} for scaled and \dQuote{c.} for centred variables. } \item{append}{ logical, if \code{TRUE}, modified columns are appended to the original data frame. } \item{response}{logical, stating whether the response should be standardized. By default, only variables on the right-hand side of the formula are standardized. } \item{data}{ an object coercible to \code{data.frame}, containing the variables in \code{formula}. Passed to, and used by \lcode{model.frame}. } \item{newdata}{a \code{data.frame} returned by \code{stdize}, to be used by the modified model.} \item{\dots}{ for the \code{formula} method, additional arguments passed to \lcode{model.frame}. For other methods, it is silently ignored. } \item{object}{a fitted model object or an expression being a \code{call} to the modelling function. } \item{which}{ a character string naming arguments which should be modified. This should be all arguments which are evaluated in the \code{data} environment. Can be also \code{TRUE} to modify the expression as a whole. The \code{data} argument is additionally replaced with that passed to \code{stdizeFit}. } \item{evaluate}{ if \code{TRUE}, the modified call is evaluated and the fitted model object is returned. } \item{quote}{ if \code{TRUE}, avoids evaluating \code{object}. Equivalent to \code{stdizeFit(quote(expr), ...)}. Defaults to \code{NA} in which case \code{object} being a call to non-primitive function is quoted. } } \value{ \code{stdize} returns a vector or object of the same dimensions as \code{x}, where the values are centred and/or scaled. Transformation is carried out column-wise in \code{data.frame}s and matrices. The returned value is compatible with that of \lcode{scale} in that the numeric centring and scalings used are stored in attributes \code{"scaled:center"} and \code{"scaled:scale"} (these can be \code{NA} if no centring or scaling has been done). \code{stdizeFit} returns a modified, fitted model object that uses transformed variables from \code{newdata}, or, if \code{evaluate} is \code{FALSE}, an unevaluated call where the variable names are replaced to point the transformed variables. } \details{ \code{stdize} resembles \lcode{scale}, but uses special rules for factors, similarly to \code{standardize} in package \pkg{arm}. \code{stdize} differs from \code{standardize} in that it is used on data rather than on the fitted model object. The scaled data should afterwards be passed to the modelling function, instead of the original data. Unlike \code{standardize}, it applies special \sQuote{binary} scaling only to two-level \code{factor}s and logical variables, rather than to any variable with two unique values. Variables of only one unique value are unchanged. By default, \code{stdize} scales by dividing by standard deviation rather than twice the \acronym{SD} as \code{standardize} does. Scaling by \acronym{SD} is used also on uncentred values, which is different from \lcode{scale} where root-mean-square is used. If \code{center} or \code{scale} are logical scalars or vectors of length equal to the number of columns of \code{x}, the centring is done by subtracting the mean (if \code{center} corresponding to the column is \code{TRUE}), and scaling is done by dividing the (centred) value by standard deviation (if corresponding \code{scale} is \code{TRUE}). If \code{center} or \code{scale} are numeric vectors with length equal to the number of columns of \code{x} (or numeric scalars for vector methods), then these are used instead. Any \code{NA}s in the numeric vector result in no centring or scaling on the corresponding column. Note that \code{scale = 0} is equivalent to no scaling (i.e. \code{scale = 1}). Binary variables, logical or factors with two levels, are converted to numeric variables and transformed according to the argument \code{binary}, unless \code{center} or \code{scale} are explicitly given. } \author{Kamil Barto\enc{ń}{n}} \references{ Gelman, A. 2008 Scaling regression inputs by dividing by two standard deviations. \emph{Statistics in medicine} \bold{27}, 2865--2873. } \seealso{ Compare with \lcode{scale} and \code{standardize} or \code{rescale} (the latter two in package \pkg{arm}). For typical standardizing, model coefficients transformation may be easier, see \lcode{std.coef}. \lcode{apply} and \lcode{sweep} for arbitrary transformations of columns in a \code{data.frame}. } \examples{ # compare "stdize" and "scale" nmat <- matrix(runif(15, 0, 10), ncol = 3) stdize(nmat) scale(nmat) rootmeansq <- function(v) { v <- v[!is.na(v)] sqrt(sum(v^2) / max(1, length(v) - 1L)) } scale(nmat, center = FALSE) stdize(nmat, center = FALSE, scale = rootmeansq) if(require(lme4)) { # define scale function as twice the SD to reproduce "arm::standardize" twosd <- function(v) 2 * sd(v, na.rm = TRUE) # standardize data (scaled variables are prefixed with "z.") z.CO2 <- stdize(uptake ~ conc + Plant, data = CO2, omit = "Plant", scale = twosd) summary(z.CO2) fmz <- stdizeFit(lmer(uptake ~ conc + I(conc^2) + (1 | Plant)), newdata = z.CO2) # produces: # lmer(uptake ~ z.conc + I(z.conc^2) + (1 | Plant), data = z.CO2) ## standardize using scale and center from "z.CO2", keeping the original data: z.CO2a <- stdize(CO2, source = z.CO2, append = TRUE) # Here, the "subset" expression uses untransformed variable, so we modify only # "formula" argument, keeping "subset" as-is. For that reason we needed the # untransformed variables in "newdata". stdizeFit(lmer(uptake ~ conc + I(conc^2) + (1 | Plant), subset = conc > 100, ), newdata = z.CO2a, which = "formula", evaluate = FALSE) # create new data as a sequence along "conc" newdata <- data.frame(conc = seq(min(CO2$conc), max(CO2$conc), length = 10)) # scale new data using scale and center of the original scaled data: z.newdata <- stdize(newdata, source = z.CO2) \dontshow{ if(require(graphics)) \{ } # plot predictions against "conc" on real scale: plot(newdata$conc, predict(fmz, z.newdata, re.form = NA)) \dontshow{ \} } # compare with "arm::standardize" \dontrun{ library(arm) fms <- standardize(lmer(uptake ~ conc + I(conc^2) + (1 | Plant), data = CO2)) plot(newdata$conc, predict(fms, z.newdata, re.form = NA)) } } } \keyword{manip} MuMIn/man/bootWeights.Rd0000644000176200001440000000313415161443462014606 0ustar liggesusers\encoding{utf-8} \name{bootWeights} \alias{bootWeights} \title{Bootstrap model weights} \usage{ bootWeights(object, ..., R, rank = c("AICc", "AIC", "BIC")) } \arguments{ \item{object, \dots}{two or more fitted \lcode{glm} objects, or a \code{list} of such, or an \lxcode{"averaging"}{=model.avg} object.} \item{R}{the number of replicates.} \item{rank}{a character string, specifying the information criterion to use for model ranking. Defaults to \lcode{AICc}.} } \value{ A numeric vector of model weights. } \description{ Compute model weights using bootstrap. } \details{ The models are fitted repeatedly to a resampled data set and ranked using \AIC-type criterion. The model weights represent the proportion of replicates when a model has the lowest IC value. } \examples{ # To speed up the bootstrap, use 'x = TRUE' so that model matrix is included # in the returned object fm <- glm(Prop ~ mortality + dose, family = binomial, data = Beetle, na.action = na.fail, x = TRUE) fml <- lapply(dredge(fm, eval = FALSE), eval) am <- model.avg(fml) Weights(am) <- bootWeights(am, data = Beetle, R = 25) summary(am) } \references{ Dormann, C. et al. 2018 Model averaging in ecology: a review of Bayesian, information-theoretic, and tactical approaches for predictive inference. \emph{Ecological Monographs} \strong{88}, 485–504. } \seealso{ \lcode{Weights}, \lcode{model.avg} Other model weights: \code{\link{BGWeights}()}, \code{\link{cos2Weights}()}, \code{\link{jackknifeWeights}()}, \code{\link{stackingWeights}()} } \author{ Kamil Barto\enc{ń}{n}, Carsten Dormann } \concept{model weights} \keyword{models} MuMIn/man/loo.Rd0000644000176200001440000000322115161443462013076 0ustar liggesusers\encoding{utf-8} \name{loo} \alias{loo} \alias{loo.default} \alias{loo.lm} \title{Leave-one-out cross-validation} \usage{ loo(object, type = c("loglik", "rmse"), ...) } \arguments{ \item{object}{a fitted object model, currently only \code{lm}/\code{glm} is accepted.} \item{type}{the criterion to use, given as a character string, either \code{"rmse"} for Root-Mean-Square Error or \code{"loglik"} for log-likelihood.} \item{...}{other arguments are currently ignored.} } \value{ A single numeric value of \acronym{RMSE} or mean log-likelihood. } \description{ Compute \acronym{RMSE}/log-likelihood based on leave-one-out cross-validation. } \details{ Leave-one-out cross validation is a \var{K}-fold cross validation, with \var{K} equal to the number of data points in the set \var{N}. For all \var{i} from 1 to \var{N}, the model is fitted to all the data except for \var{i}-th row and a prediction is made for that value. The average error is computed and used to evaluate the model. } \examples{ fm <- lm(y ~ X1 + X2 + X3 + X4, Cement) loo(fm, type = "l") loo(fm, type = "r") ## Compare LOO_RMSE and AIC/c options(na.action = na.fail) dd <- dredge(fm, rank = loo, extra = list(AIC, AICc), type = "rmse") plot(loo ~ AIC, dd, ylab = expression(LOO[RMSE]), xlab = "AIC/c") points(loo ~ AICc, data = dd, pch = 19) legend("topleft", legend = c("AIC", "AICc"), pch = c(1, 19)) } \references{ Dormann, C. et al. 2018 Model averaging in ecology: a review of Bayesian, information-theoretic, and tactical approaches for predictive inference. \emph{Ecological Monographs} \strong{88}, 485–504. } \author{ Kamil Barto\enc{ń}{n}, based on code by Carsten Dormann } \keyword{models} MuMIn/DESCRIPTION0000644000176200001440000000262515161557552012766 0ustar liggesusersPackage: MuMIn Type: Package Title: Multi-Model Inference Version: 1.48.19 Date: 2026-03-27 Encoding: UTF-8 Authors@R: c( person("Kamil", "Bartoń", role=c("aut", "cre"), email="kamil.barton@go2.pl", comment = c(ORCID = "0000-0001-5562-8274")) ) Author: Kamil Bartoń [aut, cre] (ORCID: ) Maintainer: Kamil Bartoń Description: Tools for model selection and model averaging with support for a wide range of statistical models. Automated model selection through subsets of the maximum model, with optional constraints for model inclusion. Averaging of model parameters and predictions based on model weights derived from information criteria (AICc and alike) or custom model weighting schemes. License: GPL-2 Depends: R (>= 4.4.0) Imports: graphics, methods, Matrix, stats, stats4, nlme, insight Suggests: lme4 (>= 1.1.0), mgcv (>= 1.7.5), gamm4, MASS, nnet, survival (>= 3.1.0), geepack, performance Enhances: aod, betareg, caper, coxme (>= 2.2.4), cplm, gee, glmmML, logistf, MCMCglmm, ordinal, pscl, spatialreg, splm, unmarked (>= 1.5.1), geeM (>= 0.7.5), gamlss, RMark, glmmTMB, brglm, quantreg, maxlike LazyData: yes NeedsCompilation: no Packaged: 2026-03-27 09:09:51 UTC; kb2 Repository: CRAN Date/Publication: 2026-03-27 19:50:02 UTC