tests/testthat/test-qscore.R

In qcluster: Clustering via Quadratic Scoring

test_that("qscore accepts covariance matrices with determinant equal to one", {
  dat <- matrix(
    c(
      0, 0,
      1, 1
    ),
    ncol = 2,
    byrow = TRUE
  )

  params <- list(
    proportion = 1,
    mean = matrix(c(0.5, 0.5), ncol = 1),
    cov = array(diag(2), dim = c(2, 2, 1))
  )

  score <- qscore(dat, params, type = "both")

  expect_true(all(is.finite(score)))
  expect_equal(unname(score), c(-0.25, -0.25), tolerance = 1e-12)
})

test_that("qscore matches direct evaluation of the paper formulas", {
  dat <- matrix(
    c(
      -1.0, 0.1,
      -0.2, 0.0,
      0.9, 0.3
    ),
    ncol = 2,
    byrow = TRUE
  )

  params <- list(
    proportion = c(0.4, 0.6),
    mean = matrix(
      c(
        -0.5, 0.0,
         0.7, 0.2
      ),
      nrow = 2
    ),
    cov = array(
      c(
        1.2, 0.1,
        0.1, 0.8,
        0.9, -0.2,
        -0.2, 1.1
      ),
      dim = c(2, 2, 2)
    )
  )

  q_mat <- matrix(NA_real_, nrow = nrow(dat), ncol = length(params$proportion))
  for (k in seq_along(params$proportion)) {
    delta <- dat - matrix(params$mean[, k], nrow(dat), ncol(dat), byrow = TRUE)
    inv_cov <- solve(params$cov[, , k])
    smd <- rowSums((delta %*% inv_cov) * delta)
    q_mat[, k] <- log(params$proportion[k]) - 0.5 * log(det(params$cov[, , k])) - 0.5 * smd
  }

  tau <- exp(q_mat)
  tau <- tau / rowSums(tau)

  expected_smooth <- mean(rowSums(tau * q_mat))
  expected_hard <- mean(apply(q_mat, 1, max))

  score <- qscore(dat, params, type = "both")

  expect_equal(unname(score[["hard"]]), expected_hard, tolerance = 1e-12)
  expect_equal(unname(score[["smooth"]]), expected_smooth, tolerance = 1e-12)
})

test_that("qscore hard scoring returns NaN for singular covariances", {
  dat <- matrix(
    c(
      0, 0,
      1, 1
    ),
    ncol = 2,
    byrow = TRUE
  )

  params <- list(
    proportion = 1,
    mean = matrix(c(0.5, 0.5), ncol = 1),
    cov = array(c(1, 0, 0, 0), dim = c(2, 2, 1))
  )

  warning_seen <- FALSE
  score <- withCallingHandlers(
    qscore(dat, params, type = "hard"),
    warning = function(w) {
      warning_seen <<- TRUE
      invokeRestart("muffleWarning")
    }
  )

  expect_true(warning_seen)
  expect_true(is.nan(score[["hard"]]))
  expect_true(is.na(score[["smooth"]]))
})

test_that("qscore returns NA for the score component that was not requested", {
  dat <- matrix(
    c(
      0, 0,
      1, 1
    ),
    ncol = 2,
    byrow = TRUE
  )

  params <- list(
    proportion = 1,
    mean = matrix(c(0.5, 0.5), ncol = 1),
    cov = array(diag(2), dim = c(2, 2, 1))
  )

  hard <- qscore(dat, params, type = "hard")
  smooth <- qscore(dat, params, type = "smooth")

  expect_true(is.finite(hard[["hard"]]))
  expect_true(is.na(hard[["smooth"]]))
  expect_true(is.na(smooth[["hard"]]))
  expect_true(is.finite(smooth[["smooth"]]))
})

test_that("qscore rejects invalid score types", {
  dat <- matrix(
    c(
      0, 0,
      1, 1
    ),
    ncol = 2,
    byrow = TRUE
  )

  params <- list(
    proportion = 1,
    mean = matrix(c(0.5, 0.5), ncol = 1),
    cov = array(diag(2), dim = c(2, 2, 1))
  )

  expect_error(
    qscore(dat, params, type = "oops"),
    "qscore: 'type' must be in"
  )
})

test_that("qscore rejects non-numeric mean and covariance inputs before entering C", {
  dat <- matrix(
    c(
      0, 0,
      1, 1
    ),
    ncol = 2,
    byrow = TRUE
  )

  bad_mean <- list(
    proportion = 1,
    mean = array("a", dim = c(2, 1)),
    cov = array(diag(2), dim = c(2, 2, 1))
  )
  bad_cov <- list(
    proportion = 1,
    mean = matrix(c(0.5, 0.5), ncol = 1),
    cov = array("a", dim = c(2, 2, 1))
  )

  expect_error(
    qscore(dat, bad_mean),
    "The object '\\$mean' must be numeric"
  )
  expect_error(
    qscore(dat, bad_cov),
    "The object '\\$cov' must be numeric"
  )
})