Bugfixes #508, #509, #510

DESCRIPTION

@@ -1,10 +1,11 @@
 Package: emmeans
 Type: Package
 Title: Estimated Marginal Means, aka Least-Squares Means
-Version: 1.10.4.900001
-Date: 2024-08-30
+Version: 1.10.4.900003
+Date: 2024-10-02
 Authors@R: c(person("Russell V.", "Lenth", role = c("aut", "cre", "cph"), 
     email = "russell-lenth@uiowa.edu"),
+    person("Balazs", "Banfai", role = "ctb"),
     person("Ben", "Bolker", role = "ctb"),
     person("Paul", "Buerkner", role = "ctb"),
     person("Iago", "Giné-Vázquez", role = "ctb"),

NAMESPACE

@@ -228,6 +228,7 @@ export(trt.vs.ctrl.emmc)
 export(trt.vs.ctrl1.emmc)
 export(trt.vs.ctrlk.emmc)
 export(tukey.emmc)
+export(with_emm_options)
 export(wtcon.emmc)
 exportClasses(emmGrid)
 import(estimability)

NEWS.md

@@ -4,7 +4,8 @@ title: "NEWS for the emmeans package"
 
 ## emmeans 1.10.4.90xxxx
   * Fix for long-standing `weights` bug in `lme()` (#356)
-  * Fix for inconsistent contrasts in case of missing levels (#508)
+  * Fix for inconsistent contrasts in case of missing levels (#508, #509)
+  * Fix for using nuisance variables with proportional weights (#510)
 
 
 ## emmeans 1.10.4

R/ref-grid.R

@@ -1103,11 +1103,11 @@ ref_grid <- function(object, at, cov.reduce = mean, cov.keep = get_emm_option("c
 # bottom part, and substitute those averages in the required columns in the top part 
 # of the model matrix.
 .basis.nuis = function(basis, info, wt, levs, data, grid, ref.levels) {
-  X = basis$X
-  if(!is.null(basis$misc$regrid.flag) || all(apply(X, 1, \(x) sum(x != 0)) == 1))   # each row has 1 nonzero element
-      stop("Sorry, 'nuisance' specs are not allowed for this situation.",
-           " Revise the call accordingly.", call. = FALSE)
-  ra = info$row.assign
+    X = basis$X
+    if(!is.null(basis$misc$regrid.flag) || all(apply(X, 1, \(x) sum(x != 0)) == 1))   # each row has 1 nonzero element
+        stop("Sorry, 'nuisance' specs are not allowed for this situation.",
+             " Revise the call accordingly.", call. = FALSE)
+    ra = info$row.assign
     r. = rep(".", length(ra))  # fillers
     n = sum(ra == ".main.grid.")
     k = nrow(X) / length(ra)   # multivariate dimension
@@ -1139,9 +1139,9 @@ ref_grid <- function(object, at, cov.reduce = mean, cov.keep = get_emm_option("c
     basis$misc$avgd.over = paste(length(nuis), "nuisance factors")
     RA = rep(ra, k)
     basis$X = X[RA == ".main.grid.", , drop = FALSE]
-    basis$grid = grid[ra == ".main.grid.", , drop = FALSE]
     non.nuis = setdiff(names(ref.levels), info$nuis)
     basis$ref.levels = ref.levels[non.nuis]
+    basis$grid = grid[ra == ".main.grid.", non.nuis, drop = FALSE]
     basis
 }
 

tests/testthat/test-ref_grid.R

@@ -78,7 +78,18 @@ miss.df = data.frame(x = factor(c("a", "a", "b", NA), levels = c("a", "b", "c",
 miss.lm = lm(y ~ x, data = miss.df)
 miss.rg1 = ref_grid(miss.lm)
 miss.rg2 = ref_grid(miss.lm, data = miss.df)
+# Now try allowing NA levels
+miss.dfa = transform(miss.df, x = factor(x, exclude = NULL))
+miss.lma = lm(y ~ x, data = miss.dfa)
+miss.rg1a = ref_grid(miss.lma)
+miss.rg2a = ref_grid(miss.lma, data = miss.dfa)
 test_that("Reference grid handles missing values", {
     expect_equal(length(miss.rg1@levels$x), 2)
     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
 })
+