library(testthat)
# most common expectations:
# equality: expect_equal() and expect_identical()
# regexp: expect_match()
# catch-all: expect_true() and expect_false()
# console output: expect_output()
# messages: expect_message()
# warning: expect_warning()
# errors: expect_error()
escapeString <- function(s) {
t <- gsub("(\\\\)", "\\\\\\\\", s)
t <- gsub("(\n)", "\\\\n", t)
t <- gsub("(\r)", "\\\\r", t)
t <- gsub("(\")", "\\\\\"", t)
return(t)
}
prepStr <- function(s, varName="html") {
t <- escapeString(s)
u <- eval(parse(text=paste0("\"", t, "\"")))
if(s!=u) stop("Unable to escape string!")
if(is.null(varName)) varName <- "html"
t <- paste0("\t", varName, " <- \"", t, "\"")
utils::writeClipboard(t)
return(invisible())
}
context("DATA FRAME TESTS")
test_that("empty data frame (0 cols)", {
df <- data.frame()
library(basictabler)
tbl <- BasicTable$new(compatibility=list(headerCellsAsTD=TRUE))
tbl$addData(df)
# tbl$renderTable()
# prepStr(tbl$print(asCharacter=TRUE), "str")
# prepStr(as.character(tbl$getHtml()))
str <- NULL
html <- ""
expect_identical(tbl$print(asCharacter=TRUE), str)
expect_identical(as.character(tbl$getHtml()), html)
})
test_that("empty data frame (1 col, 0 rows)", {
df <- data.frame(a=integer(0))
library(basictabler)
tbl <- BasicTable$new(compatibility=list(headerCellsAsTD=TRUE))
tbl$addData(df)
# tbl$renderTable()
# prepStr(tbl$print(asCharacter=TRUE), "str")
# prepStr(as.character(tbl$getHtml()))
str <- "a "
html <- ""
expect_identical(tbl$print(asCharacter=TRUE), str)
expect_identical(as.character(tbl$getHtml()), html)
})
test_that("empty data frame (2 cols, 0 rows)", {
df <- data.frame(a=integer(0), b=character(0))
library(basictabler)
tbl <- BasicTable$new(compatibility=list(headerCellsAsTD=TRUE))
tbl$addData(df)
# tbl$renderTable()
# prepStr(tbl$print(asCharacter=TRUE), "str")
# prepStr(as.character(tbl$getHtml()))
str <- "a b "
html <- ""
expect_identical(tbl$print(asCharacter=TRUE), str)
expect_identical(as.character(tbl$getHtml()), html)
})
test_that("1 col, 1 row data frame", {
df <- data.frame(a=5)
library(basictabler)
tbl <- BasicTable$new(compatibility=list(headerCellsAsTD=TRUE))
tbl$addData(df)
# tbl$renderTable()
# prepStr(tbl$print(asCharacter=TRUE), "str")
# prepStr(as.character(tbl$getHtml()))
str <- "a \n5 "
html <- ""
expect_identical(tbl$print(asCharacter=TRUE), str)
expect_identical(as.character(tbl$getHtml()), html)
})
test_that("2 cols, 1 row data frame", {
df <- data.frame(a=5, b="hello")
library(basictabler)
tbl <- BasicTable$new(compatibility=list(headerCellsAsTD=TRUE))
tbl$addData(df)
# tbl$renderTable()
# prepStr(tbl$print(asCharacter=TRUE), "str")
# prepStr(as.character(tbl$getHtml()))
str <- "a b \n5 hello "
html <- "\n \n | a | \n b | \n
\n \n | 5 | \n hello | \n
\n
"
expect_identical(tbl$print(asCharacter=TRUE), str)
expect_identical(as.character(tbl$getHtml()), html)
})
test_that("1 col, 2 rows data frame", {
df <- data.frame(a=c(5, 7))
library(basictabler)
tbl <- BasicTable$new(compatibility=list(headerCellsAsTD=TRUE))
tbl$addData(df)
# tbl$renderTable()
# prepStr(tbl$print(asCharacter=TRUE), "str")
# prepStr(as.character(tbl$getHtml()))
str <- "a \n5 \n7 "
html <- "\n \n | a | \n
\n \n | 5 | \n
\n \n | 7 | \n
\n
"
expect_identical(tbl$print(asCharacter=TRUE), str)
expect_identical(as.character(tbl$getHtml()), html)
})
test_that("2 cols, 2 rows data frame", {
df <- data.frame(a=c(5, 7), b=c("hello", "world"))
library(basictabler)
tbl <- BasicTable$new(compatibility=list(headerCellsAsTD=TRUE))
tbl$addData(df)
# tbl$renderTable()
# prepStr(tbl$print(asCharacter=TRUE), "str")
# prepStr(as.character(tbl$getHtml()))
str <- "a b \n5 hello \n7 world "
html <- "\n \n | a | \n b | \n
\n \n | 5 | \n hello | \n
\n \n | 7 | \n world | \n
\n
"
expect_identical(tbl$print(asCharacter=TRUE), str)
expect_identical(as.character(tbl$getHtml()), html)
})
test_that("1 col, 3 rows data frame", {
df <- data.frame(a=c(5, 7, 9))
library(basictabler)
tbl <- BasicTable$new(compatibility=list(headerCellsAsTD=TRUE))
tbl$addData(df)
# tbl$renderTable()
# prepStr(tbl$print(asCharacter=TRUE), "str")
# prepStr(as.character(tbl$getHtml()))
str <- "a \n5 \n7 \n9 "
html <- "\n \n | a | \n
\n \n | 5 | \n
\n \n | 7 | \n
\n \n | 9 | \n
\n
"
expect_identical(tbl$print(asCharacter=TRUE), str)
expect_identical(as.character(tbl$getHtml()), html)
})
test_that("2 cols, 3 rows data frame", {
df <- data.frame(a=c(5, 7, 9), b=c("hello", "world", "today"))
library(basictabler)
tbl <- BasicTable$new(compatibility=list(headerCellsAsTD=TRUE))
tbl$addData(df)
# tbl$renderTable()
# prepStr(tbl$print(asCharacter=TRUE), "str")
# prepStr(as.character(tbl$getHtml()))
str <- "a b \n5 hello \n7 world \n9 today "
html <- "\n \n | a | \n b | \n
\n \n | 5 | \n hello | \n
\n \n | 7 | \n world | \n
\n \n | 9 | \n today | \n
\n
"
expect_identical(tbl$print(asCharacter=TRUE), str)
expect_identical(as.character(tbl$getHtml()), html)
})
test_that("data type tests", {
df <- data.frame(dtlogical=c(TRUE, FALSE, TRUE, FALSE, TRUE, NA),
dtInteger=as.integer(c(-1023411, 0, 1, 4, 4233, NA)),
dtNumeric=c(-14234.2324, -1, 0, 4234.3, 423544255435.234, NA),
dtComplex=c(-3423-54i, 0, 324-2i, -42354.342+645i, 342+5543i, NA),
dtCharacter=c("a", "wfdsg", "fsdgsg", "tgsg", "fsdgsrg", NA),
dtFactor=as.factor(c("A", "B", "A", "X", "B", NA)),
dtDate=as.Date(c("1980-12-01", "1999-01-02", "2000-01-01", "2003-09-08", "2017-09-28", NA)),
dtPOSIXct=as.POSIXct(c("1980-12-01 00:07:31", "1999-01-02 15:26:35", "2000-01-01 00:00:00",
"2003-09-08 09:30:22", "2017-09-28 23:59:59", NA), tz = "UTC"),
dtPOSIXlt=as.POSIXlt(c("1980-12-01 00:07:31", "1999-01-02 15:26:35", "2000-01-01 00:00:00",
"2003-09-08 09:30:22", "2017-09-28 23:59:59", NA), tz = "UTC"))
library(basictabler)
tbl <- BasicTable$new(compatibility=list(headerCellsAsTD=TRUE))
tbl$addData(df)
# tbl$renderTable()
# prepStr(tbl$print(asCharacter=TRUE), "str")
# prepStr(as.character(tbl$getHtml()))
str <- "dtlogical dtInteger dtNumeric dtComplex dtCharacter dtFactor dtDate dtPOSIXct dtPOSIXlt \n TRUE -1023411 -14234.2324 -3423-54i a A 1980-12-01 1980-12-01 00:07:31 1980-12-01 00:07:31 \n FALSE 0 -1 0+0i wfdsg B 1999-01-02 1999-01-02 15:26:35 1999-01-02 15:26:35 \n TRUE 1 0 324-2i fsdgsg A 2000-01-01 2000-01-01 2000-01-01 \n FALSE 4 4234.3 -42354.342+645i tgsg X 2003-09-08 2003-09-08 09:30:22 2003-09-08 09:30:22 \n TRUE 4233 423544255435.234 342+5543i fsdgsrg B 2017-09-28 2017-09-28 23:59:59 2017-09-28 23:59:59 \n "
html <- "\n \n | dtlogical | \n dtInteger | \n dtNumeric | \n dtComplex | \n dtCharacter | \n dtFactor | \n dtDate | \n dtPOSIXct | \n dtPOSIXlt | \n
\n \n | TRUE | \n -1023411 | \n -14234.2324 | \n -3423-54i | \n a | \n A | \n 1980-12-01 | \n 1980-12-01 00:07:31 | \n 1980-12-01 00:07:31 | \n
\n \n | FALSE | \n 0 | \n -1 | \n 0+0i | \n wfdsg | \n B | \n 1999-01-02 | \n 1999-01-02 15:26:35 | \n 1999-01-02 15:26:35 | \n
\n \n | TRUE | \n 1 | \n 0 | \n 324-2i | \n fsdgsg | \n A | \n 2000-01-01 | \n 2000-01-01 | \n 2000-01-01 | \n
\n \n | FALSE | \n 4 | \n 4234.3 | \n -42354.342+645i | \n tgsg | \n X | \n 2003-09-08 | \n 2003-09-08 09:30:22 | \n 2003-09-08 09:30:22 | \n
\n \n | TRUE | \n 4233 | \n 423544255435.234 | \n 342+5543i | \n fsdgsrg | \n B | \n 2017-09-28 | \n 2017-09-28 23:59:59 | \n 2017-09-28 23:59:59 | \n
\n \n | NA | \n NA | \n NA | \n NA | \n NA | \n NA | \n NA | \n NA | \n NA | \n
\n
"
expect_identical(tbl$print(asCharacter=TRUE), str)
expect_identical(as.character(tbl$getHtml()), html)
})
test_that("multiple row headers (method 1)", {
# aggregate the sample data to make a small data frame
library(basictabler)
library(dplyr)
tocsummary <- bhmsummary %>%
group_by(TOC, TrainCategory, PowerType) %>%
summarise(OnTimeArrivals=sum(OnTimeArrivals),
OnTimeDepartures=sum(OnTimeDepartures),
TotalTrains=sum(TrainCount)) %>%
ungroup() %>%
mutate(OnTimeArrivalPercent=OnTimeArrivals/TotalTrains*100,
OnTimeDeparturePercent=OnTimeDepartures/TotalTrains*100) %>%
arrange(TOC)
# To specify formatting, a list is created which contains one element for each column in
# the data frame, i.e. tocsummary contains six columns so the columnFormats list has six elements.
# The values in the first column in the data frame won't be formatted since NULL has been specified.
# The values in the 2nd, 3rd and 4th columns will be formatted using format(value, big.mark=",")
# The values in the 5th and 6th columns will be formatted using sprintf(value, "%.1f")
columnFormats=list(NULL, NULL, NULL, list(big.mark=","), list(big.mark=","), list(big.mark=","), "%.1f", "%.1f")
# render the table directly as a html widget
tbl <- qtbl(tocsummary, firstColumnAsRowHeaders=TRUE, numberOfColumnsAsRowHeaders=3,
explicitColumnHeaders=c("TOC", "Category", "Power", "On-Time Arrivals", "On-Time Departures",
"Total Trains", "On-Time Arrival %", "On-Time Departure %"),
columnFormats=columnFormats)
# tbl$renderTable()
# prepStr(tbl$print(asCharacter=TRUE), "str")
# prepStr(as.character(tbl$getHtml()))
str <- " TOC Category Power On-Time Arrivals On-Time Departures Total Trains On-Time Arrival % On-Time Departure % \nArriva Trains Wales Express Passenger DMU 1,082 1,859 3,079 35.1 60.4 \nArriva Trains Wales Ordinary Passenger DMU 322 489 830 38.8 58.9 \n CrossCountry Express Passenger DMU 5,485 9,920 22,133 24.8 44.8 \n CrossCountry Express Passenger HST 314 314 732 42.9 42.9 \n CrossCountry Ordinary Passenger DMU 0 12 63 0.0 19.0 \n London Midland Express Passenger DMU 1,490 2,084 5,638 26.4 37.0 \n London Midland Express Passenger EMU 1,271 3,040 8,849 14.4 34.4 \n London Midland Ordinary Passenger DMU 1,351 1,596 5,591 24.2 28.5 \n London Midland Ordinary Passenger EMU 8,924 10,464 28,201 31.6 37.1 \n Virgin Trains Express Passenger DMU 866 903 2,137 40.5 42.3 \n Virgin Trains Express Passenger EMU 2,423 2,961 6,457 37.5 45.9 "
html <- "\n \n | TOC | \n Category | \n Power | \n On-Time Arrivals | \n On-Time Departures | \n Total Trains | \n On-Time Arrival % | \n On-Time Departure % | \n
\n \n \n \n \n | 1,082 | \n 1,859 | \n 3,079 | \n 35.1 | \n 60.4 | \n
\n \n \n \n \n | 322 | \n 489 | \n 830 | \n 38.8 | \n 58.9 | \n
\n \n \n \n \n | 5,485 | \n 9,920 | \n 22,133 | \n 24.8 | \n 44.8 | \n
\n \n \n \n \n | 314 | \n 314 | \n 732 | \n 42.9 | \n 42.9 | \n
\n \n \n \n \n | 0 | \n 12 | \n 63 | \n 0.0 | \n 19.0 | \n
\n \n \n \n \n | 1,490 | \n 2,084 | \n 5,638 | \n 26.4 | \n 37.0 | \n
\n \n \n \n \n | 1,271 | \n 3,040 | \n 8,849 | \n 14.4 | \n 34.4 | \n
\n \n \n \n \n | 1,351 | \n 1,596 | \n 5,591 | \n 24.2 | \n 28.5 | \n
\n \n \n \n \n | 8,924 | \n 10,464 | \n 28,201 | \n 31.6 | \n 37.1 | \n
\n \n \n \n \n | 866 | \n 903 | \n 2,137 | \n 40.5 | \n 42.3 | \n
\n \n \n \n \n | 2,423 | \n 2,961 | \n 6,457 | \n 37.5 | \n 45.9 | \n
\n
"
expect_identical(tbl$print(asCharacter=TRUE), str)
expect_identical(as.character(tbl$getHtml()), html)
})
test_that("multiple row headers (method 2)", {
# aggregate the sample data to make a small data frame
library(basictabler)
library(dplyr)
tocsummary <- bhmsummary %>%
group_by(TOC, TrainCategory, PowerType) %>%
summarise(OnTimeArrivals=sum(OnTimeArrivals),
OnTimeDepartures=sum(OnTimeDepartures),
TotalTrains=sum(TrainCount)) %>%
ungroup() %>%
mutate(OnTimeArrivalPercent=OnTimeArrivals/TotalTrains*100,
OnTimeDeparturePercent=OnTimeDepartures/TotalTrains*100) %>%
arrange(TOC)
# To specify formatting, a list is created which contains one element for each column in
# the data frame, i.e. tocsummary contains six columns so the columnFormats list has six elements.
# The values in the first column in the data frame won't be formatted since NULL has been specified.
# The values in the 2nd, 3rd and 4th columns will be formatted using format(value, big.mark=",")
# The values in the 5th and 6th columns will be formatted using sprintf(value, "%.1f")
columnFormats=list(NULL, NULL, NULL, list(big.mark=","), list(big.mark=","), list(big.mark=","), "%.1f", "%.1f")
# render the table directly as a html widget
tbl <- qtbl(tocsummary, firstColumnAsRowHeaders=TRUE,
explicitColumnHeaders=c("TOC", "Category", "Power", "On-Time Arrivals", "On-Time Departures",
"Total Trains", "On-Time Arrival %", "On-Time Departure %"),
columnFormats=columnFormats, columnCellTypes=c("rowHeader", "rowHeader", "rowHeader", "cell", "cell", "cell", "cell", "cell"))
# tbl$renderTable()
# prepStr(tbl$print(asCharacter=TRUE), "str")
# prepStr(as.character(tbl$getHtml()))
str <- " TOC Category Power On-Time Arrivals On-Time Departures Total Trains On-Time Arrival % On-Time Departure % \nArriva Trains Wales Express Passenger DMU 1,082 1,859 3,079 35.1 60.4 \nArriva Trains Wales Ordinary Passenger DMU 322 489 830 38.8 58.9 \n CrossCountry Express Passenger DMU 5,485 9,920 22,133 24.8 44.8 \n CrossCountry Express Passenger HST 314 314 732 42.9 42.9 \n CrossCountry Ordinary Passenger DMU 0 12 63 0.0 19.0 \n London Midland Express Passenger DMU 1,490 2,084 5,638 26.4 37.0 \n London Midland Express Passenger EMU 1,271 3,040 8,849 14.4 34.4 \n London Midland Ordinary Passenger DMU 1,351 1,596 5,591 24.2 28.5 \n London Midland Ordinary Passenger EMU 8,924 10,464 28,201 31.6 37.1 \n Virgin Trains Express Passenger DMU 866 903 2,137 40.5 42.3 \n Virgin Trains Express Passenger EMU 2,423 2,961 6,457 37.5 45.9 "
html <- "\n \n | TOC | \n Category | \n Power | \n On-Time Arrivals | \n On-Time Departures | \n Total Trains | \n On-Time Arrival % | \n On-Time Departure % | \n
\n \n \n \n \n | 1,082 | \n 1,859 | \n 3,079 | \n 35.1 | \n 60.4 | \n
\n \n \n \n \n | 322 | \n 489 | \n 830 | \n 38.8 | \n 58.9 | \n
\n \n \n \n \n | 5,485 | \n 9,920 | \n 22,133 | \n 24.8 | \n 44.8 | \n
\n \n \n \n \n | 314 | \n 314 | \n 732 | \n 42.9 | \n 42.9 | \n
\n \n \n \n \n | 0 | \n 12 | \n 63 | \n 0.0 | \n 19.0 | \n
\n \n \n \n \n | 1,490 | \n 2,084 | \n 5,638 | \n 26.4 | \n 37.0 | \n
\n \n \n \n \n | 1,271 | \n 3,040 | \n 8,849 | \n 14.4 | \n 34.4 | \n
\n \n \n \n \n | 1,351 | \n 1,596 | \n 5,591 | \n 24.2 | \n 28.5 | \n
\n \n \n \n \n | 8,924 | \n 10,464 | \n 28,201 | \n 31.6 | \n 37.1 | \n
\n \n \n \n \n | 866 | \n 903 | \n 2,137 | \n 40.5 | \n 42.3 | \n
\n \n \n \n \n | 2,423 | \n 2,961 | \n 6,457 | \n 37.5 | \n 45.9 | \n
\n
"
expect_identical(tbl$print(asCharacter=TRUE), str)
expect_identical(as.character(tbl$getHtml()), html)
})