tests/testthat/test-secuTrial.R

In SwissClinicalTrialOrganisation/DM_secuTrial_R: Handling of secuTrial related data

context("secuTrial-testing")

# load data
load.tables(data.dir=system.file("extdata", "s_export_CSV-xls_BMD.zip", package = "secuTrial"))
calcium_st <- read.table(system.file("extdata", "calcium_secuTrial.csv", package = "secuTrial"), sep=";", header=TRUE)

# test that rectangular data NOT identified
test_that("Rectangular data not identified by load.study.options", {
  expect_false(study.options$is.rectangular)
})

# test that zip data identified
test_that("Zipped data identified by load.study.options", {
  expect_true(study.options$is.zip)
})

# test that shortnames identified
test_that("Shortnames identified by load.study.options", {
  expect_true(study.options$is.zip)
})

# test dimensions
test_that("Bone mineral density dataset (non rectangular) has the correct dimensions", {
  expect_equal(dim(bmd),c(504, 25))
})

# test that all data imported
test_that("All data imported", {
  expect_true(all(sapply(study.options$data.names, exists)))
})


# retain relevant columns
bmd_compare <- bmd[,c("pat.id","mnpvispdt","age","grouping","bmd")]
calcium_st_compare <- calcium_st[,c("patid","visitdate","bmd.age","bmd.grouping","bmd.bmd")]

# test for data (age, patid, done mineral density) equality
test_that("Test import and export data for equality", {
   expect_equal(sum( (calcium_st_compare$bmd.age - bmd_compare$age) +  # age
                     (calcium_st_compare$patid - bmd_compare$pat.id) + # patid
                     (calcium_st_compare$bmd.bmd - bmd_compare$bmd),   # bone mineral density
                    na.rm=TRUE),
                0)
})

# test for visitdate equality
test_that("Test for visitdate equality", {
   expect_equal(calcium_st_compare$visitdate==format(as.Date(bmd_compare$mnpvispdt), "%d.%m.%Y"),
                rep(TRUE, 504))
})

# test for grouping equality
# empty strings need to be NA for the comparison
calcium_st_compare$bmd.grouping[calcium_st_compare$bmd.grouping==""] <- NA
calcium_st_compare$bmd.grouping <- droplevels(calcium_st_compare$bmd.grouping)
test_that("Test for grouping equality", {
   expect_equal(calcium_st_compare$bmd.grouping==bmd_compare$grouping,
                c(rep(TRUE, 502),NA,NA))
})

# test column moving
test_that("Test column moving", {
   expect_equal(names(move.column.after(df=calcium_st_compare,col.name=c("bmd.grouping","bmd.bmd"),"visitdate")),
                c("patid", "visitdate", "bmd.grouping", "bmd.bmd", "bmd.age"))
   expect_equal(names(move.column.to.pos(df=calcium_st_compare,col.idx=5,new.col.idx=3)),
                c("patid", "visitdate", "bmd.bmd", "bmd.age", "bmd.grouping"))
})

# test id translation
test_that("Test id translation", {
   expect_equal(mnppid2mnpaid(1781), 104)
   expect_equal(mnpaid2mnppid(104), 1781)
})

# test tag stripping
test_that("Test tag stripping", {
   expect_equal(remove.center.tag("Universitätsspital Basel (SWISS-AF)"), "Universitätsspital Basel")
   expect_equal(remove.center.tag("HUG Genève (SSR)"), "HUG Genève")
})

# test center retrieval
test_that("Test center retrieval", {
   expect_equal(as.character(mnppid2center(1781)), "Hospital")
   expect_equal(as.character(mnppid2center(1781, remove.ctag = 0)), "Hospital (BMD)")
})

# test rectangular table loading
load.tables(data.dir=system.file("extdata", "s_export_rt-CSV-xls_BMD.zip", package = "secuTrial"), decode.rt.visitlabels = T)

# test dimensions
 test_that("Bone mineral density dataset (rectangular) has the correct dimensions", {
   expect_equal(dim(rtdata),c(113, 128))
})

# test that rectangular data identified
 test_that("Rectangular data identified by load.study.options", {
   expect_true(study.options$is.rectangular)
 })

# test that zip data identified
 test_that("Zipped data identified by load.study.options", {
   expect_true(study.options$is.zip)
 })

# test load.labels
load.study.options(data.dir=system.file("extdata", "s_export_CSV-xls_BMD.zip", package = "secuTrial"))
labs <- load.labels()
test_that("First label is age", {
  expect_equal(unname(labs["age"]),"Age")
})

# test rectangular label in study.options
# rect data
load.study.options(data.dir=system.file("extdata", "s_export_rt-CSV-xls_BMD.zip", package = "secuTrial"))
test_that("Data is rectangular", {
  expect_true(study.options$is.rectangular)
})

# test loading of Validation Overview
val_ov <- load_validation_overview(path=system.file("extdata", "bmd_validation_overview.xlsx", package = "secuTrial"))
test_that("Validation Overview loaded and dimensions are correct", {
  expect_equal(dim(val_ov),c(5, 12))
})

# test variable completeness "allforms"
all_form_completeness <- assess_form_variable_completeness(bmd, patient, val_ov, completeness = "allforms", occ_in_vp = 5)
test_that("All form completeness assessed correctly", {
  expect_equal(round(head(all_form_completeness$completeness,n=3), digits=3) , c(0.890, 0.888, 0.888))
})

# test variable completeness "savedforms"
saved_form_completeness <- assess_form_variable_completeness(bmd, patient, val_ov, completeness = "savedforms")
test_that("Saved form completeness assessed correctly", {
  expect_equal(round(saved_form_completeness$completeness,digits=3) , c(0.998, 0.996, 0.996))
})

# test times entered "allforms"
test_that("All form times entered assessed correctly", {
  expect_equal(all_form_completeness$timesentered , c(503, 502, 502, 504, 504))
})

# test times entered "savedforms"
test_that("Saved form times entered assessed correctly", {
  expect_equal(saved_form_completeness$timesentered , c(503, 502, 502))
})