survey matching intercept names for ord

Author: vincentarelbundock

NEWS.md

@@ -9,6 +9,7 @@ Bugs:
 * Error when merging the original data back into `comparisons()` when the data includes some list columns. The problem is that `data.table` does not support that column type. We now return the original data.table error as a warning, and do not merge the data back. Thanks to @raffaem for report #1638.
 * Improve warning message for hypothesis string order. Thanks to @zakarydraper for report #1640.
 * `comparisons()` with survey-weighted ordinal regressions failed because `stats::na.omit()` discarded every row when auxiliary columns were all `NA`, and the remaining objects fell out of alignment. We now filter using a shared index so hi/lo predictions, weights, and posterior draws stay synchronized.
+* `set_coef.svyolr()` did not recognize thresholds named like `"Intercept: 1|2"`, so delta-method perturbations replaced all cutpoints with `NA` and SEs vanished for `comparisons()`/`avg_*()` on survey ordinal models. Threshold names are now matched with or without the `"Intercept:"` prefix.
 
 ## 0.31.0
 

R/methods_survey.R

@@ -16,7 +16,15 @@ set_coef.svyolr <- function(model, coefs, ...) {
     # in basic model classes coefficients are named vector
     idx <- match(names(model$coefficients), names(coefs))
     model[["coefficients"]] <- coefs[idx]
-    idx <- match(names(model$zeta), names(coefs))
+
+    # thresholds can be named either "1|2" or "Intercept: 1|2"
+    zeta_names <- names(model$zeta)
+    idx <- match(zeta_names, names(coefs))
+    if (anyNA(idx)) {
+        zeta_alt <- paste("Intercept:", zeta_names)
+        idx_alt <- match(zeta_alt, names(coefs))
+        idx <- ifelse(is.na(idx), idx_alt, idx)
+    }
     model[["zeta"]] <- coefs[idx]
     model
 }

R/sanitize_newdata.R

@@ -184,7 +184,7 @@ add_wts_column <- function(wts, newdata, model) {
     flag2 <- isTRUE(checkmate::check_numeric(wts, len = nrow(newdata)))
     if (!flag1 && !flag2) {
         msg <- sprintf(
-            "The `wts` argument must be a numeric vector of length %s, or a string which matches a column name in `newdata`. If you did not supply a `newdata` explicitly, `marginaleffects` extracted it automatically from the model object, and the `wts` variable may not have been available. The easiest strategy is often to supply a data frame such as the original data to `newdata` explicitly, and to make sure that it includes an appropriate column of weights, identified by the `wts` argument.",
+            "The `wts` argument must be a numeric vector of length %s, or a string which matches one of the `colnames()` in the data frame that you supplied to the `newdata`, or in the `marginaleffects` objects.",
             nrow(newdata)
         )
         stop(msg, call. = FALSE)

inst/tinytest/test-pkg-survey.R

@@ -58,3 +58,23 @@ m <- suppressWarnings(svyglm(
 ))
 cmp <- avg_comparisons(m, variables = "education", by = c("ban", "gender"), wts = "weights", hypothesis = ~reference)
 expect_false(anyNA(cmp$estimate))
+
+# svyolr delta-method standard errors
+set.seed(1234)
+n <- 400
+z <- rbinom(n, 1, 0.5)
+x <- factor(sample(c("1", "2", "3"), n, replace = TRUE))
+beta_x <- c("1" = 0, "2" = 0.4, "3" = -0.3)
+beta_z <- 0.6
+eta <- beta_x[x] + beta_z * z + rlogis(n)
+cuts <- c(-1.5, -0.5, 0.5, 1.5)
+y <- cut(eta, breaks = c(-Inf, cuts, Inf), labels = 1:5, ordered_result = TRUE)
+weights <- rlnorm(n, meanlog = log(50000), sdlog = 1)
+design <- svydesign(ids = ~1, weights = ~weights, data = data.frame(y, x, z, weights))
+ord_svy <- svyolr(y ~ x + z, method = "logistic", design = design)
+cmp <- comparisons(ord_svy, wts = "(weights)")
+expect_true(any(!is.na(cmp$std.error)))
+avg_cmp <- avg_comparisons(ord_svy, wts = "(weights)")
+expect_true(any(!is.na(avg_cmp$std.error)))
+avg_pred <- avg_predictions(ord_svy, wts = "(weights)")
+expect_true(any(!is.na(avg_pred$std.error)))