inst/tinytest/test_utils.R

In validate: Data Validation Infrastructure

## Options can be set
  # warning on nonexistent option 
  expect_warning(voptions(fiets=3))
  # invalid 'raise' value -- not implemented yet
  #expect_error(voptions(raise='aap'))
  # this should run without problems
  reset(voptions)
  expect_equal(voptions('raise')[[1]],'none')



## match_cells",{
  d1 <- data.frame(id=paste(1:3),x=1:3,y=4:6)
  d2 <- data.frame(id=paste(4:1),y=4:7,x=1:4)
  expect_equal(
    names(match_cells(d1,d2,id='id')[[1]])
    ,names(match_cells(d1,d2,id='id')[[2]])    
  )
  expect_equal(
    as.character(match_cells(d1,d2,id='id')[[1]][,'id'])
    , as.character(match_cells(d1,d2,id='id')[[2]][,'id'])
  )  


## validating/indicating expressions can be named
  expect_equal(names(validator(aap=x>3)),'aap')
  expect_equal(names(indicator(fiets=mean(x))),'fiets')    


## cells works",{
  cls <- cells(women, women)
  expect_equivalent(cls[,1], cls[,2])
  d <- as.data.frame(cls)
  expect_true(inherits(d, "data.frame"))
  expect_equal(nrow(d), 9*2)
  expect_equal(ncol(d), 3)



# code for these methods in confrontation.R
## other methods for 'variables
  expect_equal(variables(women),c("height","weight"))  
  expect_equal(variables(as.list(women)),c("height","weight"))
  expect_equal(variables(as.environment(women)),c("height","weight"))



## compare works
  d1 <- data.frame(x=1:3,y=4:6)
  d2 <- data.frame(x=c(NA,2,NA),y=c(4,5,NA))  
  v <- validator(x>0,y<5)
  a <- array(
    c( 6,6,0,0,0,4,4,0,2,2,0
      ,6,3,3,0,3,2,2,0,1,1,0 ),dim=c(11,2)
  )
  expect_equivalent(unclass(compare(v,d1,d2)),a)

  d <- as.data.frame(compare(v,d1,d2))
  expect_true(inherits(d,"data.frame"))
  expect_equal(ncol(d),3)
  expect_equal(nrow(d),11*2)
  


## comparison objects can be plotted
  d1 <- data.frame(x=1:3,y=4:6)
  d2 <- data.frame(x=c(NA,2,NA),y=c(4,5,NA))  
  rules <- validator(x>0,y<5)
  expect_silent(plot(compare(rules, d1,d2)))
  expect_silent(plot(cells(d1,d2)))
  expect_equal(length(barplot(cells(d1,d2))),2)
  expect_equal(length(barplot(compare(rules, d1,d2))),2)



## blocks works
  v <- validator(x + y > z, q > 0, z + x == 3)
  expect_equivalent(v$blocks()[[1]],c(1,3))
  expect_equivalent(v$blocks()[[2]],2)
  v <- validator(
    x > 0
    , y > 0
    , x + y == z
    , u + v == w
    , u > 0)
  expect_equal(length(v$blocks()),2)
  
  v <- validator(x +y ==z, x+z>0)
  expect_equal(length(v$blocks()),1)
  


## %vin% ----
  expect_identical(
    c("a","b") %vin% integer(0)
    , logical(2)
  )
  expect_identical(
    c("a","b") %vin% c("a","c","d")
    , c(TRUE, FALSE)
  )
  expect_identical(
    c("a",NA) %vin% c("a","c","d")
    , c(TRUE, NA)
  )
  expect_identical(
    c(NA,"b") %vin% c("a","c","d")
    , c(NA,FALSE)
  )
  expect_identical(
    c("a","b") %vin% c(NA,"c","d")
    , c(NA,NA)
  )
  expect_identical(
    c("a","b") %vin% c("a",NA,"d")
    , c(TRUE,NA)
  )




## utility record selector functions
expect_equal(
  satisfying(women, validator(height>60))
  , subset(women, height>60)
)

expect_equal(
  satisfying(women, check_that(women, height>60))
  , subset(women, height>60)
)


expect_equal(
  violating(women, validator(height<=60))
  , subset(women, height>60)
)

expect_equal(
  violating(women, check_that(women, height<=60))
  , subset(women, height>60)
)

local({
  women[1,1] <- NA
  expect_equal(
    lacking(women, validator(height<=60))
   , women[1,,drop=FALSE]
  )
  expect_equal(
    lacking(women, check_that(women, height<=60))
   , women[1,,drop=FALSE]
  )
})