Cleanup Bug and Fix Demographics

R/cleanCohortTables.R

@@ -1,9 +1,11 @@
-library(CDMConnector)
+#' Names of a cohort table and its companion tables (_attrition, _codelist, _set), for one or more cohorts
 
-cleanUpTables <- function(cdm, prefix) {
-  names <- c("_attrition", "_codelist", "_set")
-  tables <- sprintf("%s%s", prefix, names)
-  CDMConnector::dropTable(cdm, tables)
-  CDMConnector::dropTable(cdm, prefix)
-  cdm
+cohortTableNames <- function(names) {
+  suffixes <- c("_attrition", "_codelist", "_set")
+  c(names, as.vector(outer(names, suffixes, paste0)))
 }
+
+cleanUpTables <- function(cdm, names) {
+  omopgenerics::dropSourceTable(cdm = cdm, name = cohortTableNames(names))
+  cdm
+}

inst/scripts/addCharacteristics.R

@@ -44,17 +44,26 @@ cohort <- cdm[[arguments$name]]
 ageGroup <- if (arguments$addAge) parseAgeGroups(arguments$ageGroup) else NULL
 
 if (arguments$useDemographics) {
-  demographicsArgs <- list(
+    demographicsArgs <- list(
+    indexDate = arguments$indexDate,
     age = arguments$addAge,
     ageName = arguments$ageName,
     ageGroup = ageGroup,
+    ageImposeMonth = arguments$ageImposeMonth,
+    ageImposeDay = arguments$ageImposeDay,
     sex = arguments$addSex,
     sexName = "sex",
     priorObservation = arguments$addPriorObservation,
     priorObservationName = "prior_observation",
     futureObservation = arguments$addFutureObservation,
     futureObservationName = "future_observation"
   )
+  if (!is.null(arguments$ageMissingMonth) && !identical(arguments$ageMissingMonth, "NULL")) {
+    demographicsArgs$ageMissingMonth <- as.numeric(arguments$ageMissingMonth)
+  }
+  if (!is.null(arguments$ageMissingDay) && !identical(arguments$ageMissingDay, "NULL")) {
+    demographicsArgs$ageMissingDay <- as.numeric(arguments$ageMissingDay)
+  }
 
   cohort <- do.call(addDemographics, c(list(x = cohort), demographicsArgs))
 

tests/testthat/test-cleanCohortTables.R

@@ -0,0 +1,16 @@
+test_that("Cohort table names are built for one cohort", {
+  expect_setequal(
+    cohortTableNames("cohort_a"),
+    c("cohort_a", "cohort_a_attrition", "cohort_a_codelist", "cohort_a_set")
+  )
+})
+
+test_that("Cohort table names are built for several cohorts", {
+  expect_setequal(
+    cohortTableNames(c("cohort_a", "cohort_b")),
+    c(
+      "cohort_a", "cohort_a_attrition", "cohort_a_codelist", "cohort_a_set",
+      "cohort_b", "cohort_b_attrition", "cohort_b_codelist", "cohort_b_set"
+    )
+  )
+})