Momocs: Morphometrics using R

context("nse")

x <- Out(a2l(replicate(50, matrix(1:4, 2, 2))),
         fac=dplyr::tibble(a=rep(letters[1:5], 10),
                               b=rep(LETTERS[1:5], each=10)))



test_that("fac_dispatcher works fine", {
  bot <- mutate(bot, s=rnorm(40), fake=factor(rep(letters[1:4], 10)))
  # factor, on the fly
  expect_true(fac_dispatcher(bot, factor(rep(letters[1:4], 10))) %>% is.factor)

  # column id
  expect_true(fac_dispatcher(bot, 1) %>% is.factor)

  # column name
  expect_true(fac_dispatcher(bot, "type") %>% is.factor)
  # same, numeric case
  expect_true(fac_dispatcher(bot, "s") %>% is.numeric)

  # formula interface
  expect_true(fac_dispatcher(bot, ~type) %>% is.factor)

  # formula interface + interaction on the fly
  expect_true(fac_dispatcher(bot, ~type+fake) %>% is.factor)
})

# prepare_fac -----
# test_that("prepare_fac works fine", {
#   olea$fac$fake <-  rnorm(length(olea))
#   # Valid ways below ------
#   # nothing
#   expect_null(prepare_fac(olea))
#   # column id
#   expect_identical(prepare_fac(olea, 2), olea$fac[, 2])
#   # column name
#   expect_identical(prepare_fac(olea, "domes"), olea$fac[, "domes"])
#   # column name NSE, unquoted
#   expect_identical(prepare_fac(olea, domes), olea$fac$domes)
#   # formula style
#   expect_identical(prepare_fac(olea, ~domes), olea$fac$domes)
#   # formula + interactions
#   expect_identical(prepare_fac(olea, ~domes+var), with(olea$fac, interaction(domes, var)))
#   # factor on the fly
#   f <- factor(rep(letters[1:7], each=30))
#   expect_identical(prepare_fac(olea, f), f)
#   # numeric on the fly
#   n <- rnorm(length(olea))
#   expect_identical(prepare_fac(olea, n), n)
#   # non-valid ways
#   data(olea)
#   # non-existing column
#   expect_error(prepare_fac(olea, 84))
#   # non existing column name
#   expect_error(prepare_fac(olea, "rock_and_roll"))
#   # also, formula style
#   expect_error(prepare_fac(olea, ~rock_and_roll))
#   # passing a factor of the wrong length
#   expect_error(prepare_fac(olea, factor(rep(letters[1:7], each=10))))
#   # passing a numeric of the wrong length
#   expect_error(prepare_fac(olea, rnorm(70)))
# })

# dplyr verbs -------
test_that("select works fine",{
  nc <- function(x) ncol(x$fac)
  expect_equal(select(olea, 1) %>% nc, 1)
  expect_equal(select(olea, 1:2) %>% nc, 2)
  expect_equal(select(olea, var) %>% nc, 1)
  expect_equal(select(olea, var, domes) %>% nc, 2)
  expect_equal(select(olea, -(1:2)) %>% nc, nc(olea)-2)
})


test_that("filter works fine",{
  expect_equal(length(filter(x, a=="a")) , 10)
  expect_equal(length(filter(x, a %in% c("a", "b"))) , 20)
  expect_equal(length(filter(x, !(a %in% c("a", "b")))) , 30)
  # only two rows in the fac, both with {a; B}
  x_lite <-filter(x, a=="a", b=="B")
  expect_equal(length(x_lite), 2)
  # test for the dropping of factor levels
  expect_true(all(sapply(x_lite$fac, function(.x) length(unique(.x)))==1))
})

# rename
# mutate
#  trnsmute
# arrange
# slice

test_that("slice works fine",{
  expect_true(x %>% slice(0) %>% verify %>% is_Out())
  expect_true(x %>% slice(1) %>% verify %>% is_Out())
  expect_true(x %>% slice(-1) %>% verify %>% is_Out())
  expect_true(x %>% slice(1:5) %>% verify %>% is_Out())
  expect_true(x %>% slice(-(1:5)) %>% verify %>% is_Out())
  expect_true(x %>% slice(sample(c(TRUE, FALSE), length(.), rep=T)) %>% is_Out())
})

# sample_n
test_that("sample_n works fine", {
  expect_equal(sample_n(x, 0) %>% length(), 0)
  expect_equal(sample_n(x, 5) %>% length(), 5)
})

# sample_frac
test_that("sample_frac works fine", {
  expect_equal(sample_frac(x, 0) %>% length(), 0)
  expect_equal(sample_frac(x, 0.5) %>% length(), length(x)/2)
  expect_equal(sample_frac(x, 1) %>% length(), length(x))
})


# chop
test_that("chop works fine",{
  expect_true(chop(x, ~a) %>% is.list())
  expect_equal(chop(x, ~a) %>% length, 5)
  expect_true(chop(x, "a") %>% sapply(is_Out) %>% all)
})

# combine
test_that("combine works fine", {
  expect_true(chop(x, ~a) %>% combine %>% is_Out())
  expect_equal(chop(x, ~a) %>% combine %>% length(), length(x))
})

# dissolve
test_that("dissolve works fine", {
  bw <- bot %>% chop(~type) %>% lapply(efourier, 10) %>% combine
  expect_true(bw %>% is_OutCoe())
  expect_equal(ncol(bw$coe), 80)
  expect_true(bw %>% dissolve(1) %>% is_OutCoe())
  expect_equal(bw %>% dissolve(1) %$% ncol(coe), 40)
})

# subsetize
test_that("subsetize works fine", {
  expect_equal(subsetize(bot, type=="whisky") %>% length, 20)
  expect_equal(subsetize(bot, type!="whisky") %>% length, 20)
  expect_equal(subsetize(bot, 1:5) %>% length, 5)
  expect_equal(subsetize(bot, -(1:5)) %>% length, 35)
})

# rw
# test_that("rw_rule works fine", {
#   expect_equal(rw_fac(x, "b", "C", "foo")$a %>% unique(), c("A", "B", "D", "E", "foo"))
# })

# at_least
xx <- Out(a2l(replicate(50, matrix(1:4, 2, 2))),
          fac=dplyr::tibble(a=rep(letters[1:5], 10),
                                b=factor(c(rep(LETTERS[1], 5),
                                           rep(LETTERS[2], 10),
                                           rep(LETTERS[3], 15),
                                           rep(LETTERS[4], 20)))))
test_that("at_least works fine", {
  expect_equal(at_least(xx, "b", 5)$b %>% unique() %>% length(), 4)
  expect_equal(at_least(xx, "b", 6)$b %>% unique() %>% length(), 3)
  expect_equal(at_least(xx, "b", 20)$b %>% unique() %>% length(), 1)
  expect_equal(at_least(xx, "b", 50)$b %>% unique() %>% length(), 0)
  expect_message(at_least(xx, "b", 50)$b %>% unique() %>% length())
})