diff --git a/R/llcont.R b/R/llcont.R index d8e496a..61cab63 100644 --- a/R/llcont.R +++ b/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)]) } ################################################################ diff --git a/tests/testthat/test_llcont_polr_indexing.R b/tests/testthat/test_llcont_polr_indexing.R new file mode 100644 index 0000000..2b95d57 --- /dev/null +++ b/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))) + }) +})