Add support for minCellCount

R/Export.R

@@ -45,6 +45,7 @@
 #'
 #' @param databaseId                  Optional - when specified, the databaseId will be added
 #'                                    to the exported results
+#' @template minCellCount
 #'
 #' @template CohortDefinitionSet
 #'
@@ -61,6 +62,7 @@ exportCohortStatsTables <- function(connectionDetails,
                                     fileNamesInSnakeCase = FALSE,
                                     incremental = FALSE,
                                     databaseId = NULL,
+                                    minCellCount = 5,
                                     cohortDefinitionSet = NULL,
                                     tablePrefix = "") {
   if (is.null(connection)) {
@@ -80,7 +82,18 @@ exportCohortStatsTables <- function(connectionDetails,
                           tablePrefix) {
     fullFileName <- file.path(cohortStatisticsFolder, paste0(tablePrefix, fileName))
     primaryKeyColumns <- getPrimaryKey(resultsDataModelTableName)
+    columnsToCensor <- getColumnsToCensor(resultsDataModelTableName)
     rlang::inform(paste0("- Saving data to - ", fullFileName))
+
+    # Make sure the data is censored before saving
+    if (length(columnsToCensor) > 0) {
+      for (i in seq_along(columnsToCensor)) {
+        colName <- ifelse(isTRUE(snakeCaseToCamelCase), yes = columnsToCensor[i], no = SqlRender::camelCaseToSnakeCase(columnsToCensor[i]))
+        data <- data %>%
+          enforceMinCellValue(colName, minCellCount)
+      }
+    }
+
     if (incremental) {
       # Dynamically build the arguments to the saveIncremental
       # to specify the primary key(s) for the file
@@ -226,3 +239,35 @@ getPrimaryKey <- function(tableName) {
     SqlRender::snakeCaseToCamelCase()
   return(columns)
 }
+
+getColumnsToCensor <- function(tableName) {
+  columns <- readCsv(
+    file = system.file("csv", "resultsDataModelSpecification.csv", package = "CohortGenerator")
+  ) %>%
+    dplyr::filter(.data$tableName == !!tableName & tolower(.data$minCellCount) == "yes") %>%
+    dplyr::pull(.data$columnName) %>%
+    SqlRender::snakeCaseToCamelCase()
+  return(columns)
+}
+
+enforceMinCellValue <- function(data, fieldName, minValues, silent = FALSE) {
+  toCensor <- !is.na(pull(data, fieldName)) & pull(data, fieldName) < minValues & pull(data, fieldName) != 0
+  if (!silent) {
+    percent <- round(100 * sum(toCensor) / nrow(data), 1)
+    message(
+      "    censoring ",
+      sum(toCensor),
+      " values (",
+      percent,
+      "%) from ",
+      fieldName,
+      " because value below minimum"
+    )
+  }
+  if (length(minValues) == 1) {
+    data[toCensor, fieldName] <- -minValues
+  } else {
+    data[toCensor, fieldName] <- -minValues[toCensor]
+  }
+  return(data)
+}

R/RunCohortGeneration.R

@@ -58,6 +58,8 @@
 #'
 #' @param databaseId    A unique ID for the database. This will be appended to
 #'                      most tables.
+#'                      
+#' @template minCellCount
 #'
 #' @param incremental   Create only cohorts that haven't been created before?
 #'
@@ -78,6 +80,7 @@ runCohortGeneration <- function(connectionDetails,
                                 stopOnError = TRUE,
                                 outputFolder,
                                 databaseId = 1,
+                                minCellCount = 5,
                                 incremental = FALSE,
                                 incrementalFolder = NULL) {
   if (is.null(cohortDefinitionSet) && is.null(negativeControlOutcomeCohortSet)) {
@@ -127,6 +130,7 @@ runCohortGeneration <- function(connectionDetails,
     stopOnError = stopOnError,
     outputFolder = outputFolder,
     databaseId = databaseId,
+    minCellCount = minCellCount,
     incremental = incremental,
     incrementalFolder = incrementalFolder
   )
@@ -142,6 +146,7 @@ runCohortGeneration <- function(connectionDetails,
     detectOnDescendants = detectOnDescendants,
     outputFolder = outputFolder,
     databaseId = databaseId,
+    minCellCount = minCellCount,
     incremental = incremental,
     incrementalFolder = incrementalFolder
   )
@@ -164,6 +169,7 @@ generateAndExportCohorts <- function(connection,
                                      stopOnError,
                                      outputFolder,
                                      databaseId,
+                                     minCellCount,
                                      incremental,
                                      incrementalFolder) {
   # Generate the cohorts
@@ -220,6 +226,9 @@ generateAndExportCohorts <- function(connection,
   }
 
   rlang::inform("Saving cohort counts")
+  cohortCounts <- cohortCounts %>%
+    enforceMinCellValue("cohortEntries", minCellCount) %>%
+    enforceMinCellValue("cohortSubjects", minCellCount)
   writeCsv(
     x = cohortCounts,
     file = cohortCountsFileName
@@ -235,6 +244,7 @@ generateAndExportCohorts <- function(connection,
     fileNamesInSnakeCase = TRUE,
     incremental = incremental,
     databaseId = databaseId,
+    minCellCount = minCellCount,
     cohortDefinitionSet = cohortDefinitionSet,
     tablePrefix = "cg_"
   )
@@ -254,6 +264,7 @@ generateAndExportNegativeControls <- function(connection,
                                               detectOnDescendants,
                                               outputFolder,
                                               databaseId,
+                                              minCellCount,
                                               incremental,
                                               incrementalFolder) {
   # Generate any negative controls
@@ -299,6 +310,9 @@ generateAndExportNegativeControls <- function(connection,
   )
 
   rlang::inform("Saving negative control outcome cohort counts")
+  cohortCountsNegativeControlOutcomes <- cohortCountsNegativeControlOutcomes %>%
+    enforceMinCellValue("cohortEntries", minCellCount) %>%
+    enforceMinCellValue("cohortSubjects", minCellCount)
   writeCsv(
     x = cohortCountsNegativeControlOutcomes,
     file = cohortCountsNegativeControlOutcomesFileName

man-roxygen/MinCellCount.R

@@ -0,0 +1,3 @@
+#' @param minCellCount  To preserve privacy: the minimum number of subjects contributing
+#'                      to a count before it can be included in the results. If the
+#'                      count is below this threshold, it will be set to `-minCellCount`.