tests/testthat/test-validate.R

In omopgenerics: Methods and Classes for the OMOP Common Data Model

test_that("test validateNameArgument", {
  expect_error(validateNameArgument(name = 1))
  expect_error(validateNameArgument(name = c("sda", "asdfsa")))
  expect_identical("my_name", validateNameArgument("my_name"))
  expect_error(validateNameArgument("myName"))
  expect_warning(expect_identical("my_name", validateNameArgument("myName", validation = "warning")))
  expect_warning(expect_warning(expect_identical(
    "my_name", validateNameArgument("myName", list("my_name" = 1), validation = "warning")
  )))
  expect_no_error(validateNameArgument(name = NULL, null = TRUE))
  expect_error(validateNameArgument(name = NULL, null = FALSE))
})

test_that("test validateCohortIdArgument", {
  cohort <- 1
  class(cohort) <- c("cohort_table", "cdm_table")
  attr(cohort, "cohort_set") <- dplyr::tibble(
    "cohort_definition_id" = c(2, 4), "cohort_name" = c("a", "b")
  )
  expect_error(validateCohortIdArgument("adsfd", cohort))
  expect_identical(validateCohortIdArgument(2, cohort), 2L)
  expect_identical(validateCohortIdArgument(c(2, 4), cohort), c(2L, 4L))
  expect_identical(validateCohortIdArgument(c(4L, 2L), cohort), c(4L, 2L))
  expect_error(validateCohortIdArgument(1, cohort))
})

test_that("test validateWindowArgument", {
  window <- c(0, 1)
  expect_no_error(validateWindowArgument(window))
  window <- list(c(0, 1), c(2, 3))
  expect_no_error(validateWindowArgument(window))
  window <- list(c("a", 1))
  expect_error(validateWindowArgument(window))
  window <- list("window" = c(0, 1), "window2" = c(-1, 1))
  expect_no_error(validateWindowArgument(window))
  window <- list(c(0, -1))
  expect_error(validateWindowArgument(window))
  window <- list(c(-Inf, -Inf))
  expect_error(validateWindowArgument(window))
  window <- list(c(Inf, Inf))
  expect_error(validateWindowArgument(window))

  #window name check
  window <- list(c(-1, 1))

  window <- window |> validateWindowArgument(snakeCase = FALSE)

  expect_true(names(window) == "-1 to 1")

  window <- list(c(-1, 1))

  window <- window |> validateWindowArgument(snakeCase = TRUE)

  expect_true(names(window) == "m1_to_1")


  window <- list("window" = c(-1, 1))
  window <- window |> validateWindowArgument(snakeCase = TRUE)
  expect_true(names(window) == "window")

})

test_that("test validateAgeGroup", {
  #test list
  expect_error(validateAgeGroupArgument(c("1", "18")))
  ageGroup = list(c(0, 18))
  expect_no_error(validateAgeGroupArgument(ageGroup))

  #test name
  ageGroup = validateAgeGroupArgument(ageGroup)
  expect_true(names(ageGroup) == "age_group")

  # name multiple group
  ageGroup = list(list(c(0, 19)), list(c(0, 18)))
  ageGroup = validateAgeGroupArgument(ageGroup)
  expect_true(all(names(ageGroup) == c("age_group_1", "age_group_2")))

  #test overlap
  ageGroup = list(c(0, 18), c(16, 20))
  expect_error(validateAgeGroupArgument(ageGroup, overlap = FALSE))
  expect_no_error(validateAgeGroupArgument(ageGroup, overlap = TRUE))

  #test order
  ageGroup = list(c(19, 18), c(21, 20))
  expect_error(validateAgeGroupArgument(ageGroup, overlap = FALSE))

  # test multiple age group
  ageGroup = list(list(c(0, 19)), list(c(0, 18)))
  expect_error(validateAgeGroupArgument(
    ageGroup, overlap = FALSE, multipleAgeGroup = FALSE))
  expect_no_error(validateAgeGroupArgument(
    ageGroup, overlap = FALSE, multipleAgeGroup = TRUE))

  # null age group
  expect_no_error(validateAgeGroupArgument(
    ageGroup = NULL, overlap = FALSE, multipleAgeGroup = FALSE))
  expect_error(validateAgeGroupArgument(
    ageGroup = NULL, overlap = FALSE, null = FALSE, multipleAgeGroup = FALSE))

  # correct naming
  x <- list(0, c(1, 19), c(20, 39), c(40, 59), c(60, 79), c(80, Inf)) |>
    validateAgeGroupArgument()
  expect_identical(
    x,
    list("age_group" = list(
      "0 to 0" = c(0, 0), "1 to 19" = c(1, 19), "20 to 39" = c(20, 39),
      "40 to 59" = c(40, 59), "60 to 79" = c(60, 79), "80 or above" = c(80, Inf)
    ))
  )
  expect_identical(
    validateAgeGroupArgument(c(0, Inf), ageGroupName = "my_age_group"),
    list(my_age_group = list(overall = c(0L, Inf)))
  )
})

