##############################################################################
# Copyright (c) 2012-2024 Russell V. Lenth #
# #
# This file is part of the emmeans package for R (*emmeans*) #
# #
# *emmeans* is free software: you can redistribute it and/or modify #
# it under the terms of the GNU General Public License as published by #
# the Free Software Foundation, either version 2 of the License, or #
# (at your option) any later version. #
# #
# *emmeans* is distributed in the hope that it will be useful, #
# but WITHOUT ANY WARRANTY; without even the implied warranty of #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
# GNU General Public License for more details. #
# #
# You should have received a copy of the GNU General Public License #
# along with R and *emmeans*. If not, see #
# <https://www.r-project.org/Licenses/> and/or #
# <http://www.gnu.org/licenses/>. #
##############################################################################
# Methods for emm_list objects
# First, here is documentation for the emm_list class
#' The \code{emm_list} class
#'
#' An \code{emm_list} object is simply a list of
#' \code{\link[=emmGrid-class]{emmGrid}} objects. Such a list is returned,
#' for example, by \code{\link{emmeans}} with a two-sided formula or a list as its
#' \code{specs} argument. Several methods for this class are provided, as detailed below.
#' Typically, these methods just quietly do the same thing as their \code{emmGrid}
#' methods, using the first element of the list. You can specify \code{which}
#' to select a different element, or just run the corresponding \code{emmGrid}
#' method on \code{object[[k]]}.
#'
#' @param object,x an object of class \code{emm_list}
#' @param ... additional arguments passed to corresponding \code{emmGrid} method
#' @param which integer vector specifying which elements to select.
#'
#' @return a \code{list} of objects returned by the corresponding \code{emmGrid}
#' method (thus, often, another \code{emm_list} object). However, if
#' \code{which} has length 1, the one result is not wrapped in a list.
#'
#' @rdname emm_list-object
#' @name emm_list
#' @order 1
NULL
# Internal utility to noisily return one of an emm_list
# Call with ... argument so that message is suppressed if we specify 'which'
.chk.list = function(object, which, ...) {
if (inherits(object, "emm_list")) {
if (missing(which))
which = 1
object = object[[which]]
}
object
}
# My own lapply() function that drops when the dimension is 1
.lapply = function(...) {
rtn = lapply(...)
if (length(rtn) == 1) {
rtn = rtn[[1]]
}
else {
cls = ifelse(class(rtn[[1]])[1] == "emmGrid", "emm_list", "summary_eml")
class(rtn) = c(cls, "list")
}
rtn
}
#' @export
#' @method str emm_list
#' @rdname emm_list-object
#' @order 12
str.emm_list = function(object, ...) {
for(nm in names(object)) {
cat(paste("$", nm, "\n", sep=""))
str(object[[nm]])
cat("\n")
}
}
# summary.emm_list et al take an argument 'which' that allows doing a subset
# Each returns a regular 'list'
#' @export
#' @method summary emm_list
#' @return \code{summary.emm_list} returns an object
#' of class \code{summary_eml}, which is a list of \code{summary_emm}
#' objects.
#' @rdname emm_list-object
#' @order 13
summary.emm_list <- function(object, ..., which = seq_along(object)) {
# .lapply(object[which], function(x) {
# if (inherits(x, "summary_emm")) x
# else summary.emmGrid(x, ...)
# })
if(length(which) == 1)
summary.emmGrid(object[[which]], ...)
else
.lapply(object[which], \(x) summary.emmGrid(x, ...))
}
#' @export
summary.summary_eml = function(object, ...) object
#' @export
#' @rdname emm_list-object
#' @order 25
#' @param row.names,optional Required arguments of \code{as.data.frame}, ignored
#' @method as.data.frame summary_eml
as.data.frame.summary_eml = function(x, row.names = NULL, optional = FALSE, which, ...) {
rbind(x, which = which)
}
#' @export
print.summary_eml = function(x, ...) {
attr(x, "class") = NULL
print(x)
}
#' @export
#' @method print emm_list
#' @rdname emm_list-object
#' @order 14
#' @note No \code{export} option is provided for printing an \code{emm_list}
#' (see \code{\link{print.emmGrid}}). If you wish to export these objects, you
#' must do so separately for each element in the list.
#'
print.emm_list = function(x, ...) {
print(summary(x, ...))
}
#' @export
#' @method contrast emm_list
#' @rdname emm_list-object
#' @order 3
contrast.emm_list = function(object, ... , which = 1) {
.lapply(object[which], contrast, ...)
}
#' @export
#' @method pairs emm_list
#' @rdname emm_list-object
#' @order 4
pairs.emm_list = function(x, ..., which = 1) {
.lapply(x[which], pairs, ...)
}
#' @export
#' @method test emm_list
#' @rdname emm_list-object
#' @order 6
test.emm_list = function(object, ..., which = seq_along(object)) {
.lapply(object[which], test, ...)
}
#' @export
#' @method confint emm_list
#' @rdname emm_list-object
#' @order 7
confint.emm_list = function(object, ..., which = seq_along(object)) {
.lapply(object[which], confint, ...)
}
#' @export
#' @method coef emm_list
#' @rdname emm_list-object
#' @order 9
coef.emm_list = function(object, ..., which = 2) {
.lapply(object[which], coef, ...)
}
#' @export
#' @method plot emm_list
#' @rdname emm_list-object
#' @order 8
#' @note The \code{plot} method uses only the first element of \code{which}; the others are ignored.
plot.emm_list = function(x, ..., which = 1) {
plot.emmGrid(x[[which[1]]], ...)
}
#' @rdname rbind.emmGrid
#' @order 23
#' @param which Integer vector of subset of elements to use; if missing, all are combined
#' @return The \code{rbind} method for \code{emm_list} objects simply combines
#' the \code{emmGrid} objects comprising the first element of \code{...}.
#' Note that the returned object is not yet summarized, so any \code{adjust}
#' parameters apply to the combined \code{emmGrid}.
#' @export
#' @method rbind emm_list
#' @examples
#'
#' ### Working with 'emm_list' objects
#' mod <- lm(conc ~ source + factor(percent), data = pigs)
#' all <- emmeans(mod, list(src = pairwise ~ source, pct = consec ~ percent))
#' rbind(all, which = c(2, 4), adjust = "mvt")
rbind.emm_list = function(..., which, adjust = "bonferroni") {
elobj = list(...)[[1]]
if(!missing(which))
elobj = elobj[which]
class(elobj) = c("emm_list", "list")
update(do.call(rbind.emmGrid, elobj), adjust = adjust)
}
#' @rdname rbind.emmGrid
#' @order 33
#' @return The \code{rbind} method for \code{summary_emm} objects (or a list thereof)
#' returns a single \code{summary_emm} object. This combined object
#' \emph{preserves} any adjusted P values or confidence limits in the
#' original summaries, since those quantities have already been computed.
#' @export
#' @method rbind summary_emm
rbind.summary_emm = function(..., which) {
slobj = list(...)
if(!all(sapply(slobj, \(z) inherits(z, "data.frame")))) {
# workaround to make tern.gee::lsmeans() work
slobj = lapply(slobj, \(z) if(inherits(z, "data.frame")) data.frame(z) else z)
return(do.call("rbind", slobj))
}
rbind.summary_eml(slobj, which = which)
}
#'
#' @export
#' @method rbind summary_eml
rbind.summary_eml = function(..., which) {
x = list(...)[[1]]
if(!missing(which))
x = x[which]
nms.lst = lapply(x, names)
bys = unique(do.call(c, lapply(x, \(z) attr(z, "by.vars"))))
pris = unique(do.call(c, lapply(x, \(z) attr(z, "pri.vars"))))
if (length(x) == 1) {
attr(x[[1]], "pri.vars") = c(pris, bys)
attr(x[[1]], "by.vars") = NULL
return (x[[1]])
}
nms = pris = union(bys, pris)
for (n in nms.lst)
nms = union(nms, n)
nums = setdiff(nms, pris) # numeric columns
xx = lapply(x, function(df) {
d = data.frame(matrix(".", nrow = nrow(df), ncol = length(nms),
dimnames = list(NULL, nms)))
d[, nums] = NA
d[, names(df)] = df
d
})
rtn = do.call("rbind", xx)
row.names(rtn) = NULL
class(rtn) = c("summary_emm", "data.frame")
attr(rtn, "pri.vars") = pris
attr(rtn, "estName") = attr(x[[1]], "estName")
mesg = otr.mesg = attr(x[[1]], "mesg")
for (i in 2:length(x)) {
mesg = intersect(mesg, attr(x[[i]], "mesg"))
otr.mesg = union(otr.mesg, attr(x[[i]], "mesg"))
}
otr.mesg = setdiff(otr.mesg, mesg)
if (length(otr.mesg) > 0)
mesg = c(mesg, "The following messages apply only to some rows:",
paste("*", otr.mesg))
attr(rtn, "mesg") = mesg
rtn
}
#' @export
#' @rdname emm_list-object
#' @order 24
#' @return The \code{as.data.frame} methods return a single data frame via
#' \code{as.data.frame(rbind(x))}.
#' See also \code{\link{rbind.emm_list}} and \code{\link{as.data.frame.emmGrid}}
#' @method as.data.frame emm_list
as.data.frame.emm_list = function(x, ...) {
if (length(x) > 1)
warning("Note: 'as.data.frame' has combined your ", length(x), " sets of results into one object,\n",
"and this affects things like adjusted P values. Refer to the annotations.")
as.data.frame(rbind(x, ..., check.names = FALSE))
}
#' @export
#' @method as.list emm_list
as.list.emm_list = function(x, ...) {
rtn = list()
for (nm in names(x))
rtn[[nm]] = as.list.emmGrid(x[[nm]])
attr(rtn, "emm_list") = TRUE
rtn
}
#' @export
#' @return \code{as.emm_list} returns an object of class \code{emm_list}.
#'
#' @rdname as.emmGrid
#' @order 3
as.emm_list = function(object, ...) {
if (is.null(attr(object, "emm_list")))
as.emmGrid(object, ...)
else
lapply(object, as.emmGrid, ...)
}
### Others we won't document
#' @exportS3Method update emm_list
update.emm_list = function(object, ...)
update.emmGrid(object[[1]])
#' @exportS3Method predict emm_list
predict.emm_list = function(object, ...)
predict.emmGrid(object[[1]], ...)
#' @exportS3Method vcov emm_list
vcov.emm_list = function(object, ...)
vcov.emmGrid(object[[1]], ...)
xtable.emm_list = function(x, ...)
xtable.emmGrid(x[[1]], ...)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.