Fix subset with glm

DESCRIPTION

@@ -24,6 +24,7 @@ Imports:
     tidyselect,
     vctrs (>= 0.6.5)
 Suggests:
+    broom,
     dplyr,
     ggplot2,
     knitr,

NAMESPACE

@@ -1,10 +1,17 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("!=",psw)
+S3method("<",psw)
+S3method("<=",psw)
+S3method("==",psw)
+S3method(">",psw)
+S3method(">=",psw)
 S3method("[",ps_calib)
 S3method("[",ps_trim)
 S3method("[",ps_trim_matrix)
 S3method("[",ps_trunc)
 S3method("[",ps_trunc_matrix)
+S3method("[",psw)
 S3method(Summary,ps_calib)
 S3method(Summary,ps_trim)
 S3method(Summary,ps_trunc)

NEWS.md

@@ -1,3 +1,16 @@
 # propensity (development version)
 
+* Fixed `broom::tidy(glm_fit, conf.int = TRUE)` failing on GLMs weighted by
+  `psw` vectors. `confint.glm()` builds profile-likelihood intervals via
+  `profile.glm()`, which refits through `glm.fit()`; the refit indexes
+  `weights[good]` with a matrix subscript, which `[.vctrs_vctr` rejected.
+  Added a `[.psw` method that falls back to base R linear indexing for
+  matrix/array subscripts and delegates everything else to `[.vctrs_vctr`.
+
+* Comparison operators on `psw` (`==`, `!=`, `<`, `>`, `<=`, `>=`) now
+  short-circuit `vec_equal()` / `vec_compare()` and return a logical vector
+  silently. Previously each comparison fired a `propensity_class_downgrade`
+  warning via `vec_ptype2.psw.double()`, producing 100+ warnings during a
+  single `tidy(glm, conf.int = TRUE)` call. Combine and cast paths still warn.
+
 * Added a `NEWS.md` file to track changes to the package.

R/psw.R

@@ -35,8 +35,11 @@
 #' metadata matches; mismatched metadata produces a warning and falls back to a
 #' plain numeric vector.
 #'
-#' Subsetting with `[` preserves class and attributes. Summary functions
-#' ([sum()], [mean()], etc.) return plain numeric values.
+#' Subsetting with `[` preserves class and attributes for vector subscripts.
+#' Matrix or array subscripts intentionally drop the `psw` class and return
+#' a plain numeric vector via base R linear indexing; this is required so
+#' `glm.fit()`-style internal indexing works on `psw`-weighted GLMs.
+#' Summary functions ([sum()], [mean()], etc.) return plain numeric values.
 #'
 #' @import vctrs
 #' @export
@@ -227,6 +230,19 @@ is_refit.psw <- function(x) {
   FALSE
 }
 
