tests/testthat/test-predict-PLADMM.R

In PlackettLuce: Plackett-Luce Models for Rankings

coef_tol <- 1e-4

if (requireNamespace("prefmod", quietly = TRUE)) {
    test_that("PLADMM predict works for standard PL [salad]", {
        ## setting rho ~ 10% log-lik gives good results (not extensively tested!)
        ## reduce rtol a little so vcov more accurate
        res0_PLADMM <- pladmm(salad_rankings, ~ salad, data = features, rho = 8,
                              rtol = 1e-5)
        ## linear predictor, no new data
        expect_equal(predict(res0_PLADMM),
                     log(res0_PLADMM[["tilde_pi"]]),
                     tolerance = coef_tol)
        ## same returned by fitted
        expect_equal(predict(res0_PLADMM),
                     fitted(res0_PLADMM),
                     tolerance = coef_tol)
        ## linear predictor, new data
        expect_equal(unname(predict(res0_PLADMM, newdata = features[1:2,])),
                     unname(predict(res0_PLADMM)[1:2]),
                     tolerance = coef_tol)
        ## itempar, no new data
        expect_equal(predict(res0_PLADMM, type = "itempar"),
                     c(itempar(res0_PLADMM)),
                     tolerance = coef_tol)
        ## itempar, new data
        worth <- itempar(res0_PLADMM)[1:2]
        expect_equal(unname(predict(res0_PLADMM, type = "itempar",
                                    newdata = features[1:2,])),
                     unname(worth/sum(worth)),
                     tolerance = coef_tol)
    })

    if (requireNamespace("BradleyTerry2", quietly = TRUE)) {
        test_that("PLADMM predict works for PL with covariates [salad pairs]", {
            ## setting rho ~ 10% log-lik gives good results (not extensively tested!)
            res_PLADMM <- pladmm(salad_pairs, ~ acetic + gluconic,
                                 data = features, rho = 2)
            winner <- apply(salad_pairs == 1, 1, which)
            loser <- apply(salad_pairs == 2, 1, which)
            lev <- colnames(salad_pairs)
            contests <- data.frame(winner = factor(lev[winner], levels = lev),
                                   loser = factor(lev[loser]), levels = lev)
            ## warns that no random effect in predictor
            res_BTm <- suppressWarnings(BTm(outcome = rep(1, nrow(salad_pairs)),
                                            winner, loser,
                                            ~ acetic[..] + gluconic[..],
                                            data = list(contests = contests,
                                                        predictors = features)))
            # expect log-worth the same up to constant
            ability <- c(BTabilities(res_BTm)[, "ability"])
            expect_equal(predict(res_PLADMM) - coef(res_PLADMM)[1],
                         ability,
                         tolerance = coef_tol)
            # expect s.e. of log-worth to be the same
            se <- c(BTabilities(res_BTm)[, "s.e."])
            expect_equal(predict(res_PLADMM, se.fit = TRUE)$se.fit,
                         se,
                         tolerance = coef_tol)
            # expect predicted item worth correct for new data
            pred1 <- predict(res_PLADMM, type = "itempar", ref = 2:3,
                             se.fit = TRUE)
            pred2 <- predict(res_PLADMM, type = "itempar",
                             newdata = features[2:3,],
                             se.fit = TRUE)
            expect_equal(unname(pred1$fit[2:3]),
                         unname(pred2$fit),
                         tolerance = coef_tol)
            expect_equal(unname(pred1$se.fit[2:3]),
                         unname(pred2$se.fit),
                         tolerance = coef_tol)
        })

        test_that("PLADMM predict works for PL with other contrasts [salad pairs]", {
            ## setting rho ~ 10% log-lik gives good results (not extensively tested!)
            res_PLADMM <- pladmm(salad_pairs, ~ salad, data = features,
                                 rho = 1, contrasts = list(salad = "contr.sum"),
                                 rtol = 1e-5)
            winner <- apply(salad_pairs == 1, 1, which)
            loser <- apply(salad_pairs == 2, 1, which)
            lev <- colnames(salad_pairs)
            contests <- data.frame(winner = factor(lev[winner], levels = lev),
                                   loser = factor(lev[loser]), levels = lev)
            ## warns that no random effect in predictor
            res_BTm <- BTm(outcome = rep(1, nrow(salad_pairs)),
                           winner, loser,
                           ~ salad, id = "salad", x = FALSE,
                           contrasts = list(salad = "contr.sum"),
                           data = list(contests = contests,
                                       predictors = features))
            # expect log-worth the same up to constant
            ability <- c(BTabilities(res_BTm)[, "ability"])
            expect_equal(predict(res_PLADMM) - coef(res_PLADMM)[1],
                         ability,
                         tolerance = coef_tol)
            # expect s.e. of log-worth to be the same
            se <- c(BTabilities(res_BTm)[, "s.e."])
            expect_equal(predict(res_PLADMM, se.fit = TRUE)$se.fit,
                         se,
                         tolerance = coef_tol)
            # expect predicted item worth correct for new data
            pred1 <- predict(res_PLADMM, type = "itempar", ref = 2:3,
                             se.fit = TRUE)
            pred2 <- predict(res_PLADMM, type = "itempar",
                             newdata = features[2:3,],
                             se.fit = TRUE)
            expect_equal(unname(pred1$fit[2:3]),
                         unname(pred2$fit),
                         tolerance = coef_tol)
            expect_equal(unname(pred1$se.fit[2:3]),
                         unname(pred2$se.fit),
                         tolerance = coef_tol)
        })
    }
}