tests/testthat/test-cluster_metric_set.R

In tidyclust: A Common API to Clustering

test_that("cluster_metric_set() works", {
  kmeans_spec <- k_means(num_clusters = 5) |>
    set_engine("stats")

  kmeans_fit <- fit(kmeans_spec, ~., mtcars)

  my_metrics <- cluster_metric_set(
    sse_ratio,
    sse_total,
    sse_within_total,
    silhouette_avg
  )

  exp_res <- tibble::tibble(
    .metric = c("sse_ratio", "sse_total", "sse_within_total", "silhouette_avg"),
    .estimator = "standard",
    .estimate = vapply(
      list(
        sse_ratio_vec,
        sse_total_vec,
        sse_within_total_vec,
        silhouette_avg_vec
      ),
      function(x) x(kmeans_fit, new_data = mtcars),
      FUN.VALUE = numeric(1)
    )
  )

  expect_equal(
    my_metrics(kmeans_fit, new_data = mtcars),
    exp_res
  )

  expect_snapshot(error = TRUE, my_metrics(kmeans_fit))

  my_metrics <- cluster_metric_set(sse_ratio, sse_total, sse_within_total)

  expect_equal(
    my_metrics(kmeans_fit, new_data = mtcars),
    exp_res[-4, ]
  )
})

test_that("cluster_metric_set() error with wrong input", {
  expect_snapshot(
    error = TRUE,
    cluster_metric_set(mean)
  )

  expect_snapshot(
    error = TRUE,
    cluster_metric_set(sse_ratio, mean)
  )
})

test_that("cluster_metric_set() errors with advice for some functions", {
  expect_snapshot(
    error = TRUE,
    cluster_metric_set(silhouette)
  )

  expect_snapshot(
    error = TRUE,
    cluster_metric_set(sse_within)
  )
})

test_that("cluster_metric_set() errors when empty", {
  expect_snapshot(error = TRUE, cluster_metric_set())
})

test_that("cluster_metric_set() errors with non-functions", {
  expect_snapshot(error = TRUE, cluster_metric_set("not_a_function"))
})

test_that("print.cluster_metric_set() works", {
  metrics <- cluster_metric_set(sse_total, sse_ratio)
  expect_snapshot(print(metrics))
})

test_that("cluster_metric_set() works with namespaced functions", {
  metrics <- cluster_metric_set(tidyclust::sse_total, tidyclust::sse_ratio)

  kmeans_fit <- k_means(num_clusters = 3) |>
    set_engine("stats") |>
    fit(~., mtcars)

  res <- metrics(kmeans_fit, new_data = mtcars)
  expect_equal(res$.metric, c("sse_total", "sse_ratio"))
})

test_that("new_cluster_metric() works", {
  fn <- function(object, new_data = NULL) {
    tibble::tibble(.metric = "test", .estimator = "standard", .estimate = 1)
  }

  metric <- new_cluster_metric(fn, direction = "maximize")

  expect_s3_class(metric, "cluster_metric")
  expect_equal(attr(metric, "direction"), "maximize")
})

test_that("custom metric wrapping a built-in metric works in cluster_metric_set()", {
  kmeans_fit <- k_means(num_clusters = 5) |>
    set_engine("stats") |>
    fit(~., mtcars)

  manhattan_dist <- function(x) philentropy::distance(x, method = "manhattan")

  manhattan_silhouette_avg <- new_cluster_metric(
    function(object, new_data = NULL, ...) {
      silhouette_avg(
        object,
        new_data = new_data,
        dist_fun = manhattan_dist,
        ...
      )
    },
    direction = "maximize"
  )

  my_metrics <- cluster_metric_set(manhattan_silhouette_avg, sse_ratio)

  res <- my_metrics(kmeans_fit, new_data = mtcars)

  expect_equal(res$.metric, c("manhattan_silhouette_avg", "sse_ratio"))
  expect_equal(
    res$.estimate[[1]],
    silhouette_avg_vec(kmeans_fit, new_data = mtcars, dist_fun = manhattan_dist)
  )
})

test_that("metrics wrapping the same built-in stay distinct in a metric set", {
  kmeans_fit <- k_means(num_clusters = 5) |>
    set_engine("stats") |>
    fit(~., mtcars)

  manhattan_dist <- function(x) philentropy::distance(x, method = "manhattan")
  euclidean_dist <- function(x) philentropy::distance(x, method = "euclidean")

  mk <- function(f) {
    new_cluster_metric(
      function(object, new_data = NULL, ...) {
        silhouette_avg(object, new_data = new_data, dist_fun = f, ...)
      },
      direction = "maximize"
    )
  }

  manhattan_silhouette_avg <- mk(manhattan_dist)
  euclidean_silhouette_avg <- mk(euclidean_dist)

  my_metrics <- cluster_metric_set(
    manhattan_silhouette_avg,
    euclidean_silhouette_avg
  )

  res <- my_metrics(kmeans_fit, new_data = mtcars)

  expect_equal(
    res$.metric,
    c("manhattan_silhouette_avg", "euclidean_silhouette_avg")
  )
  expect_equal(
    res$.estimate,
    c(
      silhouette_avg_vec(
        kmeans_fit,
        new_data = mtcars,
        dist_fun = manhattan_dist
      ),
      silhouette_avg_vec(
        kmeans_fit,
        new_data = mtcars,
        dist_fun = euclidean_dist
      )
    )
  )
})

test_that("new_cluster_metric() errors with non-function", {
  expect_snapshot(
    error = TRUE,
    new_cluster_metric("not a function", direction = "maximize")
  )
})

test_that("new_cluster_metric() errors with invalid direction", {
  fn <- function(object, new_data = NULL) 1
  expect_snapshot(
    error = TRUE,
    new_cluster_metric(fn, direction = "invalid")
  )
})