https://github.com/cran/MuMIn
Tip revision: b4fae7a102a8a67407ddf3b3ef825ed34735704b authored by Kamil BartoĊ on 18 December 2019, 19:20:02 UTC
version 1.43.14
version 1.43.14
Tip revision: b4fae7a
rbind.model.selection.R
`rbind.model.selection` <-
function (..., deparse.level = 1, make.row.names = TRUE) {
allargs <- list(...)
n <- length(allargs)
if(n == 1L) return(allargs[[1L]])
if(!all(vapply(allargs, inherits, FALSE, "model.selection")))
stop("need all \"model.selection\" objects")
### XXX: This modifies original objects!!!
allargs <- lapply(allargs, "class<-", "data.frame")
## ... reverting to original (?) class on exit:
on.exit(lapply(allargs, "class<-", c("model.selection", "data.frame")))
allitemsidentical <- function(x) all(vapply(x[-1L], identical, FALSE, x[[1L]]))
if(!allitemsidentical(lapply(lapply(allargs, attr, "rank"), attr, "call")))
stop("tables are not ranked by the same IC")
if(!allitemsidentical(lapply(allargs, "attr", "nobs")))
stop("models are fitted to different number of observations")
.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(allargs, 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(allargs, nrow)), length(nm)),
dimnames = list(NULL, nm)))
row1 <- 1L
for(z in allargs) {
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
}
newattr <- list(column.types = vct)
for(i in c("model.calls", "coefTables"))
newattr[[i]] <- unlist(lapply(allargs, attr, i), recursive = FALSE, use.names = FALSE)
k <- c("rank", "nobs")
newattr[k] <- attributes(allargs[[1L]])[k]
tmp <- lapply(allargs, 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(allargs), sapply(allargs, nrow))
rn1[i] <- paste0(rn1[i <- rn1 != ""], ".")
rlabs <- paste0(rn1, unlist(lapply(allargs, 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
}