+#' @export
+`[.psw` <- function(x, i, ...) {
+  # Bare `x[]` must return the whole psw unchanged; reading `i` here would
+  # force the missing argument and error.
+  if (missing(i)) {
+    return(NextMethod())
+  }
+  if (is.matrix(i) || is.array(i)) {
+    return(vec_data(x)[i, ...])
+  }
+  NextMethod()
+}
+
 #' @export
 vec_ptype_abbr.psw <- function(x, ...) {
   estimand <- estimand(x)
@@ -327,6 +343,70 @@ vec_arith.psw.integer <- function(op, x, y, ...) {
   vec_restore(result, x)
 }
 
+#' Comparison operators on `psw` short-circuit `vec_equal()`/`vec_compare()`.
+#'
+#' Without these methods, `==.vctrs_vctr` and friends route through
+#' `vec_equal()` -> `vec_cast_common()` -> `vec_ptype2.psw.double()`, which
+#' fires `warn_class_downgrade()` once per call. `glm.fit()` evaluates
+#' `weights == 0` and `weights > 0` repeatedly inside `profile.glm()`, so a
+#' single `tidy(glm, conf.int = TRUE)` call can emit 100+ identical warnings.
+#' Comparing weights returns a logical vector, so no class is actually being
+#' downgraded from the user's perspective; the warning is spurious here.
+#'
+#' Strict vctrs size semantics are preserved: `vec_recycle_common()` enforces
+#' the same N-or-1 size rule that `vec_equal()` would, so length-mismatched
+#' comparisons error rather than silently recycling per base R rules. Combine
+#' paths (`vec_c()`, `vec_cast()`) still go through the warning-emitting
+#' `vec_ptype2` methods, so the user is still informed when the psw class
+#' really is dropped.
+#' @noRd
+psw_compare <- function(e1, e2) {
+  args <- vec_recycle_common(e1, e2)
+  if (inherits(args[[1]], "psw")) {
+    args[[1]] <- vec_data(args[[1]])
+  }
+  if (inherits(args[[2]], "psw")) {
+    args[[2]] <- vec_data(args[[2]])
+  }
+  list(e1 = args[[1]], e2 = args[[2]])
+}
+
+#' @export
+`==.psw` <- function(e1, e2) {
+  args <- psw_compare(e1, e2)
+  args$e1 == args$e2
+}
+
+#' @export
+`!=.psw` <- function(e1, e2) {
+  args <- psw_compare(e1, e2)
+  args$e1 != args$e2
+}
+
+#' @export
+`<.psw` <- function(e1, e2) {
+  args <- psw_compare(e1, e2)
+  args$e1 < args$e2
+}
+
+#' @export
+`>.psw` <- function(e1, e2) {
+  args <- psw_compare(e1, e2)
+  args$e1 > args$e2
+}
+
+#' @export
+`<=.psw` <- function(e1, e2) {
+  args <- psw_compare(e1, e2)
+  args$e1 <= args$e2
+}
+
+#' @export
+`>=.psw` <- function(e1, e2) {
+  args <- psw_compare(e1, e2)
+  args$e1 >= args$e2
+}
+
 #' @export
 vec_math.psw <- function(.fn, .x, ...) {
   # Some functions like cumsum/cumprod should preserve psw class

tests/testthat/_snaps/coercion-warnings.md

@@ -217,26 +217,6 @@
       i Metadata cannot be preserved when combining incompatible objects
       i Use identical objects or explicitly cast to numeric to avoid this warning
 
-# comparison operations warn about class downgrade
-
-    Code
-      expr
-    Condition <propensity_class_downgrade_warning>
-      Warning in `vec_ptype2.psw.double()`:
-      Converting psw to numeric
-      i Class-specific attributes and metadata have been dropped
-      i Use explicit casting to numeric to avoid this warning
-
----
-
-    Code
-      expr
-    Condition <propensity_class_downgrade_warning>
-      Warning in `vec_ptype2.psw.double()`:
-      Converting psw to numeric
-      i Class-specific attributes and metadata have been dropped
-      i Use explicit casting to numeric to avoid this warning
-
 # c() ordering matters for warnings
 
     Code

tests/testthat/test-bracket-psw.R

@@ -0,0 +1,141 @@
+test_that("[.psw preserves class and metadata for vector subscripts", {
+  w <- psw(c(1, 2, 3, 4, 5), estimand = "ate")
+
+  out <- w[c(1, 3, 5)]
+  expect_s3_class(out, "psw")
+  expect_equal(estimand(out), "ate")
+  expect_equal(vec_data(out), c(1, 3, 5))
+
+  out <- w[c(TRUE, FALSE, TRUE, FALSE, TRUE)]
+  expect_s3_class(out, "psw")
+  expect_equal(vec_data(out), c(1, 3, 5))
+
+  out <- w[-1]
+  expect_s3_class(out, "psw")
+  expect_equal(vec_data(out), c(2, 3, 4, 5))
+
+  out <- w[c(1, NA, 3)]
+  expect_s3_class(out, "psw")
+  expect_equal(vec_data(out), c(1, NA, 3))
+
+  out <- w[integer()]
+  expect_s3_class(out, "psw")
+  expect_length(out, 0)
+})
+
+test_that("[.psw with matrix subscript falls back to base linear indexing", {
+  w <- psw(c(1, 2, 3, 4, 5), estimand = "ate")
+
+  # A 2x2 logical matrix is unrolled column-major to c(T, F, T, F) and then
+  # recycled to length(w) = 5, giving c(T, F, T, F, T). Base R selects
+  # positions 1, 3, 5. The psw class is intentionally dropped since matrix
+  # subscripts have no meaningful vctrs semantics.
+  m <- matrix(c(TRUE, FALSE, TRUE, FALSE), nrow = 2)
+  out <- w[m]
+
+  expect_false(inherits(out, "psw"))
+  expect_type(out, "double")
+  expect_equal(out, c(1, 3, 5))
+})
+
+test_that("[.psw with no subscript returns the full psw unchanged", {
+  w <- psw(c(1, 2, 3), estimand = "ate")
+  out <- w[]
+  expect_s3_class(out, "psw")
+  expect_equal(estimand(out), "ate")
+  expect_equal(vec_data(out), c(1, 2, 3))
+})
+
+test_that("psw comparison operators dispatch on either side and return logicals silently", {
+  w <- psw(c(1, 2, 3), estimand = "ate")
+
+  # All six ops, psw on the LHS.
+  expect_no_warning(
+    {
+      expect_equal(w == 2, c(FALSE, TRUE, FALSE))
+      expect_equal(w != 2, c(TRUE, FALSE, TRUE))
+      expect_equal(w < 2, c(TRUE, FALSE, FALSE))
+      expect_equal(w > 2, c(FALSE, FALSE, TRUE))
+      expect_equal(w <= 2, c(TRUE, TRUE, FALSE))
+      expect_equal(w >= 2, c(FALSE, TRUE, TRUE))
+    },
+    class = "propensity_class_downgrade_warning"
+  )
+
+  # psw on the RHS still dispatches to the psw method (S3 group dispatch picks
+  # up the method from either operand). Behavior should mirror LHS.
+  expect_no_warning(
+    {
+      expect_equal(2 == w, c(FALSE, TRUE, FALSE))
+      expect_equal(2 != w, c(TRUE, FALSE, TRUE))
+      expect_equal(2 > w, c(TRUE, FALSE, FALSE))
+      expect_equal(2 < w, c(FALSE, FALSE, TRUE))
+      expect_equal(2 >= w, c(TRUE, TRUE, FALSE))
+      expect_equal(2 <= w, c(FALSE, TRUE, TRUE))
+    },
+    class = "propensity_class_downgrade_warning"
+  )
+
+  # psw vs psw: data-only comparison, no metadata check needed.
+  w2 <- psw(c(1, 1, 3), estimand = "att")
+  expect_no_warning(
+    {
+      expect_equal(w == w2, c(TRUE, FALSE, TRUE))
+      expect_equal(w > w2, c(FALSE, TRUE, FALSE))
+    },
+    class = "propensity_class_downgrade_warning"
+  )
+})
+
+test_that("psw comparisons enforce vctrs strict size semantics", {
+  # vec_equal()/vec_compare() error on size-mismatched inputs (anything other
+  # than equal length, or one side of length 1). The bypass through
+  # psw_compare() must preserve that contract via vec_recycle_common(), not
+  # silently fall back to base R recycling.
+  a <- psw(c(1, 2, 3, 4), estimand = "ate")
+  b <- psw(c(1, 2), estimand = "ate")
+
+  expect_error(a == b, class = "vctrs_error_incompatible_size")
+  expect_error(a > b, class = "vctrs_error_incompatible_size")
+  expect_error(a != b, class = "vctrs_error_incompatible_size")
+
+  # Scalar broadcasting (size-1 RHS) still works and remains silent — this is
+  # the path glm.fit() exercises with `weights == 0` / `weights > 0`.
+  expect_no_warning(
+    {
+      expect_equal(a == 2, c(FALSE, TRUE, FALSE, FALSE))
+      expect_equal(a > 2, c(FALSE, FALSE, TRUE, TRUE))
+    },
+    class = "propensity_class_downgrade_warning"
+  )
+})
+
+test_that("tidy(glm, conf.int = TRUE) works on glms weighted by psw vectors", {
+  skip_if_not_installed("broom")
+
+  set.seed(1)
+  n <- 200
+  d <- data.frame(
+    y = rbinom(n, 1, 0.4),
+    x = rbinom(n, 1, 0.5),
+    z = rnorm(n)
+  )
+  ps <- glm(x ~ z, data = d, family = binomial())
+  d$ps <- predict(ps, type = "response")
+  d$w <- wt_att(d$ps, d$x)
+
+  m <- glm(y ~ x, data = d, weights = w, family = quasibinomial())
+
+  # The bug originally errored with `Subscript `i` must be a simple vector,
+  # not a matrix.` Once the [.psw matrix-subscript fix is in place,
+  # profile.glm() runs to completion. It also evaluates `weights == 0` and
+  # `weights > 0` many times, which used to trigger
+  # `propensity_class_downgrade_warning` from vec_ptype2.psw.double on every
+  # comparison; the comparison-operator methods on psw silence that path.
+  expect_no_warning(
+    tidied <- broom::tidy(m, exponentiate = TRUE, conf.int = TRUE),
+    class = "propensity_class_downgrade_warning"
+  )
+  expect_true(all(c("conf.low", "conf.high") %in% names(tidied)))
+  expect_equal(nrow(tidied), 2)
+})

tests/testthat/test-coercion-warnings.R

@@ -313,16 +313,25 @@ test_that("arithmetic operations with different metadata work correctly", {
   expect_equal(as.numeric(result2), c(0.15, 0.56))
 })
 
-test_that("comparison operations warn about class downgrade", {
+test_that("comparison operations on psw return logicals without warning", {
+  # Comparisons short-circuit vec_equal/vec_compare via the dedicated
+  # `==.psw` / `>.psw` / etc. methods, so the user does not see the
+  # `propensity_class_downgrade_warning` that vec_ptype2.psw.double would
+  # otherwise fire. Nothing is being downgraded from the user's perspective:
+  # the result is a logical vector. This also prevents a warning cascade
+  # inside glm.fit() / profile.glm() comparisons during
+  # `tidy(glm, conf.int = TRUE)` on psw-weighted GLMs.
   x <- psw(c(0.5, 0.7), estimand = "ate")
 
-  expect_propensity_warning(
-    result <- x > 0.6
+  expect_no_warning(
+    result <- x > 0.6,
+    class = "propensity_class_downgrade_warning"
   )
   expect_equal(result, c(FALSE, TRUE))
 
-  expect_propensity_warning(
-    result2 <- x == 0.5
+  expect_no_warning(
+    result2 <- x == 0.5,
+    class = "propensity_class_downgrade_warning"
   )
   expect_equal(result2, c(TRUE, FALSE))
 })