inst/tests/test-S3.R
In huashan/pander: An R Pandoc Writer
library(testthat)
library(pander)
## reset later
original_contrasts_options <- getOption('contrasts')
context('pandoc.table')
tables <- list(
mtcars,
mtcars$am,
mtcars[1:2, ],
mtcars[1:2, 5],
summary(mtcars$am),
table(mtcars$am) + 0.1,
table(mtcars$am, mtcars$gear) + 0.1,
summary(lm(mtcars$hp~1))$coeff,
table(mtcars$am, mtcars$gear, mtcars$carb),
addmargins(table(mtcars$gear, mtcars$carb))
)
test_that('no error: multiline', {
for (t in tables)
expect_that(pandoc.table.return(t, style = 'multiline'), is_a('character'))
})
test_that('no error: simple', {
for (t in tables)
expect_that(pandoc.table.return(t, style = 'simple'), is_a('character'))
})
test_that('no error: grid', {
for (t in tables)
expect_that(pandoc.table.return(t, style = 'grid'), is_a('character'))
})
test_that('no error: rmarkdown', {
for (t in tables)
expect_that(pandoc.table.return(t, style = 'rmarkdown'), is_a('character'))
})
tables <- list(
mtcars,
mtcars$am,
mtcars[1:2, ],
mtcars[1:2, 5],
summary(mtcars$am),
table(mtcars$am) + 0.1,
table(mtcars$am, mtcars$gear) + 0.1,
lm(mtcars$hp~1),
t.test(extra ~ group, data = sleep),
prcomp(USArrests),
density(mtcars$hp),
table(mtcars$am, mtcars$gear, mtcars$carb) + 0.1
)
test_that('split.tables', {
# test exact values (#164)
t <- data.frame(a = '7 chars', b = paste(rep('Δ', 5), collapse = ' '))
expect_equal(nchar('Δ Δ Δ Δ Δ', type='width'), 9)
res_grid <- pander_return(t, style='grid', split.tables = 23)
expect_equal(length(res_grid), 8)
expect_false(any(grepl('Table', res_grid)))
res_grid <- pander_return(t, style='grid', split.tables = 22)
expect_equal(length(res_grid), 18)
expect_true(any(grepl('Table', res_grid)))
res_simple <- pander_return(t, style='simple', split.tables = 17)
expect_equal(length(res_simple), 6)
expect_false(any(grepl('Table', res_simple)))
res_simple <- pander_return(t, style='simple', split.tables = 16)
expect_equal(length(res_simple), 14)
expect_true(any(grepl('Table', res_simple)))
})
test_that('rmarkdown pipe-delimited table is correct (#186)', {
d <- data.frame(a = 'foo|bar', b = 'my missing cell')
res <- pander_return(d, style='rmarkdown')
expect_true(any(grep('foo', res)))
expect_true(any(grep('bar', res)))
expect_true(any(grep('my missing cell', res)))
rownames(d) <- 'x|y'
res <- pander_return(d, style='rmarkdown')
expect_true(any(grep('x', res)))
expect_true(any(grep('y', res)))
expect_true(any(grep('foo', res)))
expect_true(any(grep('bar', res)))
expect_true(any(grep('my missing cell', res)))
})
test_that('pandoc.table.return behaves correctly', {
expect_warning(pander_return(mtcars[,1:2], split.tables = Inf, split.cells = c('50%', '50%')))
t <- mtcars[1:3, 1:2]
attr(t, 'alignment') <- 'left'
attr(t, 'caption') <- 'simplified mtcars'
res <- pander_return(t, emphasize.rownames = F)
expect_false(any(grep('^[[:space:]]', res))) # because of left alignment
expect_true(any(grep('simplified mtcars', res)))
expect_error(pander_return(t, justify = c('left', 'right'))) # needs 3 because of rownames
expect_error(pander_return(t, justify = 'lr')) # needs 3 because of rownames
res <- pander_return(t, justify = 'lrr')
expect_false(any(grep('[[:space:]]$', res)))
expect_error(pander_return(t, justify='laft'))
res <- pander_return(t, split.tables = 1)
expect_equal(length(res), 24)
res <- pander_return(t, split.cells = c(10, 10, 10))
expect_equal(length(res), 16)
expect_warning(pander_return(t, split.cells = vector()))
})
dm <- panderOptions('decimal.mark')
panderOptions('decimal.mark', ',')
test_that('decimal mark', {
for (t in tables)
expect_true(grepl(',', paste(pander_return(t), collapse = '\n')))
})
panderOptions('decimal.mark', dm)
context('highlight tables')
t <- mtcars[1:3, 1:5]
test_that('highlight 1D: no error', {
expect_that(pandoc.table.return(t$mpg, emphasize.italics.cells = 1), is_a('character'))
expect_that(pandoc.table.return(t$mpg, emphasize.italics.cells = 1:2), is_a('character'))
expect_that(pandoc.table.return(t$mpg, emphasize.strong.cells = 1), is_a('character'))
expect_that(pandoc.table.return(t$mpg, emphasize.strong.cells = 1:2), is_a('character'))
})
t <- table(mtcars$am, mtcars$gear)
test_that('emphasize 2D: no error', {
expect_that(pandoc.table.return(t, emphasize.italics.rows = 1), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.italics.rows = 1:2), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.italics.cols = 1), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.italics.cols = 1:2), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.italics.cells = which(t > 10, arr.ind = TRUE)), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.italics.cells = which(t > 20, arr.ind = TRUE)), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.strong.rows = 1), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.strong.rows = 1:2), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.strong.cols = 1), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.strong.cols = 1:2), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.strong.cells = which(t > 10, arr.ind = TRUE)), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.strong.cells = which(t > 20, arr.ind = TRUE)), is_a('character'))
})
test_that('emphasize: error', {
expect_that(pandoc.table(t, emphasize.italics.cols = 1:5), throws_error())
expect_that(pandoc.table(t, emphasize.italics.cols = 1.5), throws_error())
expect_that(pandoc.table(t, emphasize.strong.cols = 1:5), throws_error())
expect_that(pandoc.table(t, emphasize.strong.cols = 1.5), throws_error())
})
test_that('no warning for highlight NA/empty strings', {
expect_that(pandoc.table(data.frame(x = 1:2, y = c(1,NA)), emphasize.italics.cols = 2), not(gives_warning()))
})
test_that('emphasize.italics.rows works correctly', {
# test for issue 176
df <- data.frame(a=1:3, b=1:3, c=1:3)
res <- capture.output(pander(df, emphasize.italics.rows = c(1,2), style = 'simple'))
expect_equal(res[5], '*1* *1* *1*')
expect_equal(res[6], '*2* *2* *2*')
res <- capture.output(pander(df, emphasize.strong.rows = c(1,2), style = 'simple'))
expect_equal(res[5], '**1** **1** **1**')
expect_equal(res[6], '**2** **2** **2**')
})
test_that('emphasize.verbatim works correctly', {
df <- data.frame(a=1:3, b=4:6, c=7:9)
res <- pander_return(df, emphasize.verbatim.rows = c(1,2), style = 'simple')
expect_equal(res[5], '`1` `4` `7`')
expect_equal(res[6], '`2` `5` `8`')
res <- pander_return(df, emphasize.verbatim.cols = c(1,2), style = 'simple')
expect_equal(res[5], '`1` `4` 7 ')
expect_equal(res[6], '`2` `5` 8 ')
res <- pander_return(df, emphasize.verbatim.cells = which(df > 5, arr.ind = TRUE), style = 'simple')
expect_equal(res[5], ' 1 4 `7`')
expect_equal(res[6], ' 2 5 `8`')
res <- pander_return(df, emphasize.verbatim.cells = which(df > 5, arr.ind = TRUE),
emphasize.strong.rows = c(1,2), style = 'simple')
expect_equal(res[5], '**1** **4** **`7`**')
expect_equal(res[7], ' 3 `6` `9` ')
})
context('captions')
tables <- list(
mtcars,
mtcars[1:2, ],
summary(mtcars$am),
table(mtcars$am) + 0.1,
table(mtcars$am, mtcars$gear) + 0.1,
lm(mtcars$hp~1),
t.test(extra ~ group, data = sleep),
prcomp(USArrests),
density(mtcars$hp)
)
has.caption <- function(ttt, evals = FALSE) {
set.caption('foo')
if (!evals)
any(grepl('Table:', pander_return(ttt)))
else
!is.null(attr(evals('get("ttt")', env = parent.frame())[[1]]$result, 'caption'))
}
test_that('direct call', {
for (ttt in tables)
expect_that(has.caption(ttt), is_true())
})
cache.dir <- evalsOptions('cache.dir')
graph.dir <- evalsOptions('graph.dir')
wd <- getwd()
setwd(tempdir())
evalsOptions('cache.dir', file.path(tempdir(), '.cache'))
evalsOptions('graph.dir', file.path(tempdir(), 'plots'))
test_that('evals', {
for (ttt in tables)
expect_that(has.caption(ttt, evals = TRUE), is_true())
})
evalsOptions('cache.dir', cache.dir)
evalsOptions('graph.dir', graph.dir)
setwd(wd)
context('default alignments')
tables <- list(
mtcars,
mtcars$am,
mtcars[1:2, ],
mtcars[1:2, 5],
summary(mtcars$am),
table(mtcars$am) + 0.1,
table(mtcars$am, mtcars$gear) + 0.1,
summary(lm(mtcars$hp~1))$coeff,
table(mtcars$am, mtcars$gear, mtcars$carb)
)
tad <- panderOptions('table.alignment.default')
tar <- panderOptions('table.alignment.rownames')
panderOptions('table.alignment.default', 'centre')
panderOptions('table.alignment.rownames', 'right')
test_that('no error: allright', {
for (t in tables)
expect_that(pandoc.table.return(t, style = 'multiline'), is_a('character'))
})
f <- function(df) {
if (class(df) != 'matrix' && !is.table(df) || length(dim(df)) < 2)
ifelse(sapply(df, is.numeric), 'right', 'left')
else
ifelse(apply(df, 2, is.numeric), 'right', 'left')
}
panderOptions('table.alignment.default', f)
test_that('no error: functions', {
for (t in tables)
expect_that(pandoc.table.return(t, style = 'multiline'), is_a('character'))
})
panderOptions('table.alignment.default', tad)
panderOptions('table.alignment.rownames', tar)
test_that('digits param', {
m <- matrix(rep(0.111111, 6), nrow = 2)
res <- pander_return(m, digits = c(2,4,1))
expect_equal(res[3], '0.11 0.1111 0.1')
expect_warning(pander_return(m, digits=c(1,2)))
res <- pander_return(m, digits = c(2))
expect_equal(res[3],'0.11 0.11 0.11')
mt <- mtcars[1:4, 5:8]
res <- pander_return(mt, digits = c(1,4,3,4), keep.trailing.zeros = T)
expect_equal(res[5], ' **Mazda RX4** 4 2.62 16.5 0 ')
})
test_that('round param', {
m <- matrix(rep(0.111111, 6), nrow = 2)
res <- pander_return(m, round = c(2,4,1))
expect_equal(res[3], '0.11 0.1111 0.1')
expect_warning(pander_return(m, round=c(1,2)))
res <- pander_return(m, round = c(2))
expect_equal(res[3],'0.11 0.11 0.11')
})
context('keep.line.breaks')
test_that('keep.line.breaks works correctly', {
# keeping line breaks in a simple data.frame with one line breaks differs lines amount by one
x <- data.frame(a='Pander\nPackage')
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE), '\n')[[1]])
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks + 1, lines.x.keep.breaks)
# keeping line breaks in a simple data.frame with 2 rows with 1 line breaks differst lines amount by 2
x <- data.frame(a=c('Pander\nPackage','Pander\nPackage'))
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE), '\n')[[1]])
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks + 2, lines.x.keep.breaks)
#if there are no line breaks originally, they do not get introduced
x <- data.frame(a=c('Pander Package','Pander Package'))
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE), '\n')[[1]])
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks, lines.x.keep.breaks)
# works with random number of rows added
rows <- sample(1:100, 1)
x <- data.frame(a=rep('Pander\nPackage', rows))
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE), '\n')[[1]])
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks + rows, lines.x.keep.breaks)
# random number of line breaks in one cell
n <- sample(1:10, 1)
x <- data.frame(a=paste(rep('pander', n), collapse='\n'))
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE, split.cells = Inf), '\n')[[1]])
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks + n - 1, lines.x.keep.breaks)
# random number of line breaks in cells, 3 columns
n <- sample(1:10, 3)
x <- data.frame(a=paste(rep('pander', n[1]), collapse='\n'),
b = paste(rep('pander', n[2]), collapse='\n'),
c = paste(rep('pander', n[3]), collapse='\n'))
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE, split.cells = Inf, split.tables = Inf), '\n')[[1]]) #nolint
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks + max(n) - 1, lines.x.keep.breaks)
# 3 columns, 2 rows
x <- rbind(x,x)
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE, split.cells = Inf, split.tables = Inf), '\n')[[1]]) #nolint
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks + 2 * max(n) - 2, lines.x.keep.breaks)
})
context('split.cells')
test_that('split.cells works correctly',{
x <- data.frame(a = 'foo bar\nfo bar')
# single line break behaves correctly combines with keep line breaks
expect_equal(pandoc.table.return(x, keep.line.breaks = T, split.cells = 7),
'\n-------\n a \n-------\nfoo bar\nfo bar \n-------\n\n')
expect_equal(pandoc.table.return(x, keep.line.breaks = T, split.cells = 6),
'\n------\n a \n------\n foo \n bar \nfo bar\n------\n\n')
# Corner values of split.cells
x <- data.frame(a = 'foo bar', b = 'foo bar')
expect_equal(length(strsplit(pandoc.table.return(x, split.cells = c(6, Inf)), '\n')[[1]]), 8)
expect_equal(pandoc.table.return(x, split.cells = c(6, Inf)),
'\n-----------\n a b \n--- -------\nfoo foo bar\nbar \n-----------\n\n')
expect_equal(pandoc.table.return(x, split.cells = c(Inf, 6)),
'\n-----------\n a b \n------- ---\nfoo bar foo\n bar\n-----------\n\n')
expect_equal(pandoc.table.return(x, split.cells = c(7, 7)),
'\n---------------\n a b \n------- -------\nfoo bar foo bar\n---------------\n\n')
expect_equal(pandoc.table.return(x, split.cells = c(7, 7)), pandoc.table.return(x, split.cells = Inf))
expect_equal(pandoc.table.return(x, split.cells = c(6 ,6)), pandoc.table.return(x, split.cells = 6))
expect_equal(pandoc.table.return(x, split.cells = c(7 ,7)), pandoc.table.return(x, split.cells = 7))
expect_equal(pandoc.table.return(x, split.cells = c(7 ,7)), pandoc.table.return(x, split.cells = 7))
# relative split.cells
expect_equal(pandoc.table.return(x, split.cells = c('50%', '50%')),
pandoc.table.return(x, split.cells = c(7)))
expect_equal(pandoc.table.return(x, split.cells = c('20%', '80%'), split.tables = 30),
pandoc.table.return(x, split.cells = c(6, Inf)))
expect_equal(pandoc.table.return(x, split.cells = c('80%', '20%'), split.tables = 30),
pandoc.table.return(x, split.cells = c(Inf, 6)))
})
test_that('split.cells param produces expected warnings',{
mt <- mtcars[1:2, 1:4]
expect_warning(pander(mt, split.cells = c(1,2)))
expect_warning(pander(mt, split.cells = c(1,2,3)))
expect_warning(pander(mt, split.cells = c('10%','10%','10%')))
expect_warning(pander(mt, split.cells = c('30%','30%','40%')))
})
context('table.expand')
test_that('produces.errors',{
x <- data.frame(a='Pander\nPackage')
expect_error(pander(x, style='simple', keep.line.breaks = T))
expect_error(pander(x, style='rmarkdown', keep.line.breaks = T))
})
table.expand <- function(cells, cols.width, justify, sep.cols, style) {
.Call('pander_tableExpand_cpp', PACKAGE = 'pander', cells, cols.width, justify, sep.cols, style)
}
test_that('table.expand behaves correctly',{
## multiline style check
argv <- structure(list(txt = structure(c(1L, 4L, 2L, 3L), .Label = c(' ', 'cyl', 'disp', 'mpg'), class = 'factor'), width = c(19, 5, 5, 6), justify = structure(c(1L, 1L, 1L, 1L), .Label = 'centre', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c(NA, -4L), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'multiline'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)),
length(strsplit(res, '\n')[[1]]))
expect_equal(nchar(res),
nchar(sep.cols)[1] + (length(argv[,2]) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(argv[,2]))
expect_equal(res, ' mpg cyl disp ');
## grid style check
argv <- structure(list(txt = structure(c(1L, 5L, 2L, 3L, 4L), .Label = c(' ', 'cyl', 'disp', 'hp', 'mpg'), class = 'factor'), width = c(20, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'centre', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c(NA, -5L), class = 'data.frame') #nolint
sep.cols <- c('| ', ' | ', ' |')
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)), length(strsplit(res, '\n')[[1]]))
expect_equal(nchar(res), nchar(sep.cols)[1] + (length(argv[,2]) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(argv[,2])) #nolint
expect_equal(res, '| | mpg | cyl | disp | hp |' )
## rmarkdown style check
argv <- structure(list(txt = structure(c(1L, 4L, 5L, 3L, 2L), .Label = c('**Mazda RX4**', '110', '160', '21', '6'), class = 'factor'), width = c(20, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'centre', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c('t.rownames', 'mpg', 'cyl', 'disp', 'hp'), class = 'data.frame') #nolint
sep.cols <- c('| ', ' | ', ' |')
style <- 'rmarkdown'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)), length(strsplit(res, '\n')[[1]]))
expect_equal(nchar(res),
nchar(sep.cols)[1] + (length(argv[,2]) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(argv[,2]))
expect_equal(res, '| **Mazda RX4** | 21 | 6 | 160 | 110 |')
## simple style check
argv <- structure(list(txt = structure(c(1L, 3L, 4L, 2L, 5L), .Label = c('**Datsun 710**', '108', '22.8', '4', '93'), class = 'factor'), width = c(20, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'centre', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c('t.rownames', 'mpg', 'cyl', 'disp', 'hp'), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'simple'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)), length(strsplit(res, '\n')[[1]]))
expect_equal(nchar(res),
nchar(sep.cols)[1] + (length(argv[,2]) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(argv[,2]))
expect_equal(res, ' **Datsun 710** 22.8 4 108 93 ')
## left justification
argv <- structure(list(txt = structure(c(1L, 4L, 5L, 3L, 2L), .Label = c('**Mazda', '110', '160', '21', '6'), class = 'factor'), width = c(10, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'left', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c(NA, -5L), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'multiline'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)), length(strsplit(res, '\n')[[1]]))
expect_equal(nchar(res),
nchar(sep.cols)[1] + (length(argv[,2]) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(argv[,2]))
expect_equal(res, '**Mazda 21 6 160 110 ');
## right justification
argv <- structure(list(txt = structure(c(1L, 3L, 5L, 4L, 2L), .Label = c('**Hornet 4 Drive**', '110', '21.4', '258', '6'), class = 'factor'), width = c(20, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'right', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c('t.rownames', 'mpg', 'cyl', 'disp', 'hp'), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'simple'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)), length(strsplit(res, '\n')[[1]]))
expect_equal(nchar(res),
nchar(sep.cols)[1] + (length(argv[,2]) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(argv[,2]))
expect_equal(res, ' **Hornet 4 Drive** 21.4 6 258 110' );
## multiple lines
argv <- structure(list(txt = structure(c(1L, 3L, 5L, 4L, 2L), .Label = c('**Hornet\n4\nDrive**', '110', '21.4', '258', '6'), class = 'factor'), width = c(10, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'left', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c('t.rownames', 'mpg', 'cyl', 'disp', 'hp'), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'multiline'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)),
length(strsplit(res, '\n')[[1]]))
# max number of line breaks equals number of lines in the result
expect_equal(res, '**Hornet 21.4 6 258 110 \n4 \nDrive** '); #nolint
argv <- structure(list(txt = structure(c(1L, 3L, 4L, 2L, 5L), .Label = c('**Datsun\n710**', '108', '22.8', '4', '93'), class = 'factor'), width = c(10, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'left', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c('t.rownames', 'mpg', 'cyl', 'disp', 'hp'), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'multiline'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)),
length(strsplit(res, '\n')[[1]]))
expect_equal(res, '**Datsun 22.8 4 108 93 \n710** ');
argv <- structure(list(txt = structure(c(1L, 4L, 5L, 3L, 2L), .Label = c('**Mazda\nRX4\nWag**', '110', '160', '21', '6'), class = 'factor'), width = c(10, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'left', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c('t.rownames', 'mpg', 'cyl', 'disp', 'hp'), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'multiline'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)), length(strsplit(res, '\n')[[1]]))
expect_equal(res, '**Mazda 21 6 160 110 \nRX4 \nWag** '); #nolint
# empty cells
cells <- c('','','')
cols.width <- c(2, 2, 2)
justify <- c('centre', 'centre', 'centre')
sep.cols <- c('', ' ', '')
res <- table.expand(cells, cols.width, justify, sep.cols, 'multiline')
# when max.width param is small, every word is a line
expect_equal(max(sapply(strsplit(as.character(cells), '\n'), length)), 0)
expect_equal(nchar(res),
nchar(sep.cols)[1] + (length(cells) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(cols.width))
expect_equal(res, ' ')
# backslashes issue (#22)
expect_equal(pandoc.table.return(data.frame(a='\\1 \\ 32',b='23')),
'\n-----------\n a b \n------- ---\n\\1 \\ 32 23 \n-----------\n\n')
expect_equal(pandoc.table.return(data.frame(a='\\1 \\ 32',b='23'), justify = 'right'),
'\n-----------\n a b\n------- ---\n\\1 \\ 32 23\n-----------\n\n')
expect_equal(pandoc.table.return(data.frame(a='\\1',b='23')),
'\n-------\n a b \n--- ---\n\\1 23 \n-------\n\n')
# unicode string issue
expect_equal(pandoc.table.return(data.frame(a = 'ßß')), '\n---\n a \n---\nßß \n---\n\n')
})
context('Empty objects')
test_that('Behavior for empty objects is correct', {
mt <- mtcars[mtcars$mpg < 0, 1:4]
res <- pander_return(mt)
expect_equal(res[3], '**mpg** **cyl** **disp** **hp**')
expect_equal(length(res), 6)
colnames(mt) <- NULL
res <- suppressWarnings(pander_return(mt))
expect_equal(length(res), 0)
expect_warning(pander_return(mt))
mt <- matrix(0, nrow = 0, ncol = 5)
res <- suppressWarnings(pander_return(mt))
expect_equal(length(res), 0)
expect_warning(pander_return(mt))
colnames(mt) <- 1:5
res <- pander_return(mt)
expect_equal(res[3], '**1** **2** **3** **4** **5**')
expect_equal(length(res), 6)
expect_equal(length(pander_return(data.frame())), 0)
expect_warning(pander_return(data.frame()))
})
context('plain.ascii')
test_that('plain.ascii option works correctly', {
# dim is NULL
x <- 1:10
res <- pandoc.table.return(x, emphasize.cells=c(3,4), plain.ascii = T)
res <- strsplit(res, '\n')[[1]]
expect_false(any(grepl('\\*', res)))
expect_equal(res[3], '1 2 3 4 5 6 7 8 9 10')
# length(dim) == 1
x <- array(1:10)
res <- pandoc.table.return(x, emphasize.cells=c(3,4), plain.ascii = T)
res <- strsplit(res, '\n')[[1]]
expect_false(any(grepl('\\*', res)))
expect_equal(res[3], '1 2 3 4 5 6 7 8 9 10')
# length(dim) > 1
x <- mtcars[1:3, 1:4]
res <- pandoc.table.return(x, emphasize.rows = 2, plain.ascii = T)
expect_false(grepl(' ', res))
expect_false(grepl('\\*', res))
})
context('S3 methods')
test_that('pander.tabular behaves correctly', {
suppressMessages(require(tables))
tab <- pander_return(tables::tabular(as.factor(am) ~ (mpg + hp + qsec) * (mean + median),
data = mtcars),
emphasize.rownames = FALSE,
split.tables = Inf)
expect_equal(length(tab), 10)
tab <- pander_return(tables::tabular( (Species + 1) ~ (n = 1) + Format(digits = 2) * (Sepal.Length + Sepal.Width) * (mean + sd), data=iris ), #nolint
split.tables = Inf)
expect_equal(length(tab), 14)
})
test_that('pander.CrossTable behaves correctly', {
suppressMessages(require(descr))
# issue https://github.com/Rapporter/pander/issues/163
x <- CrossTable(mtcars$cyl, mtcars$gear, prop.c = FALSE, prop.t = FALSE, chisq = FALSE, prop.chisq = FALSE)
res <- pander_return(x)
expect_true(any(grepl(gsub('\\$', '\\\\$', x$ColData), res))) #nolint
expect_true(any(grepl(gsub('\\$', '\\\\$', x$RowData), res))) #nolint
# expected N, residual, std residual, adj std residual rownames was not included
x <- suppressWarnings(CrossTable(mtcars$cyl, mtcars$gear, expected = T, resid = T, sresid = T, asresid = T))
res <- pander_return(x)
expect_true(any(grepl('Expected N', res)))
expect_true(any(grepl('Residual', res)))
expect_true(any(grepl('Std Residual', res)))
expect_true(any(grepl('Adj Std Resid', res)))
# issue 211 support for total.r total.c
x <- CrossTable(mtcars$cyl, mtcars$gear)
res <- pander_return(x, total.c = FALSE)
expect_equal(length(res), 27)
expect_equal(length(grep('Total', res)), 4)
res <- pander_return(x, total.r = FALSE)
expect_equal(length(res), 30)
expect_equal(length(grep('Total', res)), 4)
res <- pander_return(x)
expect_equal(length(res), 30)
expect_equal(length(grep('Total', res)), 5)
})
test_that('pander.NULL behaves correctly', {
expect_equal(length(pander_return(NULL)), 0)
expect_equal(length(pander_return(c(NULL, NULL))), 0)
})
test_that('pander.cast_df behaves correctly', {
df <- data.frame(type=c(1, 1, 2, 2, 3, 3), variable='n', value=c(71, 72, 68, 80, 21, 20))
df.cast <- reshape::cast(df, type~., sum)
expect_equal(pander_return(df.cast, style='simple'),
c('','',' type (all) ','------ -------',' 1 143 ',' 2 148 ',' 3 41 ',''))
})
test_that('pander.lm/pander.summary.lm behaves correctly', {
ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14)
trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69)
group <- gl(2, 10, 20, labels = c('Ctl','Trt'))
weight <- c(ctl, trt)
lm.D9 <- lm(weight ~ group)
res1 <- pander_return(lm.D9)
expect_equal(length(res1), 11)
expect_equal(max(nchar(res1)), 62)
res <- pander_return(summary(lm.D9))
expect_true(any(grepl('Fitting linear model', res)))
expect_true(any(grepl('Observations', res)))
expect_equal(length(res), 18)
})
test_that('pander.glm/pander.summary.glm behaves correctly', {
clotting <- data.frame(
u = c(5,10,15,20,30,40,60,80,100),
lot1 = c(118,58,42,35,27,25,21,19,18),
lot2 = c(69,35,26,21,18,16,13,12,12))
glmm <- glm(lot1 ~ log(u), data = clotting, family = Gamma)
pglmm <- pander_return(glmm)
expect_equal(length(pglmm), 11)
expect_equal(max(nchar(pglmm)), 70)
res <- pander_return(summary(glmm))
expect_true(any(grepl('Null deviance', res)))
expect_equal(length(res), 21)
})
test_that('pander.aov/pander.summary.aov behaves correctly', {
npk.aovE <- aov(yield ~ N * P * K + Error(block), npk)
paov <- pander_return(npk.aovE)
psaov <- pander_return(summary(npk.aovE))
expect_equal(paov, psaov) # choice of similar result for summary and standard
expect_equal(length(psaov), 23)
})
test_that('pander.anova behaves correctly', {
fit <- lm(sr ~ ., data = LifeCycleSavings)
a <- anova(fit)
pa <- pander_return(a, style = 'simple')
expect_true(all(sapply(names(a)[-5], grepl, pa[3])))
#more complicated run
fit0 <- lm(sr ~ 1, data = LifeCycleSavings)
fit1 <- update(fit0, . ~ . + pop15)
fit2 <- update(fit1, . ~ . + pop75)
fit3 <- update(fit2, . ~ . + dpi)
fit4 <- update(fit3, . ~ . + ddpi)
a <- anova(fit0, fit1, fit2, fit3, fit4, test = 'F')
pa <- pander_return(a, style='simple')
expect_true(all(sapply(names(a)[-6], grepl, pa[3])))
})
test_that('pander.aovlist/pander.summary.aovlist behaves correctly', {
options(contrasts = c('contr.helmert', 'contr.poly'))
N <- c(0,1,0,1,1,1,0,0,0,1,1,0,1,1,0,0,1,0,1,0,1,1,0,0)
P <- c(1,1,0,0,0,1,0,1,1,1,0,0,0,1,0,1,1,0,0,1,0,1,1,0)
K <- c(1,0,0,1,0,1,1,0,0,1,0,1,0,1,1,0,0,0,1,1,1,0,1,0)
yield <- c(49.5,62.8,46.8,57.0,59.8,58.5,55.5,56.0,62.8,55.8,69.5,
55.0, 62.0,48.8,45.5,44.2,52.0,51.5,49.8,48.8,57.2,59.0,53.2,56.0)
npk <- data.frame(block=gl(6,4), N=factor(N), P=factor(P),
K=factor(K), yield=yield)
a <- aov(yield ~ N * P * K + Error(block), npk)
pa <- pander_return(a, style='simple')
expect_equal(length(pa), 14)
})
test_that('pander.mtable behaves correctly', {
suppressMessages(require(memisc))
lm0 <- lm(sr ~ pop15 + pop75, data = LifeCycleSavings)
pm <- pander_return(memisc::mtable(lm0), style='grid') # produces 2 columns, corner case
expect_equal(length(strsplit(pm[3], '\\+')[[1]]), 3)
expect_equal(length(pm), 35)
berkeley <- Aggregate(Table(Admit,Freq)~.,data=UCBAdmissions)
berk0 <- glm(cbind(Admitted,Rejected)~1,data=berkeley,family='binomial')
berk1 <- glm(cbind(Admitted,Rejected)~Gender,data=berkeley,family='binomial')
berk2 <- glm(cbind(Admitted,Rejected)~Gender + Dept,data=berkeley,family='binomial')
pm <- pander_return(mtable(berk0, summary.stats=NULL), style='grid') # only one row
expect_equal(length(pm), 7)
# horizontal, produced an error before
x <- memisc::mtable(berk0,berk1,berk2,
coef.style='horizontal',
summary.stats=c('Deviance','AIC','N'))
pm <- pander_return(x, style='grid')
expect_equal(length(pm), 33)
expect_true(all(sapply(colnames(x$coeficient), grepl, pm[4])))
# more complex mtable
pm <- pander_return(memisc::mtable(berk0,berk1,berk2,
coef.style='all',
summary.stats=c('Deviance','AIC','N')), style = 'grid')
expect_equal(length(pm), 47)
})
test_that('pander.ts behaves correctly', {
# ncol NULL
res <- pander_return(ts(1:10, frequency = 4, start = c(1959, 2)), style = 'simple')
expect_equal(res[3], ' Q1 Q2 Q3 Q4 ')
expect_equal(length(res), 8)
# ncol not NULL
res <- pander_return(ts(matrix(rnorm(30), 10, 3), start = c(1961, 1), frequency = 12), style = 'simple')
expect_equal(res[3], ' Series.1 Series.2 Series.3 ')
expect_equal(length(res), 15)
})
test_that('pander.coxph behaves correctly', {
suppressMessages(require(survival))
test1 <- list(time=c(4,3,1,1,2,2,3),
status=c(1,1,1,0,1,1,0),
x=c(0,2,1,1,1,0,0),
sex=c(0,0,0,0,1,1,1))
# Fit a stratified model
res <- pander_return(coxph(Surv(time, status) ~ x + strata(sex), test1))
expect_equal(res[3], ' coef exp(coef) se(coef) z p ')
expect_equal(length(res), 10)
})
test_that('pander.clogit works correctly', {
resp <- levels(logan$occupation)
n <- nrow(logan)
indx <- rep(1:n, length(resp))
logan2 <- data.frame(logan[indx,],
id = indx,
tocc = factor(rep(resp, each=n)))
logan2$case <- (logan2$occupation == logan2$tocc)
res <- pander_return(suppressWarnings(clogit(case ~ tocc + tocc:education + strata(id), logan2)))
expect_true(grepl('Fitting Conditional logistic regression', res[24]))
expect_equal(length(res), 26)
})
test_that('pander.zoo works correctly', {
suppressMessages(require(zoo))
x.Date <- as.Date('2003-02-01') + c(1, 3, 7, 9, 14) - 1
res <- pander_return(zoo(rnorm(5), x.Date), style='simple')
expect_true(grepl('Value', res[3]))
expect_equal(length(res), 10)
# more complex example with colnames
res <- pander_return(zoo(cbind(foo = rnorm(5), bar = rnorm(5))), style='simple')
expect_true(grepl('foo', res[3]))
expect_equal(length(res), 10)
})
test_that('pander.lme/pander.summary.lme behaves correctly', {
suppressMessages(require(nlme))
l1 <- lme(distance ~ age, Orthodont, random = ~ age | Subject)
sl <- summary(l1)
pl <- pander_return(l1)
spl <- pander_return(sl)
expect_equal(length(pl), 11)
expect_equal(length(grep('Table', pl)), 1)
expect_equal(length(spl), 29)
expect_equal(length(grep('Table', spl)), 3)
})
# test_that('pander.describe works correctly', {
# suppressMessages(require(psych))
# x <- data.frame(a=rnorm(10), b=rnorm(10, 2, 2), c=rnorm(10, 3, 4))
# res <- pander_return(describe(x))
# expect_equal(length(res), 37)
# expect_equal(length(grep('Table', res)), 2)
# res <- pander_return(describe(x), split.tables = Inf)
# expect_equal(length(res), 11)
# })
test_that('pander.survdiff works correctly', {
suppressMessages(require(survival))
res <- pander_return(survdiff(Surv(futime, fustat) ~ rx,data=ovarian))
expect_equal(length(res), 12)
expect_equal(res[3], ' N Observed Expected (O-E)^2/E (O-E)^2/V ')
# length(x$n) == 1
expect <- survexp(futime ~ ratetable(age = (accept.dt - birth.dt),
sex = 1,
year = accept.dt,
race = 'white'),
jasa, cohort = FALSE, ratetable = survexp.usr)
res <- pander_return(survdiff(Surv(jasa$futime, jasa$fustat) ~ offset(expect)))
expect_equal(res[3], ' Observed Expected Z p ')
expect_equal(length(res), 9)
})
test_that('pander.survfit works correctly', {
suppressMessages(require(survival))
res <- pander_return(survfit(Surv(time, status) ~ x, data = aml))
expect_equal(length(res), 20)
expect_true(any(grepl('Table', res)))
# using additional options
res <- pander_return(survfit(Surv(time, status) ~ x, data = aml), print.rmean = T)
expect_equal(length(res), 21)
expect_equal(res[21], '* restricted mean with upper limit = 103')
})
test_that('pander.sessionInfo works correctly', {
suppressMessages(require(utils))
res <- pander_return(sessionInfo())
expect_true(any(grepl('locale', res)))
expect_true(any(grepl('attached base package', res)))
res <- pander_return(sessionInfo(), locale = F, compact = F)
expect_false(any(grepl('locale', res)))
expect_true(any(grepl('utils', res)))
})
test_that('pander.stat.table works correctly', {
suppressMessages(require(Epi))
res <- pander_return(stat.table(tension,list(count(),mean(breaks)),data=warpbreaks))
expect_equal(length(res), 11)
expect_equal(res[3], ' count() mean(breaks) ')
res <- pander_return(stat.table(index=list(tension,wool),mean(breaks),data=warpbreaks))
expect_equal(length(res), 13)
# here add test
})
test_that('pander.microbenchmark works correctly', {
suppressMessages(require(microbenchmark))
res <- pander_return(microbenchmark(paste(1:10), paste0(1:10)))
expect_true(any(grepl('Unit', res)))
expect_equal(length(res), 11)
res <- pander_return(microbenchmark(paste(1:10), paste0(1:10)), split.tables = Inf, expr.labels = c('A'))
expect_true(any(grepl('A', res)))
expect_true(any(grepl('paste0\\(1:10\\)', res)))
res <- pander_return(microbenchmark(paste(1:10), paste0(1:10)), split.tables = Inf, expr.labels = c('A', 'B'))
expect_true(any(grepl('A', res)))
expect_true(any(grepl('B', res)))
expect_false(any(grepl('paste0\\(1:10\\)', res)))
res <- pander_return(microbenchmark(paste(1:10), paste0(1:10)), split.tables = Inf, expr.labels = c('A', 'B', 'C'))
expect_true(any(grepl('A', res)))
expect_true(any(grepl('B', res)))
expect_false(any(grepl('paste0\\(1:10\\)', res)))
})
test_that('pander.function works correctly', {
testf <- function(x) {
y <- x + 1
y
}
res <- pander_return(testf)
expect_true(all(grepl('\t', res)))
expect_equal(length(res), 5)
res <- pander_return(testf, syntax.highlighting = T, add.name = T)
expect_equal(length(res), 7)
expect_equal(res[1], '```r')
expect_true(grepl('testf', res[2]))
})
test_that('pander.rlm works correctly', {
res <- pander_return(rlm(stack.loss ~ ., stackloss))
expect_equal(res[4], ' (Intercept) Air.Flow Water.Temp Acid.Conc. ')
expect_equal(length(res), 13)
res <- pander_return(rlm(stack.loss ~ ., stackloss, psi = psi.hampel, init = 'lts'))
expect_equal(res[11], 'Degrees of freedom: 21 total; 17 residual')
expect_equal(length(res), 13)
})
test_that('pander.summary.table works correctly', {
ts <- summary(xtabs(cbind(ncases, ncontrols) ~ ., data = esoph))
res <- pander_return(ts)
expect_equal(res[6], ' Chisq df p.value ' )
expect_equal(length(res), 13)
res <- pander_return(ts, print.call = F)
expect_false(any(grepl('Calls', res)))
expect_equal(length(res), 12)
res <- pander_return(ts, caption = 'Factor')
expect_equal(res[11], 'Table: Factor')
res <- pander_return(summary(table(1:3)))
expect_false(any(grepl('-', res)))
expect_equal(length(res), 2)
})
test_that('pander.randomForest works correctly', {
suppressMessages(require(randomForest))
iris.rf <- randomForest(Species ~ ., data=iris, importance=TRUE,
proximity=TRUE)
res <- pander_return(iris.rf)
expect_equal(length(res), 20)
expect_equal(res[19], 'Table: Confusion Matrix')
ozone.rf <- randomForest(Ozone ~ ., data=airquality, mtry=3,
importance=TRUE, na.action=na.omit)
res <- pander_return(ozone.rf)
expect_equal(length(res), 8)
expect_false(any(grep('-', res)))
# with test
index <- 1:nrow(iris)
trainindex <- sample(index, trunc(length(index) / 2))
trainset <- iris[trainindex, ]
testset <- iris[-trainindex, ]
res <- pander_return(randomForest(x=trainset[ ,-1], y=trainset[ ,1], xtest=testset[ ,-1], ytest=testset[ ,1]))
expect_equal(length(res), 10)
expect_true(any(grepl('Test set MSE', res)))
res <- pander_return(randomForest(x=trainset[ ,-ncol(trainset)],
y=trainset[ ,ncol(trainset)],
xtest=testset[ ,-ncol(testset)],
ytest=testset[ ,ncol(testset)]))
expect_equal(length(res), 34)
expect_equal(res[33], 'Table: Test Confusion Matrix')
})
test_that('pander.irts works correctly', {
suppressMessages(require(tseries))
n <- 10
t <- cumsum(rexp(n, rate = 0.1))
v <- rnorm(n)
res <- pander_return(as.irts(cbind(t, v)))
expect_equal(length(res), 23)
u <- rnorm(n)
res <- pander_return(irts(t, cbind(u, v)))
expect_equal(length(res), 23)
})
test_that('pander.manova/summary.manova works correctly', {
npk2 <- within(npk, foo <- rnorm(24))
x <- manova(cbind(yield, foo) ~ block + N * P * K, npk2)
res1 <- pander_return(x)
xs <- summary(x)
res2 <- pander_return(xs)
expect_equal(res1, res2)
expect_equal(length(res1), 21)
})
test_that('pander.gtable works correctly', {
suppressMessages(require(gtable))
a <- gtable(unit(1:3, c('cm')), unit(5, 'cm'))
rect <- rectGrob(gp = gpar(fill = 'black'))
a <- gtable_add_grob(a, rect, 1, 1)
res <- pander_return(a)
expect_equal(length(res), 7)
})
test_that('pander.nls/pander.summary.nls works correctly', {
utils::data(muscle, package = 'MASS')
with(muscle, table(Strip))
musc.1 <- nls(Length ~ cbind(1, exp(-Conc / th)), muscle,
start = list(th = 1), algorithm = 'plinear')
res <- pander_return(musc.1, show.convergence = T)
expect_equal(length(res), 17)
res <- pander_return(musc.1)
expect_equal(length(res), 14)
musc.1.s <- summary(musc.1)
res <- pander_return(musc.1.s)
expect_equal(length(res), 18)
res <- pander_return(musc.1.s, show.convergence = T)
expect_equal(length(res), 21)
musc.1.s <- summary(musc.1, correlation = T)
res <- pander_return(musc.1.s)
expect_true(any(grepl('Correlation', res)))
expect_equal(length(res), 31)
})
test_that('pander.arima works correctly', {
res <- pander_return(arima(lh, order = c(1,0,0)))
expect_equal(length(res), 17)
expect_true(any(grep('s\\.e', res)))
res <- pander_return(arima(lh, order = c(3,0,0)))
expect_equal(length(res), 17)
expect_true(any(grep('s\\.e', res)))
res <- pander_return(arima(lh, order = c(3,0,0), method = 'CSS'), se = FALSE)
expect_equal(length(res), 15)
expect_false(any(grep('s\\.e', res)))
})
test_that('pander.polr/summary.polr works correctly', {
house.plr <- polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing)
res <- pander_return(house.plr)
expect_equal(length(res), 25)
expect_equal(length(grep('Table', res)), 2)
res <- pander_return(suppressMessages(summary(house.plr)))
expect_equal(length(res), 39)
expect_equal(length(grep('Table', res)), 2)
res <- pander_return(suppressMessages(summary(house.plr, correlation = TRUE)), split.table = Inf)
expect_equal(length(res), 60)
expect_equal(length(grep('Table', res)), 3)
})
test_that('pander.survreg/summary.survreg works correctly', {
suppressMessages(require(survival))
x <- survreg(Surv(futime, fustat) ~ ecog.ps + rx, ovarian, dist='exponential')
res <- pander_return(x)
expect_equal(length(res), 27)
expect_equal(length(grep('Table', res)), 1)
res <- pander_return(suppressMessages(summary(x)))
expect_equal(length(res), 33)
expect_equal(length(grep('Table', res)), 1)
res <- pander_return(suppressMessages(summary(x, correlation = TRUE)), split.table = Inf)
expect_equal(length(res), 44)
expect_equal(length(grep('Table', res)), 2)
})
test_that('pander.ols works correctly', {
suppressMessages(require(rms))
set.seed(123)
n <- 1000
age <- rnorm(n, 50, 10)
cholesterol <- rnorm(n, 200, 25)
sex <- factor(sample(c('female', 'male'), n, TRUE))
health <- data.frame(age, cholesterol)
dd <- datadist(age, sex)
fit1 <- ols(cholesterol ~ age)
fit2 <- ols(cholesterol ~ age + sex)
res1 <- pander_return(fit1)
expect_equal(length(res1), 40)
expect_equal(length(grep('Table', res1)), 3)
res2 <- pander_return(fit2, coefs = FALSE)
expect_equal(length(res2), 29)
expect_equal(length(grep('Table', res2)), 2)
})
test_that('pander.lrm works correctly', {
suppressMessages(require(rms))
x <- 1:5
y <- c(0,1,0,1,0)
reps <- c(1,2,3,2,1)
res <- pander_return(lrm(y ~ x))
expect_equal(length(res), 39)
expect_true(any(grep('y ~ x', res)))
expect_equal(length(grep('Table', res)), 2)
x <- rep(x, reps)
y <- rep(y, reps)
res <- pander_return(lrm(y ~ x), coefs = FALSE)
expect_equal(length(res), 28)
expect_true(any(grep('y ~ x', res)))
expect_equal(length(grep('Table', res)), 1)
res <- pander_return(lrm(y ~ x, penalty = 0.1), coefs = TRUE)
expect_true(any(grep('y ~ x', res)))
expect_equal(length(grep('Table', res)), 3)
})
test_that('pander.orm works correctly', {
suppressMessages(require(rms))
n <- 100
y <- round(runif(n), 2)
x1 <- sample(c(-1,0,1), n, TRUE)
x2 <- sample(c(-1,0,1), n, TRUE)
res <- pander_return(orm(y ~ x1 + x2, eps=1e-5))
expect_equal(length(res), 39)
expect_true(any(grep('y ~ x1 \\+ x2', res)))
expect_equal(length(grep('Table', res)), 2)
res <- pander_return(orm(y ~ x1 + x2, eps=1e-5), coefs = FALSE)
expect_equal(length(res), 28)
expect_true(any(grep('y ~ x1 \\+ x2', res)))
expect_equal(length(grep('Table', res)), 1)
})
test_that('pander.Glm works correctly', {
suppressMessages(require(rms))
counts <- c(18,17,15,20,10,20,25,13,12)
outcome <- gl(3,1,9)
treatment <- gl(3,3)
f <- Glm(counts ~ outcome + treatment, family=poisson())
res <- pander_return(f)
expect_equal(length(res), 37)
expect_true(any(grep('counts ~ outcome \\+ treatment', res)))
expect_equal(length(grep('Table', res)), 2)
res <- pander_return(f, coefs = FALSE)
expect_equal(length(res), 20)
expect_true(any(grep('counts ~ outcome \\+ treatment', res)))
expect_equal(length(grep('Table', res)), 1)
})
test_that('pander.cph', {
options(contrasts = original_contrasts_options)
suppressMessages(require(rms))
n <- 1000
set.seed(731)
age <- 50 + 12 * rnorm(n)
label(age) <- 'Age'
sex <- factor(sample(c('Male','Female'), n, rep=TRUE, prob=c(.6, .4)))
cens <- 15 * runif(n)
h <- .02 * exp(.04 * (age - 50) + .8 * (sex == 'Female'))
dt <- -log(runif(n)) / h
label(dt) <- 'Follow-up Time'
e <- ifelse(dt <= cens, 1, 0)
dt <- pmin(dt, cens)
units(dt) <- 'Year'
dd <- datadist(age, sex)
S <- Surv(dt,e)
f <- cph(S ~ rcs(age,4) + sex, x=TRUE, y=TRUE)
res <- pander_return(f)
expect_equal(length(res), 43)
expect_true(any(grep('S ~ rcs\\(age, 4\\) \\+ sex', res)))
expect_equal(length(grep('Table', res)), 2)
res <- pander_return(f, conf.int = 0.95)
expect_equal(length(res), 58)
expect_true(any(grep('S ~ rcs\\(age, 4\\) \\+ sex', res)))
expect_equal(length(grep('Table', res)), 3)
})
huashan/pander documentation built on May 17, 2019, 9:10 p.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(pander)
## reset later
original_contrasts_options <- getOption('contrasts')
context('pandoc.table')
tables <- list(
mtcars,
mtcars$am,
mtcars[1:2, ],
mtcars[1:2, 5],
summary(mtcars$am),
table(mtcars$am) + 0.1,
table(mtcars$am, mtcars$gear) + 0.1,
summary(lm(mtcars$hp~1))$coeff,
table(mtcars$am, mtcars$gear, mtcars$carb),
addmargins(table(mtcars$gear, mtcars$carb))
)
test_that('no error: multiline', {
for (t in tables)
expect_that(pandoc.table.return(t, style = 'multiline'), is_a('character'))
})
test_that('no error: simple', {
for (t in tables)
expect_that(pandoc.table.return(t, style = 'simple'), is_a('character'))
})
test_that('no error: grid', {
for (t in tables)
expect_that(pandoc.table.return(t, style = 'grid'), is_a('character'))
})
test_that('no error: rmarkdown', {
for (t in tables)
expect_that(pandoc.table.return(t, style = 'rmarkdown'), is_a('character'))
})
tables <- list(
mtcars,
mtcars$am,
mtcars[1:2, ],
mtcars[1:2, 5],
summary(mtcars$am),
table(mtcars$am) + 0.1,
table(mtcars$am, mtcars$gear) + 0.1,
lm(mtcars$hp~1),
t.test(extra ~ group, data = sleep),
prcomp(USArrests),
density(mtcars$hp),
table(mtcars$am, mtcars$gear, mtcars$carb) + 0.1
)
test_that('split.tables', {
# test exact values (#164)
t <- data.frame(a = '7 chars', b = paste(rep('Δ', 5), collapse = ' '))
expect_equal(nchar('Δ Δ Δ Δ Δ', type='width'), 9)
res_grid <- pander_return(t, style='grid', split.tables = 23)
expect_equal(length(res_grid), 8)
expect_false(any(grepl('Table', res_grid)))
res_grid <- pander_return(t, style='grid', split.tables = 22)
expect_equal(length(res_grid), 18)
expect_true(any(grepl('Table', res_grid)))
res_simple <- pander_return(t, style='simple', split.tables = 17)
expect_equal(length(res_simple), 6)
expect_false(any(grepl('Table', res_simple)))
res_simple <- pander_return(t, style='simple', split.tables = 16)
expect_equal(length(res_simple), 14)
expect_true(any(grepl('Table', res_simple)))
})
test_that('rmarkdown pipe-delimited table is correct (#186)', {
d <- data.frame(a = 'foo|bar', b = 'my missing cell')
res <- pander_return(d, style='rmarkdown')
expect_true(any(grep('foo', res)))
expect_true(any(grep('bar', res)))
expect_true(any(grep('my missing cell', res)))
rownames(d) <- 'x|y'
res <- pander_return(d, style='rmarkdown')
expect_true(any(grep('x', res)))
expect_true(any(grep('y', res)))
expect_true(any(grep('foo', res)))
expect_true(any(grep('bar', res)))
expect_true(any(grep('my missing cell', res)))
})
test_that('pandoc.table.return behaves correctly', {
expect_warning(pander_return(mtcars[,1:2], split.tables = Inf, split.cells = c('50%', '50%')))
t <- mtcars[1:3, 1:2]
attr(t, 'alignment') <- 'left'
attr(t, 'caption') <- 'simplified mtcars'
res <- pander_return(t, emphasize.rownames = F)
expect_false(any(grep('^[[:space:]]', res))) # because of left alignment
expect_true(any(grep('simplified mtcars', res)))
expect_error(pander_return(t, justify = c('left', 'right'))) # needs 3 because of rownames
expect_error(pander_return(t, justify = 'lr')) # needs 3 because of rownames
res <- pander_return(t, justify = 'lrr')
expect_false(any(grep('[[:space:]]$', res)))
expect_error(pander_return(t, justify='laft'))
res <- pander_return(t, split.tables = 1)
expect_equal(length(res), 24)
res <- pander_return(t, split.cells = c(10, 10, 10))
expect_equal(length(res), 16)
expect_warning(pander_return(t, split.cells = vector()))
})
dm <- panderOptions('decimal.mark')
panderOptions('decimal.mark', ',')
test_that('decimal mark', {
for (t in tables)
expect_true(grepl(',', paste(pander_return(t), collapse = '\n')))
})
panderOptions('decimal.mark', dm)
context('highlight tables')
t <- mtcars[1:3, 1:5]
test_that('highlight 1D: no error', {
expect_that(pandoc.table.return(t$mpg, emphasize.italics.cells = 1), is_a('character'))
expect_that(pandoc.table.return(t$mpg, emphasize.italics.cells = 1:2), is_a('character'))
expect_that(pandoc.table.return(t$mpg, emphasize.strong.cells = 1), is_a('character'))
expect_that(pandoc.table.return(t$mpg, emphasize.strong.cells = 1:2), is_a('character'))
})
t <- table(mtcars$am, mtcars$gear)
test_that('emphasize 2D: no error', {
expect_that(pandoc.table.return(t, emphasize.italics.rows = 1), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.italics.rows = 1:2), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.italics.cols = 1), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.italics.cols = 1:2), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.italics.cells = which(t > 10, arr.ind = TRUE)), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.italics.cells = which(t > 20, arr.ind = TRUE)), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.strong.rows = 1), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.strong.rows = 1:2), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.strong.cols = 1), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.strong.cols = 1:2), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.strong.cells = which(t > 10, arr.ind = TRUE)), is_a('character'))
expect_that(pandoc.table.return(t, emphasize.strong.cells = which(t > 20, arr.ind = TRUE)), is_a('character'))
})
test_that('emphasize: error', {
expect_that(pandoc.table(t, emphasize.italics.cols = 1:5), throws_error())
expect_that(pandoc.table(t, emphasize.italics.cols = 1.5), throws_error())
expect_that(pandoc.table(t, emphasize.strong.cols = 1:5), throws_error())
expect_that(pandoc.table(t, emphasize.strong.cols = 1.5), throws_error())
})
test_that('no warning for highlight NA/empty strings', {
expect_that(pandoc.table(data.frame(x = 1:2, y = c(1,NA)), emphasize.italics.cols = 2), not(gives_warning()))
})
test_that('emphasize.italics.rows works correctly', {
# test for issue 176
df <- data.frame(a=1:3, b=1:3, c=1:3)
res <- capture.output(pander(df, emphasize.italics.rows = c(1,2), style = 'simple'))
expect_equal(res[5], '*1* *1* *1*')
expect_equal(res[6], '*2* *2* *2*')
res <- capture.output(pander(df, emphasize.strong.rows = c(1,2), style = 'simple'))
expect_equal(res[5], '**1** **1** **1**')
expect_equal(res[6], '**2** **2** **2**')
})
test_that('emphasize.verbatim works correctly', {
df <- data.frame(a=1:3, b=4:6, c=7:9)
res <- pander_return(df, emphasize.verbatim.rows = c(1,2), style = 'simple')
expect_equal(res[5], '`1` `4` `7`')
expect_equal(res[6], '`2` `5` `8`')
res <- pander_return(df, emphasize.verbatim.cols = c(1,2), style = 'simple')
expect_equal(res[5], '`1` `4` 7 ')
expect_equal(res[6], '`2` `5` 8 ')
res <- pander_return(df, emphasize.verbatim.cells = which(df > 5, arr.ind = TRUE), style = 'simple')
expect_equal(res[5], ' 1 4 `7`')
expect_equal(res[6], ' 2 5 `8`')
res <- pander_return(df, emphasize.verbatim.cells = which(df > 5, arr.ind = TRUE),
emphasize.strong.rows = c(1,2), style = 'simple')
expect_equal(res[5], '**1** **4** **`7`**')
expect_equal(res[7], ' 3 `6` `9` ')
})
context('captions')
tables <- list(
mtcars,
mtcars[1:2, ],
summary(mtcars$am),
table(mtcars$am) + 0.1,
table(mtcars$am, mtcars$gear) + 0.1,
lm(mtcars$hp~1),
t.test(extra ~ group, data = sleep),
prcomp(USArrests),
density(mtcars$hp)
)
has.caption <- function(ttt, evals = FALSE) {
set.caption('foo')
if (!evals)
any(grepl('Table:', pander_return(ttt)))
else
!is.null(attr(evals('get("ttt")', env = parent.frame())[[1]]$result, 'caption'))
}
test_that('direct call', {
for (ttt in tables)
expect_that(has.caption(ttt), is_true())
})
cache.dir <- evalsOptions('cache.dir')
graph.dir <- evalsOptions('graph.dir')
wd <- getwd()
setwd(tempdir())
evalsOptions('cache.dir', file.path(tempdir(), '.cache'))
evalsOptions('graph.dir', file.path(tempdir(), 'plots'))
test_that('evals', {
for (ttt in tables)
expect_that(has.caption(ttt, evals = TRUE), is_true())
})
evalsOptions('cache.dir', cache.dir)
evalsOptions('graph.dir', graph.dir)
setwd(wd)
context('default alignments')
tables <- list(
mtcars,
mtcars$am,
mtcars[1:2, ],
mtcars[1:2, 5],
summary(mtcars$am),
table(mtcars$am) + 0.1,
table(mtcars$am, mtcars$gear) + 0.1,
summary(lm(mtcars$hp~1))$coeff,
table(mtcars$am, mtcars$gear, mtcars$carb)
)
tad <- panderOptions('table.alignment.default')
tar <- panderOptions('table.alignment.rownames')
panderOptions('table.alignment.default', 'centre')
panderOptions('table.alignment.rownames', 'right')
test_that('no error: allright', {
for (t in tables)
expect_that(pandoc.table.return(t, style = 'multiline'), is_a('character'))
})
f <- function(df) {
if (class(df) != 'matrix' && !is.table(df) || length(dim(df)) < 2)
ifelse(sapply(df, is.numeric), 'right', 'left')
else
ifelse(apply(df, 2, is.numeric), 'right', 'left')
}
panderOptions('table.alignment.default', f)
test_that('no error: functions', {
for (t in tables)
expect_that(pandoc.table.return(t, style = 'multiline'), is_a('character'))
})
panderOptions('table.alignment.default', tad)
panderOptions('table.alignment.rownames', tar)
test_that('digits param', {
m <- matrix(rep(0.111111, 6), nrow = 2)
res <- pander_return(m, digits = c(2,4,1))
expect_equal(res[3], '0.11 0.1111 0.1')
expect_warning(pander_return(m, digits=c(1,2)))
res <- pander_return(m, digits = c(2))
expect_equal(res[3],'0.11 0.11 0.11')
mt <- mtcars[1:4, 5:8]
res <- pander_return(mt, digits = c(1,4,3,4), keep.trailing.zeros = T)
expect_equal(res[5], ' **Mazda RX4** 4 2.62 16.5 0 ')
})
test_that('round param', {
m <- matrix(rep(0.111111, 6), nrow = 2)
res <- pander_return(m, round = c(2,4,1))
expect_equal(res[3], '0.11 0.1111 0.1')
expect_warning(pander_return(m, round=c(1,2)))
res <- pander_return(m, round = c(2))
expect_equal(res[3],'0.11 0.11 0.11')
})
context('keep.line.breaks')
test_that('keep.line.breaks works correctly', {
# keeping line breaks in a simple data.frame with one line breaks differs lines amount by one
x <- data.frame(a='Pander\nPackage')
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE), '\n')[[1]])
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks + 1, lines.x.keep.breaks)
# keeping line breaks in a simple data.frame with 2 rows with 1 line breaks differst lines amount by 2
x <- data.frame(a=c('Pander\nPackage','Pander\nPackage'))
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE), '\n')[[1]])
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks + 2, lines.x.keep.breaks)
#if there are no line breaks originally, they do not get introduced
x <- data.frame(a=c('Pander Package','Pander Package'))
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE), '\n')[[1]])
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks, lines.x.keep.breaks)
# works with random number of rows added
rows <- sample(1:100, 1)
x <- data.frame(a=rep('Pander\nPackage', rows))
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE), '\n')[[1]])
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks + rows, lines.x.keep.breaks)
# random number of line breaks in one cell
n <- sample(1:10, 1)
x <- data.frame(a=paste(rep('pander', n), collapse='\n'))
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE, split.cells = Inf), '\n')[[1]])
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks + n - 1, lines.x.keep.breaks)
# random number of line breaks in cells, 3 columns
n <- sample(1:10, 3)
x <- data.frame(a=paste(rep('pander', n[1]), collapse='\n'),
b = paste(rep('pander', n[2]), collapse='\n'),
c = paste(rep('pander', n[3]), collapse='\n'))
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE, split.cells = Inf, split.tables = Inf), '\n')[[1]]) #nolint
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks + max(n) - 1, lines.x.keep.breaks)
# 3 columns, 2 rows
x <- rbind(x,x)
lines.x.no.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = FALSE, split.cells = Inf, split.tables = Inf), '\n')[[1]]) #nolint
lines.x.keep.breaks <- length(strsplit(pandoc.table.return(x, keep.line.breaks = TRUE), '\n')[[1]])
expect_equal(lines.x.no.breaks + 2 * max(n) - 2, lines.x.keep.breaks)
})
context('split.cells')
test_that('split.cells works correctly',{
x <- data.frame(a = 'foo bar\nfo bar')
# single line break behaves correctly combines with keep line breaks
expect_equal(pandoc.table.return(x, keep.line.breaks = T, split.cells = 7),
'\n-------\n a \n-------\nfoo bar\nfo bar \n-------\n\n')
expect_equal(pandoc.table.return(x, keep.line.breaks = T, split.cells = 6),
'\n------\n a \n------\n foo \n bar \nfo bar\n------\n\n')
# Corner values of split.cells
x <- data.frame(a = 'foo bar', b = 'foo bar')
expect_equal(length(strsplit(pandoc.table.return(x, split.cells = c(6, Inf)), '\n')[[1]]), 8)
expect_equal(pandoc.table.return(x, split.cells = c(6, Inf)),
'\n-----------\n a b \n--- -------\nfoo foo bar\nbar \n-----------\n\n')
expect_equal(pandoc.table.return(x, split.cells = c(Inf, 6)),
'\n-----------\n a b \n------- ---\nfoo bar foo\n bar\n-----------\n\n')
expect_equal(pandoc.table.return(x, split.cells = c(7, 7)),
'\n---------------\n a b \n------- -------\nfoo bar foo bar\n---------------\n\n')
expect_equal(pandoc.table.return(x, split.cells = c(7, 7)), pandoc.table.return(x, split.cells = Inf))
expect_equal(pandoc.table.return(x, split.cells = c(6 ,6)), pandoc.table.return(x, split.cells = 6))
expect_equal(pandoc.table.return(x, split.cells = c(7 ,7)), pandoc.table.return(x, split.cells = 7))
expect_equal(pandoc.table.return(x, split.cells = c(7 ,7)), pandoc.table.return(x, split.cells = 7))
# relative split.cells
expect_equal(pandoc.table.return(x, split.cells = c('50%', '50%')),
pandoc.table.return(x, split.cells = c(7)))
expect_equal(pandoc.table.return(x, split.cells = c('20%', '80%'), split.tables = 30),
pandoc.table.return(x, split.cells = c(6, Inf)))
expect_equal(pandoc.table.return(x, split.cells = c('80%', '20%'), split.tables = 30),
pandoc.table.return(x, split.cells = c(Inf, 6)))
})
test_that('split.cells param produces expected warnings',{
mt <- mtcars[1:2, 1:4]
expect_warning(pander(mt, split.cells = c(1,2)))
expect_warning(pander(mt, split.cells = c(1,2,3)))
expect_warning(pander(mt, split.cells = c('10%','10%','10%')))
expect_warning(pander(mt, split.cells = c('30%','30%','40%')))
})
context('table.expand')
test_that('produces.errors',{
x <- data.frame(a='Pander\nPackage')
expect_error(pander(x, style='simple', keep.line.breaks = T))
expect_error(pander(x, style='rmarkdown', keep.line.breaks = T))
})
table.expand <- function(cells, cols.width, justify, sep.cols, style) {
.Call('pander_tableExpand_cpp', PACKAGE = 'pander', cells, cols.width, justify, sep.cols, style)
}
test_that('table.expand behaves correctly',{
## multiline style check
argv <- structure(list(txt = structure(c(1L, 4L, 2L, 3L), .Label = c(' ', 'cyl', 'disp', 'mpg'), class = 'factor'), width = c(19, 5, 5, 6), justify = structure(c(1L, 1L, 1L, 1L), .Label = 'centre', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c(NA, -4L), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'multiline'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)),
length(strsplit(res, '\n')[[1]]))
expect_equal(nchar(res),
nchar(sep.cols)[1] + (length(argv[,2]) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(argv[,2]))
expect_equal(res, ' mpg cyl disp ');
## grid style check
argv <- structure(list(txt = structure(c(1L, 5L, 2L, 3L, 4L), .Label = c(' ', 'cyl', 'disp', 'hp', 'mpg'), class = 'factor'), width = c(20, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'centre', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c(NA, -5L), class = 'data.frame') #nolint
sep.cols <- c('| ', ' | ', ' |')
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)), length(strsplit(res, '\n')[[1]]))
expect_equal(nchar(res), nchar(sep.cols)[1] + (length(argv[,2]) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(argv[,2])) #nolint
expect_equal(res, '| | mpg | cyl | disp | hp |' )
## rmarkdown style check
argv <- structure(list(txt = structure(c(1L, 4L, 5L, 3L, 2L), .Label = c('**Mazda RX4**', '110', '160', '21', '6'), class = 'factor'), width = c(20, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'centre', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c('t.rownames', 'mpg', 'cyl', 'disp', 'hp'), class = 'data.frame') #nolint
sep.cols <- c('| ', ' | ', ' |')
style <- 'rmarkdown'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)), length(strsplit(res, '\n')[[1]]))
expect_equal(nchar(res),
nchar(sep.cols)[1] + (length(argv[,2]) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(argv[,2]))
expect_equal(res, '| **Mazda RX4** | 21 | 6 | 160 | 110 |')
## simple style check
argv <- structure(list(txt = structure(c(1L, 3L, 4L, 2L, 5L), .Label = c('**Datsun 710**', '108', '22.8', '4', '93'), class = 'factor'), width = c(20, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'centre', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c('t.rownames', 'mpg', 'cyl', 'disp', 'hp'), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'simple'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)), length(strsplit(res, '\n')[[1]]))
expect_equal(nchar(res),
nchar(sep.cols)[1] + (length(argv[,2]) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(argv[,2]))
expect_equal(res, ' **Datsun 710** 22.8 4 108 93 ')
## left justification
argv <- structure(list(txt = structure(c(1L, 4L, 5L, 3L, 2L), .Label = c('**Mazda', '110', '160', '21', '6'), class = 'factor'), width = c(10, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'left', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c(NA, -5L), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'multiline'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)), length(strsplit(res, '\n')[[1]]))
expect_equal(nchar(res),
nchar(sep.cols)[1] + (length(argv[,2]) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(argv[,2]))
expect_equal(res, '**Mazda 21 6 160 110 ');
## right justification
argv <- structure(list(txt = structure(c(1L, 3L, 5L, 4L, 2L), .Label = c('**Hornet 4 Drive**', '110', '21.4', '258', '6'), class = 'factor'), width = c(20, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'right', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c('t.rownames', 'mpg', 'cyl', 'disp', 'hp'), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'simple'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)), length(strsplit(res, '\n')[[1]]))
expect_equal(nchar(res),
nchar(sep.cols)[1] + (length(argv[,2]) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(argv[,2]))
expect_equal(res, ' **Hornet 4 Drive** 21.4 6 258 110' );
## multiple lines
argv <- structure(list(txt = structure(c(1L, 3L, 5L, 4L, 2L), .Label = c('**Hornet\n4\nDrive**', '110', '21.4', '258', '6'), class = 'factor'), width = c(10, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'left', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c('t.rownames', 'mpg', 'cyl', 'disp', 'hp'), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'multiline'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)),
length(strsplit(res, '\n')[[1]]))
# max number of line breaks equals number of lines in the result
expect_equal(res, '**Hornet 21.4 6 258 110 \n4 \nDrive** '); #nolint
argv <- structure(list(txt = structure(c(1L, 3L, 4L, 2L, 5L), .Label = c('**Datsun\n710**', '108', '22.8', '4', '93'), class = 'factor'), width = c(10, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'left', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c('t.rownames', 'mpg', 'cyl', 'disp', 'hp'), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'multiline'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)),
length(strsplit(res, '\n')[[1]]))
expect_equal(res, '**Datsun 22.8 4 108 93 \n710** ');
argv <- structure(list(txt = structure(c(1L, 4L, 5L, 3L, 2L), .Label = c('**Mazda\nRX4\nWag**', '110', '160', '21', '6'), class = 'factor'), width = c(10, 5, 5, 6, 4), justify = structure(c(1L, 1L, 1L, 1L, 1L), .Label = 'left', class = 'factor')), .Names = c('txt', 'width', 'justify'), row.names = c('t.rownames', 'mpg', 'cyl', 'disp', 'hp'), class = 'data.frame') #nolint
sep.cols <- c('', ' ', '')
style <- 'multiline'
res <- table.expand(argv[,1], argv[,2], argv[,3], sep.cols, style)
# max number of line breaks equals number of lines in the result
expect_equal(max(sapply(strsplit(as.character(argv[,1]), '\n'), length)), length(strsplit(res, '\n')[[1]]))
expect_equal(res, '**Mazda 21 6 160 110 \nRX4 \nWag** '); #nolint
# empty cells
cells <- c('','','')
cols.width <- c(2, 2, 2)
justify <- c('centre', 'centre', 'centre')
sep.cols <- c('', ' ', '')
res <- table.expand(cells, cols.width, justify, sep.cols, 'multiline')
# when max.width param is small, every word is a line
expect_equal(max(sapply(strsplit(as.character(cells), '\n'), length)), 0)
expect_equal(nchar(res),
nchar(sep.cols)[1] + (length(cells) - 1) * nchar(sep.cols)[2] + nchar(sep.cols)[3] + sum(cols.width))
expect_equal(res, ' ')
# backslashes issue (#22)
expect_equal(pandoc.table.return(data.frame(a='\\1 \\ 32',b='23')),
'\n-----------\n a b \n------- ---\n\\1 \\ 32 23 \n-----------\n\n')
expect_equal(pandoc.table.return(data.frame(a='\\1 \\ 32',b='23'), justify = 'right'),
'\n-----------\n a b\n------- ---\n\\1 \\ 32 23\n-----------\n\n')
expect_equal(pandoc.table.return(data.frame(a='\\1',b='23')),
'\n-------\n a b \n--- ---\n\\1 23 \n-------\n\n')
# unicode string issue
expect_equal(pandoc.table.return(data.frame(a = 'ßß')), '\n---\n a \n---\nßß \n---\n\n')
})
context('Empty objects')
test_that('Behavior for empty objects is correct', {
mt <- mtcars[mtcars$mpg < 0, 1:4]
res <- pander_return(mt)
expect_equal(res[3], '**mpg** **cyl** **disp** **hp**')
expect_equal(length(res), 6)
colnames(mt) <- NULL
res <- suppressWarnings(pander_return(mt))
expect_equal(length(res), 0)
expect_warning(pander_return(mt))
mt <- matrix(0, nrow = 0, ncol = 5)
res <- suppressWarnings(pander_return(mt))
expect_equal(length(res), 0)
expect_warning(pander_return(mt))
colnames(mt) <- 1:5
res <- pander_return(mt)
expect_equal(res[3], '**1** **2** **3** **4** **5**')
expect_equal(length(res), 6)
expect_equal(length(pander_return(data.frame())), 0)
expect_warning(pander_return(data.frame()))
})
context('plain.ascii')
test_that('plain.ascii option works correctly', {
# dim is NULL
x <- 1:10
res <- pandoc.table.return(x, emphasize.cells=c(3,4), plain.ascii = T)
res <- strsplit(res, '\n')[[1]]
expect_false(any(grepl('\\*', res)))
expect_equal(res[3], '1 2 3 4 5 6 7 8 9 10')
# length(dim) == 1
x <- array(1:10)
res <- pandoc.table.return(x, emphasize.cells=c(3,4), plain.ascii = T)
res <- strsplit(res, '\n')[[1]]
expect_false(any(grepl('\\*', res)))
expect_equal(res[3], '1 2 3 4 5 6 7 8 9 10')
# length(dim) > 1
x <- mtcars[1:3, 1:4]
res <- pandoc.table.return(x, emphasize.rows = 2, plain.ascii = T)
expect_false(grepl(' ', res))
expect_false(grepl('\\*', res))
})
context('S3 methods')
test_that('pander.tabular behaves correctly', {
suppressMessages(require(tables))
tab <- pander_return(tables::tabular(as.factor(am) ~ (mpg + hp + qsec) * (mean + median),
data = mtcars),
emphasize.rownames = FALSE,
split.tables = Inf)
expect_equal(length(tab), 10)
tab <- pander_return(tables::tabular( (Species + 1) ~ (n = 1) + Format(digits = 2) * (Sepal.Length + Sepal.Width) * (mean + sd), data=iris ), #nolint
split.tables = Inf)
expect_equal(length(tab), 14)
})
test_that('pander.CrossTable behaves correctly', {
suppressMessages(require(descr))
# issue https://github.com/Rapporter/pander/issues/163
x <- CrossTable(mtcars$cyl, mtcars$gear, prop.c = FALSE, prop.t = FALSE, chisq = FALSE, prop.chisq = FALSE)
res <- pander_return(x)
expect_true(any(grepl(gsub('\\$', '\\\\$', x$ColData), res))) #nolint
expect_true(any(grepl(gsub('\\$', '\\\\$', x$RowData), res))) #nolint
# expected N, residual, std residual, adj std residual rownames was not included
x <- suppressWarnings(CrossTable(mtcars$cyl, mtcars$gear, expected = T, resid = T, sresid = T, asresid = T))
res <- pander_return(x)
expect_true(any(grepl('Expected N', res)))
expect_true(any(grepl('Residual', res)))
expect_true(any(grepl('Std Residual', res)))
expect_true(any(grepl('Adj Std Resid', res)))
# issue 211 support for total.r total.c
x <- CrossTable(mtcars$cyl, mtcars$gear)
res <- pander_return(x, total.c = FALSE)
expect_equal(length(res), 27)
expect_equal(length(grep('Total', res)), 4)
res <- pander_return(x, total.r = FALSE)
expect_equal(length(res), 30)
expect_equal(length(grep('Total', res)), 4)
res <- pander_return(x)
expect_equal(length(res), 30)
expect_equal(length(grep('Total', res)), 5)
})
test_that('pander.NULL behaves correctly', {
expect_equal(length(pander_return(NULL)), 0)
expect_equal(length(pander_return(c(NULL, NULL))), 0)
})
test_that('pander.cast_df behaves correctly', {
df <- data.frame(type=c(1, 1, 2, 2, 3, 3), variable='n', value=c(71, 72, 68, 80, 21, 20))
df.cast <- reshape::cast(df, type~., sum)
expect_equal(pander_return(df.cast, style='simple'),
c('','',' type (all) ','------ -------',' 1 143 ',' 2 148 ',' 3 41 ',''))
})
test_that('pander.lm/pander.summary.lm behaves correctly', {
ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14)
trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69)
group <- gl(2, 10, 20, labels = c('Ctl','Trt'))
weight <- c(ctl, trt)
lm.D9 <- lm(weight ~ group)
res1 <- pander_return(lm.D9)
expect_equal(length(res1), 11)
expect_equal(max(nchar(res1)), 62)
res <- pander_return(summary(lm.D9))
expect_true(any(grepl('Fitting linear model', res)))
expect_true(any(grepl('Observations', res)))
expect_equal(length(res), 18)
})
test_that('pander.glm/pander.summary.glm behaves correctly', {
clotting <- data.frame(
u = c(5,10,15,20,30,40,60,80,100),
lot1 = c(118,58,42,35,27,25,21,19,18),
lot2 = c(69,35,26,21,18,16,13,12,12))
glmm <- glm(lot1 ~ log(u), data = clotting, family = Gamma)
pglmm <- pander_return(glmm)
expect_equal(length(pglmm), 11)
expect_equal(max(nchar(pglmm)), 70)
res <- pander_return(summary(glmm))
expect_true(any(grepl('Null deviance', res)))
expect_equal(length(res), 21)
})
test_that('pander.aov/pander.summary.aov behaves correctly', {
npk.aovE <- aov(yield ~ N * P * K + Error(block), npk)
paov <- pander_return(npk.aovE)
psaov <- pander_return(summary(npk.aovE))
expect_equal(paov, psaov) # choice of similar result for summary and standard
expect_equal(length(psaov), 23)
})
test_that('pander.anova behaves correctly', {
fit <- lm(sr ~ ., data = LifeCycleSavings)
a <- anova(fit)
pa <- pander_return(a, style = 'simple')
expect_true(all(sapply(names(a)[-5], grepl, pa[3])))
#more complicated run
fit0 <- lm(sr ~ 1, data = LifeCycleSavings)
fit1 <- update(fit0, . ~ . + pop15)
fit2 <- update(fit1, . ~ . + pop75)
fit3 <- update(fit2, . ~ . + dpi)
fit4 <- update(fit3, . ~ . + ddpi)
a <- anova(fit0, fit1, fit2, fit3, fit4, test = 'F')
pa <- pander_return(a, style='simple')
expect_true(all(sapply(names(a)[-6], grepl, pa[3])))
})
test_that('pander.aovlist/pander.summary.aovlist behaves correctly', {
options(contrasts = c('contr.helmert', 'contr.poly'))
N <- c(0,1,0,1,1,1,0,0,0,1,1,0,1,1,0,0,1,0,1,0,1,1,0,0)
P <- c(1,1,0,0,0,1,0,1,1,1,0,0,0,1,0,1,1,0,0,1,0,1,1,0)
K <- c(1,0,0,1,0,1,1,0,0,1,0,1,0,1,1,0,0,0,1,1,1,0,1,0)
yield <- c(49.5,62.8,46.8,57.0,59.8,58.5,55.5,56.0,62.8,55.8,69.5,
55.0, 62.0,48.8,45.5,44.2,52.0,51.5,49.8,48.8,57.2,59.0,53.2,56.0)
npk <- data.frame(block=gl(6,4), N=factor(N), P=factor(P),
K=factor(K), yield=yield)
a <- aov(yield ~ N * P * K + Error(block), npk)
pa <- pander_return(a, style='simple')
expect_equal(length(pa), 14)
})
test_that('pander.mtable behaves correctly', {
suppressMessages(require(memisc))
lm0 <- lm(sr ~ pop15 + pop75, data = LifeCycleSavings)
pm <- pander_return(memisc::mtable(lm0), style='grid') # produces 2 columns, corner case
expect_equal(length(strsplit(pm[3], '\\+')[[1]]), 3)
expect_equal(length(pm), 35)
berkeley <- Aggregate(Table(Admit,Freq)~.,data=UCBAdmissions)
berk0 <- glm(cbind(Admitted,Rejected)~1,data=berkeley,family='binomial')
berk1 <- glm(cbind(Admitted,Rejected)~Gender,data=berkeley,family='binomial')
berk2 <- glm(cbind(Admitted,Rejected)~Gender + Dept,data=berkeley,family='binomial')
pm <- pander_return(mtable(berk0, summary.stats=NULL), style='grid') # only one row
expect_equal(length(pm), 7)
# horizontal, produced an error before
x <- memisc::mtable(berk0,berk1,berk2,
coef.style='horizontal',
summary.stats=c('Deviance','AIC','N'))
pm <- pander_return(x, style='grid')
expect_equal(length(pm), 33)
expect_true(all(sapply(colnames(x$coeficient), grepl, pm[4])))
# more complex mtable
pm <- pander_return(memisc::mtable(berk0,berk1,berk2,
coef.style='all',
summary.stats=c('Deviance','AIC','N')), style = 'grid')
expect_equal(length(pm), 47)
})
test_that('pander.ts behaves correctly', {
# ncol NULL
res <- pander_return(ts(1:10, frequency = 4, start = c(1959, 2)), style = 'simple')
expect_equal(res[3], ' Q1 Q2 Q3 Q4 ')
expect_equal(length(res), 8)
# ncol not NULL
res <- pander_return(ts(matrix(rnorm(30), 10, 3), start = c(1961, 1), frequency = 12), style = 'simple')
expect_equal(res[3], ' Series.1 Series.2 Series.3 ')
expect_equal(length(res), 15)
})
test_that('pander.coxph behaves correctly', {
suppressMessages(require(survival))
test1 <- list(time=c(4,3,1,1,2,2,3),
status=c(1,1,1,0,1,1,0),
x=c(0,2,1,1,1,0,0),
sex=c(0,0,0,0,1,1,1))
# Fit a stratified model
res <- pander_return(coxph(Surv(time, status) ~ x + strata(sex), test1))
expect_equal(res[3], ' coef exp(coef) se(coef) z p ')
expect_equal(length(res), 10)
})
test_that('pander.clogit works correctly', {
resp <- levels(logan$occupation)
n <- nrow(logan)
indx <- rep(1:n, length(resp))
logan2 <- data.frame(logan[indx,],
id = indx,
tocc = factor(rep(resp, each=n)))
logan2$case <- (logan2$occupation == logan2$tocc)
res <- pander_return(suppressWarnings(clogit(case ~ tocc + tocc:education + strata(id), logan2)))
expect_true(grepl('Fitting Conditional logistic regression', res[24]))
expect_equal(length(res), 26)
})
test_that('pander.zoo works correctly', {
suppressMessages(require(zoo))
x.Date <- as.Date('2003-02-01') + c(1, 3, 7, 9, 14) - 1
res <- pander_return(zoo(rnorm(5), x.Date), style='simple')
expect_true(grepl('Value', res[3]))
expect_equal(length(res), 10)
# more complex example with colnames
res <- pander_return(zoo(cbind(foo = rnorm(5), bar = rnorm(5))), style='simple')
expect_true(grepl('foo', res[3]))
expect_equal(length(res), 10)
})
test_that('pander.lme/pander.summary.lme behaves correctly', {
suppressMessages(require(nlme))
l1 <- lme(distance ~ age, Orthodont, random = ~ age | Subject)
sl <- summary(l1)
pl <- pander_return(l1)
spl <- pander_return(sl)
expect_equal(length(pl), 11)
expect_equal(length(grep('Table', pl)), 1)
expect_equal(length(spl), 29)
expect_equal(length(grep('Table', spl)), 3)
})
# test_that('pander.describe works correctly', {
# suppressMessages(require(psych))
# x <- data.frame(a=rnorm(10), b=rnorm(10, 2, 2), c=rnorm(10, 3, 4))
# res <- pander_return(describe(x))
# expect_equal(length(res), 37)
# expect_equal(length(grep('Table', res)), 2)
# res <- pander_return(describe(x), split.tables = Inf)
# expect_equal(length(res), 11)
# })
test_that('pander.survdiff works correctly', {
suppressMessages(require(survival))
res <- pander_return(survdiff(Surv(futime, fustat) ~ rx,data=ovarian))
expect_equal(length(res), 12)
expect_equal(res[3], ' N Observed Expected (O-E)^2/E (O-E)^2/V ')
# length(x$n) == 1
expect <- survexp(futime ~ ratetable(age = (accept.dt - birth.dt),
sex = 1,
year = accept.dt,
race = 'white'),
jasa, cohort = FALSE, ratetable = survexp.usr)
res <- pander_return(survdiff(Surv(jasa$futime, jasa$fustat) ~ offset(expect)))
expect_equal(res[3], ' Observed Expected Z p ')
expect_equal(length(res), 9)
})
test_that('pander.survfit works correctly', {
suppressMessages(require(survival))
res <- pander_return(survfit(Surv(time, status) ~ x, data = aml))
expect_equal(length(res), 20)
expect_true(any(grepl('Table', res)))
# using additional options
res <- pander_return(survfit(Surv(time, status) ~ x, data = aml), print.rmean = T)
expect_equal(length(res), 21)
expect_equal(res[21], '* restricted mean with upper limit = 103')
})
test_that('pander.sessionInfo works correctly', {
suppressMessages(require(utils))
res <- pander_return(sessionInfo())
expect_true(any(grepl('locale', res)))
expect_true(any(grepl('attached base package', res)))
res <- pander_return(sessionInfo(), locale = F, compact = F)
expect_false(any(grepl('locale', res)))
expect_true(any(grepl('utils', res)))
})
test_that('pander.stat.table works correctly', {
suppressMessages(require(Epi))
res <- pander_return(stat.table(tension,list(count(),mean(breaks)),data=warpbreaks))
expect_equal(length(res), 11)
expect_equal(res[3], ' count() mean(breaks) ')
res <- pander_return(stat.table(index=list(tension,wool),mean(breaks),data=warpbreaks))
expect_equal(length(res), 13)
# here add test
})
test_that('pander.microbenchmark works correctly', {
suppressMessages(require(microbenchmark))
res <- pander_return(microbenchmark(paste(1:10), paste0(1:10)))
expect_true(any(grepl('Unit', res)))
expect_equal(length(res), 11)
res <- pander_return(microbenchmark(paste(1:10), paste0(1:10)), split.tables = Inf, expr.labels = c('A'))
expect_true(any(grepl('A', res)))
expect_true(any(grepl('paste0\\(1:10\\)', res)))
res <- pander_return(microbenchmark(paste(1:10), paste0(1:10)), split.tables = Inf, expr.labels = c('A', 'B'))
expect_true(any(grepl('A', res)))
expect_true(any(grepl('B', res)))
expect_false(any(grepl('paste0\\(1:10\\)', res)))
res <- pander_return(microbenchmark(paste(1:10), paste0(1:10)), split.tables = Inf, expr.labels = c('A', 'B', 'C'))
expect_true(any(grepl('A', res)))
expect_true(any(grepl('B', res)))
expect_false(any(grepl('paste0\\(1:10\\)', res)))
})
test_that('pander.function works correctly', {
testf <- function(x) {
y <- x + 1
y
}
res <- pander_return(testf)
expect_true(all(grepl('\t', res)))
expect_equal(length(res), 5)
res <- pander_return(testf, syntax.highlighting = T, add.name = T)
expect_equal(length(res), 7)
expect_equal(res[1], '```r')
expect_true(grepl('testf', res[2]))
})
test_that('pander.rlm works correctly', {
res <- pander_return(rlm(stack.loss ~ ., stackloss))
expect_equal(res[4], ' (Intercept) Air.Flow Water.Temp Acid.Conc. ')
expect_equal(length(res), 13)
res <- pander_return(rlm(stack.loss ~ ., stackloss, psi = psi.hampel, init = 'lts'))
expect_equal(res[11], 'Degrees of freedom: 21 total; 17 residual')
expect_equal(length(res), 13)
})
test_that('pander.summary.table works correctly', {
ts <- summary(xtabs(cbind(ncases, ncontrols) ~ ., data = esoph))
res <- pander_return(ts)
expect_equal(res[6], ' Chisq df p.value ' )
expect_equal(length(res), 13)
res <- pander_return(ts, print.call = F)
expect_false(any(grepl('Calls', res)))
expect_equal(length(res), 12)
res <- pander_return(ts, caption = 'Factor')
expect_equal(res[11], 'Table: Factor')
res <- pander_return(summary(table(1:3)))
expect_false(any(grepl('-', res)))
expect_equal(length(res), 2)
})
test_that('pander.randomForest works correctly', {
suppressMessages(require(randomForest))
iris.rf <- randomForest(Species ~ ., data=iris, importance=TRUE,
proximity=TRUE)
res <- pander_return(iris.rf)
expect_equal(length(res), 20)
expect_equal(res[19], 'Table: Confusion Matrix')
ozone.rf <- randomForest(Ozone ~ ., data=airquality, mtry=3,
importance=TRUE, na.action=na.omit)
res <- pander_return(ozone.rf)
expect_equal(length(res), 8)
expect_false(any(grep('-', res)))
# with test
index <- 1:nrow(iris)
trainindex <- sample(index, trunc(length(index) / 2))
trainset <- iris[trainindex, ]
testset <- iris[-trainindex, ]
res <- pander_return(randomForest(x=trainset[ ,-1], y=trainset[ ,1], xtest=testset[ ,-1], ytest=testset[ ,1]))
expect_equal(length(res), 10)
expect_true(any(grepl('Test set MSE', res)))
res <- pander_return(randomForest(x=trainset[ ,-ncol(trainset)],
y=trainset[ ,ncol(trainset)],
xtest=testset[ ,-ncol(testset)],
ytest=testset[ ,ncol(testset)]))
expect_equal(length(res), 34)
expect_equal(res[33], 'Table: Test Confusion Matrix')
})
test_that('pander.irts works correctly', {
suppressMessages(require(tseries))
n <- 10
t <- cumsum(rexp(n, rate = 0.1))
v <- rnorm(n)
res <- pander_return(as.irts(cbind(t, v)))
expect_equal(length(res), 23)
u <- rnorm(n)
res <- pander_return(irts(t, cbind(u, v)))
expect_equal(length(res), 23)
})
test_that('pander.manova/summary.manova works correctly', {
npk2 <- within(npk, foo <- rnorm(24))
x <- manova(cbind(yield, foo) ~ block + N * P * K, npk2)
res1 <- pander_return(x)
xs <- summary(x)
res2 <- pander_return(xs)
expect_equal(res1, res2)
expect_equal(length(res1), 21)
})
test_that('pander.gtable works correctly', {
suppressMessages(require(gtable))
a <- gtable(unit(1:3, c('cm')), unit(5, 'cm'))
rect <- rectGrob(gp = gpar(fill = 'black'))
a <- gtable_add_grob(a, rect, 1, 1)
res <- pander_return(a)
expect_equal(length(res), 7)
})
test_that('pander.nls/pander.summary.nls works correctly', {
utils::data(muscle, package = 'MASS')
with(muscle, table(Strip))
musc.1 <- nls(Length ~ cbind(1, exp(-Conc / th)), muscle,
start = list(th = 1), algorithm = 'plinear')
res <- pander_return(musc.1, show.convergence = T)
expect_equal(length(res), 17)
res <- pander_return(musc.1)
expect_equal(length(res), 14)
musc.1.s <- summary(musc.1)
res <- pander_return(musc.1.s)
expect_equal(length(res), 18)
res <- pander_return(musc.1.s, show.convergence = T)
expect_equal(length(res), 21)
musc.1.s <- summary(musc.1, correlation = T)
res <- pander_return(musc.1.s)
expect_true(any(grepl('Correlation', res)))
expect_equal(length(res), 31)
})
test_that('pander.arima works correctly', {
res <- pander_return(arima(lh, order = c(1,0,0)))
expect_equal(length(res), 17)
expect_true(any(grep('s\\.e', res)))
res <- pander_return(arima(lh, order = c(3,0,0)))
expect_equal(length(res), 17)
expect_true(any(grep('s\\.e', res)))
res <- pander_return(arima(lh, order = c(3,0,0), method = 'CSS'), se = FALSE)
expect_equal(length(res), 15)
expect_false(any(grep('s\\.e', res)))
})
test_that('pander.polr/summary.polr works correctly', {
house.plr <- polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing)
res <- pander_return(house.plr)
expect_equal(length(res), 25)
expect_equal(length(grep('Table', res)), 2)
res <- pander_return(suppressMessages(summary(house.plr)))
expect_equal(length(res), 39)
expect_equal(length(grep('Table', res)), 2)
res <- pander_return(suppressMessages(summary(house.plr, correlation = TRUE)), split.table = Inf)
expect_equal(length(res), 60)
expect_equal(length(grep('Table', res)), 3)
})
test_that('pander.survreg/summary.survreg works correctly', {
suppressMessages(require(survival))
x <- survreg(Surv(futime, fustat) ~ ecog.ps + rx, ovarian, dist='exponential')
res <- pander_return(x)
expect_equal(length(res), 27)
expect_equal(length(grep('Table', res)), 1)
res <- pander_return(suppressMessages(summary(x)))
expect_equal(length(res), 33)
expect_equal(length(grep('Table', res)), 1)
res <- pander_return(suppressMessages(summary(x, correlation = TRUE)), split.table = Inf)
expect_equal(length(res), 44)
expect_equal(length(grep('Table', res)), 2)
})
test_that('pander.ols works correctly', {
suppressMessages(require(rms))
set.seed(123)
n <- 1000
age <- rnorm(n, 50, 10)
cholesterol <- rnorm(n, 200, 25)
sex <- factor(sample(c('female', 'male'), n, TRUE))
health <- data.frame(age, cholesterol)
dd <- datadist(age, sex)
fit1 <- ols(cholesterol ~ age)
fit2 <- ols(cholesterol ~ age + sex)
res1 <- pander_return(fit1)
expect_equal(length(res1), 40)
expect_equal(length(grep('Table', res1)), 3)
res2 <- pander_return(fit2, coefs = FALSE)
expect_equal(length(res2), 29)
expect_equal(length(grep('Table', res2)), 2)
})
test_that('pander.lrm works correctly', {
suppressMessages(require(rms))
x <- 1:5
y <- c(0,1,0,1,0)
reps <- c(1,2,3,2,1)
res <- pander_return(lrm(y ~ x))
expect_equal(length(res), 39)
expect_true(any(grep('y ~ x', res)))
expect_equal(length(grep('Table', res)), 2)
x <- rep(x, reps)
y <- rep(y, reps)
res <- pander_return(lrm(y ~ x), coefs = FALSE)
expect_equal(length(res), 28)
expect_true(any(grep('y ~ x', res)))
expect_equal(length(grep('Table', res)), 1)
res <- pander_return(lrm(y ~ x, penalty = 0.1), coefs = TRUE)
expect_true(any(grep('y ~ x', res)))
expect_equal(length(grep('Table', res)), 3)
})
test_that('pander.orm works correctly', {
suppressMessages(require(rms))
n <- 100
y <- round(runif(n), 2)
x1 <- sample(c(-1,0,1), n, TRUE)
x2 <- sample(c(-1,0,1), n, TRUE)
res <- pander_return(orm(y ~ x1 + x2, eps=1e-5))
expect_equal(length(res), 39)
expect_true(any(grep('y ~ x1 \\+ x2', res)))
expect_equal(length(grep('Table', res)), 2)
res <- pander_return(orm(y ~ x1 + x2, eps=1e-5), coefs = FALSE)
expect_equal(length(res), 28)
expect_true(any(grep('y ~ x1 \\+ x2', res)))
expect_equal(length(grep('Table', res)), 1)
})
test_that('pander.Glm works correctly', {
suppressMessages(require(rms))
counts <- c(18,17,15,20,10,20,25,13,12)
outcome <- gl(3,1,9)
treatment <- gl(3,3)
f <- Glm(counts ~ outcome + treatment, family=poisson())
res <- pander_return(f)
expect_equal(length(res), 37)
expect_true(any(grep('counts ~ outcome \\+ treatment', res)))
expect_equal(length(grep('Table', res)), 2)
res <- pander_return(f, coefs = FALSE)
expect_equal(length(res), 20)
expect_true(any(grep('counts ~ outcome \\+ treatment', res)))
expect_equal(length(grep('Table', res)), 1)
})
test_that('pander.cph', {
options(contrasts = original_contrasts_options)
suppressMessages(require(rms))
n <- 1000
set.seed(731)
age <- 50 + 12 * rnorm(n)
label(age) <- 'Age'
sex <- factor(sample(c('Male','Female'), n, rep=TRUE, prob=c(.6, .4)))
cens <- 15 * runif(n)
h <- .02 * exp(.04 * (age - 50) + .8 * (sex == 'Female'))
dt <- -log(runif(n)) / h
label(dt) <- 'Follow-up Time'
e <- ifelse(dt <= cens, 1, 0)
dt <- pmin(dt, cens)
units(dt) <- 'Year'
dd <- datadist(age, sex)
S <- Surv(dt,e)
f <- cph(S ~ rcs(age,4) + sex, x=TRUE, y=TRUE)
res <- pander_return(f)
expect_equal(length(res), 43)
expect_true(any(grep('S ~ rcs\\(age, 4\\) \\+ sex', res)))
expect_equal(length(grep('Table', res)), 2)
res <- pander_return(f, conf.int = 0.95)
expect_equal(length(res), 58)
expect_true(any(grep('S ~ rcs\\(age, 4\\) \\+ sex', res)))
expect_equal(length(grep('Table', res)), 3)
})
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.