test_that("test validateCdmArgument", {

  cdm_object <- 1
  class(cdm_object) <- c("cdm_reference")
  expect_no_error(
    validateCdmArgument(
      cdm_object,
      checkOverlapObservation = FALSE,
      checkStartBeforeEndObservation = FALSE
    )
  )
  expect_error(
    validateCdmArgument(
      cdm_object,
      checkOverlapObservation = TRUE,
      checkStartBeforeEndObservation = TRUE
    )
  )

  cdm_object <- list(
    "observation_period" = dplyr::tibble(
      observation_period_id = 1L, person_id = 1L,
      observation_period_start_date = as.Date("2000-01-01"),
      observation_period_end_date = as.Date("2023-12-31"),
      period_type_concept_id = 0L
    ))

  class(cdm_object) <- c("cdm_reference")

  expect_no_error(
    validateCdmArgument(
      cdm_object,
      checkOverlapObservation = TRUE,
      checkStartBeforeEndObservation = TRUE
    )
  )

  cdm_object <- list(
    "observation_period" = dplyr::tibble(
      observation_period_id = c(1L,1L), person_id = c(1L,1L),
      observation_period_start_date = c(as.Date("2000-01-01"),as.Date("2000-01-01")),
      observation_period_end_date = c(as.Date("2023-12-31"),as.Date("2023-01-01")),
      period_type_concept_id = c(0L,0L)
    ))
  class(cdm_object) <- c("cdm_reference")

  expect_error(
    validateCdmArgument(
      cdm_object,
      checkOverlapObservation = TRUE,
      checkStartBeforeEndObservation = TRUE
    )
  )

  expect_no_error(
    validateCdmArgument(
      cdm_object,
      checkOverlapObservation = FALSE,
      checkStartBeforeEndObservation = FALSE
    )
  )

  # implausible starting observation date
  cdm_object <- list(
    "observation_period" = dplyr::tibble(
      observation_period_id = c(1L,1L), person_id = c(1L,1L),
      observation_period_start_date = c(as.Date("1700-01-01"),as.Date("2000-01-01")),
      observation_period_end_date = c(as.Date("2000-01-01"),as.Date("2023-01-01")),
      period_type_concept_id = c(0L,0L)
    ))
  class(cdm_object) <- c("cdm_reference")
  expect_warning(
    validateCdmArgument(
      cdm_object,
      checkPlausibleObservationDates = TRUE
    )
  )
  expect_no_error(
    validateCdmArgument(
      cdm_object,
      checkPlausibleObservationDates = FALSE
    )
  )

  # implausible ending observation date - currently a warning instead of e
  cdm_object <- list(
    "observation_period" = dplyr::tibble(
      observation_period_id = c(1L,1L), person_id = c(1L,1L),
      observation_period_start_date = c(as.Date("2000-01-01"),as.Date("2000-01-02")),
      observation_period_end_date = c(as.Date("2000-01-01"),as.Date("2100-01-01")),
      period_type_concept_id = c(0L,0L)
    ))
  class(cdm_object) <- c("cdm_reference")
  expect_warning(
    validateCdmArgument(
      cdm_object,
      checkPlausibleObservationDates = TRUE
    )
  )
  expect_no_error(
    validateCdmArgument(
      cdm_object,
      checkPlausibleObservationDates = FALSE
    )
  )


  # no errors or warnings if cdm is empty
  expect_no_error(
    validateCdmArgument(
      emptyCdmReference("test"),
      checkOverlapObservation = TRUE,
      checkStartBeforeEndObservation = TRUE,
      checkPlausibleObservationDates = TRUE
    )
    )

  # warnings if clinical table contain person id not in person  table

  cdm_object <- list(
    "observation_period" = dplyr::tibble(
      observation_period_id = c(1L,1L), person_id = c(1L,1L),
      observation_period_start_date = c(as.Date("2000-01-01"),as.Date("2000-01-02")),
      observation_period_end_date = c(as.Date("2000-01-01"),as.Date("2100-01-01")),
      period_type_concept_id = c(0L,0L)
    ),
    "person" = dplyr::tibble(
      person_id = c(1L,1L),
      gender_concept_id = c(8507L,8507L),
      year_of_birth = c(1991L,1992L)
    ),
    "condition_occurrence" = dplyr::tibble(
      condition_occurrence_id = c(1L,2L),
      person_id = c(8507L,8507L),
      condition_start_date =  c(as.Date("2000-01-01"),as.Date("2000-01-02")),
      condition_end_date = c(as.Date("2000-01-01"),as.Date("2100-01-01"))
    ))

  class(cdm_object) <- c("cdm_reference")

  expect_no_warning(
    validateCdmArgument(
      cdm_object,
      checkPerson = FALSE
    )
  )

  expect_warning(
    validateCdmArgument(
      cdm_object,
      checkPerson = TRUE
    )
  )

})

