https://github.com/cran/MuMIn
Raw File
Tip revision: 69fda28b879d6147f7dda937d28114b28cc8ebc8 authored by Kamil BartoĊ„ on 14 May 2014, 02:44:24 UTC
version 1.10.0
Tip revision: 69fda28
get.models.R
`get.models` <-
function(object, subset, ...) {
    if (!inherits(object, "model.selection"))
		stop("'object' must be a 'model.selection' object")

	calls <- attr(object, "model.calls")
	if(is.null(calls)) stop("'object' has no 'model.calls' attribute")

	if(!missing(subset)) {
	    r <- eval(substitute(subset), object, parent.frame())
		if(is.character(r)) r <- match(r, dimnames(object)[[1L]])
		calls <- calls[r]
	}

	newargs <- match.call()
	newargs[[1L]] <- NULL
	newargs[c('object', 'subset')] <- NULL

	naNames <- names(newargs)
	if(length(newargs))  for(i in seq_along(calls)) calls[[i]][naNames] <- newargs

	glo <- attr(object, "global")
	if(is.null(glo)) {
		models <- lapply(attr(object, "model.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)
	}

	attr(models, "rank.call") <- attr(object, "rank.call")
	attr(models, "rank") <- attr(object, "rank")

	return(models)
}

`pget.models` <-
function(object, cluster = NA, subset, ...) {
	if (!inherits(object, "model.selection"))
		stop("'object' must be a 'model.selection' object")

	calls <- attr(object, "model.calls")
	if(is.null(calls)) stop("object has no 'calls' attribute")

	if(!missing(subset)) {
	    r <- eval(substitute(subset), object, parent.frame())
		if(is.character(r)) r <- match(r, dimnames(object)[[1L]])
		calls <- calls[r]
	}
	newargs <- match.call()
	newargs[[1L]] <- NULL
	newargs[c('object', 'subset', 'cluster')] <- NULL

	naNames <- names(newargs)
	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(attr(object, "model.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)
		}
	}

	attr(models, "rank.call") <- attr(object, "rank.call")
	attr(models, "rank") <- attr(object, "rank")

	return(models)
}
back to top