tests/testthat/test-classified.R

In yamlet: Versatile Curation of Table Metadata

test_that('classified factors can be combined with each other and with vanilla factors',{
  set.seed(0)
  library(magrittr)
  library(dplyr)
  library(yamlet)
  library(tidyr)
  library(ggplot2)
  library(vctrs)
  x <- data.frame(id = 1:4)
  x %<>% mutate(wt  = 78:81)
  x %<>% mutate(age = 18:21)
  x %<>% mutate(sex = c(0, 1, 0, 1))
  x %<>% mutate(coh = c(1, 2, 3, 2))
  x %<>% mutate(CL  = rnorm(id, 10, 15) %>% signif)
  x %<>% mutate(V   = rnorm(id, 3, 0.25) %>% signif)
  
  x %<>% decorate('
id: Subject ID
wt:  [ Body Weight, kg]
age: [ Age, year]
sex: [ Sex, [ Female: 0, Male: 1 ]]
coh: [ Cohort, [ Cohort 1: 1, Cohort 2: 2, Cohort 3: 3]]
CL:  [ CL/F, L/h]
V:   [ V/F, L ]
')

  # works, but gives appropriate warnings:
  x %>% pivot_longer(c(coh, sex)) 

  # should succeed by casting to factor if attr not compatible:
  x %>% resolve %>% pivot_longer(c(coh, sex))
  x %>% resolve %>% pivot_longer(c(coh, sex)) %>% decorations
  
  # don't handle:
  # x %>% resolve(coh) %>% pivot_longer(c(coh, sex))
  
  x %<>% resolve
  y <- x
  y$coh %<>% factor
  y$sex %<>% factor
  
  # attributes on right missing, attributes on left dropped:
  rbind(x, y)

  # classified~factor: If factor levels match exactly, promote factor to classified and keep attributes of classified
  bind_rows(x, y) %>% decorations
  bind_rows(y, x) %>% decorations
  
  vec_c(x$sex, y$sex)
  vec_c(y$sex, x$sex) # no label for y$sex
  
  
  z <- y %>% rename(coh = sex, sex = coh)
  
  # attributes on right missing, attributes on left dropped:
  rbind(x, z)

  
  # classified~factor: if factor levels don't match, demote classified to factor and adopt default behaviors
  bind_rows(x, z) # labels preserved
  
  a <- x %>% rename(coh = sex, sex = coh)
  
  # classified~classified: demotes both sides to factor
  rbind(x, a)  
  
  # classified-classified: if factor levels don't match drop codelist names
  bind_rows(x, a)
  
  c1 <- classified('a', levels = c('a','b')) %>% structure(label = 'c1')
  c2 <- classified('b', levels = c('a','b')) %>% structure(label = 'c2')
  c3 <- classified('c', levels = c('a','c')) %>% structure(label = 'c3')
  f1 <- factor('a', levels = c('a','b')) %>% structure(label = 'f1')
  f2 <- factor('b', levels = c('a','b')) %>% structure(label = 'f2')
  f3 <- factor('c', levels = c('a','c')) %>% structure(label = 'f3')
 
  expect_equal_to_reference(file = '122.rds', vec_c(c1, c1))
  expect_equal_to_reference(file = '123.rds', vec_c(c1, c2))
  expect_equal_to_reference(file = '124.rds', vec_c(c2, c1))
  expect_equal_to_reference(file = '125.rds', vec_c(c1, c3))
  expect_equal_to_reference(file = '126.rds', vec_c(c3, c1))
  expect_equal_to_reference(file = '127.rds', vec_c(c1, f1))
  expect_equal_to_reference(file = '128.rds', vec_c(f1, c1))
  expect_equal_to_reference(file = '129.rds', vec_c(c1, f2))
  expect_equal_to_reference(file = '130.rds', vec_c(f2, c1))
  expect_equal_to_reference(file = '131.rds', vec_c(c1, f3))
  expect_equal_to_reference(file = '132.rds', vec_c(f3, c1))
})

test_that('items with an empty list as guide resolve to classified',{
  library(magrittr)
  library(dplyr)
  library(yamlet)
  library(testthat)
  x <- data.frame(ID = 1:3)
  x %<>% redecorate('ID: [ Identifier, []]')
  x %<>% resolve
  expect_true(is.factor(x$ID))
  x %<>% desolve(collapse = 0)
  expect_false(is.factor(x$ID))
  expect_true(length(attr(x$ID, 'guide')) == 0)
  decorations(x)
})