tests/testthat/test-compat-vctrs-helpers-parameters.R

# ------------------------------------------------------------------------------
# tib_upcast()

test_that("parameters can be upcast to a tibble", {
  x <- parameters(penalty())
  expect_s3_class_bare_tibble(tib_upcast(x))
})

test_that("upcasting drops extra attributes", {
  x <- parameters(penalty())
  attr(x, "foo") <- "bar"

  x <- tib_upcast(x)

  expect_identical(attr(x, "foo"), NULL)
})

# ------------------------------------------------------------------------------
# parameters_reconstructable()

test_that("identical parameters are reconstructable", {
  x <- parameters(penalty())
  expect_true(parameters_reconstructable(x, x))
})

test_that("column order doesn't matter", {
  to <- parameters(list(penalty(), mixture()))
  x <- as_tibble(to)[rev(names(to))]
  expect_true(parameters_reconstructable(x, to))
})

test_that("all columns must exist", {
  to <- parameters(list(penalty(), mixture()))
  x <- as_tibble(to)["name"]
  expect_false(parameters_reconstructable(x, to))
})

test_that("can't have extra columns", {
  to <- parameters(list(penalty(), mixture()))
  x <- as_tibble(to)
  x[["extra"]] <- 1
  expect_false(parameters_reconstructable(x, to))
})

test_that("can't rename a column to unknown name", {
  to <- parameters(list(penalty(), mixture()))
  x <- as_tibble(to)

  names <- names(x)
  names[[1]] <- "foo"
  names(x) <- names

  expect_false(parameters_reconstructable(x, to))
})

test_that("can technically swap column names", {
  to <- parameters(list(penalty(), mixture()))
  x <- as_tibble(to)

  names <- names(x)
  one <- names[[1]]
  names[[1]] <- names[[3]]
  names[[3]] <- one
  names(x) <- names

  # This is a necessary evil but we can prevent it causing problems
  # in `rename()` and `names<-` with a `names<-` method. It shouldn't
  # cause problems for anything user facing.
  expect_true(parameters_reconstructable(x, to))
})

test_that("column type can't change", {
  to <- parameters(list(penalty(), mixture()))
  x <- as_tibble(to)

  x[["name"]] <- 1

  expect_false(parameters_reconstructable(x, to))
})

test_that("`$object` must be a list of `params`", {
  to <- parameters(list(penalty(), mixture()))
  x <- as_tibble(to)

  x[["object"]] <- list(1)

  expect_false(parameters_reconstructable(x, to))
})

test_that("`$id` can't be duplicated", {
  to <- parameters(list(penalty(), mixture()))
  x <- as_tibble(to)
  x <- x[c(1, 1), ]

  expect_false(parameters_reconstructable(x, to))
})

test_that("number of rows and row order doesn't matter", {
  to <- parameters(list(penalty(), mixture()))
  x <- as_tibble(to)

  idx <- 1
  expect_true(parameters_reconstructable(x[idx, ], to))

  idx <- rev(seq_len(nrow(x)))
  expect_true(parameters_reconstructable(x[idx, ], to))
})

Try the dials package in your browser

Any scripts or data that you put into this service are public.

dials documentation built on April 3, 2023, 5:43 p.m.