tests/testthat/test-estfun.R

In PlackettLuce: Plackett-Luce Models for Rankings

## The artificial example in ?PlackettLuce
R <- matrix(c(1, 2, 0, 0,
              4, 1, 2, 3,
              2, 1, 1, 1,
              1, 2, 3, 0,
              2, 1, 1, 0,
              1, 0, 3, 2), nrow = 6, byrow = TRUE)
colnames(R) <- c("apple", "banana", "orange", "pear")

tol <- 1e-7

test_that("estfun matches agRank, fixed adherence [fake triple comparisons]", {
    m <- ncol(R)
    n <- nrow(R)
    adherence <- seq(0.75, 1.25, length.out = n)
    alpha <- seq(0.25, 0.75, length.out = m)
    delta <- seq(0.5, 1.5, length.out = 2)
    # Fit model using PlackettLuce
    mod_PL <- PlackettLuce(rankings = R, npseudo = 0,
                           adherence = adherence, start = c(alpha, delta))
    # sum over all sets st object i is in selected set adherence/size
    A <- c(sum(adherence[c(1, 4, 6)]),
           sum(adherence[c(2, 3, 4, 5)]*c(1, 1/3, 1, 1/2)),
           sum(adherence[c(2, 3, 5)]*c(1, 1/3, 1/2)),
           sum(adherence[c(2, 3, 6)]*c(1, 1/3, 1)))
    # number of sets with cardinality d
    B <- c(8, 1, 1)
    # expectations
    R2 <- matrix(c(2, 1, 3, 4,
                   1, 4, 3, 2,
                   1, 2, 3, 4,
                   3, 2, 1, 4,
                   1, 2, 3, 4,
                   3, 4, 1, 2), nrow = 6, byrow = TRUE)
    G <- list(NULL, c(1, 2, 4, 6), c(2, 4, 5, 6), c(2, 3))
    W <- list(NULL, c(1, 1, 1, 1), c(1, 1, 1, 1), c(1, 1))
    par <- mod_PL$coefficients
    fit <- expectation(c("alpha", "delta"), par[1:m], c(1.0, par[-(1:m)]),
                       adherence, m, 1:3, 2:4, R2, G, W)
    # score wrt log-parameters
    score <- score_common(par = par, N = m,
                          mu = NULL, Kinv = NULL, A = A, B = B, fit = fit)*par
    # score = c(A - fit$expA, B[-1] - fit$expB*par[-(1:m)])
    expect_equal(colSums(estfun(mod_PL, ref = NULL)), score)
    # model with weights
    w <- c(2, 7, 3, 4, 10, 5)
    mod_PL <- PlackettLuce(rankings = R, npseudo = 0, weights = w,
                           adherence = adherence, start = c(alpha, delta))
    A <- c(sum(w[c(1, 4, 6)] * adherence[c(1, 4, 6)]),
           sum(w[c(2, 3, 4, 5)] * adherence[c(2, 3, 4, 5)]*c(1, 1/3, 1, 1/2)),
           sum(w[c(2, 3, 5)] * adherence[c(2, 3, 5)]*c(1, 1/3, 1/2)),
           sum(w[c(2, 3, 6)] * adherence[c(2, 3, 6)]*c(1, 1/3, 1)))
    B <- c(sum(w[c(1, 2, 2, 2, 4, 4, 6, 6)]), w[5], w[3])
    W <- list(NULL, w[G[[2]]], w[G[[3]]], w[G[[4]]])
    par <- mod_PL$coefficients
    fit <- expectation(c("alpha", "delta"), par[1:m], c(1.0, par[-(1:m)]),
                       adherence, m, 1:3, 2:4, R2, G, W)
    score <- score_common(par = par, N = m,
                          mu = NULL, Kinv = NULL, A = A, B = B, fit = fit)*par

    expect_equal(colSums(estfun(mod_PL, ref = NULL)), score,
                 tolerance = tol)
})