context("Convert to an interactive DataTables for clinical data")
# Note: last tests are skipped in CRAN
# because of pandoc requirement
# require extra libraries
library(tibble)
library(crosstalk)
test_that("A basic DataTables is correctly exported", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
SEX = c("F", "M", "F", "M", "F"),
stringsAsFactors = FALSE
)
expect_silent(dt <- getClinDT(data = data))
expect_is(dt, "datatables")
expect_identical(object = dt$x$data, expected = data)
})
test_that("An error is generated if data is of the wrong type", {
expect_error(getClinDT(data = TRUE))
})
test_that("SharedData DataTables are correctly generated", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
SEX = c("F", "M", "F", "M", "F"),
stringsAsFactors = FALSE
)
# works
dataSD <- crosstalk::SharedData$new(data = data, key = as.formula("~USUBJID"))
expect_silent(dt <- getClinDT(data = dataSD))
expect_identical(dt$x$data, data)
})
test_that("An error is generated if a SharedData with incorrect key is set", {
expect_error(dt <- getClinDT(crosstalk::SharedData$new(data = data, key = "test")))
})
test_that("A DataTables is correctly generated when input table is a tibble", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
SEX = c("F", "M", "F", "M", "F"),
stringsAsFactors = FALSE
)
dataTB <- tibble::as_tibble(data)
expect_silent(dt <- getClinDT(data = dataTB))
expect_identical(dt$x$data, data)
})
test_that("Column names are successfully renamed in DataTables", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
SEX = c("F", "M", "F", "M", "F"),
stringsAsFactors = FALSE
)
colnames <- c(
"Sex" = "SEX",
"Subject ID" = "USUBJID",
"Treatment" = "TRT"
)
# correct
expect_silent(dt <- getClinDT(data = data, colnames = colnames))
expect_match(
object = dt$x$container,
regexp = ".+
Subject ID | .+Treatment | .+Sex | .+"
)
})
test_that("A warning is generated if column names are not correctly specified", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
SEX = c("F", "M", "F", "M", "F"),
stringsAsFactors = FALSE
)
expect_warning(dt <- getClinDT(data = data, colnames = c(TEST = "TEST")))
})
test_that("A warning is generated if the old specification for non visible var is used", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
SEX = c("F", "M", "F", "M", "F"),
stringsAsFactors = FALSE
)
# old spec
expect_warning(
dt <- getClinDT(
data = data,
nonVisible = match("TRT", colnames(data))-1
),
regex = "deprecated"
)
})
test_that("Invisible columns are not shown in the DataTables output", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
SEX = c("F", "M", "F", "M", "F"),
stringsAsFactors = FALSE
)
expect_silent(
dt <- getClinDT(
data = data,
nonVisibleVar = "TRT"
)
)
cDefs <- dt$x$options$columnDefs
cDefsNonVisible <- sapply(cDefs, function(x) isFALSE(x$visible))
expect_true(any(cDefsNonVisible))
expect(cDefs[[which(cDefsNonVisible)]]$targets, 1)
})
test_that("An error is generated if invisible columns are incorrectly specified", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
SEX = c("F", "M", "F", "M", "F"),
stringsAsFactors = FALSE
)
# in case JS indices not used
expect_warning(
expect_error(
getClinDT(data = data, nonVisible = ncol(data)),
"Javascript indexing"
)
)
})
test_that("Percentages are correctly formatted", {
expect_silent(
dt <- getClinDT(
data = data.frame(
USUBJID = seq.int(5),
perc = c(0.06, 0.001, 0.65, 0.99, 1)
),
percVar = "perc",
)
)
cDefs <- dt$x$options$columnDefs
cDefsFmtPercentage <- sapply(cDefs, function(x) "render" %in% names(x) && grepl("formatPercentage", x$render))
expect_true(any(cDefsFmtPercentage))
expect(cDefs[[which(cDefsFmtPercentage)]]$targets, 1)
})
test_that("A warning is generated if the variable for barplot is not available", {
data <- data.frame(
USUBJID = as.character(1:5),
AGE = c(20, 40, 67, 36, 50),
stringsAsFactors = FALSE
)
expect_warning(getClinDT(data = data, barVar = "blabla"))
})
test_that("Barplot are correctly rendered within DataTables", {
data <- data.frame(
USUBJID = as.character(1:5),
AGE = c(20, 40, 67, 36, 50),
stringsAsFactors = FALSE
)
# specification of variable for the bar
expect_silent(dt <- getClinDT(data = data, barVar = "AGE"))
rCB <- dt$x$options$rowCallback
expect_match(object = rCB, regex = ".*color.*")
expect_match(object = rCB, regexp = "data[1]", fixed = TRUE)
})
test_that("A threshold for the barplot is correctly set", {
data <- data.frame(
USUBJID = as.character(1:5),
AGE = c(20, 40, 67, 36, 50),
stringsAsFactors = FALSE
)
expect_silent(dt <- getClinDT(data = data, barVar = "AGE", barColorThr = 28))
rCB <- dt$x$options$rowCallback
expect_match(object = rCB, regex = ".*data\\[1\\].*28.*")
})
test_that("A range for the barplot is correctly set", {
data <- data.frame(
USUBJID = as.character(1:5),
AGE = c(20, 40, 67, 36, 50),
stringsAsFactors = FALSE
)
# specification of range for the bar
expect_silent(dt <- getClinDT(data = data, barVar = "AGE", barRange = c(0, 100)))
rCB <- dt$x$options$rowCallback
expect_match(object = rCB, regex = "100")
})
test_that("A range for the barplots of multiple variables is correctly set", {
data <- data.frame(
USUBJID = as.character(1:5),
AGE = c(20, 40, 67, 36, 50),
WEIGHTBL = c(60, 45, 89, 120, 78),
stringsAsFactors = FALSE
)
# multiple variables
expect_silent(
dt <- getClinDT(
data = data,
barVar = c("AGE", "WEIGHTBL"),
barColorThr = c(AGE = 50),
barRange = list(AGE = c(0, 100), WEIGHTBL = range(data$WEIGHTBL))
)
)
rCB <- dt$x$options$rowCallback
expect_match(object = rCB, regex = ".*data\\[1\\].*data\\[2\\]")
})
test_that("A warning is generated is a variable for a barplot is not numeric", {
data <- data.frame(USUBJID = as.character(1:5))
expect_warning(dt <- getClinDT(data = data, barVar = "USUBJID"))
})
test_that("The location of the filter box is correctly set", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
filters <- c("top", "none")
for(filter in filters){
dt <- getClinDT(data, filter = filter)
tableFilter <- dt$x$filter
expect_identical(tableFilter, filter)
}
})
test_that("The search box is correctly enabled or disabled in the DataTables", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
for(includeSearchBox in c(TRUE, FALSE)){
dt <- getClinDT(data, searchBox = includeSearchBox)
expect_equal(grepl("f", dt$x$options$dom), includeSearchBox)
}
})
test_that("The number of records (page length) is correctly set", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
dt <- getClinDT(data, pageLength = 2)
expect_equal(dt$x$options$pageLength, 2) # page length properly set
expect_true(grepl("p", dt$x$options$dom)) # include pagination control
})
test_that("Fixed columns are correctly specified in the DataTables", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
fC <- list(leftColumns = 2)
dt <- getClinDT(data, fixedColumns = fC)
expect_equal(dt$x$options$fixedColumns, fC)
})
test_that("Columns widths are correctly specified in the DataTables", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
widths <- c(3, 7)
dt <- getClinDT(data, columnsWidth = widths)
# extract column defs
cDefs <- dt$x$options$columnDefs
cDefs <- unlist(cDefs, recursive = FALSE)
idxColDefs <- which(sapply(cDefs, function(x) "columnsWidth" %in% names(x)))
cDefs <- cDefs[idxColDefs]
cDefsDf <- do.call(rbind.data.frame, cDefs)
# check if match specified width:
expect_equal(
object = cDefsDf[which(cDefsDf$targets == 1), "columnsWidth"],
expected = 3
)
expect_equal(
object = cDefsDf[which(cDefsDf$targets == 2), "columnsWidth"],
expected = 7
)
})
test_that("Extra options with default values are correctly overwritten when they are specified", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
# specified options overwrites the default (with message)
expect_message(
dt <- getClinDT(data, options = list(pageLength = 20)),
regexp = "overwrites the default"
)
expect_equal(dt$x$options$pageLength, 20) # page length properly set
})
test_that("Extra options without default values are correctly set", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
expect_silent(dt <- getClinDT(data, options = list(lengthChange = 20)))
expect_equal(dt$x$options[["lengthChange"]], 20)
# Note: wrong 'options' are handled by the JS DataTable library
})
test_that("A single expanded variable is correctly handled in the DataTables", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
# Expand mechanism done in Javascript
# so check at least than the HTML is well specified
# test in combination of colnames
expandVar <- "USUBJID"
colnames <- c(
"Subject ID" = "USUBJID",
"Treatment" = "TRT"
)
expect_silent(dt <- getClinDT(data, expandVar = expandVar, colnames = colnames))
cDefs <- dt$x$options$columnDefs
# target columns are hidden
idxColsHidden <- which(sapply(cDefs, function(x) "visible" %in% names(x) && !isTRUE(x$visible)))
expect_length(idxColsHidden, 1)
expect_setequal(object = idxColsHidden, expected = match(expandVar, colnames(data)))
# and correct variables specified in JS callback
expandVarLab <- names(colnames)[match(expandVar, colnames)]
expect_true(all(sapply(expandVarLab, grepl, dt$x$callback, fixed = TRUE)))
})
test_that("A warning is generated if a expanded variable is not available", {
data <- data.frame(USUBJID = 1:5)
expect_warning(dt <- getClinDT(data, expandVar = "blabla"))
})
test_that("Multiple column specifications at once are correctly handled in the DataTables", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
SEX = c("F", "M", "F", "M", "F"),
AGE = c(20, 40, 67, 36, 50),
stringsAsFactors = FALSE
)
dataEscape <- cbind(
url = sprintf('%s', data$USUBJID),
data,
stringsAsFactors = FALSE
)
expandVar <- c("url", colnames(data)[c(1, ncol(data))])
nonVisibleVar <- colnames(data)[3]
barVar <- "AGE"
cAlignLeft <- 3 # 6th column
expect_silent(dt <-
getClinDT(
data = dataEscape,
expandVar = expandVar,
escape = -1,
barVar = barVar,
nonVisibleVar = nonVisibleVar,
options = list(columnDefs = list(
list(className = "dt-left", targets = cAlignLeft)
))
)
)
cDefs <- dt$x$options$columnDefs
# escape (first column is the '+')
expect_identical(dt$x$data[[2]], dataEscape[, "url"])
# bar (+1: extra col, -1: JS)
expect_true(grepl("color", dt$x$options$rowCallback))
# non visible vars: expand and non-visible (+1: extra col, -1: JS)
idxNonVisible <- match(c(nonVisibleVar, expandVar), colnames(dataEscape))
idxCDefsNonVisible <- which(sapply(cDefs, function(x)
"visible" %in% names(x) && !x$visible
))
expect_setequal(
cDefs[[idxCDefsNonVisible]]$targets,
expected = idxNonVisible
)
# extra column defs
idxCDefsCtrl <- which(sapply(cDefs, function(x)
"className" %in% names(x) && x$className == "dt-left"
))
expect_setequal(
cDefs[[idxCDefsCtrl]]$targets,
expected = cAlignLeft+1 # +1: one extra column added
)
})
test_that("Cells can be correctly expanded in DataTables", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
SEX = c("F", "M", "F", "M", "F"),
stringsAsFactors = FALSE
)
# Expand mechanism done in Javascript
# so check at least than the HTML is well specified
# correct spec
idxRow <- c(1, 2)
idxCol <- c(2, 2)
expandIdx <- cbind(row = idxRow, col = idxCol)
expect_silent(dt <- getClinDT(data, expandIdx = expandIdx))
cDefs <- dt$x$options$columnDefs
# target columns are hidden
idxCDefsNonVisible <- which(sapply(cDefs, function(x)
"visible" %in% names(x) && !x$visible
))
expect_silent(cColsHidden <- cDefs[[idxCDefsNonVisible]]$targets)
expect_setequal(object = cColsHidden, expected = idxCol)
# check that values are correct
dtData <- dt$x$data
expandIdxCol <- unique(idxCol)
# column displayed
expect_identical(
object = dtData[[expandIdxCol]][-idxRow],
expected = data[-idxRow, expandIdxCol]
)
# hidden column
expect_identical(
object = as.character(dtData[[expandIdxCol+1]][idxRow]),
expected = data[idxRow, expandIdxCol]
)
})
test_that("An error is generated if the specification of cells to expand is incorrect", {
data <- data.frame(USUBJID = 1:5)
expect_error(dt <- getClinDT(data, expandIdx = list()))
})
test_that("HTML is correctly escaped by default in the DataTables", {
dataEscape <- data.frame(
url = sprintf('%s', 1:5),
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
expect_silent(dt <- getClinDT(dataEscape))
expect_match(attr(dt$x$options, "escapeIdx"), regexp = "1,2,3")
})
test_that("HTML is correctly escaped when specified for all columns at once in the DataTables", {
dataEscape <- data.frame(
url = sprintf('%s', 1:5),
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
# as logical
expect_silent(dt <- getClinDT(dataEscape, escape = FALSE))
expect_false(grepl("1,2,3", attr(dt$x$options, "escapeIdx")))
# wrong specification
expect_error(
getClinDT(dataEscape, escape = c(TRUE, FALSE)),
"logical.*of length 1"
)
})
test_that("HTML is correctly not escaped for a specific column in the DataTables", {
dataEscape <- data.frame(
url = sprintf('%s', 1:5),
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
# as negative integer
expect_silent(dt <- getClinDT(dataEscape, escape = -1))
expect_false(grepl("1", attr(dt$x$options, "escapeIdx")))
})
test_that("An error is generated when the column to escape is not available", {
dataEscape <- data.frame(
url = sprintf('%s', 1:5),
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
# wrong spec
expect_error(
dt <- getClinDT(dataEscape, escape = "blabla"),
"not found in data"
)
expect_error(
dt <- getClinDT(dataEscape, escape = ncol(dataEscape) * 2),
"columns not in data"
)
})
test_that("Row grouping is correctly handled in the DataTables", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
STUDYID = rep("study1", each = 5),
SITEID = c("a", "b", "c", "a", "c"),
stringsAsFactors = FALSE
)
# Note: done in JS
rowGroupVars <- c("STUDYID", "SITEID")
expect_silent(dt <- getClinDT(data, rowGroupVar = rowGroupVars))
expect_equal(
object = dt$x$options$rowGroup$dataSrc,
expected = match(rowGroupVars, colnames(data))-1
)
})
test_that("A warning is generated when the variable to consider for the row grouping is not available", {
data <- data.frame(USUBJID = 1:5)
# variable not available in the data
expect_warning(
dt <- getClinDT(data, rowGroupVar = "blabla"),
"not available in the data."
)
})
test_that("A warning is generated when old specification for row grouping is used", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
STUDYID = rep("study1", each = 5),
SITEID = c("a", "b", "c", "a", "c"),
stringsAsFactors = FALSE
)
rowGroupVars <- c("STUDYID", "SITEID")
# old spec
expect_warning(
dt <- getClinDT(data, rowGroup = rowGroupVars),
"deprecated"
)
expect_equal(
object = dt$x$options$rowGroup$dataSrc,
expected = match(rowGroupVars, colnames(data))-1
)
})
test_that("Vertical alignment can be set in the DataTables", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
expect_silent(dt <- getClinDT(data, vAlign = "bottom"))
expect_true(grepl("'vertical-align':'bottom'", dt$x$options$rowCallback))
})
test_that("A custom call back Javascript function can be set in the DataTables", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
callback <- htmlwidgets::JS("testCallback")
expect_silent(dt <- getClinDT(data, callback = callback))
expect_true(grepl("testCallback", dt$x$callback))
})
test_that("Buttons can be correctly specified in the DataTables", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
# specify buttons
buttons <- "copy"
expect_silent(dt <- getClinDT(data, buttons = buttons))
expect_setequal(dt$x$options$buttons, buttons)
expect_true(grepl("B", dt$x$options$dom)) # in DOM
expect_true("Buttons" %in% dt$x$extensions) # Js extension specified
})
test_that("Buttons can be unset in the DataTables", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
expect_silent(dt <- getClinDT(data, buttons = NULL))
expect_length(dt$x$options$buttons, 0)
expect_false(grepl("B", dt$x$options$dom))
expect_false("Buttons" %in% dt$x$extensions)
# Note: if uncorrect button specified -> JS error
})
test_that("A button to select columns is included if specified", {
data <- data.frame(
USUBJID = sample.int(5),
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
dt <- getClinDT(data,
buttons = getClinDTButtons(type = "colvis")
)
expect_equal(dt$x$options$buttons[[1]]$extend, "colvis")
# non visible columns are not included
expect_match(
object = dt$x$options$buttons[[1]]$columns,
regexp = ".noVis"
)
})
test_that("Specified button options are correctly included", {
data <- data.frame(
USUBJID = sample.int(5),
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
buttons <- getClinDTButtons(
type = "pdf",
opts = list(pdf = list(orientation = "landscape"))
)
dt <- getClinDT(data, buttons = buttons)
expect_equal(dt$x$options$buttons[[1]]$extend, "pdf")
expect_equal(dt$x$options$buttons[[1]]$orientation, "landscape")
})
test_that("An extra button is added to the set of default buttons", {
data <- data.frame(
USUBJID = sample.int(5),
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
# default set of buttons
dt <- getClinDT(data)
# extra button
dtExtra <- getClinDT(data,
buttons = getClinDTButtons(typeExtra = "colvis")
)
dtExtraBtns <- dtExtra$x$options$buttons
idxExtraBtn <- which(sapply(dtExtraBtns, `[[`, "extend") == "colvis")
# check that specified button is included
expect_length(idxExtraBtn, 1)
# check that default set of buttons is included as well
expect_equal(
object = dtExtra$x$options$buttons[-idxExtraBtn],
expected = dt$x$options$buttons
)
})
test_that("Scrolling along the x-axis can be correctly set in the DataTables", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
for(scrollX in c(TRUE, FALSE)){
dt <- getClinDT(data, scrollX = scrollX)
expect_equal(dt$x$options$scrollX, scrollX)
}
})
test_that("Additional DataTables options can be passed to the DataTables outside of the 'options' parameter", {
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
# internal default
expect_warning(getClinDT(data, rownames = TRUE))
# extra parameter
width <- "10px"
expect_silent(dt <- getClinDT(data, width = width))
expect_equal(dt$width, width)
})
test_that("DataTables can be exported to a file", {
skip_on_cran()
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
# correct file format
file <- tempfile(fileext = ".html")
expect_silent(dt <- getClinDT(data, file = file))
expect_true(file.exists(file))
})
test_that("An error is generated if the file to export to has an incorrect extension", {
skip_on_cran()
data <- data.frame(
USUBJID = 1:5,
TRT = c("A", "A", "B", "B", "B"),
stringsAsFactors = FALSE
)
# incorrect file format
file <- tempfile(fileext = ".csv")
expect_error(
dt <- getClinDT(data, file = file),
pattern = "extension"
)
})