tests/testthat/test-clustering.R

In rsample: General Resampling Infrastructure

test_that("default param", {
  set.seed(11)
  rs1 <- clustering_cv(dat1, c, v = 2)

  same_data <-
    purrr::map_lgl(rs1$splits, function(x) {
      all.equal(x$data, dat1)
    })
  expect_true(all(same_data))

  good_holdout <- purrr::map_lgl(
    rs1$splits,
    function(x) {
      length(intersect(x$in_ind, x$out_id)) == 0
    }
  )
  expect_true(all(good_holdout))
})

test_that("repeated", {
  set.seed(11)
  rs2 <- clustering_cv(dat1, c, v = 2, repeats = 4)
  sizes2 <- dim_rset(rs2)

  same_data <-
    purrr::map_lgl(rs2$splits, function(x) {
      all.equal(x$data, dat1)
    })
  expect_true(all(same_data))

  good_holdout <- purrr::map_lgl(
    rs2$splits,
    function(x) {
      length(intersect(x$in_ind, x$out_id)) == 0
    }
  )
  expect_true(all(good_holdout))
})

test_that("bad args", {
  expect_snapshot_error(clustering_cv(dat1))
  expect_snapshot_error(clustering_cv(iris, Sepal.Length, v = -500))
  expect_snapshot_error(clustering_cv(iris, Sepal.Length, v = 500))
  expect_snapshot_error(clustering_cv(iris, Sepal.Length, cluster_function = "not an option"))
  expect_snapshot(error = TRUE, clustering_cv(Orange, v = 1, vars = "Tree"))
  expect_snapshot_error(clustering_cv(Orange, repeats = 0))
  expect_snapshot_error(clustering_cv(Orange, repeats = NULL))
})

test_that("printing", {
  set.seed(11)
  expect_snapshot(clustering_cv(dat1, c, v = 2))
})

test_that("rsplit labels", {
  rs <- clustering_cv(dat1, c, v = 2)
  all_labs <- purrr::map(rs$splits, labels) %>%
    list_rbind()
  original_id <- rs[, grepl("^id", names(rs))]
  expect_equal(all_labs, original_id)
})