tests/testthat/test-likelihood.R

In erossiter/catSurv: Computerized Adaptive Testing for Survey Research

context("likelihood")
load("cat_objects.Rdata")

likelihood_test <- function(cat, theta){
  answered_qs <- which(!is.na(cat@answers), arr.ind = T)
  answers <- cat@answers[answered_qs]
  
  probs <- lapply(answered_qs, function(x) probability(cat, theta, x))
    
  if(cat@model == "ltm" | cat@model == "tpm") {
    prod_these <- sapply(1:length(probs), function(x){
      probs[[x]]^answers[x] * (1 - probs[[x]])^(1 - answers[x])})
    output <- prod(prod_these) 
  }
  
  if(cat@model == "grm"){
    prod_these <- vector("list", length(probs))
    for(i in 1:length(probs)){
      for (k in 2:length(probs[[i]])){
        prod_these[[i]][k - 1] <- probs[[i]][k] - probs[[i]][k - 1]
      }
    }
    for(i in 1:length(prod_these)){
      for(k in 1:length(prod_these[[i]])){
        prod_these[[i]][k] <- (prod_these[[i]][k])^(answers[i] == k)
      }
    }
    output <- prod(sapply(prod_these, prod))
  }
  
  if(cat@model == "gpcm"){
    L <- length(answered_qs)
    for(i in 1:length(answered_qs)){
      q <- answered_qs[i]
      answer <- cat@answers[q]
      probs <- probability(cat, theta, item = q)
      L[i] <- log(probs[answer])
      }
    output <- exp(sum(L))
  }
  
  return(output)
}


test_that("ltm likelihood calculates correctly", {
  ltm_cat@answers[1:5] <- c(0, 1, 0, 0, 1)
  package_lk <- likelihood(ltm_cat, 1)
  test_lk <- likelihood_test(ltm_cat, 1)
  
  expect_equal(package_lk, test_lk)
})

test_that("grm likelihood calculates correctly", {
  grm_cat@answers[1:5] <- c(4, 5, 2, 4, 4)
  package_lk <- likelihood(grm_cat, 1)
  test_lk <- likelihood_test(grm_cat, 1)
  
  expect_equal(package_lk, test_lk)
})

test_that("gpcm likelihood calculates correctly", {
  gpcm_cat@answers[1:5] <- c(4, 5, 2, 4, 4) 
  package_lk <- likelihood(gpcm_cat, 1)
  test_lk <- likelihood_test(gpcm_cat, 1)
  
  expect_equal(package_lk, test_lk)
})

test_that("likelihood calculates to 1 when no questions answered", {
  ltm_cat@answers[1:5] <- rep(NA, 5)
  grm_cat@answers[1:5] <- rep(NA, 5)
  gpcm_cat@answers[1:5] <- rep(NA, 5)
  
  expect_equal(likelihood(ltm_cat, 5), 1)
  expect_equal(likelihood(grm_cat, 5), 1)
  expect_equal(likelihood(gpcm_cat, 5), 1)
})