fix(polr): index fitted probabilities by model row position

R/llcont.R

@@ -363,12 +363,8 @@ llcont.nls <- function (x, ...) {
 llcont.polr <- function(x, ...) {
   m <- x$model
   y <- unclass(model.response(m))
-  wherey <- matrix(c(as.numeric(names(y)), y), ncol=2)
-  idx <- matrix(0, nrow=length(y), ncol=length(x$lev))
-  idx[wherey] <- 1
-
-  ## Bolt: replaced apply(..., 1, sum) with optimized rowSums() for performance
-  model.weights(m) * log(rowSums(idx * x$fitted.values))
+  ## Index fitted probabilities by model row position; row names are labels, not positional authority.
+  model.weights(m) * log(x$fitted.values[cbind(seq_along(y), y)])
 }
 
 ################################################################

tests/testthat/test_llcont_polr_indexing.R

@@ -0,0 +1,17 @@
+test_that("polr llcont indexes fitted rows independently of model row names", {
+  with_test_packages("MASS", {
+    named_housing <- housing
+    rownames(named_housing) <- sprintf("case-%03d", seq_len(nrow(named_housing)))
+
+    fit <- polr(
+      Sat ~ Infl + Type + Cont,
+      weights = Freq,
+      data = named_housing
+    )
+
+    contributions <- llcont(fit)
+
+    expect_length(contributions, nrow(fit$model))
+    expect_equal(sum(contributions), as.numeric(logLik(fit)))
+  })
+})