test_that("test validateResults", {

  x <- dplyr::tibble(
    "result_id" = as.integer(1),
    "cdm_name" = "cprd",
    "result_type" = "summarised_characteristics",
    "package_name" = "PatientProfiles",
    "package_version" = "0.4.0",
    "group_name" = "cohort_name",
    "group_level" = "cohort1",
    "strata_name" = "sex",
    "strata_level" = "male",
    "variable_name" = "Age group",
    "variable_level" = "10 to 50",
    "estimate_name" = "count",
    "estimate_type" = "numeric",
    "estimate_value" = "5",
    "additional_name" = "overall",
    "additional_level" = "overall"
  )



  expect_no_error(x |>
                    newSummarisedResult() |>
                    validateResultArgument())

})

test_that("test isResultSuppressed",{
  obj <- dplyr::tibble(
    "result_id" = as.integer(1),
    "cdm_name" = "mock",
    "group_name" = "overall",
    "group_level" = "overall",
    "strata_name" = c(rep("overall", 6), rep("sex", 3)),
    "strata_level" = c(rep("overall", 6), "male", "female", "female"),
    "variable_name" = c("number records", "age_group", "age_group", "age_group", "age_group", "my_variable", "number records", "age_group", "age_group"),
    "variable_level" = c(NA, "<50", "<50", ">=50", ">=50", NA, NA, "<50", "<50"),
    "estimate_name" = c("count", "count", "percentage", "count", "percentage", "random", "count", "count", "percentage"),
    "estimate_type" = c("integer", "integer", "percentage", "integer", "percentage", "numeric", "integer", "integer", "percentage"),
    "estimate_value" = c("10", "5", "50", "3", "30", "1", "3", "12", "6"),
    "additional_name" = "overall",
    "additional_level" = "overall"
  ) |>
    newSummarisedResult(settings = dplyr::tibble(
      "result_id" = as.integer(1),
      "result_type" = "summarised_characteristics",
      "package_name" = "omopgenerics",
      "package_version" = as.character(utils::packageVersion("omopgenerics"))
    ))

  # Test for no min_cell_count column
  expect_warning(isResultSuppressed(result = obj, minCellCount = 3))

  result <- suppress(obj, minCellCount = 2)

  # Test for correctly specified min_cell_count
  expect_no_warning(isResultSuppressed(result = result, minCellCount = 2))

  # Test for greater actual min_cell_count
  expect_warning(isResultSuppressed(result = result, minCellCount = 1))

  # Test for smaller actual min_cell_count
  expect_warning(isResultSuppressed(result = result, minCellCount = 3))

})