From 70f9a1869846eaa642f7428b449cdf8327330b53 Mon Sep 17 00:00:00 2001 From: "Russell V. Lenth" Date: Wed, 2 Oct 2024 18:11:18 -0500 Subject: [PATCH] with_emm_options() + models vignette link (#502) --- NEWS.md | 2 + R/emmGrid-methods.R | 138 +++++++-------------------------- man/emm_options.Rd | 14 ++++ tests/testthat/test-ref_grid.R | 5 +- vignettes/models.Rmd | 3 +- 5 files changed, 48 insertions(+), 114 deletions(-) diff --git a/NEWS.md b/NEWS.md index a55c758..2c96c45 100644 --- a/NEWS.md +++ b/NEWS.md @@ -6,6 +6,8 @@ title: "NEWS for the emmeans package" * Fix for long-standing `weights` bug in `lme()` (#356) * Fix for inconsistent contrasts in case of missing levels (#508, #509) * Fix for using nuisance variables with proportional weights (#510) + * New function `with_emm_options()` to run code with options temporarily set + ## emmeans 1.10.4 diff --git a/R/emmGrid-methods.R b/R/emmGrid-methods.R index 4c7236e..492da0e 100644 --- a/R/emmGrid-methods.R +++ b/R/emmGrid-methods.R @@ -676,6 +676,34 @@ get_emm_option = function(x, default = emm_defaults[[x]]) { default } +#' @rdname emm_options +#' @param expr Expression to evaluate. If missing, the last element of \code{...} is used. +#' @return \code{with_emm_options()} temporarily sets the options in \code{...}, then +#' evaluates \code{try(expr)} and returns the result. +#' @export +#' @examples +#' +#' # Illustration of how 'opt.digits' affects the results of print() +#' # Note that the returned value is printed with the default setting (opt.digits = TRUE) +#' pigs.lm <- lm(inverse(conc) ~ source, data = pigs) +#' with_emm_options(opt.digits = FALSE, print(emmeans(pigs.lm, "source"))) +#' +with_emm_options = function(..., expr) { + cl = match.call() + if(missing(expr)) { + expr = cl[[length(cl)]] + cl = cl[-length(cl)] + } + cl[[1]] = as.name("emm_options") + oldopts = getOption("emmeans") + eval(cl, parent.frame()) + result = try(eval(expr, parent.frame())) + options(emmeans = oldopts) + result +} + + + ### Exported defaults for certain options #' @rdname emm_options #' @export @@ -747,116 +775,6 @@ emm_defaults = list ( update.emmGrid(x, levels = value) } -# ### transform method (I decided to ditch this completely in favor of levels<-) -# #' Modify variable names and/or levels in a reference grid -# #' -# #' @param `_data` An object of class \code{emmGrid} -# #' @param ... Specifications for changes to be made. See Specifications section -# #' @param `_par` named \code{list} containing any additional parameters needed -# #' in evaluating expressions -# #' -# #' @section Specifications: -# #' Each specification can be of one of the following forms: -# #' \itemize{ -# #' \item{\code{name = } (replace levels only)} -# #' \item{\code{name = newname ~ } (replace levels and rename)} -# #' \item{\code{name = ~ } (calculate new levels)} -# #' \item{\code{name = newname ~ } (calculate new levels and rename)} -# #' \item{\code{newame ~ name } (rename with levels unchanged)} -# #' \item{\code{newname ~ } (calculate new levels for variable -# #' in expression, and rename)} -# #' } -# #' Here, \code{name} must be the name of an existing predictor in the grid, -# #' and \code{} is a character of numeric vector of length -# #' exactly equal to the number of levels of \code{name}. The type of the replacement levels -# #' does not need to match the type of the existing levels; however, any factor in the grid -# #' remains a factor, with its levels changed. -# #' -# #' Expressions must be supplied via a formula, and must be evaluable in the context -# #' of \code{envir} and the existing levels of \code{name}. -# #' If a formula has a left-hand side, it is used as -# #' a replacement name for that variable. -# #' -# #' @return a modified \code{emmGrid} object -# #' @export -# #' -# #' @note -# #' An alternative way to use this is to supply a list of arguments as the \code{morph} -# #' option in \code{\link{update.emmGrid}}. -# #' -# #' @examples -# #' warp.lm <- lm(breaks ~ wool * tension, data = warpbreaks) -# #' (warp.rg <- ref_grid(warp.lm)) -# #' transform(warp.rg, tension = 1:3, wool = texture ~ c("soft", "coarse")) -# #' -# #' # Standardized predictor -# #' z <- scale(fiber$diameter) -# #' fiber.lm <- lm(strength ~ z + machine, data = fiber) -# #' -# #' ### Mean predictions at 1-SD intervals: -# #' (fiber.emm <- emmeans(fiber.lm, "z", at = list(z = -1:1))) -# #' -# #' ### Same predictions labeled with actual diameter values: -# #' transform(fiber.emm, diameter ~ `scaled:center` + `scaled:scale` * z, -# #' `_par` = attributes(z)) -# #' -# #' -# -# transform.emmGrid <- function(`_data`, ..., `_par` = list()) { -# specs = list(...) -# nms = names(c(`_dummy_` = 0, specs))[-1] # keeps this from being NULL -# for (i in which(nms == "")) { # get name from formula rhs -# if (!inherits(spc <- specs[[i]], "formula") -# || (inherits(spc, "formula") && (length(spc) < 3))) -# stop("Unnamed specifications must be two-sided formulas") -# nms[i] = names(specs)[i] = c(intersect(all.vars(spc[-2]), -# names(`_data`@levels)), "(absent)")[1] -# } -# for (var in nms) { -# oldlev = `_data`@levels[[var]] -# if (is.null(oldlev)) -# stop("No variable named '", var, "' in this object.") -# newlev = specs[[var]] -# if(inherits(newlev, "formula") && length(newlev) > 2) { -# newname = as.character(newlev)[2] -# newlev = newlev[-2] -# } -# else -# newname = "" -# if ((is.numeric(newlev) || is.character(newlev)) -# && length(newlev) != length(oldlev)) -# stop("Must provide exactly ", length(oldlev), " levels for '", var, "'") -# else if (inherits(newlev, "formula")) -# newlev = eval(str2expression(as.character(newlev)[2]), -# envir = c(`_data`@levels[var], `_par`)) -# # so at this point we have conforming numbers of levels. -# `_data`@levels[[var]] = newlev -# v = newv = `_data`@grid[[var]] -# if (inherits(v, "factor")) -# levels(newv) = newlev -# else for (i in seq_along(oldlev)) -# newv[v == oldlev[[i]]] = newlev[[i]] -# `_data`@grid[[var]] = newv -# if (newname != "") { -# i = which(names(`_data`@levels) == var) -# names(`_data`@levels)[i] = newname -# i = which(names(`_data`@grid) == var) -# names(`_data`@grid)[i] = newname -# i = which(`_data`@roles$predictors == var) -# if (length(i) > 0) -# `_data`@roles$predictors[i] = newname -# nst = `_data`@model.info$nesting -# if (!is.null(nst)) { -# names(nst)[names(nst) == var] = newname -# nst = lapply(nst, function(x) { x[x == var] = newname; x }) -# `_data`@model.info$nesting = nst -# } -# } -# } -# `_data` -# } - - ### Utility to change the internal structure of an emmGrid object ### Returned emmGrid object has linfct = I and bhat = estimates diff --git a/man/emm_options.Rd b/man/emm_options.Rd index 239abc8..5d8cf45 100644 --- a/man/emm_options.Rd +++ b/man/emm_options.Rd @@ -4,6 +4,7 @@ \name{emm_options} \alias{emm_options} \alias{get_emm_option} +\alias{with_emm_options} \alias{emm_defaults} \title{Set or change emmeans options} \format{ @@ -14,6 +15,8 @@ emm_options(..., disable) get_emm_option(x, default = emm_defaults[[x]]) +with_emm_options(..., expr) + emm_defaults } \arguments{ @@ -28,6 +31,8 @@ on reproducible bugs. When \code{disable} is specified, the other arguments are \item{x}{Character value - the name of an option to be queried} \item{default}{Value to return if \code{x} is not found} + +\item{expr}{Expression to evaluate. If missing, the last element of \code{...} is used.} } \value{ \code{emm_options} returns the current options (same as the result @@ -35,6 +40,9 @@ on reproducible bugs. When \code{disable} is specified, the other arguments are \code{get_emm_option} returns the currently stored option for \code{x}, or its default value if not found. + +\code{with_emm_options()} temporarily sets the options in \code{...}, then + evaluates \code{expr} and returns the result. } \description{ Use \code{emm_options} to set or change various options that are used in @@ -184,6 +192,12 @@ emm_options(disable = TRUE) emm_options(disable = FALSE) } + +# Illustration of how 'opt.digits' affects the results of print() +# Note that the returned value is printed with the default setting (opt.digits = TRUE) +pigs.lm <- lm(inverse(conc) ~ source, data = pigs) +with_emm_options(opt.digits = FALSE, print(emmeans(pigs.lm, "source"))) + } \seealso{ \code{\link{update.emmGrid}} diff --git a/tests/testthat/test-ref_grid.R b/tests/testthat/test-ref_grid.R index a4c1afb..7aacbda 100644 --- a/tests/testthat/test-ref_grid.R +++ b/tests/testthat/test-ref_grid.R @@ -88,8 +88,7 @@ test_that("Reference grid handles missing values", { expect_equal(length(miss.rg2@levels$x), 2) expect_equal(length(miss.rg1a@levels$x), 3) expect_equal(length(miss.rg2a@levels$x), 3) - emm_options(allow.na.levs = FALSE) - expect_error(ref_grid(miss.lma)) - emm_options(allow.na.levs = NULL) # revert to default + expect_equal(inherits(with_emm_options(allow.na.levs = FALSE, ref_grid(miss.lma)), + "try-error"), TRUE) }) diff --git a/vignettes/models.Rmd b/vignettes/models.Rmd index 166e920..2d7a720 100644 --- a/vignettes/models.Rmd +++ b/vignettes/models.Rmd @@ -251,7 +251,8 @@ adjustment (Barnard & Rubin 1999). In the case of `mira` models with model classes not supported by **emmeans**, [GitHub issue #446](https://github.com/rvlenth/emmeans/issues/446) includes a function `pool_estimates_for_qdrg()` that may be useful for obtaining -results via `qdrg()`. +results via `qdrg()`. Another useful link may be a page that shows [how to pool several `emmeans` +results](https://github.com/adrianolszewski/Useful-R-codes/blob/main/Pooling%20emmeans%20objects.md); that is, instead of pooling the models and then running `emmeans()`, we do just the reverse. Support for `MuMIn::averaging` objects may be somewhat dodgy, as it is not clear that all supported model classes will work. The object *must* have a