Nothing
library(qwraps2)
set.seed(42)
################################################################################
# testing attributes
x <- qable(mtcars2[, c("mpg", "disp")], markup = "latex")
stopifnot(
identical(
attributes(x)
,
list(dim = c(32L, 3L), dimnames = list(NULL, c("", "mpg", "disp")), class = "qwraps2_qable", qable_args = list(rtitle = "", rgroup = numeric(0), rnames = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", "30", "31", "32"), cnames = c("", "mpg", "disp"), markup = "latex", kable_args = list()))
)
)
################################################################################
# simple output tests
output_latex <- capture.output(print(qable(mtcars2, markup = "latex")))
output_markdown <- capture.output(print(qable(mtcars2, markup = "markdown")))
# simple print test
stopifnot(any(grepl("142E\\ \\&\\ 21\\.4", output_latex)))
stopifnot(any(grepl("142E\\ +\\|21\\.4", output_markdown)))
# error for unexpected markup language
test <- tryCatch(qable(mtcars2, markup = "rts"), error = function(e) e)
stopifnot(inherits(test, "error"))
# rtitle
out <- capture.output(print(qable(mtcars[1, ], rtitle = "user defined rtitle")))
stopifnot(grepl("^user\\ defined\\ rtitle", out[4]))
out <- capture.output(print(qable(mtcars[1, ], markup = "markdown", rtitle = "user defined rtitle")))
stopifnot(grepl("^\\|user\\ defined\\ rtitle", out[3]))
# rgroups
make <- sub("^(\\w+)\\s?(.*)$", "\\1", rownames(mtcars))
make <- c(table(make))
output <- capture.output(print(qable(mtcars[sort(rownames(mtcars)), ], rgroup = make)))
any(grepl("\\\\bf\\{Volvo\\}\\ \\&\\ ~", output))
any(grepl("~~\\ Volvo\\ 142E\\ \\&\\ 21\\.4", output))
output <- capture.output(print(qable(mtcars[sort(rownames(mtcars)), ], rgroup = make, markup = "markdown")))
stopifnot(any(grepl("\\*\\*\\Volvo\\*\\*", output)))
stopifnot(any(grepl("\\ \\ \\ Volvo", output)))
################################################################################
# Test cbind
qtab_1 <- qable(mtcars[sort(rownames(mtcars)), c("mpg", "cyl")], rgroup = make, kable_args = list(caption = "1"))
qtab_2 <- qable(mtcars[sort(rownames(mtcars)), c("disp", "hp", "drat")], rgroup = make, kable_args = list(caption = "2"))
qtab_0 <- qable(mtcars[sort(rownames(mtcars)), c("mpg", "cyl", "disp", "hp", "drat")], rgroup = make, kable_args = list(caption = "1"))
# the number of column of each of these tables should be one more than the
# number of columns of the data.frame passed. the "extra" column is the row
# grouping and names.
stopifnot(identical(ncol(qtab_1), 3L))
stopifnot(identical(ncol(qtab_2), 4L))
stopifnot(identical(ncol(qtab_0), 6L))
# qtab_1 and qtab_2 should join together to be identical to qtab_0
stopifnot(identical(cbind(qtab_1, qtab_2), qtab_0))
# should be able to cbind on a vector of values
out <- cbind(qtab_1, a_number = rnorm(nrow(qtab_1)))
stopifnot(identical(colnames(out), c("", "mpg", "cyl", "a_number")))
# should be able to cbind on a vector of values as a matrix
out <- cbind(qtab_1, a_number = matrix(rnorm(nrow(qtab_1)), ncol = 1))
stopifnot(identical(colnames(out), c("", "mpg", "cyl", "a_number")))
# or even another matrix
out <- cbind(qtab_1, a = matrix(rnorm(3 * nrow(qtab_1)), ncol = 3))
stopifnot(identical(colnames(out), c("", "mpg", "cyl", "a1", "a2", "a3")))
# error if nrows are not the same, or if a vector length is different from the
# nrow of the first element
test <-
tryCatch(
cbind(qtab_1, qtab_1_2, a_number = rnorm(nrow(qtab_1) - 1)),
error = function(e) e)
stopifnot(identical(inherits(test, "simpleError"), TRUE))
test <-
tryCatch(
cbind(qtab_1, qtab_1_2[1:3, ]),
error = function(e) e)
stopifnot(identical(inherits(test, "simpleError"), TRUE))
# there should be an error if the row groups are not identical
m <- make; names(m) <- toupper(names(m))
qtab_1_2 <- qable(mtcars[, c("mpg", "cyl")], rgroup = m)
test <- tryCatch(cbind(qtab_1, qtab_1_2), error = function(e) e)
stopifnot(identical(inherits(test, "simpleError"), TRUE))
qtab_1_3 <- qable(mtcars[, c("mpg", "cyl")], rgroup = sample(make))
test <- tryCatch(cbind(qtab_1, qtab_1_3), error = function(e) e)
stopifnot(identical(inherits(test, "simpleError"), TRUE))
# the attributes of the object from cbind should be those of the first object
# passed in
stopifnot(identical(attributes(qtab_2)$qable_args$kable_args, list(caption = "2")))
stopifnot(identical(attributes(qtab_1)$qable_args$kable_args, list(caption = "1")))
stopifnot(identical(attributes(cbind(qtab_1, qtab_2))$qable_args$kable_args, list(caption = "1")))
stopifnot(identical(attributes(cbind(qtab_2, qtab_1))$qable_args$kable_args, list(caption = "2")))
################################################################################
# testing rbind
m1 <- mtcars2[grepl("^M", mtcars2$make), ]
m1 <- m1[order(m1$make, m1$model), ]
m2 <- mtcars2[!grepl("^M", mtcars2$make), ]
m2 <- m2[order(m2$make, m2$model), ]
rg1 <- c(table(m1$make))
rg2 <- c(table(m2$make))
m <- rbind(m1, m2)
rg <- c(table(m$make))
rg <- rg[c(names(rg1), names(rg2))]
stopifnot(isTRUE(
all.equal(
rbind(qable(m1, rgroup = rg1), qable(m2, rgroup = rg2))
,
qable(m, rgroup = rg)
)
)
)
################################################################################
## End of File ##
################################################################################
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.