tests/testthat/test-valid.R

In S7: An Object Oriented System Meant to Become a Successor to S3 and S4

test_that("validate() validates object and type recursively", {
  klass <- new_class("klass", package = NULL,
    properties = list(x = class_double, y = class_double),
    validator = function(self) {
      c(
        if (self@x < 0) "x must be positive",
        if (self@y > 0) "y must be negative"
      )
    }
  )

  expect_snapshot(error = TRUE, {
    obj <- klass(1, -1)
    attr(obj, "x") <- -1
    validate(obj)

    attr(obj, "x") <- "y"
    validate(obj)
  })

  klass2 <- new_class("klass2", parent = klass, package = NULL,
                      properties = list(z = class_double))
  expect_snapshot(error = TRUE, {
    obj <- klass2(1, -1, 1)
    attr(obj, "x") <- -1
    validate(obj)

    attr(obj, "x") <- "y"
    attr(obj, "z") <- "y"
    validate(obj)
  })
})

test_that("validate checks base type", {
  Double <- new_class("Double", package = NULL, parent = class_double)
  x <- Double(10)
  mode(x) <- "character"

  expect_snapshot(error = TRUE, validate(x))
})

test_that("validate checks the type of setters", {
  foo <- new_class("foo", package = NULL, properties = list(x =
    new_property(
      class_double,
      setter = function(self, value) {
        self@x <- as.character(value)
        self
      }
    )
  ))
  expect_snapshot(foo(x = 123), error = TRUE)
})

test_that("validate does not check type of getters", {
  # because getters can be peform arbitrary computation and we want
  # validation to always be cheap

  prop <- new_property(class_integer, getter = function(self) "x")
  foo <- new_class("foo", properties =  list(x = prop))

  expect_no_error(foo())
})

test_that("valid eventually calls the validation function only at the end", {
  foo <- new_class("foo",
    properties = list(x = class_double),
    validator = function(self) if (self@x < 0) "must be positive"
  )
  obj <- foo(10)

  obj <- valid_eventually(obj, function(self) {
    self@x <- -1
    self@x <- 1
    self
  })
  expect_error(validate(obj), NA)
})

test_that("valid implicitly does _not_ call the validation function", {
  foo <- new_class("foo",
    properties = list(x = class_double),
    validator = function(self) if (self@x < 0) "must be positive"
  )
  obj <- foo(10)

  obj <- valid_implicitly(obj, function(self) {
    self@x <- -1
    self
  })
  expect_error(validate(obj), "must be positive")
})