tests/testthat/helper-clustering.R

In qcluster: Clustering via Quadratic Scoring

simulate_gaussian <- function(n, mean, cov) {
  z <- matrix(rnorm(n * length(mean)), ncol = length(mean))
  sweep(z %*% chol(cov), 2, mean, "+")
}

all_permutations <- function(x) {
  if (length(x) <= 1L) {
    return(list(x))
  }

  out <- vector("list", factorial(length(x)))
  idx <- 1L
  for (i in seq_along(x)) {
    for (perm in all_permutations(x[-i])) {
      out[[idx]] <- c(x[i], perm)
      idx <- idx + 1L
    }
  }
  out
}

normalize_labels <- function(x) {
  lev <- sort(unique(x))
  vapply(x, function(value) which(lev == value), integer(1))
}

best_label_accuracy <- function(truth, pred) {
  truth <- normalize_labels(truth)
  pred <- normalize_labels(pred)
  k <- max(c(truth, pred))
  perms <- all_permutations(seq_len(k))

  max(vapply(
    perms,
    function(mapping) mean(truth == mapping[pred]),
    numeric(1)
  ))
}