Nothing
tests/testthat/test-yamlet.R
In yamlet: Versatile Curation of Table Metadata
library(testthat)
library(magrittr)
library(yaml)
test_that('yaml package result is stable',{
expect_equal_to_reference(file = '001.rds', yaml.load('[ID: ]'))
expect_equal_to_reference(file = '002.rds', yaml.load('ID: '))
expect_equal_to_reference(file = '003.rds', yaml.load('[ ID: ]'))
expect_equal_to_reference(file = '004.rds', yaml.load('[ ID: ]'))
expect_equal_to_reference(file = '005.rds', yaml.load('RACE'))
expect_equal_to_reference(file = '006.rds', yaml.load('RACE:'))
expect_equal_to_reference(file = '007.rds', yaml.load('? RACE'))
expect_equal_to_reference(file = '008.rds', yaml.load('[{RACE: }, ID: ]'))
expect_equal_to_reference(file = '009.rds', yaml.load('[? RACE, ? ID]'))
expect_equal_to_reference(file = '010.rds', yaml.load('[RACE: , ID: ]'))
expect_equal_to_reference(file = '011.rds', yaml.load('RACE: [ race, [ foo: bar, hey: baz ]]'))
expect_equal_to_reference(file = '012.rds', yaml.load('RACE: [ race, [ {foo: bar}, {hey: baz} ]]'))
expect_equal_to_reference(file = '013.rds', yaml.load('RACE: [ race, [ {foo: bar}, hey: baz ]]'))
expect_equal_to_reference(file = '014.rds', yaml.load('RACE: [ race, [ {foo: bar}, ? baz ]]'))
expect_equal_to_reference(file = '015.rds', yaml.load('RACE: [ race, [ {foo: bar}, baz: ]]'))
expect_equal_to_reference(file = '016.rds', yaml.load('RACE: [ race, [ {foo: bar}, hey: ]]'))
expect_equal_to_reference(file = '017.rds', yaml.load('RACE: [ race, [ bar, baz ]]'))
expect_equal_to_reference(file = '018.rds', yaml.load('RACE: [ race, [ {foo: bar} ]]'))
expect_equal_to_reference(file = '019.rds', yaml.load('RACE: [ label: race, [ foo: bar ]]'))
expect_equal_to_reference(file = '020.rds', yaml.load('RACE: [ label: race, [ foo: bar, hey: baz ]]'))
expect_equal_to_reference(file = '021.rds', yaml.load('RACE: [ label: race, [ foo: bar, baz ]]'))
expect_equal_to_reference(file = '022.rds', yaml.load('1')) # a length-one vector
expect_equal_to_reference(file = '023.rds', yaml.load('a')) # a length-one vector
expect_equal_to_reference(file = '024.rds', yaml.load('a:')) # a length-one named list
expect_equal_to_reference(file = '025.rds', yaml.load('a: ')) # a length-one named list
expect_equal_to_reference(file = '026.rds', yaml.load('? a')) # a length-one named list
expect_equal_to_reference(file = '027.rds', yaml.load('[ 0]')) # a length-one sequence, represented as a vector
expect_equal_to_reference(file = '028.rds', yaml.load('[ 0, 1]')) # a sequence, represented as a vector
expect_equal_to_reference(file = '029.rds', yaml.load('a: 0')) # a length-one mapping, represented as a length-one named list
expect_equal_to_reference(file = '030.rds', yaml.load('[a: 0]')) # a list of named list * recursive
expect_equal_to_reference(file = '031.rds', yaml.load('[a: 0, b: 1]')) # a list of named lists *
expect_equal_to_reference(file = '032.rds', yaml.load('[a: [0,1,2], b: 1]')) # a list of lists *
expect_equal_to_reference(file = '033.rds', yaml.load('[a: [0,1,2], 5 ]')) # a list of one list and one int
expect_equal_to_reference(file = '034.rds', yaml.load('[ [ [ [d: [0, 1, 2]]]]]')) # a list of named list * recursive
})
test_that('as_yamlet result is stable',{
expect_equal_to_reference(file = '035.rds', as_yamlet('RACE: [white: 0, 1 ]')) # surprising, but correct.
expect_equal_to_reference(file = '036.rds', as_yamlet('RACE: [race, [white: 0, 1 ]]'))
expect_equal_to_reference(
file = '037.rds', # @ 0.7.7 this was runaway parsimony
as_yamlet(
'RACE: [ race, [ foo: bar ]]' # @ 0.7.8 we see (correctly) label, guide not label, foo
)
)
})
test_that('as_yamlet result is still stable',{
# yaml.load('foo: bar')
# yaml.load('foo: bar', handlers = list(seq = parsimonious))
# yaml.load('[foo: bar]')
# yaml.load('[foo: bar]', handlers = list(seq = parsimonious))
#
# yaml.load('RACE: [ label: race, [ foo: bar ]]')
# yaml.load('RACE: [ label: race, [ foo: bar ]]', handlers = list(seq = parsimonious))
#
# yaml.load('RACE: [ label: race, [ foo: bar, hey: baz ]]')
# yaml.load('RACE: [ label: race, [ foo: bar, hey: baz ]]', handlers = list(seq = parsimonious))
#
# as_yamlet('RACE: [ label: race, [ foo: bar ]]')
# as_yamlet('RACE: [ label: race, [ foo: bar, hey: baz ]]')
#
# as_yam('RACE: [ label: race, [ foo: bar ]]') %>% str
# as_yam('RACE: [ label: race, [ foo: bar, hey: baz ]]') %>% str
expect_equal_to_reference(file = '038.rds',as_yamlet('RACE: [ label: race, [ foo: bar ]]')) # must not be label, label; must not drop foo
expect_equal_to_reference(file = '039.rds', as_yamlet('RACE: [ label: race, [ foo: bar, hey: baz ]]')) # 'label: race' must reduce in presence of plural list
})
test_that('more elements than keys gives warning',{
expect_warning(as_yamlet('RACE: [label: race, guide: [white: 0, black: 1 ], categorical, 0]\nID: [1, 2, 3]'))
})
test_that('yamlet reads length-one character equivalently to vector',{
expect_identical(as_yam(c('ID:','TIME:')),as_yam('ID:\nTIME:'))
})
test_that('key priority by source is explicit > object > argument > option > default',{
expect_identical(names(as_yamlet('a: value')$a), 'label') # default
old <- getOption('yamlet_default_keys')
options(yamlet_default_keys = 'option')
expect_identical(names(as_yamlet('a: value')$a), 'option') # option
expect_identical(names(as_yamlet('a: value', default_keys = 'argument')$a), 'argument') # argument
expect_identical(names(as_yamlet('a: value\n_keys: object', default_keys = 'argument')$a),'object')
expect_identical(names(as_yamlet('a: [explicit: value]\n_keys: object', default_keys = 'argument')$a),'explicit')
options(yamlet_default_keys = old)
})
test_that('mixed-length vector types are respected',{
expect_equal_to_reference(
file = '099.rds',
as_yamlet('RACE: [ race, [white, black, asian ]]')
)
})
test_that('mixed-depth nesting is supported',{
expect_equal_to_reference(file = '100.rds', as_yamlet('ITEM: [ label: item, [ foo: bar, hey: baz ]]'))
})
test_that('default decorations are equivalent to explicit requests',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
meta <- system.file(package = 'yamlet', 'extdata','quinidine.yaml')
expect_identical(decorate(file),decorate(file, meta = meta))
expect_identical(decorate(file, meta = as_yamlet(meta)),decorate(file, meta = meta))
expect_identical(decorate(file),decorate(file, meta = meta))
})
test_that('non-default import is equivalent',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
b <- decorate(file, source = FALSE) %>% resolve
c <- decorate(
file,
read = read.table,
quote = "",
as.is = TRUE,
sep = ',',
header = TRUE,
na.strings = c('', '\\s', '.','NA'),
strip.white = TRUE,
check.names = FALSE
) %>% resolve
expect_identical(b, c)
})
test_that('interconversion to and from storage is conservative',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
meta <- system.file(package = 'yamlet', 'extdata','quinidine.yaml')
expect_identical(
readLines(meta),
as.character(as_yamlet(decorate(file)))
)
})
test_that('coersion to storage format is stable',{
expect_equal_to_reference(file = '053.rds', to_yamlet(3))
expect_equal_to_reference(file = '054.rds', to_yamlet(c(a = '4', b = '5.8')))
expect_equal_to_reference(file = '055.rds', to_yamlet(c(a = 4, b = 5.8)))
expect_equal_to_reference(file = '056.rds', to_yamlet(TRUE))
expect_equal_to_reference(file = '057.rds', to_yamlet('foo'))
expect_equal_to_reference(file = '058.rds', to_yamlet(c('a','b')))
expect_equal_to_reference(file = '059.rds', to_yamlet(c(a = 'a',b = 'b')))
expect_identical(to_yamlet(c(no = 'n', yes = 'y')),"[ 'no': 'n', 'yes': 'y' ]")
expect_identical(to_yamlet(c('no' = 'n', 'yes' = 'y')),"[ 'no': 'n', 'yes': 'y' ]")
expect_identical(to_yamlet(c('No' = 'n', 'Yes' = 'y')),"[ 'No': 'n', 'Yes': 'y' ]")
})
test_that('as.character.yamlet and as_yamlet.character are reciprocal',{
foo <- as_yamlet(system.file(package = 'yamlet', 'extdata','quinidine.yaml'))
expect_identical(foo, as_yamlet(as.character(foo)))
expect_identical(as.character(foo), as.character(as_yamlet(as.character(foo))))
})
test_that('read_yamlet and write_yamlet are reciprocal',{
foo <- system.file(package = 'yamlet', 'extdata','quinidine.yaml')
file <- tempfile()
write_yamlet(read_yamlet(foo), con = file)
expect_identical(readLines(file), readLines(foo))
})
test_that('decorate will not overwrite existing attributes',{
foo <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(foo)
expect_warning(y <- decorate(x, 'Subject: subject identifier'))
expect_silent(y <- redecorate(x, 'Subject: subject identifier'))
})
test_that('decorate ignores anonymous attributes',{
foo <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
library(csv)
x <- as.csv(foo)
expect_warning(meta <- as_yamlet('time: [ a, b, c]'))
expect_warning(decorate(x, meta = meta))
})
test_that('io_yamlet methods are reciprocal with default or modified arguments',{
foo <- system.file(package = 'yamlet', 'extdata','quinidine.yaml')
out <- file.path(tempdir(), 'out.yaml')
x <- io_yamlet(foo)
expect_identical(x,io_yamlet(io_yamlet(x, out)))
expect_identical(
x,
io_yamlet(
fileEncoding = 'UTF-8', # read
eol = '\n',
#default_keys = c('foo','bar'),
io_yamlet(
fileEncoding = 'UTF-8', # write
eol = '\r',
default_keys = c('foo','bar'),
x,
out
)
)
)
})
test_that('io_table methods are reciprocal with default or modified arguments',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
out <- file.path(tempdir(), 'out.tab')
foo <- io_table(x, out)
expect_identical(out, foo)
y <- io_table(foo, as.is = TRUE)
attr(x, 'source') <- NULL
rownames(x) <- NULL
rownames(y) <- NULL
expect_identical(x, y) # lossless 'round-trip'
io_table(x, out, sep = ',' , na = '.') #, fileEncoding = 'UTF-16')
y <- io_table(out, as.is = TRUE, sep = ',', na.strings = '.') #, fileEncoding = 'UTF-16')
rownames(y) <- NULL
expect_identical(x, y) # lossless 'round-trip'
})
test_that('io_csv methods are reciprocal with default or modified arguments',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
attr(x, 'source') <- NULL
out <- file.path(tempdir(), 'out.tab')
foo <- io_csv(x, out)
expect_identical(out, foo)
expect_identical(readLines(file), readLines(out))
y <- io_csv(out)
rownames(x) <- NULL
rownames(y) <- NULL
attr(x, 'source') <- NULL
attr(y, 'source') <- NULL
expect_identical(x, y) # lossless 'round-trip'
io_csv(x, out, quote = TRUE, na = 'NA', eol = '\r') #, fileEncoding = 'UTF-16')
y <- io_csv(out, na.strings = 'NA') # , fileEncoding = 'UTF-16')
attr(y, 'source') <- NULL
expect_identical(x, y) # lossless 'round-trip'
})
test_that('class attributes are excluded from storage by default',{
expect_false('class' %in% decorations(Theoph)$Subject)
})
test_that('yamlet package writes proper yaml with non-default keys',{
out <- file.path(tempdir(), 'out.yaml')
expect_silent(write_yamlet('ID: identifier', con = out))
expect_silent(write_yamlet('ID: identifier', con = out, default_keys = c('foo','bar')))
expect_warning(write_yamlet('ID: identifier', con = out, default_keys = character(0)))
foo <- system.file(package = 'yamlet', 'extdata','quinidine.yaml')
x <- io_yamlet(foo) # read
y <- as_yam(x[1], default_keys = c('foo','bar'))
io_yamlet(x, out, default_keys = c('foo','bar')) # write
expect_silent(io_yamlet(out)) # read
z <- as_yamlet('ID: identifier')
expect_identical(as.character(z), 'ID: identifier')
expect_identical(
as.character(z, default_keys = c('foo','bar'))[[1]],
'ID: [ label: identifier ]'
)
})
test_that('dplyr filter does not drop attributes',{
# not okay in 3.6.1: filter drops label on factors
library(dplyr)
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- file %>% decorate %>% resolve
x %$% Heart %>% attributes %>% names
expect_true(
setequal(
x %>% filter(!is.na(conc)) %$% Heart %>% attributes %>% names,
c('levels','class','label','codelist')
)
)
})
test_that('io_table accepts nuisance arguments without error',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
out <- file.path(tempdir(), 'out.tab')
expect_silent(foo <- io_table(x, out, foo = 'bar'))
expect_silent(y <- io_table(foo, as.is = TRUE, foo = 'bar'))
})
test_that('io_csv accepts nuisance arguments without error',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
out <- file.path(tempdir(), 'out.csv')
expect_silent(foo <- io_csv(x, out, foo = 'bar'))
expect_silent(y <- io_csv(foo, as.is = TRUE, foo = 'bar'))
})
test_that('explicit_guide recognizes encodings, units, formats, and codelists',{
library(magrittr)
a <- 'CONC: [ concentration, ng/mL ]' %>% as_yamlet %>% explicit_guide
b <- 'RACE: [ subject race, [ Caucasian, Latin, Black ]]' %>% as_yamlet %>% explicit_guide
c <- 'RACE: [ subject race, //Caucasian//Latin//Black// ]' %>% as_yamlet %>% explicit_guide
d <- 'DATE: [ date, "%Y-%m-%d" ]' %>% as_yamlet %>% explicit_guide
e <- c(
names(a[[1]])[[2]],
names(b[[1]])[[2]],
names(c[[1]])[[2]],
names(d[[1]])[[2]]
)
expect_identical(e, c('units','codelist','encoding','format'))
x <- data.frame(
ID = 1,
CONC = 1,
RACE = 1,
SEX = 1,
DATE = 1
)
x$ID %<>% structure(label = 'subject identifier')
x$CONC %<>% structure(label = 'concentration', guide = 'ng/mL')
x$RACE %<>% structure(label = 'race', guide = list(white = 0, black = 1, asian = 2))
x$SEX %<>% structure(label = 'sex', guide = list(female = 0, male = 1))
x$DATE %<>% structure(label = 'date', guide = '%Y-%m-%d')
expect_identical(
x %>% explicit_guide %>% as_yamlet %>% lapply(names) %>% unlist %>% as.character,
c('label','label','units','label','codelist','label','codelist','label','format')
)
})
test_that('classified() creates class factor and removes attribute codelist',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% explicit_guide %>% classified %>% as_yamlet(exclude_attr = NULL)
expect_identical(
x$Creatinine %>% names,
c('levels','class','label','codelist')
)
expect_true('factor' %in% x$Heart$class)
})
test_that('resolve correctly classifies conditional elements',{
skip_if_not( l10n_info()$`UTF-8` )
skip_if(
.Platform$OS.type == "unix" && Encoding(enc2native("\U00B5")) != "UTF-8",
"Skipping non-ASCII path tests on UTF-8 Unix system"
)
library(magrittr)
library(dplyr)
file <- system.file(package = 'yamlet', 'extdata','phenobarb.csv')
x <- decorate(file)
x %>% as_yamlet
x %>% explicit_guide %>% as_yamlet
expect_warning( x %>% select(value) %>% explicit_guide %>% as_yamlet) # value looks like codelist because event not available to signal conditional
x %>% explicit_guide %>% classified %>% as_yamlet
a <- x %>% resolve %>% as_yamlet
expect_true(setequal(names(a$value), c('label','units', 'title')))
})
test_that('resolve correctly classifies factors',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
expect_true(file %>% decorate %>% resolve %$% Heart %>% inherits('factor'))
})
test_that('filter, select, mutate, group_by, arrange, summarize and [ do not drop subclass decorated',{
library(dplyr)
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_identical('decorated', x %>% class %>% `[[`(1))
expect_identical('decorated', x %>% filter(!is.na(conc)) %>% class %>% `[[`(1))
expect_identical(
'decorated',
x %>%
group_by(Subject) %>%
mutate(mxt = max(time)) %>%
class %>% `[[`(1)
)
expect_identical(
'decorated',
x %>%
select(Subject:interval) %>%
class %>% `[[`(1)
)
expect_identical(
'decorated',
x %>%
summarize(mx = max(time)) %>%
class %>% `[[`(1)
)
expect_identical(
'decorated',
x %>%
arrange(Subject,time) %>%
class %>% `[[`(1)
)
expect_identical(
'decorated',
class(x[1:5, 1:3])[[1]]
)
})
test_that('conditionalize errors on mixed quotes',{
library(dplyr)
library(magrittr)
x <- data.frame(column = 'foo', test = "can't\"", value = 1)
expect_error(
x %>% conditionalize(column, label, test, value) %>% as_yamlet
)
})
test_that('conditionalize alternates single and double quotes',{
library(dplyr)
library(magrittr)
x <- data.frame(
stringsAsFactors = FALSE,
column = 'foo',
test = c('"cant"',"can't"),
value = 1
)
expect_identical(
x %>% conditionalize(column, label, test, value) %>%
as_yamlet %$% column %$% label %>% names,
c( "test == '\"cant\"'", "test == \"can't\"")
)
})
test_that('conditionalize does not quote numerics',{
library(dplyr)
library(magrittr)
x <- data.frame(
column = 1,
test = 2,
value = 3
)
expect_identical(
x %>% conditionalize(column, label, test, value) %>%
as_yamlet %$% column %$% label %>% names,
"test == 2"
)
})
test_that('conitionalize handles factors like character',{
library(dplyr)
library(magrittr)
x <- data.frame(
stringsAsFactors = TRUE,
column = 'foo',
test = c('"cant"',"can't"),
value = 1
)
expect_identical(
x %>% conditionalize(column, label, test, value) %>%
as_yamlet %$% column %$% label %>% names,
c( "test == '\"cant\"'", "test == \"can't\"")
)
})
test_that('subset classified does not drop label', {
a <- classified(factor(letters))
attr(a, 'label') <- 'foo'
a <- a[1:3]
expect_identical(attr(a,'label'), 'foo')
})
test_that('is_parseable distinguishes udunits from non-udunits',{
expect_identical(
is_parseable(c('kg/m2','kg/m^2','foo','kg.m/s2')),
c(TRUE, TRUE, FALSE, TRUE)
)
})
test_that('is_pareseable is vectorized',{
expect_identical(
is_parseable(c('kg/m2','kg/m^2','foo','kg.m/s2')),
c(TRUE, TRUE, FALSE, TRUE)
)
})
test_that('micro symbol is_pareseable',{
# https://github.com/rstudio/httpuv/issues/264
# https://github.com/rstudio/httpuv/commit/32ba7d34e9d0895552db8346cea8acbed7a74022
skip_if_not( l10n_info()$`UTF-8` )
skip_if(
.Platform$OS.type == "unix" && Encoding(enc2native("\U00B5")) != "UTF-8",
"Skipping non-ASCII path tests on UTF-8 Unix system"
)
expect_true(is_parseable('µg/L'))
})
test_that('is_parseable respects locally-defined units',{
library(units)
expect_false(is_parseable('foo'))
install_unit('foo')
expect_true(is_parseable('foo'))
remove_unit('foo')
expect_false(is_parseable('foo'))
})
test_that('all valid spork print as axis label',{
library(magrittr)
library(dplyr)
library(ggplot2)
library(spork)
expect_silent(
data.frame(y=1:10, x=1:10) %>%
decorate("x: 1 joule^\\*. ~1 kg m^2./s^2") %>%
#decorate("x: ''") %>%
mutate(x = structure(x, label = x %>% attr('label') %>%
as_spork %>%
as_plotmath %>%
as.expression)) %>%
ggplot(aes(x, y))
)
expect_silent(
data.frame(y=1:10, x=1:10) %>%
decorate("x: gravitational force \\\\ (kg\\.m/s^2.)") %>%
mutate(x = structure(x, label = x %>% attr('label') %>%
as_spork %>%
as_plotmath %>%
as.expression)) %>%
ggplot(aes(x, y))
)
})
test_that('R reserved words survive in print.dg labels',{
library(magrittr)
library(dplyr)
library(ggplot2)
library(testthat)
expect_silent(
data.frame(y=1:10, x=1:10) %>%
decorate("x: for NaN% joule^\\*. ~1 kg m^2./s^2. %") %>%
#decorate("x: ''") %>%
mutate(x = structure(x, label = x %>% attr('label') %>%
as_spork %>%
as_plotmath %>%
as.expression)) %>%
ggplot(aes(x, y))
)
})
test_that('column attributes with metacharacters are quoted or escaped on write',{
library(magrittr)
library(dplyr)
library(ggplot2)
library(testthat)
datum <- "x: [ 'AUC , [0-24]', ng*h/mL ]"
x <- data.frame(x=1:10) %>% decorate(datum)
path <- tempdir()
file <- file.path(path,'foo.csv')
x %>% io_csv(file)
y <- readLines(sub('csv','yaml',file))
expect_identical(y, datum)
})
test_that('for each named column, or all if none named, the data.frame method for modify() assigns a value in the attributes environment',{
library(magrittr)
library(dplyr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% modify(title = paste(label, '(', guide, ')'), time)
x %>% select(time, conc) %>% as_yamlet
expect_identical(attr(x$time,'title'), 'time since start of study ( h )')
expect_identical(attr(x$conc,'title'), NULL)
# modify (almost) all columns
x %<>% modify(title = paste(label, '(', guide, ')'), -Subject)
x %>% select(time, conc) %>% as_yamlet
expect_identical(attr(x$time,'title'), 'time since start of study ( h )')
expect_identical(attr(x$conc,'title'), 'quinidine serum concentration ( mg/L )')
expect_identical(attr(x$Subject,'title'), NULL)
})
test_that('modify() makes the underlying object available as an argument',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% modify(`defined values` = sum(!is.na(.)))
x %>% select(time) %>% as_yamlet
expect_identical(attr(x$time,'defined values'), 1471L)
})
test_that('modify() makes the object name available for use and assignment',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% modify(time, name = label)
expect_identical(names(x)[[2]], 'time since start of study')
})
test_that('the data.frame method for modify() gives a warning if the assignment target is reserved (i.e, class, levels, labels, names)',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_warning(x %<>% modify(class = 'numeric', Subject))
})
test_that('the data.frame method for modify() fails gracefully if assignment cannot be made',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
if(exists('foo'))rm(foo)
expect_warning(x %<>% modify(title = foo, time))
})
test_that('the default method for modify() supports lists',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
a <- list(a = 1, b = 1:10, c = letters) %>% modify(length = length(.), b:c)
expect_identical(attr(a[['a']],'length'), NULL)
expect_identical(attr(a[['c']],'length'), 26L)
})
test_that('modifier verbs are limited to dots scope',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
# as_yamlet
expect_equal_to_reference(file = '060.rds', as_yamlet(x, Height))
# decorations
expect_equal_to_reference(file = '061.rds', decorations(x, Height))
# modify
expect_equal_to_reference(
file = '062.rds',
modify(x, Height, label = 'Height (cm)') %>% as_yamlet(Height,Weight)
)
# resolve
as_yamlet(x, Height, Weight)
expect_equal_to_reference(
file = '063.rds',
resolve(x, Height) %>% as_yamlet(Height, Weight)
)
})
test_that('io_res resolves guide ambiguity on read',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- io_csv(file) %>% resolve
y <- io_res(file)
expect_identical(x, y)
})
test_that('output of as_decorated inherits class decorated',{
x <- as_decorated(list())
expect_true(inherits(x,'decorated'))
})
test_that('xtable.decorated is stable',{
library(magrittr)
library(xtable)
options(yamlet_persistence = FALSE)
set.seed(0)
x <- data.frame(
auc = rnorm(100, mean = 2400, sd = 200),
bmi = rnorm(100, mean = 20, sd = 5),
gen = 0:1
)
x %<>% decorate('auc: [AUC_0-24, ng*h/mL]')
x %<>% decorate('bmi: [Body Mass Index, kg/m^2]')
x %<>% decorate('gen: [Gender, [Male: 1, Female: 0]]')
y <- xtable(x)
expect_equal_to_reference(file = '064.rds', y)
y <- xtable(x, auc:bmi)
expect_equal_to_reference(file = '065.rds', y)
expect_equal_to_reference(file = '066.rds', resolve(x))
expect_equal_to_reference(file = '067.rds', xtable(resolve(x)))
options(yamlet_persistence = TRUE)
})
test_that('promote is stable',{
library(magrittr)
meta <- system.file(package = 'yamlet', 'extdata','phenobarb.csv')
x <- read.csv(meta)
singularity(
data = x,
list(
"event == 'conc'",
"event == 'dose'",
"event == 'metabolite'"
)
) %>% expect_identical(0L)
singularity(
data = x[x$event == 'dose',],
list(
"event == 'conc'",
"event == 'dose'",
"event == 'metabolite'"
)
) %>% expect_identical(2L)
singularity(
data = x[x$event == 'dose',],
list(
"time >= 0",
"event == 'dose'"
)
) %>% expect_identical(NA_integer_)
file <- system.file(package = 'yamlet', 'extdata','phenobarb.csv')
x <- file %>% decorate
expect_equal_to_reference(
file = '068.rds',
x %>% dplyr:::filter.data.frame(event == 'dose') %>% promote(event) %>% decorations(value)
)
expect_equal_to_reference(
file = '069.rds',
x %>% filter(event == 'dose') %>% decorations(value)
)
expect_equal_to_reference(
file = '070.rds',
x %>% filter(event == 'dose') %>% decorations(value)
)
expect_equal_to_reference(
file = '071.rds',
x %>% filter(event == 'conc') %>% decorations(value)
)
expect_equal_to_reference(
file = '072.rds',
x[x$event == 'dose',] %>% decorations(event, value)
)
expect_equal_to_reference(
file = '073.rds',
x[x$event == 'conc',] %>% decorations(event, value)
)
})
test_that('ggready is stable',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_equal_to_reference(file = '074.rds',decorations(x, Weight))
expect_equal_to_reference(file = '075.rds',decorations(as.data.frame(x), Weight))
expect_equal_to_reference(file = '076.rds',class(x))
expect_equal_to_reference(file = '078.rds',class(ggready(as.data.frame(x))))
expect_equal_to_reference(file = '079.rds',class(ggready(x)))
expect_equal_to_reference(file = '080.rds',class(ggready(resolve(x))))
x <- ggready(x)
library(magrittr)
library(ggplot2)
# Here we filter on-the-fly
# without loss of attributes.
# Notice mg/L rendering; this is actually part of an expression.
file %>%
decorate %>%
filter(!is.na(conc)) %>%
ggready %>%
ggplot(aes(x = time, y = conc, color = Heart)) +
geom_point()
# By default ggready resolves everything decorated.
# But we can intervene to resolve selectively,
# And further intervene to 'ggready' selectively.
#
x <- file %>% decorate %>% filter(!is.na(conc))
x %>%
resolve(conc, time) %>% # Heart left unresolved!
ggready(conc, Heart) %>% # time left unreadied!
ggplot(aes(x = time, y = conc, color = Heart)) + geom_point()
# Still, all the labels were actually expressions:
expect_equal_to_reference(file = '081.rds',x %>%
resolve(conc, time) %>%
ggready(conc, Heart) %$% conc %>% attributes %$% label %>% class
)
})
test_that('ggplot.resolved is stable',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
library(ggplot2)
library(dplyr)
library(magrittr)
x <- decorate(file)
x %<>% filter(!is.na(conc))
expect_equal_to_reference(file = '082.rds',class(x))
expect_equal_to_reference(file = '083.rds',class(data.frame(x)))
expect_equal_to_reference(file = '084.rds',class(as_decorated(data.frame(x))))
# The bare data.frame gives boring labels and unordered groups.
map <- aes(x = time, y = conc, color = Heart)
data.frame(x) %>% ggplot(map) + geom_point()
# Decorated data.frame uses supplied labels.
# Notice CHF levels are still not ordered.
x %>% ggplot(map) + geom_point()
# We can resolve guide for a chance to enrich the output with units.
# Notice CHF levels are now ordered.
x %<>% resolve
suppressWarnings( # because this complains for columns with no units
x <- modify(x, title = paste0(label, '\n(', units, ')'))
)
x %>% ggplot(map) + geom_point()
# Or something fancier.
x %<>% modify(conc, title = 'conc_serum. (mg*L^-1.)')
x %>% ggplot(map) + geom_point()
# The y-axis title is deliberately given in spork syntax for elegant coercion:
library(spork)
x %<>% modify(conc, expression = as.expression(as_plotmath(as_spork(title))))
x %>% ggplot(map) + geom_point()
# Add a fancier label for Heart, and facet by a factor:
x %<>% modify(Heart, expression = as.expression(as_plotmath(as_spork('CHF^\\*'))))
x %>% ggplot(map) + geom_point() + facet_wrap(~Creatinine)
# ggready handles the units and plotmath implicitly for a 'standard' display:
x %>% ggready %>% ggplot(map) + geom_point() + facet_wrap(~Creatinine)
})
test_that('ggplot.resolved is stable',{
skip_if_not( l10n_info()$`UTF-8` )
skip_if(
.Platform$OS.type == "unix" && Encoding(enc2native("\U00B5")) != "UTF-8",
"Skipping non-ASCII tests on UTF-8 Unix system"
)
# Here we try a dataset with conditional labels and units.
file <- system.file(package = 'yamlet', 'extdata','phenobarb.csv')
x <- file %>% decorate %>% resolve
# Note that value has two elements for label and guide.
expect_equal_to_reference(file = '085.rds',x %>% decorations(value))
#'
# The print method defaults to the first, with warning.
map <- aes(x = time, y = value, color = event)
expect_warning(print(x %>% ggplot(map) + geom_point()))
# If we subset appropriately, the relevant value is substituted.
expect_silent(print(x %>% filter(event == 'conc') %>% ggplot(map) + geom_point()))
})
test_that('unclassified is the inverse of classified',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% explicit_guide
y <- classified(x)
z <- unclassified(y)
# x %>% decorations(Creatinine)
# y %>% decorations(Creatinine)
# z %>% decorations(Creatinine)
# attr(y$Creatinine, 'codelist')
# identical(
# attr(x$Creatinine, 'codelist'),
# attr(z$Creatinine, 'codelist')
# )
# str(attr(x$Creatinine,'codelist'))
# str(attr(z$Creatinine,'codelist'))
#
# names(names(attr(x$Creatinine,'codelist')))
# names(names(attr(z$Creatinine,'codelist')))
expect_identical(x, z)
})
test_that('desolve is the inverse of resolve',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_identical(x, desolve(resolve(x)))
})
test_that('implicit_guide is the inverse of explicit_guide',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_identical(x, implicit_guide(explicit_guide(x)))
})
test_that('resolve and desolve retain class',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_true(inherits(resolve(x), 'decorated'))
expect_true(inherits(desolve(resolve(x)), 'decorated'))
})
test_that('labels and guide elements with colon-space are quoted',{
foo <- data.frame(x = 1)
attr(foo$x,'label') <- 'foo: x'
guide <- list(1)
names(guide) <- 'H: M'
attr(foo$x, 'guide') <- guide
dir <- tempdir()
file <- file.path(dir, 'foo.csv')
foo %>% io_csv(file)
expect_silent(io_csv(file))
})
test_that('classified methods do not lose attributes',{
foo <- classified(letters[1:5])
bar <- classified(LETTERS[1:5])
attr(foo, 'label') <- 'letters'
attr(bar, 'label') <- 'LETTERS'
foo[2:3] <- c('a','b')
foo[[4]] <- 'c'
expect_true(
setequal(
names(attributes(c(foo,bar))),
c('levels','class','codelist','label')
)
)
expect_true(
setequal(
names(attributes(foo[1:2])),
c('levels','class','codelist','label')
)
)
expect_true(
setequal(
names(attributes(foo[[2]])),
c('levels','class','codelist','label')
)
)
})
test_that('unclassified methods do not lose attributes',{
foo <- classified(letters[1:5])
attr(foo, 'label') <- 'letters'
foo <- unclassified(foo)
expect_true(
setequal(
names(attributes(foo)),
c('codelist','label','class')
)
)
})
test_that('classified() works the same on character and factor',{
expect_identical(classified(LETTERS), classified(factor(LETTERS)))
})
test_that('as_yamlet does not capture levels of classified by default',{
library(magrittr)
library(dplyr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
y <- x
y$Heart %<>% classified
expect_true(
setequal(
names(decorations(y, Heart)[[1]]),
c('label','guide','codelist')
)
)
decorations(x, Heart)
})
test_that('filter.decorated retains class', {
library(dplyr)
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_true(inherits(x %>% filter(Subject == 1), 'decorated'))
})
test_that('promote() retains class decorated', {
library(dplyr)
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','phenobarb.csv')
x <- decorate(file)
x %<>% filter(event == 'dose')
decorations(x)
expect_true(inherits(x, 'decorated'))
})
test_that('decorations() treats factor levels the same for factor and classified',{
library(dplyr)
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_false('levels' %in% (x %>% decorations(Race) %>% `[[`(1) %>% names))
expect_false('levels' %in% (x %>% resolve %>% decorations(Race) %>% `[[`(1) %>% names))
})
test_that('mimic() is stable',{
library(dplyr)
library(magrittr)
let <- letters[1:5]
LET <- LETTERS[1:5]
int <- 0L:4L
num <- as.numeric(int)
fac <- factor(let)
css <- classified(let)
expect_equal_to_reference(mimic(let, let), '086.rds')
expect_equal_to_reference(mimic(LET, let), '087.rds')
expect_equal_to_reference(mimic(int, let), '088.rds')
expect_equal_to_reference(mimic(num, let), '089.rds')
expect_equal_to_reference(mimic(fac, let), '090.rds')
expect_equal_to_reference(mimic(css, let), '091.rds')
expect_equal_to_reference(mimic(character(0)), '092.rds')
expect_equal_to_reference(mimic(numeric(0)), '093.rds')
expect_equal_to_reference(mimic(LET), '094.rds')
x <- data.frame(let, LET)
# x %<>% mutate(let = mimic(let, LET), LET = mimic(LET))
expect_equal_to_reference(x, '095.rds')
})
test_that('subset retains class for decorated inheriting grouped_df',{
library(dplyr)
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% group_by(Subject)
attr(x[['time']], 'foo') <- 'bar'
expect_true(inherits(x, 'decorated'))
# also for names<-
})
test_that('classified may contain NA',{
expect_silent(
classified(c(1,NA))
)
expect_silent(
classified(c(1,NA), exclude = NULL)
)
})
test_that('bind_rows() works for grouped_df containing classified factors',{
library(magrittr)
library(dplyr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
b <- decorate(file) %>% resolve
b %<>% group_by(Subject)
expect_silent(bind_rows(b,b))
a <- data.frame(i = c(1,1,2), x = classified(1:3))
b <- data.frame(i = c(2,2,3), x = classified(3:5))
a %<>% group_by(i)
b %<>% group_by(i)
# str(a)
# str(b)
bind_rows(a,b) %$% x %>% attributes
expect_silent(bind_rows(a,b))
expect_identical(bind_rows(a,b) %$% x %>% attributes %$% codelist, as.character(1:5))
})
test_that('gather.decorated respects supplied key and value',{
library(magrittr)
library(tidyr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
# x %>% gather('key', 'value', time, interval) %>% decorations
# x %>% gather('key', 'value', time, interval) %>% names()
# x %>% gather(key = 'key', value = 'value', time, interval) %>% names()
suppressWarnings(nms <- names(
gather(
x,
key = 'source',
value = 'widgets',
time,
interval
)
))
expect_true(all(c('source','widgets') %in% nms))
})
test_that('gather.decorated with no arguments is a non-operation',{
library(magrittr)
library(tidyr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_identical(x, gather(x, key = 'source', value = 'widgets'))
expect_identical(x, gather(x, key = 'source', value = 'widgets', !!!character(0)))
})
test_that('mimic is stable',{
let <- letters[1:5]
LET <- LETTERS[1:5]
int <- 0L:4L
num <- as.numeric(int)
fac <- factor(let)
css <- classified(let)
expect_equal_to_reference(file = '096.rds',
list(
mimic(LET, let),
mimic(let, let),
mimic(num, let),
mimic(int, let),
mimic(fac, let),
mimic(css, let),
mimic(character(0)),
mimic(numeric(0)),
mimic(LET),
mimic(let),
mimic(num),
mimic(int),
mimic(fac),
mimic(css)
))
})
test_that('factor and character can mimic numeric',{
let <- letters[1:5]
LET <- LETTERS[1:5]
int <- 0L:4L
num <- as.numeric(int)
fac <- factor(let)
css <- classified(let)
expect_silent(mimic(let, num))
expect_silent(mimic(fac, num))
expect_silent(mimic(css, num))
mimic(css, num)
unclassified(mimic(css, num))
expect_true(is.numeric(unclassified(mimic(css, num))))
mimic(css, as.character(num))
unclassified(mimic(css, as.character(num)))
expect_true(is.numeric(unclassified(mimic(css, as.character(num)))))
expect_true(
is.integer(
unclassified(
mimic(css, as.numeric(css))
)
)
)
# expect_error(mimic(css, as.integer(css))) # don't know why this should be an error
expect_silent(mimic(css, as.integer(css)))
})
test_that('as.integer.classified() returns integer with guide',{
css <- classified(letters[1:3], labels = LETTERS[1:3])
int <- as.integer(css)
expect_true('guide' %in% names(attributes(int)))
expect_true(is.integer(int))
})
test_that('as.integer.classified() is equivalent to as.numeric.classified()',{
css <- classified(c('knife','fork','spoon'))
expect_true(all(as.integer(css) == as.numeric(css)))
})
test_that('modify() does not search for assignment targets beyond data scope',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
suppressWarnings(x %<>% modify(time, SORT = .data$sort))
expect_false('sort' %in% names(attributes(x$time)))
})
test_that('print.yamlet handles unexpected objects nicely',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% modify(time, SORT = sort)
# print(decorations(x,time))
expect_equal_to_reference(file = '097.rds', decorations(x, time))
})
test_that('subset decorated succeeds when dimensions are dropped',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_silent(x[1,1])
})
test_that('NA names and values in lists can be converted to yamlet',{
expect_silent(to_yamlet(setNames(1:3, c('a','b',NA))))
expect_silent(to_yamlet(setNames(c(1,2,NA), c('a','b','c'))))
})
test_that('a length one sequence resolves parsimoniously',{
y <- as_yamlet('RACE: [ race, [ Asian: 1 ]]')
expect_equal(names(y[[1]][2]), 'guide')
})
test_that('column named *n* can be decorated',{
library(magrittr)
library(dplyr)
x <- data.frame(n = 1)
x %<>% decorate('"n": count')
expect_identical('count',decorations(x)$n$label)
})
test_that('column named *scenario* can have label *Scenario* even if there is a column with this name',{
library(magrittr)
library(dplyr)
x <- data.frame(scenario = 1, Scenario = 1)
x %<>% decorate('scenario: Scenario')
x %<>% decorate('Scenario: scenario')
expect_identical('Scenario', decorations(x)$scenario$label)
})
test_that('write_yamlet uses canonical attribute order by default',{
x <- data.frame(x = 1, y = 1, z = factor('a'))
x %<>% decorate('
x: [ guide: mm, desc: this, label: foo ]
"y": [ guide: bar, desc: other ]
')
expect_equal_to_reference(file = '101.rds', capture.output(write_yamlet(x)))
})
test_that('moot redecorate warnings are suppressed',{
x <- data.frame(x = 1, y = 1, z = factor('a'))
x %<>% decorate('
x: [ guide: mm, desc: this, label: foo ]
"y": [ guide: bar, desc: other ]
')
expect_silent(x %>% decorate(decorations(x)))
expect_warning(x %>% decorate('x: bar'))
expect_silent(x %>% decorate('x: bar', overwrite = TRUE))
})
test_that('class "decorated" persists after merges, joins, enumerations',{
library(magrittr)
library(dplyr)
x <- data.frame(foo = 1, bar = 2)
x %<>% decorate('foo: [distance, mm]')
x %<>% decorate('bar: [height, mm]')
expect_true(inherits(x, 'decorated'))
expect_true(inherits(full_join(x,x), 'decorated'))
expect_true(inherits(left_join(x,x), 'decorated'))
expect_true(inherits(left_join(x, as.data.frame(x)), 'decorated'))
expect_false(inherits(full_join(as.data.frame(x), x), 'decorated'))
expect_true(inherits(what = 'decorated', merge(x,x)))
# if(require(wrangle)){
# expect_true(inherits(what = 'decorated', enumerate(x, foo, bar)))
# } # check gives warning
})
test_that('decorations() does not print colon for un-named list',{
x <- data.frame(foo = c('a','b','c'))
x %<>% decorate('foo: [title, [[1,2],[2,3]]]')
foo <- capture_output(decorations(x), print = TRUE)
foo <- sub(':','', foo) # remove the only expected colon
expect_false(grepl(':', foo))
})
test_that('read_yamlet and write_yamlet reproduce block quote',{
x <- read_yamlet('
x:
background: |
x is so happy
a variable of note
it wants to help you
sentence: >
Sometimes we don\'t really
care where the line breaks
are.')
expect_equal_to_reference(
file = '102.rds',
capture_output(
print = TRUE,
write_yamlet(x)
)
)
expect_equal_to_reference(
file = '103.rds',
capture_output(
print = TRUE,
write_yamlet(x, block = TRUE)
)
)
})
test_that('decorated retains class when ungrouped', {
expect_true(inherits(ungroup(as_decorated(group_by(Theoph, Subject))), 'decorated'))
})
test_that('length-one codelists are not confused with units',{
x <- data.frame(race = 2, sex = 'M', conc = 1, time = 0)
x %<>% decorate('
race: [ Race, [ Asian: 2 ]]
sex: [ Sex, [M] ]
')
#x %>% resolve %>% decorations
expect_identical(
'codelist',
x %>% resolve %>% decorations %$% race %>% names %>% extract2(2)
)
expect_identical(
'codelist',
x %>% resolve %>% decorations %$% sex %>% names %>% extract2(2)
)
expect_equal_to_reference(
file = '104.rds',
'sex: [ Sex, M ]' %>% yaml.load(handlers = list(seq = parsimonious))
)
expect_equal_to_reference(
file = '105.rds',
'sex: [ Sex,[ M ]]' %>% yaml.load(handlers = list(seq = parsimonious))
)
expect_equal_to_reference(
file = '106.rds',
'sex: [ Sex,[ M, F ]]' %>% yaml.load(handlers = list(seq = parsimonious))
)
})
test_that('un-named codelists are back-transformed consistently',{
expect_identical(
'sex: Sex',
capture.output(write_yamlet(as_yamlet('sex: Sex')))
)
expect_identical(
'sex: [ Sex, M ]',
capture.output(write_yamlet(as_yamlet('sex: [ Sex, M ]')))
)
expect_identical(
'sex: [ Sex, [ M ]]',
capture.output(write_yamlet(as_yamlet('sex: [ Sex, [ M ]]')))
)
expect_identical(
'sex: [ Sex, [ M, F ]]',
capture.output(write_yamlet(as_yamlet('sex: [ Sex, [ M, F ]]')))
)
})
test_that('named codelists are back-transformed consistently',{
expect_identical(
'sex: [ Sex, [ Male: M ]]',
capture.output(write_yamlet(as_yamlet('sex: [ Sex, [ Male: M ]]')))
)
expect_identical(
'sex: [ Sex, [ Male: M, Female: F ]]',
capture.output(write_yamlet(as_yamlet('sex: [ Sex, [ Male: M, Female: F ]]')))
)
})
test_that('class "guided" or similar supports concatenation of guides',{
# Use vctrs to achieve consistent attribute treatment.
# see test-dvec.R
})
test_that('variables with units support unit math',{
# write converters for guided -> units and back
# see test-dvec.R
})
test_that('classified.data.frame passes exclude = NULL to member factors',{
x <- data.frame(letters = c('a','b','c','d', NA))
x %<>% decorate('letters: [Letters, [ a, b, c, d, NA ]]')
x %>% decorations
x %<>% explicit_guide
x %>% decorations
x %<>% classified(exclude = NULL)
expect_true(NA %in% attr(x$letters, 'codelist'))
expect_true(NA %in% levels(x$letters))
})
test_that('codelist can contain literal NA if quoted',{
x <- data.frame(letters = c('a','b','c','d', 'NA'))
x %<>% decorate('letters: [Letters, [ a, b, c, d, "NA" ]]')
x %>% decorations
x %<>% explicit_guide
x %>% decorations
x %<>% classified
expect_true('NA' %in% attr(x$letters, 'codelist'))
expect_true('NA' %in% levels(x$letters))
})
test_that('when two different decodes have the same code, classified levels match classified codelist values',{
x <- data.frame(letters = c('a','a','b'))
x %<>% decorate('letters: [Letters, [ TRT1: a, TRT2: a, TRT3: b ]]')
x
expect_warning({
x %>% resolve
x %>% resolve %>% desolve
x %>% resolve %>% desolve %>% resolve
x %<>% resolve
})
expect_identical(
levels(x$letters),
unlist(as.character(attr(x$letters, 'codelist')))
)
})
test_that('when two different codes have the same decode, classified levels match unique classified codelist values',{
x <- data.frame(letters = c('a','b','c'))
x %<>% decorate('letters: [Letters, [ TRT1: a, TRT2: b, TRT2: c ]]')
x
expect_warning({
x %>% resolve
x %>% resolve %>% desolve
x %>% resolve %>% desolve %>% decorations
x %>% resolve %>% desolve %>% resolve
x %<>% resolve
})
levels(x$letters)
as.character(attr(x$letters, 'codelist'))
expect_identical(
x %$% letters %>% levels,
x %$% letters %>% attr('codelist') %>%
as.character %>% unlist %>% unique
)
})
test_that('ggplot succeeds for class decorated that has no labels',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
library(ggplot2)
library(dplyr)
library(magrittr)
expect_silent(a <- file %>% as.csv %>% filter(!is.na(conc)) %>% as_decorated %>%
ggplot(aes(x = time, y = conc, color = Heart)) + geom_point())
# look for legend: congestive heart failure (mod/no/sev)
})
test_that('classified does not re-classify',{
# avoid alternating states
x <- data.frame(
age = c(53, 58, 60),
sex = c(0, 1, 1),
race = c(1, 1, 2)
)
x %<>% decorate('
age: [ Age, year ]
sex: [ Sex, [ Female: 0, Male: 1 ]]
race: [ Race, [White: 1, Asian: 2 ]]
')
x
x %>% resolve
x %>% resolve(sex)
x %>% resolve(sex) %>% resolve
x %>% resolve %$% sex %>% attributes
x %>% resolve(sex) %>% resolve %$% sex %>% attributes
x %>% resolve(sex) %$% sex %>% attributes
foo <- x %>% resolve(sex)
# this drops sex label:
foo %>% resolve %>% decorations
expect_identical(
x %>% resolve,
x %>% resolve(sex) %>% resolve
)
expect_identical(
x %>% resolve,
x %>% resolve(race) %>% resolve
)
expect_identical(
x %>% resolve,
x %>% resolve(age) %>% resolve
)
})
test_that('io_csv.character allows user to over-ride meta',{
# issue 3
expect_silent(
x <- io_csv(
system.file(package = 'yamlet','extdata/phenobarb.csv'),
meta = system.file(package = 'yamlet','extdata/quinidine.yaml')
)
)
expect_identical(NULL, attr(x$Wt, 'label'))
})
test_that('[ can be the first character of a code or decode',{
# issue 2
x <- data.frame(range = '[min,max]')
expect_silent(x %<>% decorate('range: [ Range, [ "[minimum,maximum]": "[min,max]" ]]'))
expect_silent(decorations(x))
where <- tempdir()
x %>% io_csv(file.path(where, 'bracket.csv'))
y <- io_csv(file.path(where, 'bracket.csv'), source = FALSE)
expect_identical(x,y)
})
test_that('Quoted Yes and No survive parsing verbatim',{
x <- "blq: [ LOQ Y/N, [ 'No': 0, 'Yes': 1 ]]"
y <- x %>% write_yamlet %>% as.character
x
y
expect_identical(x, y)
})
test_that('append_units() supports specific target',{
x <- as_dvec(1:10, label = 'acceleration', units = 'm/s^2')
x %<>% append_units(target = 'title')
expect_true('title' %in% names(attributes(x)))
})
test_that('make_title() honors pass-through arguments for append_units()',{
x <- as_dvec(1:10, label = 'acceleration', units = 'm/s^2')
x %<>% make_title(open = '[', close = ']')
attr(x, 'title')
expect_identical(attr(x, 'title'), "acceleration[m/s^2]")
})
test_that('make_title() / drop_title() active on resolve() and desolve()',{
x <- data.frame(
age = c(53, 58, 60),
sex = c(0, 1, 1),
race = c(1, 1, 2)
)
x %<>% decorate('
age: [ Age, year ]
sex: [ Sex, [ Female: 0, Male: 1 ]]
race: [ Race, [White: 1, Asian: 2 ]]
')
x
x %<>% resolve
expect_true('title' %in% names(attributes(x$age)))
x %<>% desolve
expect_false('title' %in% names(attributes(x$age)))
})
test_that('make_title() can be globally defeated',{
options(yamlet_with_title = FALSE)
x <- data.frame(
age = c(53, 58, 60),
sex = c(0, 1, 1),
race = c(1, 1, 2)
)
x %<>% decorate('
age: [ Age, year ]
sex: [ Sex, [ Female: 0, Male: 1 ]]
race: [ Race, [White: 1, Asian: 2 ]]
')
x
x %<>% resolve
expect_false('title' %in% names(attributes(x$age)))
options(yamlet_with_title = NULL)
})
test_that('yamlet_options() displays globally-configurable options',{
options(yamlet_with_title = FALSE)
expect_true('yamlet_with_title' %in% names(yamlet_options()))
options(yamlet_with_title = NULL)
expect_false('yamlet_with_title' %in% names(yamlet_options()))
})
test_that('make_title() behaves as expected for class dvec',{
x <- as_dvec(1:10, label = 'length', guide = 'mm')
expect_false('title' %in% (x %>% make_title %>% attributes %>% names))
expect_true('title' %in% (x %>% resolve %>% make_title %>% attributes %>% names))
})
test_that('add_title() and drop_title() have no effect on (undecorated) data.frame',{
x <- data.frame(
age = c(53, 58, 60),
height = c(155, 130, 145),
race = c(1, 2, 2)
)
x %<>% decorate('
age: [ Age, year ]
height: [ Height, cm, title: "Subject Height [cm]" ]
race: [ Race, [White: 1, Asian: 2 ]]
')
x %>% decorations
x %<>% as.data.frame
x %>% decorations # still has decorations, but is just a data.frame
x %<>% make_title
x %>% decorations
expect_false('title' %in% names(attributes(x$age)))
x %<>% drop_title
x %>% decorations
expect_true('title' %in% names(attributes(x$height)))
})
test_that('row_bind of supported table types returns consistent class and functional metadata',{
library(dplyr)
a <- data.frame(study = 1) %>% decorate('study: [Study, [A: 1]]', persistence = FALSE)
class(a) <- 'data.frame'
b <- data.frame(study = 2) %>% decorate('study: [Study, [B: 2]]') # decorated data.frame
c <- tibble(study = 3) %>% decorate('study: [Study, [C: 3]]') # decorated tbl_df
c %<>% group_by(study) # decorated grouped_df
# per ?bind_rows: bind_rows() returns the same type as the first input,
# either a data.frame, tbl_df, or grouped_df
# or by extension, decorated data.frame, decorated tbl_df, decorated grouped_df
# bind_rows(a, a) %>% str # no magic, attributes dropped, not surprising
# bind_rows(b, b) %>% str # magic
# bind_rows(c, c) %>% str # magic
# bind_rows(a, b) %>% str # magic @ 0.10.7
# bind_rows(b, a) %>% str # magic
# bind_rows(a, c) %>% str # magic @ 0.10.7
# bind_rows(c, a) %>% str # magic
# bind_rows(b, c) %>% str # returns decorated data.frame, not surprising
# bind_rows(c, b) %>% str # magic
expect_equal_to_reference(file = '108.rds', decorations(bind_rows(a, a)))
expect_equal_to_reference(file = '109.rds', decorations(bind_rows(b, b)))
expect_equal_to_reference(file = '110.rds', decorations(bind_rows(c, c)))
expect_equal_to_reference(file = '111.rds', decorations(bind_rows(a, b)))
expect_equal_to_reference(file = '112.rds', decorations(bind_rows(b, a)))
expect_equal_to_reference(file = '113.rds', decorations(bind_rows(a, c)))
expect_equal_to_reference(file = '114.rds', decorations(bind_rows(c, a)))
expect_equal_to_reference(file = '115.rds', decorations(bind_rows(b, c)))
expect_equal_to_reference(file = '116.rds', decorations(bind_rows(c, b)))
# Conclusions:
# * Without any additional intervention, 'decorated'
# always appears first before 'tbl_df' or 'grouped_df'
# * Without additional intervention, bind_rows() always
# returns the data type of first argument.
# * bind_rows() drops meta if returning data.frame.
# * bind_rows() respects 'vestigal' meta on data.frames otherwise.
})
test_that('yamlet warns if codelist not one-to-one',{
x <- data.frame(
age = c(53, 58, 60),
height = c(155, 130, 145),
race = c(1, 1, 1),
ethnicity = c(0, 0, 1)
)
x %<>% decorate('
age: [ Age, year ]
height: [ Height, cm, title: "Subject Height [cm]" ]
race: [ Race, [White: 1, White: 1, Asian: 1 ]]
ethnicity: [ Ethnicity, [ Hispanic: 0, Hispanic: 1]]
')
expect_warning(x %>% resolve %>% decorations)
expect_warning(x %>% resolve)
})
test_that('yamlet warns if row_bind gives overlapping codelist',{
library(dplyr)
x <- data.frame(
race = c(1, 2, 2)
)
x %<>% decorate('
race: [ Race, [White: 1, Asian: 2 ]]
')
y <- data.frame(
race = c(1, 2, 2)
)
y %<>% decorate('
race: [ Race, [Asian: 1, White: 2, Black: 3]]
')
expect_warning(bind_rows(x, y) %>% resolve)
expect_warning(bind_rows(x, y))
})
test_that('print.decorated_ggplot() warns if label has length > 1',{
library(magrittr)
library(ggplot2)
library(yamlet)
a <- Theoph %>%
as.data.frame %>%
decorate('
conc: Concentration
Time: Time
') %>%
mutate(source = 'Theoph')
b <- a %>%
ggplot(
aes(
x = Time,
y = conc
)
) +
geom_point() +
ggtitle(a$source)
b$labels
expect_warning(print(b))
})
test_that('yamlet can decorate n and N', {
x <- data.frame(a = 0, n = 0, N = 0)
x %<>% decorate('a: test')
x %<>% decorate('"n": number')
x %<>% decorate('"N": [ newtons, kg*m*s-2 ]')
expect_identical(attr(x$N, 'label'), 'newtons')
})
test_that('decorations for "n" etc. survive trip to storage', {
x <- data.frame(n = 0, sam = 0, wt = 0)
x %<>% decorate('
"n": [ Number, [a: 0, b: 1, c: -1], sort: 1]
sam: Number of Samples
wt: [ Body Weight, kg ]
')
y <- x %>% io_yamlet(tempfile()) %>% io_yamlet
expect_identical(decorations(x), y)
})
test_that('decorating with guide element -1 survives trip to storage as integer',{
expect_identical(to_yamlet(-1L), "-1")
})
test_that('classified.classified() drops unused levels',{
a <- factor(c('knife','fork'), levels = c('knife','fork','spoon'))
levels(a) # three levels
levels(factor(a)) # two levels
b <- classified(a)
levels(b) # three levels
levels(classified(b))
levels(classified(b, drop = TRUE))
expect_identical(levels(classified(b, drop = TRUE)), c('knife', 'fork'))
b
classified(b)
expect_silent(classified(b, levels = 'knife'))
expect_error(classified(b, labels = 'knife'))
expect_silent(classified(b, labels = c('Knife','Fork','Spoon')))
expect_error(classified(b, labels = c('Knife','Fork','Spoon'), exclude = 'fork'))
expect_silent(classified(b, drop = TRUE, labels = c('Knife','Fork')))
})
test_that('classified() supports NA values',{
a <- factor(c('knife','fork','spoon'), levels = c('knife','fork'))
b <- classified(a)
expect_true(any(is.na(b)))
expect_false(any(is.na(attr(b, 'codelist'))))
expect_identical(levels(a), levels(b))
})
test_that('classified() supports NA levels',{
a <- factor(c('knife','fork', NA), levels = c('knife','fork',NA), exclude = NULL)
expect_true(any(is.na(levels(a))))
b <- classified(a, exclude = NULL)
expect_false(any(is.na(b)))
expect_true(any(is.na(attr(b, 'codelist'))))
levels(a)
levels(b)
expect_identical(levels(a), levels(b))
})
test_that('as.integer.classified() supports NA values and levels',{
a <- classified(
factor(
c('knife','fork','spoon'),
levels = c('knife','fork')
)
)
b <- classified(
factor(
c('knife','fork',NA),
levels = c('knife','fork',NA),
exclude = NULL
),
exclude = NULL
)
ai <- as.integer(a, -1)
expect_identical(as.integer(ai), c(0L, 1L, NA))
expect_identical(as.integer(attr(ai, 'guide')), c(0L, 1L))
expect_identical(names(attr(ai, 'guide')), c('knife','fork'))
bi <- as.integer(b, -1, exclude = NULL)
expect_false(any(is.na(bi)))
expect_true(any(is.na(names(attr(bi, 'guide')))))
})
test_that('classified() handles multiple new levels appropriately',{
a <- structure(1:3, codelist = list(knife = 1, fork = 2, spoon = 3))
b <- classified(a)
expect_identical(b, classified(b))
expect_warning(
c <- classified(
b,
levels = c('knife','fork','spoon','chopstix','ladel'),
labels = c('Knife','Fork','Spoon','Chopstix','Ladel')
)
)
})
test_that('literal NA and NA_character_ survive round-trip',{
a <- 'letters: [ Letters, [ a, b, c, NA ]]'
x <- data.frame(letters = c('a','b','c', NA))
x %<>% decorate(a)
b <- write_yamlet(x)
expect_identical(a, b)
a <- "letters: [ Letters, [ a, b, c, 'NA' ]]"
x <- data.frame(letters = c('a','b','c', 'NA'))
x %<>% decorate(a)
b <- write_yamlet(x)
expect_identical(a, b)
})
test_that('yamlet names can be true NA or NA string',{
a <- "letters: [ Letters, [ A: a, B: b, C: c, 'NA': 'NA', NA: NA ]]"
x <- data.frame(letters = c('a','b','c', 'NA', NA ))
x %<>% decorate(a)
foo <- capture.output(b <- write_yamlet(x))
expect_identical(a, b)
c <- attr(x$letters, 'guide')
expect_true(any(is.na(names(c))))
expect_true(any(is.na(c)))
expect_equal_to_reference(capture.output(decorations(x)), file = '118.rds')
x %<>% redecorate("letters: [ Letters, [ a, b, c, 'NA', NA ]]")
expect_equal_to_reference(capture.output(decorations(x)), file = '119.rds')
})
test_that('as.integer.classified gives fully-recoverable result when NA is a level',{
library(dplyr)
x <- data.frame(letters = c('a','b','c',NA))
x %<>% decorate('letters: [ Letters, [NA, a, b, c ]]')
x %<>% resolve(exclude = NULL)
x %<>% mutate(letters = classified(letters, exclude = NULL))
x %<>% mutate(letters = as.integer(letters, -1, exclude = NULL))
expect_silent(x %>% resolve(letters))
x %<>% resolve
expect_equal_to_reference(x, file = '120.rds')
})
test_that('mimic supports solitary NA',{
expect_silent(
{
mimic(NA, NA)
mimic(factor(NA), NA)
mimic(factor(NA, exclude = NULL), NA)
mimic(NA, 1)
mimic(factor(NA), 1)
mimic(factor(NA, exclude = NULL), 1)
mimic(factor(NA, levels = c(NA, 'foo')), 1)
mimic(factor(NA, levels = NA, exclude = NULL), 1)
}
)
expect_silent(
{
mimic(
factor(
NA,
levels = NA,
exclude = NULL
),
1,
exclude = NULL
)
}
)
})
test_that('as.integer.classified preserves all levels',{
a <- classified(
c('knife','fork'),
levels = c(NA, 'knife','fork','spoon'),
exclude = NULL
)
attr(a, 'label') <- 'my label'
b <- as.integer(a)
guide <- unlist(attr(b, 'guide'))
nms <- names(guide)
names(guide) <- NULL
expect_identical(nms, levels(a))
expect_identical(guide, 1:4)
})
test_that('modify supports nonstandard column names',{
a <- data.frame(`has space` = 0, check.names = FALSE)
expect_silent(modify(a, 'has space', name = name))
})
Try the yamlet package in your browser
Any scripts or data that you put into this service are public.
yamlet documentation built on Oct. 6, 2023, 9:07 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
library(testthat)
library(magrittr)
library(yaml)
test_that('yaml package result is stable',{
expect_equal_to_reference(file = '001.rds', yaml.load('[ID: ]'))
expect_equal_to_reference(file = '002.rds', yaml.load('ID: '))
expect_equal_to_reference(file = '003.rds', yaml.load('[ ID: ]'))
expect_equal_to_reference(file = '004.rds', yaml.load('[ ID: ]'))
expect_equal_to_reference(file = '005.rds', yaml.load('RACE'))
expect_equal_to_reference(file = '006.rds', yaml.load('RACE:'))
expect_equal_to_reference(file = '007.rds', yaml.load('? RACE'))
expect_equal_to_reference(file = '008.rds', yaml.load('[{RACE: }, ID: ]'))
expect_equal_to_reference(file = '009.rds', yaml.load('[? RACE, ? ID]'))
expect_equal_to_reference(file = '010.rds', yaml.load('[RACE: , ID: ]'))
expect_equal_to_reference(file = '011.rds', yaml.load('RACE: [ race, [ foo: bar, hey: baz ]]'))
expect_equal_to_reference(file = '012.rds', yaml.load('RACE: [ race, [ {foo: bar}, {hey: baz} ]]'))
expect_equal_to_reference(file = '013.rds', yaml.load('RACE: [ race, [ {foo: bar}, hey: baz ]]'))
expect_equal_to_reference(file = '014.rds', yaml.load('RACE: [ race, [ {foo: bar}, ? baz ]]'))
expect_equal_to_reference(file = '015.rds', yaml.load('RACE: [ race, [ {foo: bar}, baz: ]]'))
expect_equal_to_reference(file = '016.rds', yaml.load('RACE: [ race, [ {foo: bar}, hey: ]]'))
expect_equal_to_reference(file = '017.rds', yaml.load('RACE: [ race, [ bar, baz ]]'))
expect_equal_to_reference(file = '018.rds', yaml.load('RACE: [ race, [ {foo: bar} ]]'))
expect_equal_to_reference(file = '019.rds', yaml.load('RACE: [ label: race, [ foo: bar ]]'))
expect_equal_to_reference(file = '020.rds', yaml.load('RACE: [ label: race, [ foo: bar, hey: baz ]]'))
expect_equal_to_reference(file = '021.rds', yaml.load('RACE: [ label: race, [ foo: bar, baz ]]'))
expect_equal_to_reference(file = '022.rds', yaml.load('1')) # a length-one vector
expect_equal_to_reference(file = '023.rds', yaml.load('a')) # a length-one vector
expect_equal_to_reference(file = '024.rds', yaml.load('a:')) # a length-one named list
expect_equal_to_reference(file = '025.rds', yaml.load('a: ')) # a length-one named list
expect_equal_to_reference(file = '026.rds', yaml.load('? a')) # a length-one named list
expect_equal_to_reference(file = '027.rds', yaml.load('[ 0]')) # a length-one sequence, represented as a vector
expect_equal_to_reference(file = '028.rds', yaml.load('[ 0, 1]')) # a sequence, represented as a vector
expect_equal_to_reference(file = '029.rds', yaml.load('a: 0')) # a length-one mapping, represented as a length-one named list
expect_equal_to_reference(file = '030.rds', yaml.load('[a: 0]')) # a list of named list * recursive
expect_equal_to_reference(file = '031.rds', yaml.load('[a: 0, b: 1]')) # a list of named lists *
expect_equal_to_reference(file = '032.rds', yaml.load('[a: [0,1,2], b: 1]')) # a list of lists *
expect_equal_to_reference(file = '033.rds', yaml.load('[a: [0,1,2], 5 ]')) # a list of one list and one int
expect_equal_to_reference(file = '034.rds', yaml.load('[ [ [ [d: [0, 1, 2]]]]]')) # a list of named list * recursive
})
test_that('as_yamlet result is stable',{
expect_equal_to_reference(file = '035.rds', as_yamlet('RACE: [white: 0, 1 ]')) # surprising, but correct.
expect_equal_to_reference(file = '036.rds', as_yamlet('RACE: [race, [white: 0, 1 ]]'))
expect_equal_to_reference(
file = '037.rds', # @ 0.7.7 this was runaway parsimony
as_yamlet(
'RACE: [ race, [ foo: bar ]]' # @ 0.7.8 we see (correctly) label, guide not label, foo
)
)
})
test_that('as_yamlet result is still stable',{
# yaml.load('foo: bar')
# yaml.load('foo: bar', handlers = list(seq = parsimonious))
# yaml.load('[foo: bar]')
# yaml.load('[foo: bar]', handlers = list(seq = parsimonious))
#
# yaml.load('RACE: [ label: race, [ foo: bar ]]')
# yaml.load('RACE: [ label: race, [ foo: bar ]]', handlers = list(seq = parsimonious))
#
# yaml.load('RACE: [ label: race, [ foo: bar, hey: baz ]]')
# yaml.load('RACE: [ label: race, [ foo: bar, hey: baz ]]', handlers = list(seq = parsimonious))
#
# as_yamlet('RACE: [ label: race, [ foo: bar ]]')
# as_yamlet('RACE: [ label: race, [ foo: bar, hey: baz ]]')
#
# as_yam('RACE: [ label: race, [ foo: bar ]]') %>% str
# as_yam('RACE: [ label: race, [ foo: bar, hey: baz ]]') %>% str
expect_equal_to_reference(file = '038.rds',as_yamlet('RACE: [ label: race, [ foo: bar ]]')) # must not be label, label; must not drop foo
expect_equal_to_reference(file = '039.rds', as_yamlet('RACE: [ label: race, [ foo: bar, hey: baz ]]')) # 'label: race' must reduce in presence of plural list
})
test_that('more elements than keys gives warning',{
expect_warning(as_yamlet('RACE: [label: race, guide: [white: 0, black: 1 ], categorical, 0]\nID: [1, 2, 3]'))
})
test_that('yamlet reads length-one character equivalently to vector',{
expect_identical(as_yam(c('ID:','TIME:')),as_yam('ID:\nTIME:'))
})
test_that('key priority by source is explicit > object > argument > option > default',{
expect_identical(names(as_yamlet('a: value')$a), 'label') # default
old <- getOption('yamlet_default_keys')
options(yamlet_default_keys = 'option')
expect_identical(names(as_yamlet('a: value')$a), 'option') # option
expect_identical(names(as_yamlet('a: value', default_keys = 'argument')$a), 'argument') # argument
expect_identical(names(as_yamlet('a: value\n_keys: object', default_keys = 'argument')$a),'object')
expect_identical(names(as_yamlet('a: [explicit: value]\n_keys: object', default_keys = 'argument')$a),'explicit')
options(yamlet_default_keys = old)
})
test_that('mixed-length vector types are respected',{
expect_equal_to_reference(
file = '099.rds',
as_yamlet('RACE: [ race, [white, black, asian ]]')
)
})
test_that('mixed-depth nesting is supported',{
expect_equal_to_reference(file = '100.rds', as_yamlet('ITEM: [ label: item, [ foo: bar, hey: baz ]]'))
})
test_that('default decorations are equivalent to explicit requests',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
meta <- system.file(package = 'yamlet', 'extdata','quinidine.yaml')
expect_identical(decorate(file),decorate(file, meta = meta))
expect_identical(decorate(file, meta = as_yamlet(meta)),decorate(file, meta = meta))
expect_identical(decorate(file),decorate(file, meta = meta))
})
test_that('non-default import is equivalent',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
b <- decorate(file, source = FALSE) %>% resolve
c <- decorate(
file,
read = read.table,
quote = "",
as.is = TRUE,
sep = ',',
header = TRUE,
na.strings = c('', '\\s', '.','NA'),
strip.white = TRUE,
check.names = FALSE
) %>% resolve
expect_identical(b, c)
})
test_that('interconversion to and from storage is conservative',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
meta <- system.file(package = 'yamlet', 'extdata','quinidine.yaml')
expect_identical(
readLines(meta),
as.character(as_yamlet(decorate(file)))
)
})
test_that('coersion to storage format is stable',{
expect_equal_to_reference(file = '053.rds', to_yamlet(3))
expect_equal_to_reference(file = '054.rds', to_yamlet(c(a = '4', b = '5.8')))
expect_equal_to_reference(file = '055.rds', to_yamlet(c(a = 4, b = 5.8)))
expect_equal_to_reference(file = '056.rds', to_yamlet(TRUE))
expect_equal_to_reference(file = '057.rds', to_yamlet('foo'))
expect_equal_to_reference(file = '058.rds', to_yamlet(c('a','b')))
expect_equal_to_reference(file = '059.rds', to_yamlet(c(a = 'a',b = 'b')))
expect_identical(to_yamlet(c(no = 'n', yes = 'y')),"[ 'no': 'n', 'yes': 'y' ]")
expect_identical(to_yamlet(c('no' = 'n', 'yes' = 'y')),"[ 'no': 'n', 'yes': 'y' ]")
expect_identical(to_yamlet(c('No' = 'n', 'Yes' = 'y')),"[ 'No': 'n', 'Yes': 'y' ]")
})
test_that('as.character.yamlet and as_yamlet.character are reciprocal',{
foo <- as_yamlet(system.file(package = 'yamlet', 'extdata','quinidine.yaml'))
expect_identical(foo, as_yamlet(as.character(foo)))
expect_identical(as.character(foo), as.character(as_yamlet(as.character(foo))))
})
test_that('read_yamlet and write_yamlet are reciprocal',{
foo <- system.file(package = 'yamlet', 'extdata','quinidine.yaml')
file <- tempfile()
write_yamlet(read_yamlet(foo), con = file)
expect_identical(readLines(file), readLines(foo))
})
test_that('decorate will not overwrite existing attributes',{
foo <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(foo)
expect_warning(y <- decorate(x, 'Subject: subject identifier'))
expect_silent(y <- redecorate(x, 'Subject: subject identifier'))
})
test_that('decorate ignores anonymous attributes',{
foo <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
library(csv)
x <- as.csv(foo)
expect_warning(meta <- as_yamlet('time: [ a, b, c]'))
expect_warning(decorate(x, meta = meta))
})
test_that('io_yamlet methods are reciprocal with default or modified arguments',{
foo <- system.file(package = 'yamlet', 'extdata','quinidine.yaml')
out <- file.path(tempdir(), 'out.yaml')
x <- io_yamlet(foo)
expect_identical(x,io_yamlet(io_yamlet(x, out)))
expect_identical(
x,
io_yamlet(
fileEncoding = 'UTF-8', # read
eol = '\n',
#default_keys = c('foo','bar'),
io_yamlet(
fileEncoding = 'UTF-8', # write
eol = '\r',
default_keys = c('foo','bar'),
x,
out
)
)
)
})
test_that('io_table methods are reciprocal with default or modified arguments',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
out <- file.path(tempdir(), 'out.tab')
foo <- io_table(x, out)
expect_identical(out, foo)
y <- io_table(foo, as.is = TRUE)
attr(x, 'source') <- NULL
rownames(x) <- NULL
rownames(y) <- NULL
expect_identical(x, y) # lossless 'round-trip'
io_table(x, out, sep = ',' , na = '.') #, fileEncoding = 'UTF-16')
y <- io_table(out, as.is = TRUE, sep = ',', na.strings = '.') #, fileEncoding = 'UTF-16')
rownames(y) <- NULL
expect_identical(x, y) # lossless 'round-trip'
})
test_that('io_csv methods are reciprocal with default or modified arguments',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
attr(x, 'source') <- NULL
out <- file.path(tempdir(), 'out.tab')
foo <- io_csv(x, out)
expect_identical(out, foo)
expect_identical(readLines(file), readLines(out))
y <- io_csv(out)
rownames(x) <- NULL
rownames(y) <- NULL
attr(x, 'source') <- NULL
attr(y, 'source') <- NULL
expect_identical(x, y) # lossless 'round-trip'
io_csv(x, out, quote = TRUE, na = 'NA', eol = '\r') #, fileEncoding = 'UTF-16')
y <- io_csv(out, na.strings = 'NA') # , fileEncoding = 'UTF-16')
attr(y, 'source') <- NULL
expect_identical(x, y) # lossless 'round-trip'
})
test_that('class attributes are excluded from storage by default',{
expect_false('class' %in% decorations(Theoph)$Subject)
})
test_that('yamlet package writes proper yaml with non-default keys',{
out <- file.path(tempdir(), 'out.yaml')
expect_silent(write_yamlet('ID: identifier', con = out))
expect_silent(write_yamlet('ID: identifier', con = out, default_keys = c('foo','bar')))
expect_warning(write_yamlet('ID: identifier', con = out, default_keys = character(0)))
foo <- system.file(package = 'yamlet', 'extdata','quinidine.yaml')
x <- io_yamlet(foo) # read
y <- as_yam(x[1], default_keys = c('foo','bar'))
io_yamlet(x, out, default_keys = c('foo','bar')) # write
expect_silent(io_yamlet(out)) # read
z <- as_yamlet('ID: identifier')
expect_identical(as.character(z), 'ID: identifier')
expect_identical(
as.character(z, default_keys = c('foo','bar'))[[1]],
'ID: [ label: identifier ]'
)
})
test_that('dplyr filter does not drop attributes',{
# not okay in 3.6.1: filter drops label on factors
library(dplyr)
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- file %>% decorate %>% resolve
x %$% Heart %>% attributes %>% names
expect_true(
setequal(
x %>% filter(!is.na(conc)) %$% Heart %>% attributes %>% names,
c('levels','class','label','codelist')
)
)
})
test_that('io_table accepts nuisance arguments without error',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
out <- file.path(tempdir(), 'out.tab')
expect_silent(foo <- io_table(x, out, foo = 'bar'))
expect_silent(y <- io_table(foo, as.is = TRUE, foo = 'bar'))
})
test_that('io_csv accepts nuisance arguments without error',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
out <- file.path(tempdir(), 'out.csv')
expect_silent(foo <- io_csv(x, out, foo = 'bar'))
expect_silent(y <- io_csv(foo, as.is = TRUE, foo = 'bar'))
})
test_that('explicit_guide recognizes encodings, units, formats, and codelists',{
library(magrittr)
a <- 'CONC: [ concentration, ng/mL ]' %>% as_yamlet %>% explicit_guide
b <- 'RACE: [ subject race, [ Caucasian, Latin, Black ]]' %>% as_yamlet %>% explicit_guide
c <- 'RACE: [ subject race, //Caucasian//Latin//Black// ]' %>% as_yamlet %>% explicit_guide
d <- 'DATE: [ date, "%Y-%m-%d" ]' %>% as_yamlet %>% explicit_guide
e <- c(
names(a[[1]])[[2]],
names(b[[1]])[[2]],
names(c[[1]])[[2]],
names(d[[1]])[[2]]
)
expect_identical(e, c('units','codelist','encoding','format'))
x <- data.frame(
ID = 1,
CONC = 1,
RACE = 1,
SEX = 1,
DATE = 1
)
x$ID %<>% structure(label = 'subject identifier')
x$CONC %<>% structure(label = 'concentration', guide = 'ng/mL')
x$RACE %<>% structure(label = 'race', guide = list(white = 0, black = 1, asian = 2))
x$SEX %<>% structure(label = 'sex', guide = list(female = 0, male = 1))
x$DATE %<>% structure(label = 'date', guide = '%Y-%m-%d')
expect_identical(
x %>% explicit_guide %>% as_yamlet %>% lapply(names) %>% unlist %>% as.character,
c('label','label','units','label','codelist','label','codelist','label','format')
)
})
test_that('classified() creates class factor and removes attribute codelist',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% explicit_guide %>% classified %>% as_yamlet(exclude_attr = NULL)
expect_identical(
x$Creatinine %>% names,
c('levels','class','label','codelist')
)
expect_true('factor' %in% x$Heart$class)
})
test_that('resolve correctly classifies conditional elements',{
skip_if_not( l10n_info()$`UTF-8` )
skip_if(
.Platform$OS.type == "unix" && Encoding(enc2native("\U00B5")) != "UTF-8",
"Skipping non-ASCII path tests on UTF-8 Unix system"
)
library(magrittr)
library(dplyr)
file <- system.file(package = 'yamlet', 'extdata','phenobarb.csv')
x <- decorate(file)
x %>% as_yamlet
x %>% explicit_guide %>% as_yamlet
expect_warning( x %>% select(value) %>% explicit_guide %>% as_yamlet) # value looks like codelist because event not available to signal conditional
x %>% explicit_guide %>% classified %>% as_yamlet
a <- x %>% resolve %>% as_yamlet
expect_true(setequal(names(a$value), c('label','units', 'title')))
})
test_that('resolve correctly classifies factors',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
expect_true(file %>% decorate %>% resolve %$% Heart %>% inherits('factor'))
})
test_that('filter, select, mutate, group_by, arrange, summarize and [ do not drop subclass decorated',{
library(dplyr)
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_identical('decorated', x %>% class %>% `[[`(1))
expect_identical('decorated', x %>% filter(!is.na(conc)) %>% class %>% `[[`(1))
expect_identical(
'decorated',
x %>%
group_by(Subject) %>%
mutate(mxt = max(time)) %>%
class %>% `[[`(1)
)
expect_identical(
'decorated',
x %>%
select(Subject:interval) %>%
class %>% `[[`(1)
)
expect_identical(
'decorated',
x %>%
summarize(mx = max(time)) %>%
class %>% `[[`(1)
)
expect_identical(
'decorated',
x %>%
arrange(Subject,time) %>%
class %>% `[[`(1)
)
expect_identical(
'decorated',
class(x[1:5, 1:3])[[1]]
)
})
test_that('conditionalize errors on mixed quotes',{
library(dplyr)
library(magrittr)
x <- data.frame(column = 'foo', test = "can't\"", value = 1)
expect_error(
x %>% conditionalize(column, label, test, value) %>% as_yamlet
)
})
test_that('conditionalize alternates single and double quotes',{
library(dplyr)
library(magrittr)
x <- data.frame(
stringsAsFactors = FALSE,
column = 'foo',
test = c('"cant"',"can't"),
value = 1
)
expect_identical(
x %>% conditionalize(column, label, test, value) %>%
as_yamlet %$% column %$% label %>% names,
c( "test == '\"cant\"'", "test == \"can't\"")
)
})
test_that('conditionalize does not quote numerics',{
library(dplyr)
library(magrittr)
x <- data.frame(
column = 1,
test = 2,
value = 3
)
expect_identical(
x %>% conditionalize(column, label, test, value) %>%
as_yamlet %$% column %$% label %>% names,
"test == 2"
)
})
test_that('conitionalize handles factors like character',{
library(dplyr)
library(magrittr)
x <- data.frame(
stringsAsFactors = TRUE,
column = 'foo',
test = c('"cant"',"can't"),
value = 1
)
expect_identical(
x %>% conditionalize(column, label, test, value) %>%
as_yamlet %$% column %$% label %>% names,
c( "test == '\"cant\"'", "test == \"can't\"")
)
})
test_that('subset classified does not drop label', {
a <- classified(factor(letters))
attr(a, 'label') <- 'foo'
a <- a[1:3]
expect_identical(attr(a,'label'), 'foo')
})
test_that('is_parseable distinguishes udunits from non-udunits',{
expect_identical(
is_parseable(c('kg/m2','kg/m^2','foo','kg.m/s2')),
c(TRUE, TRUE, FALSE, TRUE)
)
})
test_that('is_pareseable is vectorized',{
expect_identical(
is_parseable(c('kg/m2','kg/m^2','foo','kg.m/s2')),
c(TRUE, TRUE, FALSE, TRUE)
)
})
test_that('micro symbol is_pareseable',{
# https://github.com/rstudio/httpuv/issues/264
# https://github.com/rstudio/httpuv/commit/32ba7d34e9d0895552db8346cea8acbed7a74022
skip_if_not( l10n_info()$`UTF-8` )
skip_if(
.Platform$OS.type == "unix" && Encoding(enc2native("\U00B5")) != "UTF-8",
"Skipping non-ASCII path tests on UTF-8 Unix system"
)
expect_true(is_parseable('µg/L'))
})
test_that('is_parseable respects locally-defined units',{
library(units)
expect_false(is_parseable('foo'))
install_unit('foo')
expect_true(is_parseable('foo'))
remove_unit('foo')
expect_false(is_parseable('foo'))
})
test_that('all valid spork print as axis label',{
library(magrittr)
library(dplyr)
library(ggplot2)
library(spork)
expect_silent(
data.frame(y=1:10, x=1:10) %>%
decorate("x: 1 joule^\\*. ~1 kg m^2./s^2") %>%
#decorate("x: ''") %>%
mutate(x = structure(x, label = x %>% attr('label') %>%
as_spork %>%
as_plotmath %>%
as.expression)) %>%
ggplot(aes(x, y))
)
expect_silent(
data.frame(y=1:10, x=1:10) %>%
decorate("x: gravitational force \\\\ (kg\\.m/s^2.)") %>%
mutate(x = structure(x, label = x %>% attr('label') %>%
as_spork %>%
as_plotmath %>%
as.expression)) %>%
ggplot(aes(x, y))
)
})
test_that('R reserved words survive in print.dg labels',{
library(magrittr)
library(dplyr)
library(ggplot2)
library(testthat)
expect_silent(
data.frame(y=1:10, x=1:10) %>%
decorate("x: for NaN% joule^\\*. ~1 kg m^2./s^2. %") %>%
#decorate("x: ''") %>%
mutate(x = structure(x, label = x %>% attr('label') %>%
as_spork %>%
as_plotmath %>%
as.expression)) %>%
ggplot(aes(x, y))
)
})
test_that('column attributes with metacharacters are quoted or escaped on write',{
library(magrittr)
library(dplyr)
library(ggplot2)
library(testthat)
datum <- "x: [ 'AUC , [0-24]', ng*h/mL ]"
x <- data.frame(x=1:10) %>% decorate(datum)
path <- tempdir()
file <- file.path(path,'foo.csv')
x %>% io_csv(file)
y <- readLines(sub('csv','yaml',file))
expect_identical(y, datum)
})
test_that('for each named column, or all if none named, the data.frame method for modify() assigns a value in the attributes environment',{
library(magrittr)
library(dplyr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% modify(title = paste(label, '(', guide, ')'), time)
x %>% select(time, conc) %>% as_yamlet
expect_identical(attr(x$time,'title'), 'time since start of study ( h )')
expect_identical(attr(x$conc,'title'), NULL)
# modify (almost) all columns
x %<>% modify(title = paste(label, '(', guide, ')'), -Subject)
x %>% select(time, conc) %>% as_yamlet
expect_identical(attr(x$time,'title'), 'time since start of study ( h )')
expect_identical(attr(x$conc,'title'), 'quinidine serum concentration ( mg/L )')
expect_identical(attr(x$Subject,'title'), NULL)
})
test_that('modify() makes the underlying object available as an argument',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% modify(`defined values` = sum(!is.na(.)))
x %>% select(time) %>% as_yamlet
expect_identical(attr(x$time,'defined values'), 1471L)
})
test_that('modify() makes the object name available for use and assignment',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% modify(time, name = label)
expect_identical(names(x)[[2]], 'time since start of study')
})
test_that('the data.frame method for modify() gives a warning if the assignment target is reserved (i.e, class, levels, labels, names)',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_warning(x %<>% modify(class = 'numeric', Subject))
})
test_that('the data.frame method for modify() fails gracefully if assignment cannot be made',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
if(exists('foo'))rm(foo)
expect_warning(x %<>% modify(title = foo, time))
})
test_that('the default method for modify() supports lists',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
a <- list(a = 1, b = 1:10, c = letters) %>% modify(length = length(.), b:c)
expect_identical(attr(a[['a']],'length'), NULL)
expect_identical(attr(a[['c']],'length'), 26L)
})
test_that('modifier verbs are limited to dots scope',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
# as_yamlet
expect_equal_to_reference(file = '060.rds', as_yamlet(x, Height))
# decorations
expect_equal_to_reference(file = '061.rds', decorations(x, Height))
# modify
expect_equal_to_reference(
file = '062.rds',
modify(x, Height, label = 'Height (cm)') %>% as_yamlet(Height,Weight)
)
# resolve
as_yamlet(x, Height, Weight)
expect_equal_to_reference(
file = '063.rds',
resolve(x, Height) %>% as_yamlet(Height, Weight)
)
})
test_that('io_res resolves guide ambiguity on read',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- io_csv(file) %>% resolve
y <- io_res(file)
expect_identical(x, y)
})
test_that('output of as_decorated inherits class decorated',{
x <- as_decorated(list())
expect_true(inherits(x,'decorated'))
})
test_that('xtable.decorated is stable',{
library(magrittr)
library(xtable)
options(yamlet_persistence = FALSE)
set.seed(0)
x <- data.frame(
auc = rnorm(100, mean = 2400, sd = 200),
bmi = rnorm(100, mean = 20, sd = 5),
gen = 0:1
)
x %<>% decorate('auc: [AUC_0-24, ng*h/mL]')
x %<>% decorate('bmi: [Body Mass Index, kg/m^2]')
x %<>% decorate('gen: [Gender, [Male: 1, Female: 0]]')
y <- xtable(x)
expect_equal_to_reference(file = '064.rds', y)
y <- xtable(x, auc:bmi)
expect_equal_to_reference(file = '065.rds', y)
expect_equal_to_reference(file = '066.rds', resolve(x))
expect_equal_to_reference(file = '067.rds', xtable(resolve(x)))
options(yamlet_persistence = TRUE)
})
test_that('promote is stable',{
library(magrittr)
meta <- system.file(package = 'yamlet', 'extdata','phenobarb.csv')
x <- read.csv(meta)
singularity(
data = x,
list(
"event == 'conc'",
"event == 'dose'",
"event == 'metabolite'"
)
) %>% expect_identical(0L)
singularity(
data = x[x$event == 'dose',],
list(
"event == 'conc'",
"event == 'dose'",
"event == 'metabolite'"
)
) %>% expect_identical(2L)
singularity(
data = x[x$event == 'dose',],
list(
"time >= 0",
"event == 'dose'"
)
) %>% expect_identical(NA_integer_)
file <- system.file(package = 'yamlet', 'extdata','phenobarb.csv')
x <- file %>% decorate
expect_equal_to_reference(
file = '068.rds',
x %>% dplyr:::filter.data.frame(event == 'dose') %>% promote(event) %>% decorations(value)
)
expect_equal_to_reference(
file = '069.rds',
x %>% filter(event == 'dose') %>% decorations(value)
)
expect_equal_to_reference(
file = '070.rds',
x %>% filter(event == 'dose') %>% decorations(value)
)
expect_equal_to_reference(
file = '071.rds',
x %>% filter(event == 'conc') %>% decorations(value)
)
expect_equal_to_reference(
file = '072.rds',
x[x$event == 'dose',] %>% decorations(event, value)
)
expect_equal_to_reference(
file = '073.rds',
x[x$event == 'conc',] %>% decorations(event, value)
)
})
test_that('ggready is stable',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_equal_to_reference(file = '074.rds',decorations(x, Weight))
expect_equal_to_reference(file = '075.rds',decorations(as.data.frame(x), Weight))
expect_equal_to_reference(file = '076.rds',class(x))
expect_equal_to_reference(file = '078.rds',class(ggready(as.data.frame(x))))
expect_equal_to_reference(file = '079.rds',class(ggready(x)))
expect_equal_to_reference(file = '080.rds',class(ggready(resolve(x))))
x <- ggready(x)
library(magrittr)
library(ggplot2)
# Here we filter on-the-fly
# without loss of attributes.
# Notice mg/L rendering; this is actually part of an expression.
file %>%
decorate %>%
filter(!is.na(conc)) %>%
ggready %>%
ggplot(aes(x = time, y = conc, color = Heart)) +
geom_point()
# By default ggready resolves everything decorated.
# But we can intervene to resolve selectively,
# And further intervene to 'ggready' selectively.
#
x <- file %>% decorate %>% filter(!is.na(conc))
x %>%
resolve(conc, time) %>% # Heart left unresolved!
ggready(conc, Heart) %>% # time left unreadied!
ggplot(aes(x = time, y = conc, color = Heart)) + geom_point()
# Still, all the labels were actually expressions:
expect_equal_to_reference(file = '081.rds',x %>%
resolve(conc, time) %>%
ggready(conc, Heart) %$% conc %>% attributes %$% label %>% class
)
})
test_that('ggplot.resolved is stable',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
library(ggplot2)
library(dplyr)
library(magrittr)
x <- decorate(file)
x %<>% filter(!is.na(conc))
expect_equal_to_reference(file = '082.rds',class(x))
expect_equal_to_reference(file = '083.rds',class(data.frame(x)))
expect_equal_to_reference(file = '084.rds',class(as_decorated(data.frame(x))))
# The bare data.frame gives boring labels and unordered groups.
map <- aes(x = time, y = conc, color = Heart)
data.frame(x) %>% ggplot(map) + geom_point()
# Decorated data.frame uses supplied labels.
# Notice CHF levels are still not ordered.
x %>% ggplot(map) + geom_point()
# We can resolve guide for a chance to enrich the output with units.
# Notice CHF levels are now ordered.
x %<>% resolve
suppressWarnings( # because this complains for columns with no units
x <- modify(x, title = paste0(label, '\n(', units, ')'))
)
x %>% ggplot(map) + geom_point()
# Or something fancier.
x %<>% modify(conc, title = 'conc_serum. (mg*L^-1.)')
x %>% ggplot(map) + geom_point()
# The y-axis title is deliberately given in spork syntax for elegant coercion:
library(spork)
x %<>% modify(conc, expression = as.expression(as_plotmath(as_spork(title))))
x %>% ggplot(map) + geom_point()
# Add a fancier label for Heart, and facet by a factor:
x %<>% modify(Heart, expression = as.expression(as_plotmath(as_spork('CHF^\\*'))))
x %>% ggplot(map) + geom_point() + facet_wrap(~Creatinine)
# ggready handles the units and plotmath implicitly for a 'standard' display:
x %>% ggready %>% ggplot(map) + geom_point() + facet_wrap(~Creatinine)
})
test_that('ggplot.resolved is stable',{
skip_if_not( l10n_info()$`UTF-8` )
skip_if(
.Platform$OS.type == "unix" && Encoding(enc2native("\U00B5")) != "UTF-8",
"Skipping non-ASCII tests on UTF-8 Unix system"
)
# Here we try a dataset with conditional labels and units.
file <- system.file(package = 'yamlet', 'extdata','phenobarb.csv')
x <- file %>% decorate %>% resolve
# Note that value has two elements for label and guide.
expect_equal_to_reference(file = '085.rds',x %>% decorations(value))
#'
# The print method defaults to the first, with warning.
map <- aes(x = time, y = value, color = event)
expect_warning(print(x %>% ggplot(map) + geom_point()))
# If we subset appropriately, the relevant value is substituted.
expect_silent(print(x %>% filter(event == 'conc') %>% ggplot(map) + geom_point()))
})
test_that('unclassified is the inverse of classified',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% explicit_guide
y <- classified(x)
z <- unclassified(y)
# x %>% decorations(Creatinine)
# y %>% decorations(Creatinine)
# z %>% decorations(Creatinine)
# attr(y$Creatinine, 'codelist')
# identical(
# attr(x$Creatinine, 'codelist'),
# attr(z$Creatinine, 'codelist')
# )
# str(attr(x$Creatinine,'codelist'))
# str(attr(z$Creatinine,'codelist'))
#
# names(names(attr(x$Creatinine,'codelist')))
# names(names(attr(z$Creatinine,'codelist')))
expect_identical(x, z)
})
test_that('desolve is the inverse of resolve',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_identical(x, desolve(resolve(x)))
})
test_that('implicit_guide is the inverse of explicit_guide',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_identical(x, implicit_guide(explicit_guide(x)))
})
test_that('resolve and desolve retain class',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_true(inherits(resolve(x), 'decorated'))
expect_true(inherits(desolve(resolve(x)), 'decorated'))
})
test_that('labels and guide elements with colon-space are quoted',{
foo <- data.frame(x = 1)
attr(foo$x,'label') <- 'foo: x'
guide <- list(1)
names(guide) <- 'H: M'
attr(foo$x, 'guide') <- guide
dir <- tempdir()
file <- file.path(dir, 'foo.csv')
foo %>% io_csv(file)
expect_silent(io_csv(file))
})
test_that('classified methods do not lose attributes',{
foo <- classified(letters[1:5])
bar <- classified(LETTERS[1:5])
attr(foo, 'label') <- 'letters'
attr(bar, 'label') <- 'LETTERS'
foo[2:3] <- c('a','b')
foo[[4]] <- 'c'
expect_true(
setequal(
names(attributes(c(foo,bar))),
c('levels','class','codelist','label')
)
)
expect_true(
setequal(
names(attributes(foo[1:2])),
c('levels','class','codelist','label')
)
)
expect_true(
setequal(
names(attributes(foo[[2]])),
c('levels','class','codelist','label')
)
)
})
test_that('unclassified methods do not lose attributes',{
foo <- classified(letters[1:5])
attr(foo, 'label') <- 'letters'
foo <- unclassified(foo)
expect_true(
setequal(
names(attributes(foo)),
c('codelist','label','class')
)
)
})
test_that('classified() works the same on character and factor',{
expect_identical(classified(LETTERS), classified(factor(LETTERS)))
})
test_that('as_yamlet does not capture levels of classified by default',{
library(magrittr)
library(dplyr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
y <- x
y$Heart %<>% classified
expect_true(
setequal(
names(decorations(y, Heart)[[1]]),
c('label','guide','codelist')
)
)
decorations(x, Heart)
})
test_that('filter.decorated retains class', {
library(dplyr)
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_true(inherits(x %>% filter(Subject == 1), 'decorated'))
})
test_that('promote() retains class decorated', {
library(dplyr)
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','phenobarb.csv')
x <- decorate(file)
x %<>% filter(event == 'dose')
decorations(x)
expect_true(inherits(x, 'decorated'))
})
test_that('decorations() treats factor levels the same for factor and classified',{
library(dplyr)
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_false('levels' %in% (x %>% decorations(Race) %>% `[[`(1) %>% names))
expect_false('levels' %in% (x %>% resolve %>% decorations(Race) %>% `[[`(1) %>% names))
})
test_that('mimic() is stable',{
library(dplyr)
library(magrittr)
let <- letters[1:5]
LET <- LETTERS[1:5]
int <- 0L:4L
num <- as.numeric(int)
fac <- factor(let)
css <- classified(let)
expect_equal_to_reference(mimic(let, let), '086.rds')
expect_equal_to_reference(mimic(LET, let), '087.rds')
expect_equal_to_reference(mimic(int, let), '088.rds')
expect_equal_to_reference(mimic(num, let), '089.rds')
expect_equal_to_reference(mimic(fac, let), '090.rds')
expect_equal_to_reference(mimic(css, let), '091.rds')
expect_equal_to_reference(mimic(character(0)), '092.rds')
expect_equal_to_reference(mimic(numeric(0)), '093.rds')
expect_equal_to_reference(mimic(LET), '094.rds')
x <- data.frame(let, LET)
# x %<>% mutate(let = mimic(let, LET), LET = mimic(LET))
expect_equal_to_reference(x, '095.rds')
})
test_that('subset retains class for decorated inheriting grouped_df',{
library(dplyr)
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% group_by(Subject)
attr(x[['time']], 'foo') <- 'bar'
expect_true(inherits(x, 'decorated'))
# also for names<-
})
test_that('classified may contain NA',{
expect_silent(
classified(c(1,NA))
)
expect_silent(
classified(c(1,NA), exclude = NULL)
)
})
test_that('bind_rows() works for grouped_df containing classified factors',{
library(magrittr)
library(dplyr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
b <- decorate(file) %>% resolve
b %<>% group_by(Subject)
expect_silent(bind_rows(b,b))
a <- data.frame(i = c(1,1,2), x = classified(1:3))
b <- data.frame(i = c(2,2,3), x = classified(3:5))
a %<>% group_by(i)
b %<>% group_by(i)
# str(a)
# str(b)
bind_rows(a,b) %$% x %>% attributes
expect_silent(bind_rows(a,b))
expect_identical(bind_rows(a,b) %$% x %>% attributes %$% codelist, as.character(1:5))
})
test_that('gather.decorated respects supplied key and value',{
library(magrittr)
library(tidyr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
# x %>% gather('key', 'value', time, interval) %>% decorations
# x %>% gather('key', 'value', time, interval) %>% names()
# x %>% gather(key = 'key', value = 'value', time, interval) %>% names()
suppressWarnings(nms <- names(
gather(
x,
key = 'source',
value = 'widgets',
time,
interval
)
))
expect_true(all(c('source','widgets') %in% nms))
})
test_that('gather.decorated with no arguments is a non-operation',{
library(magrittr)
library(tidyr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_identical(x, gather(x, key = 'source', value = 'widgets'))
expect_identical(x, gather(x, key = 'source', value = 'widgets', !!!character(0)))
})
test_that('mimic is stable',{
let <- letters[1:5]
LET <- LETTERS[1:5]
int <- 0L:4L
num <- as.numeric(int)
fac <- factor(let)
css <- classified(let)
expect_equal_to_reference(file = '096.rds',
list(
mimic(LET, let),
mimic(let, let),
mimic(num, let),
mimic(int, let),
mimic(fac, let),
mimic(css, let),
mimic(character(0)),
mimic(numeric(0)),
mimic(LET),
mimic(let),
mimic(num),
mimic(int),
mimic(fac),
mimic(css)
))
})
test_that('factor and character can mimic numeric',{
let <- letters[1:5]
LET <- LETTERS[1:5]
int <- 0L:4L
num <- as.numeric(int)
fac <- factor(let)
css <- classified(let)
expect_silent(mimic(let, num))
expect_silent(mimic(fac, num))
expect_silent(mimic(css, num))
mimic(css, num)
unclassified(mimic(css, num))
expect_true(is.numeric(unclassified(mimic(css, num))))
mimic(css, as.character(num))
unclassified(mimic(css, as.character(num)))
expect_true(is.numeric(unclassified(mimic(css, as.character(num)))))
expect_true(
is.integer(
unclassified(
mimic(css, as.numeric(css))
)
)
)
# expect_error(mimic(css, as.integer(css))) # don't know why this should be an error
expect_silent(mimic(css, as.integer(css)))
})
test_that('as.integer.classified() returns integer with guide',{
css <- classified(letters[1:3], labels = LETTERS[1:3])
int <- as.integer(css)
expect_true('guide' %in% names(attributes(int)))
expect_true(is.integer(int))
})
test_that('as.integer.classified() is equivalent to as.numeric.classified()',{
css <- classified(c('knife','fork','spoon'))
expect_true(all(as.integer(css) == as.numeric(css)))
})
test_that('modify() does not search for assignment targets beyond data scope',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
suppressWarnings(x %<>% modify(time, SORT = .data$sort))
expect_false('sort' %in% names(attributes(x$time)))
})
test_that('print.yamlet handles unexpected objects nicely',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
x %<>% modify(time, SORT = sort)
# print(decorations(x,time))
expect_equal_to_reference(file = '097.rds', decorations(x, time))
})
test_that('subset decorated succeeds when dimensions are dropped',{
library(magrittr)
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
x <- decorate(file)
expect_silent(x[1,1])
})
test_that('NA names and values in lists can be converted to yamlet',{
expect_silent(to_yamlet(setNames(1:3, c('a','b',NA))))
expect_silent(to_yamlet(setNames(c(1,2,NA), c('a','b','c'))))
})
test_that('a length one sequence resolves parsimoniously',{
y <- as_yamlet('RACE: [ race, [ Asian: 1 ]]')
expect_equal(names(y[[1]][2]), 'guide')
})
test_that('column named *n* can be decorated',{
library(magrittr)
library(dplyr)
x <- data.frame(n = 1)
x %<>% decorate('"n": count')
expect_identical('count',decorations(x)$n$label)
})
test_that('column named *scenario* can have label *Scenario* even if there is a column with this name',{
library(magrittr)
library(dplyr)
x <- data.frame(scenario = 1, Scenario = 1)
x %<>% decorate('scenario: Scenario')
x %<>% decorate('Scenario: scenario')
expect_identical('Scenario', decorations(x)$scenario$label)
})
test_that('write_yamlet uses canonical attribute order by default',{
x <- data.frame(x = 1, y = 1, z = factor('a'))
x %<>% decorate('
x: [ guide: mm, desc: this, label: foo ]
"y": [ guide: bar, desc: other ]
')
expect_equal_to_reference(file = '101.rds', capture.output(write_yamlet(x)))
})
test_that('moot redecorate warnings are suppressed',{
x <- data.frame(x = 1, y = 1, z = factor('a'))
x %<>% decorate('
x: [ guide: mm, desc: this, label: foo ]
"y": [ guide: bar, desc: other ]
')
expect_silent(x %>% decorate(decorations(x)))
expect_warning(x %>% decorate('x: bar'))
expect_silent(x %>% decorate('x: bar', overwrite = TRUE))
})
test_that('class "decorated" persists after merges, joins, enumerations',{
library(magrittr)
library(dplyr)
x <- data.frame(foo = 1, bar = 2)
x %<>% decorate('foo: [distance, mm]')
x %<>% decorate('bar: [height, mm]')
expect_true(inherits(x, 'decorated'))
expect_true(inherits(full_join(x,x), 'decorated'))
expect_true(inherits(left_join(x,x), 'decorated'))
expect_true(inherits(left_join(x, as.data.frame(x)), 'decorated'))
expect_false(inherits(full_join(as.data.frame(x), x), 'decorated'))
expect_true(inherits(what = 'decorated', merge(x,x)))
# if(require(wrangle)){
# expect_true(inherits(what = 'decorated', enumerate(x, foo, bar)))
# } # check gives warning
})
test_that('decorations() does not print colon for un-named list',{
x <- data.frame(foo = c('a','b','c'))
x %<>% decorate('foo: [title, [[1,2],[2,3]]]')
foo <- capture_output(decorations(x), print = TRUE)
foo <- sub(':','', foo) # remove the only expected colon
expect_false(grepl(':', foo))
})
test_that('read_yamlet and write_yamlet reproduce block quote',{
x <- read_yamlet('
x:
background: |
x is so happy
a variable of note
it wants to help you
sentence: >
Sometimes we don\'t really
care where the line breaks
are.')
expect_equal_to_reference(
file = '102.rds',
capture_output(
print = TRUE,
write_yamlet(x)
)
)
expect_equal_to_reference(
file = '103.rds',
capture_output(
print = TRUE,
write_yamlet(x, block = TRUE)
)
)
})
test_that('decorated retains class when ungrouped', {
expect_true(inherits(ungroup(as_decorated(group_by(Theoph, Subject))), 'decorated'))
})
test_that('length-one codelists are not confused with units',{
x <- data.frame(race = 2, sex = 'M', conc = 1, time = 0)
x %<>% decorate('
race: [ Race, [ Asian: 2 ]]
sex: [ Sex, [M] ]
')
#x %>% resolve %>% decorations
expect_identical(
'codelist',
x %>% resolve %>% decorations %$% race %>% names %>% extract2(2)
)
expect_identical(
'codelist',
x %>% resolve %>% decorations %$% sex %>% names %>% extract2(2)
)
expect_equal_to_reference(
file = '104.rds',
'sex: [ Sex, M ]' %>% yaml.load(handlers = list(seq = parsimonious))
)
expect_equal_to_reference(
file = '105.rds',
'sex: [ Sex,[ M ]]' %>% yaml.load(handlers = list(seq = parsimonious))
)
expect_equal_to_reference(
file = '106.rds',
'sex: [ Sex,[ M, F ]]' %>% yaml.load(handlers = list(seq = parsimonious))
)
})
test_that('un-named codelists are back-transformed consistently',{
expect_identical(
'sex: Sex',
capture.output(write_yamlet(as_yamlet('sex: Sex')))
)
expect_identical(
'sex: [ Sex, M ]',
capture.output(write_yamlet(as_yamlet('sex: [ Sex, M ]')))
)
expect_identical(
'sex: [ Sex, [ M ]]',
capture.output(write_yamlet(as_yamlet('sex: [ Sex, [ M ]]')))
)
expect_identical(
'sex: [ Sex, [ M, F ]]',
capture.output(write_yamlet(as_yamlet('sex: [ Sex, [ M, F ]]')))
)
})
test_that('named codelists are back-transformed consistently',{
expect_identical(
'sex: [ Sex, [ Male: M ]]',
capture.output(write_yamlet(as_yamlet('sex: [ Sex, [ Male: M ]]')))
)
expect_identical(
'sex: [ Sex, [ Male: M, Female: F ]]',
capture.output(write_yamlet(as_yamlet('sex: [ Sex, [ Male: M, Female: F ]]')))
)
})
test_that('class "guided" or similar supports concatenation of guides',{
# Use vctrs to achieve consistent attribute treatment.
# see test-dvec.R
})
test_that('variables with units support unit math',{
# write converters for guided -> units and back
# see test-dvec.R
})
test_that('classified.data.frame passes exclude = NULL to member factors',{
x <- data.frame(letters = c('a','b','c','d', NA))
x %<>% decorate('letters: [Letters, [ a, b, c, d, NA ]]')
x %>% decorations
x %<>% explicit_guide
x %>% decorations
x %<>% classified(exclude = NULL)
expect_true(NA %in% attr(x$letters, 'codelist'))
expect_true(NA %in% levels(x$letters))
})
test_that('codelist can contain literal NA if quoted',{
x <- data.frame(letters = c('a','b','c','d', 'NA'))
x %<>% decorate('letters: [Letters, [ a, b, c, d, "NA" ]]')
x %>% decorations
x %<>% explicit_guide
x %>% decorations
x %<>% classified
expect_true('NA' %in% attr(x$letters, 'codelist'))
expect_true('NA' %in% levels(x$letters))
})
test_that('when two different decodes have the same code, classified levels match classified codelist values',{
x <- data.frame(letters = c('a','a','b'))
x %<>% decorate('letters: [Letters, [ TRT1: a, TRT2: a, TRT3: b ]]')
x
expect_warning({
x %>% resolve
x %>% resolve %>% desolve
x %>% resolve %>% desolve %>% resolve
x %<>% resolve
})
expect_identical(
levels(x$letters),
unlist(as.character(attr(x$letters, 'codelist')))
)
})
test_that('when two different codes have the same decode, classified levels match unique classified codelist values',{
x <- data.frame(letters = c('a','b','c'))
x %<>% decorate('letters: [Letters, [ TRT1: a, TRT2: b, TRT2: c ]]')
x
expect_warning({
x %>% resolve
x %>% resolve %>% desolve
x %>% resolve %>% desolve %>% decorations
x %>% resolve %>% desolve %>% resolve
x %<>% resolve
})
levels(x$letters)
as.character(attr(x$letters, 'codelist'))
expect_identical(
x %$% letters %>% levels,
x %$% letters %>% attr('codelist') %>%
as.character %>% unlist %>% unique
)
})
test_that('ggplot succeeds for class decorated that has no labels',{
file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
library(ggplot2)
library(dplyr)
library(magrittr)
expect_silent(a <- file %>% as.csv %>% filter(!is.na(conc)) %>% as_decorated %>%
ggplot(aes(x = time, y = conc, color = Heart)) + geom_point())
# look for legend: congestive heart failure (mod/no/sev)
})
test_that('classified does not re-classify',{
# avoid alternating states
x <- data.frame(
age = c(53, 58, 60),
sex = c(0, 1, 1),
race = c(1, 1, 2)
)
x %<>% decorate('
age: [ Age, year ]
sex: [ Sex, [ Female: 0, Male: 1 ]]
race: [ Race, [White: 1, Asian: 2 ]]
')
x
x %>% resolve
x %>% resolve(sex)
x %>% resolve(sex) %>% resolve
x %>% resolve %$% sex %>% attributes
x %>% resolve(sex) %>% resolve %$% sex %>% attributes
x %>% resolve(sex) %$% sex %>% attributes
foo <- x %>% resolve(sex)
# this drops sex label:
foo %>% resolve %>% decorations
expect_identical(
x %>% resolve,
x %>% resolve(sex) %>% resolve
)
expect_identical(
x %>% resolve,
x %>% resolve(race) %>% resolve
)
expect_identical(
x %>% resolve,
x %>% resolve(age) %>% resolve
)
})
test_that('io_csv.character allows user to over-ride meta',{
# issue 3
expect_silent(
x <- io_csv(
system.file(package = 'yamlet','extdata/phenobarb.csv'),
meta = system.file(package = 'yamlet','extdata/quinidine.yaml')
)
)
expect_identical(NULL, attr(x$Wt, 'label'))
})
test_that('[ can be the first character of a code or decode',{
# issue 2
x <- data.frame(range = '[min,max]')
expect_silent(x %<>% decorate('range: [ Range, [ "[minimum,maximum]": "[min,max]" ]]'))
expect_silent(decorations(x))
where <- tempdir()
x %>% io_csv(file.path(where, 'bracket.csv'))
y <- io_csv(file.path(where, 'bracket.csv'), source = FALSE)
expect_identical(x,y)
})
test_that('Quoted Yes and No survive parsing verbatim',{
x <- "blq: [ LOQ Y/N, [ 'No': 0, 'Yes': 1 ]]"
y <- x %>% write_yamlet %>% as.character
x
y
expect_identical(x, y)
})
test_that('append_units() supports specific target',{
x <- as_dvec(1:10, label = 'acceleration', units = 'm/s^2')
x %<>% append_units(target = 'title')
expect_true('title' %in% names(attributes(x)))
})
test_that('make_title() honors pass-through arguments for append_units()',{
x <- as_dvec(1:10, label = 'acceleration', units = 'm/s^2')
x %<>% make_title(open = '[', close = ']')
attr(x, 'title')
expect_identical(attr(x, 'title'), "acceleration[m/s^2]")
})
test_that('make_title() / drop_title() active on resolve() and desolve()',{
x <- data.frame(
age = c(53, 58, 60),
sex = c(0, 1, 1),
race = c(1, 1, 2)
)
x %<>% decorate('
age: [ Age, year ]
sex: [ Sex, [ Female: 0, Male: 1 ]]
race: [ Race, [White: 1, Asian: 2 ]]
')
x
x %<>% resolve
expect_true('title' %in% names(attributes(x$age)))
x %<>% desolve
expect_false('title' %in% names(attributes(x$age)))
})
test_that('make_title() can be globally defeated',{
options(yamlet_with_title = FALSE)
x <- data.frame(
age = c(53, 58, 60),
sex = c(0, 1, 1),
race = c(1, 1, 2)
)
x %<>% decorate('
age: [ Age, year ]
sex: [ Sex, [ Female: 0, Male: 1 ]]
race: [ Race, [White: 1, Asian: 2 ]]
')
x
x %<>% resolve
expect_false('title' %in% names(attributes(x$age)))
options(yamlet_with_title = NULL)
})
test_that('yamlet_options() displays globally-configurable options',{
options(yamlet_with_title = FALSE)
expect_true('yamlet_with_title' %in% names(yamlet_options()))
options(yamlet_with_title = NULL)
expect_false('yamlet_with_title' %in% names(yamlet_options()))
})
test_that('make_title() behaves as expected for class dvec',{
x <- as_dvec(1:10, label = 'length', guide = 'mm')
expect_false('title' %in% (x %>% make_title %>% attributes %>% names))
expect_true('title' %in% (x %>% resolve %>% make_title %>% attributes %>% names))
})
test_that('add_title() and drop_title() have no effect on (undecorated) data.frame',{
x <- data.frame(
age = c(53, 58, 60),
height = c(155, 130, 145),
race = c(1, 2, 2)
)
x %<>% decorate('
age: [ Age, year ]
height: [ Height, cm, title: "Subject Height [cm]" ]
race: [ Race, [White: 1, Asian: 2 ]]
')
x %>% decorations
x %<>% as.data.frame
x %>% decorations # still has decorations, but is just a data.frame
x %<>% make_title
x %>% decorations
expect_false('title' %in% names(attributes(x$age)))
x %<>% drop_title
x %>% decorations
expect_true('title' %in% names(attributes(x$height)))
})
test_that('row_bind of supported table types returns consistent class and functional metadata',{
library(dplyr)
a <- data.frame(study = 1) %>% decorate('study: [Study, [A: 1]]', persistence = FALSE)
class(a) <- 'data.frame'
b <- data.frame(study = 2) %>% decorate('study: [Study, [B: 2]]') # decorated data.frame
c <- tibble(study = 3) %>% decorate('study: [Study, [C: 3]]') # decorated tbl_df
c %<>% group_by(study) # decorated grouped_df
# per ?bind_rows: bind_rows() returns the same type as the first input,
# either a data.frame, tbl_df, or grouped_df
# or by extension, decorated data.frame, decorated tbl_df, decorated grouped_df
# bind_rows(a, a) %>% str # no magic, attributes dropped, not surprising
# bind_rows(b, b) %>% str # magic
# bind_rows(c, c) %>% str # magic
# bind_rows(a, b) %>% str # magic @ 0.10.7
# bind_rows(b, a) %>% str # magic
# bind_rows(a, c) %>% str # magic @ 0.10.7
# bind_rows(c, a) %>% str # magic
# bind_rows(b, c) %>% str # returns decorated data.frame, not surprising
# bind_rows(c, b) %>% str # magic
expect_equal_to_reference(file = '108.rds', decorations(bind_rows(a, a)))
expect_equal_to_reference(file = '109.rds', decorations(bind_rows(b, b)))
expect_equal_to_reference(file = '110.rds', decorations(bind_rows(c, c)))
expect_equal_to_reference(file = '111.rds', decorations(bind_rows(a, b)))
expect_equal_to_reference(file = '112.rds', decorations(bind_rows(b, a)))
expect_equal_to_reference(file = '113.rds', decorations(bind_rows(a, c)))
expect_equal_to_reference(file = '114.rds', decorations(bind_rows(c, a)))
expect_equal_to_reference(file = '115.rds', decorations(bind_rows(b, c)))
expect_equal_to_reference(file = '116.rds', decorations(bind_rows(c, b)))
# Conclusions:
# * Without any additional intervention, 'decorated'
# always appears first before 'tbl_df' or 'grouped_df'
# * Without additional intervention, bind_rows() always
# returns the data type of first argument.
# * bind_rows() drops meta if returning data.frame.
# * bind_rows() respects 'vestigal' meta on data.frames otherwise.
})
test_that('yamlet warns if codelist not one-to-one',{
x <- data.frame(
age = c(53, 58, 60),
height = c(155, 130, 145),
race = c(1, 1, 1),
ethnicity = c(0, 0, 1)
)
x %<>% decorate('
age: [ Age, year ]
height: [ Height, cm, title: "Subject Height [cm]" ]
race: [ Race, [White: 1, White: 1, Asian: 1 ]]
ethnicity: [ Ethnicity, [ Hispanic: 0, Hispanic: 1]]
')
expect_warning(x %>% resolve %>% decorations)
expect_warning(x %>% resolve)
})
test_that('yamlet warns if row_bind gives overlapping codelist',{
library(dplyr)
x <- data.frame(
race = c(1, 2, 2)
)
x %<>% decorate('
race: [ Race, [White: 1, Asian: 2 ]]
')
y <- data.frame(
race = c(1, 2, 2)
)
y %<>% decorate('
race: [ Race, [Asian: 1, White: 2, Black: 3]]
')
expect_warning(bind_rows(x, y) %>% resolve)
expect_warning(bind_rows(x, y))
})
test_that('print.decorated_ggplot() warns if label has length > 1',{
library(magrittr)
library(ggplot2)
library(yamlet)
a <- Theoph %>%
as.data.frame %>%
decorate('
conc: Concentration
Time: Time
') %>%
mutate(source = 'Theoph')
b <- a %>%
ggplot(
aes(
x = Time,
y = conc
)
) +
geom_point() +
ggtitle(a$source)
b$labels
expect_warning(print(b))
})
test_that('yamlet can decorate n and N', {
x <- data.frame(a = 0, n = 0, N = 0)
x %<>% decorate('a: test')
x %<>% decorate('"n": number')
x %<>% decorate('"N": [ newtons, kg*m*s-2 ]')
expect_identical(attr(x$N, 'label'), 'newtons')
})
test_that('decorations for "n" etc. survive trip to storage', {
x <- data.frame(n = 0, sam = 0, wt = 0)
x %<>% decorate('
"n": [ Number, [a: 0, b: 1, c: -1], sort: 1]
sam: Number of Samples
wt: [ Body Weight, kg ]
')
y <- x %>% io_yamlet(tempfile()) %>% io_yamlet
expect_identical(decorations(x), y)
})
test_that('decorating with guide element -1 survives trip to storage as integer',{
expect_identical(to_yamlet(-1L), "-1")
})
test_that('classified.classified() drops unused levels',{
a <- factor(c('knife','fork'), levels = c('knife','fork','spoon'))
levels(a) # three levels
levels(factor(a)) # two levels
b <- classified(a)
levels(b) # three levels
levels(classified(b))
levels(classified(b, drop = TRUE))
expect_identical(levels(classified(b, drop = TRUE)), c('knife', 'fork'))
b
classified(b)
expect_silent(classified(b, levels = 'knife'))
expect_error(classified(b, labels = 'knife'))
expect_silent(classified(b, labels = c('Knife','Fork','Spoon')))
expect_error(classified(b, labels = c('Knife','Fork','Spoon'), exclude = 'fork'))
expect_silent(classified(b, drop = TRUE, labels = c('Knife','Fork')))
})
test_that('classified() supports NA values',{
a <- factor(c('knife','fork','spoon'), levels = c('knife','fork'))
b <- classified(a)
expect_true(any(is.na(b)))
expect_false(any(is.na(attr(b, 'codelist'))))
expect_identical(levels(a), levels(b))
})
test_that('classified() supports NA levels',{
a <- factor(c('knife','fork', NA), levels = c('knife','fork',NA), exclude = NULL)
expect_true(any(is.na(levels(a))))
b <- classified(a, exclude = NULL)
expect_false(any(is.na(b)))
expect_true(any(is.na(attr(b, 'codelist'))))
levels(a)
levels(b)
expect_identical(levels(a), levels(b))
})
test_that('as.integer.classified() supports NA values and levels',{
a <- classified(
factor(
c('knife','fork','spoon'),
levels = c('knife','fork')
)
)
b <- classified(
factor(
c('knife','fork',NA),
levels = c('knife','fork',NA),
exclude = NULL
),
exclude = NULL
)
ai <- as.integer(a, -1)
expect_identical(as.integer(ai), c(0L, 1L, NA))
expect_identical(as.integer(attr(ai, 'guide')), c(0L, 1L))
expect_identical(names(attr(ai, 'guide')), c('knife','fork'))
bi <- as.integer(b, -1, exclude = NULL)
expect_false(any(is.na(bi)))
expect_true(any(is.na(names(attr(bi, 'guide')))))
})
test_that('classified() handles multiple new levels appropriately',{
a <- structure(1:3, codelist = list(knife = 1, fork = 2, spoon = 3))
b <- classified(a)
expect_identical(b, classified(b))
expect_warning(
c <- classified(
b,
levels = c('knife','fork','spoon','chopstix','ladel'),
labels = c('Knife','Fork','Spoon','Chopstix','Ladel')
)
)
})
test_that('literal NA and NA_character_ survive round-trip',{
a <- 'letters: [ Letters, [ a, b, c, NA ]]'
x <- data.frame(letters = c('a','b','c', NA))
x %<>% decorate(a)
b <- write_yamlet(x)
expect_identical(a, b)
a <- "letters: [ Letters, [ a, b, c, 'NA' ]]"
x <- data.frame(letters = c('a','b','c', 'NA'))
x %<>% decorate(a)
b <- write_yamlet(x)
expect_identical(a, b)
})
test_that('yamlet names can be true NA or NA string',{
a <- "letters: [ Letters, [ A: a, B: b, C: c, 'NA': 'NA', NA: NA ]]"
x <- data.frame(letters = c('a','b','c', 'NA', NA ))
x %<>% decorate(a)
foo <- capture.output(b <- write_yamlet(x))
expect_identical(a, b)
c <- attr(x$letters, 'guide')
expect_true(any(is.na(names(c))))
expect_true(any(is.na(c)))
expect_equal_to_reference(capture.output(decorations(x)), file = '118.rds')
x %<>% redecorate("letters: [ Letters, [ a, b, c, 'NA', NA ]]")
expect_equal_to_reference(capture.output(decorations(x)), file = '119.rds')
})
test_that('as.integer.classified gives fully-recoverable result when NA is a level',{
library(dplyr)
x <- data.frame(letters = c('a','b','c',NA))
x %<>% decorate('letters: [ Letters, [NA, a, b, c ]]')
x %<>% resolve(exclude = NULL)
x %<>% mutate(letters = classified(letters, exclude = NULL))
x %<>% mutate(letters = as.integer(letters, -1, exclude = NULL))
expect_silent(x %>% resolve(letters))
x %<>% resolve
expect_equal_to_reference(x, file = '120.rds')
})
test_that('mimic supports solitary NA',{
expect_silent(
{
mimic(NA, NA)
mimic(factor(NA), NA)
mimic(factor(NA, exclude = NULL), NA)
mimic(NA, 1)
mimic(factor(NA), 1)
mimic(factor(NA, exclude = NULL), 1)
mimic(factor(NA, levels = c(NA, 'foo')), 1)
mimic(factor(NA, levels = NA, exclude = NULL), 1)
}
)
expect_silent(
{
mimic(
factor(
NA,
levels = NA,
exclude = NULL
),
1,
exclude = NULL
)
}
)
})
test_that('as.integer.classified preserves all levels',{
a <- classified(
c('knife','fork'),
levels = c(NA, 'knife','fork','spoon'),
exclude = NULL
)
attr(a, 'label') <- 'my label'
b <- as.integer(a)
guide <- unlist(attr(b, 'guide'))
nms <- names(guide)
names(guide) <- NULL
expect_identical(nms, levels(a))
expect_identical(guide, 1:4)
})
test_that('modify supports nonstandard column names',{
a <- data.frame(`has space` = 0, check.names = FALSE)
expect_silent(modify(a, 'has space', name = name))
})
Try the yamlet package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.