diff --git a/DESCRIPTION b/DESCRIPTION index ddacd41..dcd130e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: emmeans Type: Package Title: Estimated Marginal Means, aka Least-Squares Means -Version: 1.10.6-090003 -Date: 2025-01-16 +Version: 1.10.7 +Date: 2025-01-30 Authors@R: c(person("Russell V.", "Lenth", role = c("aut", "cre", "cph"), email = "russell-lenth@uiowa.edu"), person("Balazs", "Banfai", role = "ctb"), diff --git a/NAMESPACE b/NAMESPACE index 61ea510..e778454 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -241,6 +241,7 @@ importFrom(methods,"slot<-") importFrom(methods,as) importFrom(methods,is) importFrom(methods,new) +importFrom(methods,show) importFrom(methods,slot) importFrom(methods,slotNames) importFrom(stats,coef) diff --git a/NEWS.md b/NEWS.md index ace59d9..5429aa1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,7 +2,7 @@ title: "NEWS for the emmeans package" --- -## emmeans 1.10-6-090xxx +## emmeans 1.10-7 * Spelling changes in several vignettes * We have completely revamped the design of reference grids involving counterfactuals. Now, if we specify counterfactuals `A` and `B`, the @@ -17,6 +17,9 @@ title: "NEWS for the emmeans package" * Tweaks to `regrid()` to create `@post.beta` slot correctly when there are non-estimable cases. * Bug fix for scoping in `subset.emmGrid()` (#518) + * Changed `print.emmGrid()` so that it calls `show()` unless `export = TRUE`. + This change was made because I noticed that **pkgdown** uses `print()` rather + than `show()` to display example results. ## emmeans 1.10.6 diff --git a/R/emmGrid-methods.R b/R/emmGrid-methods.R index 082437c..1a42c13 100644 --- a/R/emmGrid-methods.R +++ b/R/emmGrid-methods.R @@ -118,9 +118,16 @@ str.emmGrid <- function(object, ...) { #' @method print emmGrid #' @param x An \code{emmGrid} object #' @export -print.emmGrid = function(x, ..., export = FALSE) - print(summary.emmGrid(x, ...), export = export) +print.emmGrid = function(x, ..., export = FALSE) { + if(export) + print(summary.emmGrid(x, ...), export = export) + else + show(x) +} +### Former print method which I changed to work around a bug in pkgdown +# print.emmGrid = function(x, ..., export = FALSE) +# print(summary.emmGrid(x, ...), export = export) # vcov method #' Miscellaneous methods for \code{emmGrid} objects diff --git a/R/emmeans-package.R b/R/emmeans-package.R index a6f9df2..73289b6 100644 --- a/R/emmeans-package.R +++ b/R/emmeans-package.R @@ -1,5 +1,5 @@ ############################################################################## -# Copyright (c) 2012-2024 Russell V. Lenth # +# Copyright (c) 2012-2025 Russell V. Lenth # # # # This file is part of the emmeans package for R (*emmeans*) # # # @@ -117,7 +117,7 @@ #' @import mvtnorm #' @import stats #' @importFrom graphics pairs plot -#' @importFrom methods as is new slot slot<- slotNames +#' @importFrom methods as is new show slot slot<- slotNames #' @importFrom utils getS3method hasName installed.packages methods str #' @name emmeans-package NULL diff --git a/R/emmeans.R b/R/emmeans.R index afaa2e7..e91dfad 100644 --- a/R/emmeans.R +++ b/R/emmeans.R @@ -486,9 +486,11 @@ emmeans = function(object, specs, by = NULL, RG@misc$avgd.over = union(RG@misc$avgd.over, avgd.over) RG@misc$methDesc = "emmeans" RG@roles$predictors = setdiff(names(levs), RG@roles$multresp) - if ((length(RG@roles$multresp) > 0) && !(RG@roles$multresp %in% names(levs))) - RG@roles$multresp = character(0) - + # if ((length(RG@roles$multresp) > 0) && !(RG@roles$multresp %in% names(levs))) + # RG@roles$multresp = character(0) + # REPLACED BY: + RG@roles$multresp = intersect(RG@roles$multresp, names(levs)) + result = as.emmGrid(RG) result@linfct = linfct result@levels = levs diff --git a/R/ref-grid.R b/R/ref-grid.R index 2477c68..9033634 100644 --- a/R/ref-grid.R +++ b/R/ref-grid.R @@ -678,7 +678,6 @@ ref_grid <- function(object, at, cov.reduce = mean, cov.keep = get_emm_option("c " Non-conformable elements in reference grid.", call. = TRUE) - collapse = NULL if(!no.nuis) { basis = .basis.nuis(basis, nuis.info, wt.nuis, ref.levels, data, grid, ref.levels) grid = basis$grid @@ -957,10 +956,7 @@ ref_grid <- function(object, at, cov.reduce = mean, cov.keep = get_emm_option("c } if(!missing(regrid)) { # if(missing(wt.counter)) wt.counter = 1 - result = regrid(result, transform = regrid, sigma = sigma, - .collapse = collapse, wt.counter = wt.counter, ...) - if(!is.null(collapse)) - result@misc$avgd.over = collapse + result = regrid(result, transform = regrid, sigma = sigma, ...) } .save.ref_grid(result) @@ -1143,11 +1139,20 @@ ref_grid <- function(object, at, cov.reduce = mean, cov.keep = get_emm_option("c .cf.refgrid = function(object, counterfactuals, data, options = list(), ...) { if(missing(data)) data = recover_data(object, ...) + if(!hasName(data, "(weights)")) + pwts = rep(1, nrow(data)) + else + pwts = data[["(weights)"]] + # Start with just the ordinary reference grid rg = ref_grid(object, data = data, ...) cfac = intersect(counterfactuals, names(rg@levels)) clevs = rg@levels[cfac] cgrid = do.call(expand.grid, clevs) + # handle nasty fact that character predictors don't act like factors + for (j in cfac) + if(is.character(data[[cfac]])) + cgrid[[cfac]] = as.character(cgrid[[cfac]]) # Get the stuff we need for each main dataset step link = .get.link(rg@misc) @@ -1167,36 +1172,45 @@ ref_grid <- function(object, at, cov.reduce = mean, cov.keep = get_emm_option("c flag = flag & data[[cfac[col]]] == x[col] which(flag) }, simplify = FALSE) + + # special case for covariates with no matches + if(all(sapply(cidx, length) == 0)) + cidx = list(seq_len(nrow(data))) + # account for any NAs in bhat nonNA = !is.na(rg@bhat) # ensure we include all levels of cfacs with data all.active = sort(unlist(cidx)) deadrows = sapply(cidx, function(x) x[1]) offset = c(offset, rep(mean(offset), length(deadrows))) + pwts = c(pwts, rep(mean(pwts), length(deadrows))) data = rbind(data, data[deadrows, ]) n = nrow(data) mymean = function(x) ifelse(is.null(x), NA, mean(x)) + # get means of groups of prior weights + mpwt = sapply(cidx, \(i) mean(pwts[i])) + ## Compile the averaged results for delta method DL = matrix(nrow = 0, ncol = sum(nonNA)) bh = numeric(0) for (i in seq_len(nrow(cgrid))) { g = data for(j in cfac) - g[all.active, j] = cgrid[i, j] + g[all.active, j] = cgrid[i,j] bas = emm_basis(object, trms, xlev, g, ...) if(!is.null(bas$misc$postGridHook)) stop("Sorry, we do not support counterfactuals for this situation.") X = bas$X[, nonNA, drop = FALSE] eta = X %*% bas$bhat[nonNA] yhat = link$linkinv(eta + offset) - d = link$mu.eta(eta) + d = link$mu.eta(eta) * rep(pwts, k) # includes prior weights X = sweep(X, 1, d, "*") pos = 0 XX = matrix(nrow = 0, ncol = ncol(X)) for(I in 1:k) { - XX = sapply(cidx, \(i) apply(X[pos + i, , drop = FALSE], 2, mymean)) + XX = sapply(cidx, \(i) apply(X[pos + i, , drop = FALSE], 2, mymean)) / mpwt DL = rbind(DL, t(XX)) yy = sapply(cidx, \(i) ifelse(length(i) == 0, NA, mean(yhat[i + pos]))) bh = c(bh, yy) @@ -1216,7 +1230,7 @@ ref_grid <- function(object, at, cov.reduce = mean, cov.keep = get_emm_option("c if (k > 1) levs = c(levs, rg@levels[length(rg@levels)]) RG@levels = levs - wts = sapply(cidx, length) + wts = sapply(cidx, length) * mpwt RG@grid = do.call("expand.grid", levs) RG@grid$.wgt. = rep(wts, length(bh)/length(wts)) misc = rg@misc