Merge pull request #25 from oxford-pharmacoepi/tests

Test mock person and observationPeriod

R/Mockchecks.R

@@ -270,8 +270,8 @@ assertNumeric <- function(x,
     paste0(substitute(x), collapse = ""),
     " must be a numeric",
     ifelse(integerish, "; it has to be integerish", ""),
-    ifelse(is.infinite(min), "", paste0("; greater than", min)),
-    ifelse(is.infinite(max), "", paste0("; smaller than", max)),
+    ifelse(is.infinite(min), "", paste0("; equal or greater than ", min)),
+    ifelse(is.infinite(max), "", paste0("; smaller than ", max)),
     errorLength(length),
     errorNa(na),
     errorNull(null),
@@ -463,3 +463,26 @@ assertClass <- function(x,
   }
   invisible(x)
 }
+
+#' Assert that an object is a Date.
+#'
+#' @param x To check.
+#' @param length Length that has to have.
+#' @param call Call argument that will be passed to `cli`.
+#'
+#' @noRd
+#'
+assertDate <- function(x,
+                       length,
+                       call = parent.frame()) {
+  # create error message
+  errorMessage <- paste0(substitute(x), " must be an object of class Date.")
+  if (! class(x) %in% "Date") {
+    cli::cli_abort(errorMessage, call = call)
+  }
+  errorMessage <- paste0(substitute(x), " must have length = ", length)
+  if (length(x) != length) {
+    cli::cli_abort(errorMessage, call = call)
+  }
+  invisible(x)
+}

R/checks.R

@@ -300,9 +300,9 @@ checknPerson <- function(nPerson, call = parent.frame()) {
 
 # check birthRange
 checkbirthRange <- function(birthRange, call = parent.frame()) {
-  assertCharacter(birthRange, length = 2, call = call)
+  assertDate(birthRange, length = 2, call = call)
 
-  if(as.Date(birthRange[1]) >= as.Date(birthRange[2])){
+  if(birthRange[1] >= birthRange[2]){
     cli::cli_abort("max date must be greater than min date ", call = call)
   }
 

R/mockPerson.R

@@ -1,5 +1,3 @@
-
-
 #' mockPerson
 #'
 #' @param cdm Name of the cdm object
@@ -16,10 +14,10 @@
 #' }
 mockPerson <- function(cdm,
                        nPerson = 10,
-                       birthRange = c("1950-01-01", "2000-12-31"),
+                       birthRange = as.Date(c("1950-01-01", "2000-12-31")),
                        seed = 1) {
   checkInput(cdm = cdm)
-##  if (nrow(cdm$person) == 0) {
+ if (nrow(cdm$person) == 0) {
     checkInput(nPerson = nPerson,
                birthRange = birthRange,
                seed = seed)
@@ -31,8 +29,8 @@ mockPerson <- function(cdm,
     person_id <- seq_len(nPerson)
 
     dob <-
-      sample(seq(as.Date(birthRange[1]),
-                 as.Date(birthRange[2]),
+      sample(seq(birthRange[1],
+                 birthRange[2],
                  by =
                    "day"),
              length(person_id),
@@ -56,7 +54,11 @@ mockPerson <- function(cdm,
       omopgenerics::insertTable(cdm = cdm,
                                 name = "person",
                                 table = person)
-##  }
+
+  } else {
+    cli::cli_abort("CDM reference already contains a non-empty person table.")
+  }
+
 
   return(cdm)
 }

tests/testthat/test-mockObservationPeriod.R

@@ -1,3 +1,19 @@
-test_that("multiplication works", {
-  expect_equal(2 * 2, 4)
+test_that("mockObservationPeriod", {
+  expect_no_error(
+    cdm <- emptyCdmReference(cdmName = "test") |>
+      mockPerson(nPerson = 1000,
+                 birthRange = as.Date(c("1990-01-01", "2000-01-01"))) |>
+      mockObservationPeriod()
+  )
+  expect_true(all(colnames(cdm$observation_period) %in%
+                    c("observation_period_id", "person_id",
+                      "observation_period_start_date",
+                      "observation_period_end_date",
+                      "period_type_concept_id")))
+  expect_equal(cdm$observation_period$person_id,
+               cdm$person$person_id)
+  expect_true(all(cdm$observation_period$observation_period_start_date <
+                    cdm$observation_period$observation_period_end_date))
+  expect_true(all(cdm$observation_period$observation_period_id ==
+                    cdm$observation_period$person_id))
 })

tests/testthat/test-mockPerson.R

@@ -1,3 +1,57 @@
-test_that("multiplication works", {
-  expect_equal(2 * 2, 4)
+test_that("mockPerson", {
+  expect_no_error(
+    cdm <- emptyCdmReference(cdmName = "test") |>
+      mockPerson(nPerson = 1000,
+                 birthRange = as.Date(c("1990-01-01", "2000-01-01")))
+  )
+  expect_true(all(names(cdm) %in% c("person", "observation_period")))
+  expect_true(cdm$person |> dplyr::distinct(person_id) |> dplyr::tally()
+              |> dplyr::pull(n) == 1000)
+  expect_true(cdm$person |> dplyr::tally() |> dplyr::pull(n) == 1000)
+  expect_true(all(colnames(cdm$person) %in%
+                    c("person_id", "gender_concept_id", "year_of_birth",
+                      "month_of_birth", "day_of_birth", "race_concept_id",
+                      "ethnicity_concept_id")))
+  expect_equal(class(cdm$person),
+               c("omop_table", "cdm_table", "tbl_df", "tbl", "data.frame"))
+  dob <- cdm$person |>
+    dplyr::mutate(dob = as.Date(paste0(.data$year_of_birth, "-",
+                                       .data$month_of_birth, "-",
+                                       .data$day_of_birth))) |>
+    dplyr::pull(dob)
+  expect_true(all(dob >= as.Date("1990-01-01") & dob <= as.Date("2000-01-01")))
+
+  expect_error(
+    emptyCdmReference(cdmName = "test") |>
+      mockPerson(nPerson = 1000,
+                 birthRange = as.Date(c("1990-01-01", "1980-01-01"))
+      )
+  )
+  expect_error(
+    emptyCdmReference(cdmName = "test") |>
+      mockPerson(nPerson = NULL,
+                 birthRange = as.Date(c("1990-01-01", "2000-01-01"))
+      )
+  )
+  expect_error(
+    cdm <- emptyCdmReference(cdmName = "test") |>
+      mockPerson(nPerson = 0,
+                 birthRange = as.Date(c("1990-01-01", "2000-01-01"))
+      )
+  )
+  expect_error(
+    cdm <- emptyCdmReference(cdmName = "test") |>
+      mockPerson(nPerson = 100,
+                 birthRange = as.Date(c("1990-01-01", "2000-01-01"))
+      ) |>
+      mockPerson(nPerson = 100,
+                 birthRange = as.Date(c("1990-01-01", "2000-01-01"))
+      )
+  )
+  expect_error(
+    cdm <- emptyCdmReference(cdmName = "test") |>
+      mockPerson(nPerson = 100,
+                 birthRange = c("1990-01-01", "2000-01-01")
+      )
+  )
 })

vignettes/a01_Creating_synthetic_clinical_tables.Rmd

@@ -40,7 +40,7 @@ We can add further requirements around the population we create. For example we
 ```{r}
 cdm <- emptyCdmReference(cdmName = "synthetic cdm") %>% 
   mockPerson(nPerson = 1000,
-             birthRange = c("1960-01-01", "1980-12-31")) %>% 
+             birthRange = as.Date(c("1960-01-01", "1980-12-31"))) %>% 
   mockObservationPeriod()
 ```