Merge pull request #186 from darwin-eu/restrict_to_codes_in_use

add subsetToCodesInUse, deprecate restrictToCodesInUse
darwin-eu · Jul 9, 2024 · 4814971 · 4814971
2 parents 83979b3 + 7361e70
commit 4814971
Show file tree

Hide file tree

Showing 6 changed files with 127 additions and 32 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -23,6 +23,7 @@ export(restrictToCodesInUse)
 export(sourceCodesInUse)
 export(stratifyByRouteCategory)
 export(subsetOnRouteCategory)
+export(subsetToCodesInUse)
 export(summariseAchillesCodeUse)
 export(summariseCodeUse)
 export(summariseCohortCodeUse)

diff --git a/R/codesInUse.R b/R/codesInUse.R
@@ -32,23 +32,23 @@
 #'                            keywords = "arthritis",
 #'                            domains = "Condition",
 #'                            includeDescendants = FALSE)
-#' x <- restrictToCodesInUse(list("cs1" = codes$concept_id,
+#' x <- subsetToCodesInUse(list("cs1" = codes$concept_id,
 #'                                "cs2" = 999),
 #'                                 cdm = cdm)
 #'
 #' x
 #' CDMConnector::cdmDisconnect(cdm)
 #' }
-restrictToCodesInUse <- function(x,
-                               cdm,
-                               minimumCount = 0L,
-                               table = c("condition_occurrence",
-                                         "device_exposure",
-                                         "drug_exposure",
-                                         "measurement",
-                                         "observation",
-                                         "procedure_occurrence",
-                                         "visit_occurrence")){
+subsetToCodesInUse <- function(x,
+                                 cdm,
+                                 minimumCount = 0L,
+                                 table = c("condition_occurrence",
+                                           "device_exposure",
+                                           "drug_exposure",
+                                           "measurement",
+                                           "observation",
+                                           "procedure_occurrence",
+                                           "visit_occurrence")){
 
 
   if(is.null(cdm[["achilles_results"]])){
@@ -60,26 +60,74 @@ restrictToCodesInUse <- function(x,
                         table = table)
 
   if(is.null(dbCodes)){
-  for(i in seq_along(x)){
-    cli::cli_inform("No codes from any codelist found in the database")
-    return(invisible(omopgenerics::emptyCodelist()))
-  }
-} else {
-  for(i in seq_along(x)){
-    x[[i]] <- intersect(x[[i]], dbCodes)
-    if(!length(x[[i]]) >= 1){
-    cli::cli_inform("No codes from codelist {names(x)[i]} found in the database")
+    for(i in seq_along(x)){
+      cli::cli_inform("No codes from any codelist found in the database")
+      return(invisible(omopgenerics::emptyCodelist()))
+    }
+  } else {
+    for(i in seq_along(x)){
+      x[[i]] <- intersect(x[[i]], dbCodes)
+      if(!length(x[[i]]) >= 1){
+        cli::cli_inform("No codes from codelist {names(x)[i]} found in the database")
+      }
     }
   }
-}
 
-x <- vctrs::list_drop_empty(x)
+  x <- vctrs::list_drop_empty(x)
+
+  if(length(x) == 0){
+    return(invisible(omopgenerics::emptyCodelist()))
+  }
+
+  x
 
-if(length(x) == 0){
-  return(invisible(omopgenerics::emptyCodelist()))
 }
 
-x
+
+#' Use achilles counts to filter a codelist to keep only the codes
+#' used in the database
+#'
+#' @param x A codelist
+#' @param cdm cdm_reference via CDMConnector
+#' @param minimumCount Any codes with a frequency under this will be removed.
+#' @param table cdm table
+#'
+#' @return Use achilles counts to filter codelist to only the codes used in the database
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' cdm <- mockVocabRef("database")
+#' codes <- getCandidateCodes(cdm = cdm,
+#'                            keywords = "arthritis",
+#'                            domains = "Condition",
+#'                            includeDescendants = FALSE)
+#' x <- restrictToCodesInUse(list("cs1" = codes$concept_id,
+#'                                "cs2" = 999),
+#'                                 cdm = cdm)
+#'
+#' x
+#' CDMConnector::cdmDisconnect(cdm)
+#' }
+restrictToCodesInUse <- function(x,
+                               cdm,
+                               minimumCount = 0L,
+                               table = c("condition_occurrence",
+                                         "device_exposure",
+                                         "drug_exposure",
+                                         "measurement",
+                                         "observation",
+                                         "procedure_occurrence",
+                                         "visit_occurrence")){
+
+  lifecycle::deprecate_warn("3.1.0",
+                            "CodelistGenerator::restrictToCodesInUse()",
+                            "CodelistGenerator::subsetToCodesInUse()")
+
+  subsetToCodesInUse(x = x,
+                     cdm = cdm,
+                     minimumCount = minimumCount,
+                     table = table)
 
 }
 

diff --git a/_pkgdown.yml b/_pkgdown.yml
@@ -28,7 +28,7 @@ reference:
   - matches("codesFromCohort|codesFromConceptSet")
 - subtitle: Codelist utility functions
 - contents:
-  - matches("codesInUse|compareCodelists|restrictToCodesInUse|subsetOnRouteCategory|stratifyByRouteCategory")
+  - matches("codesInUse|compareCodelists|subsetToCodesInUse|restrictToCodesInUse|subsetOnRouteCategory|stratifyByRouteCategory")
 - subtitle: Vocabulary utility functions
 - contents:
   - matches("getVocabVersion|getVocabularies|getConceptClassId|getDomains|getDescendants|getDoseForm|doseFormToRoute|getRouteCategories|getRoutes|getRelationshipId|getMappings|sourceCodesInUse")

diff --git a/man/subsetToCodesInUse.Rd b/man/subsetToCodesInUse.Rd
diff --git a/tests/testthat/test-codesInUse.R b/tests/testthat/test-codesInUse.R
@@ -10,10 +10,10 @@ test_that("tests with mock db", {
     includeDescendants = FALSE
   )
   expect_true(all(c("4", "5") %in%
-                restrictToCodesInUse(list("cs" = codes$concept_id),
+                subsetToCodesInUse(list("cs" = codes$concept_id),
                        cdm = cdm)[[1]]))
 
-  expect_true(length(restrictToCodesInUse(list("cs1" = codes$concept_id,
+  expect_true(length(subsetToCodesInUse(list("cs1" = codes$concept_id,
                        "cs2" = 999),
                        cdm = cdm)) == 1) # will just have cs1
 
@@ -24,7 +24,7 @@ test_that("tests with mock db", {
     domains = "Condition",
     includeDescendants = FALSE
   )
- expect_message(restrictToCodesInUse(list("cs" = codes$concept_id),
+ expect_message(subsetToCodesInUse(list("cs" = codes$concept_id),
                        cdm = cdm))
 
   CDMConnector::cdm_disconnect(cdm)
@@ -50,8 +50,6 @@ test_that("sql server with achilles", {
                                     achilles_schema = c("CDMV54", "dbo"),
                                     write_schema = c("ohdsi", "dbo"))
 
-
-
   asthma_codes <- getCandidateCodes(
     cdm = cdm,
     keywords = "asthma",
@@ -60,7 +58,7 @@ test_that("sql server with achilles", {
   )
   asthma_cl <- list("cs" = asthma_codes$concept_id)
 
-  asthma_codes_present <- restrictToCodesInUse(x = asthma_cl,
+  asthma_codes_present <- subsetToCodesInUse(x = asthma_cl,
                                                cdm = cdm)
 
 expect_equal(sort(asthma_codes_present[[1]]),

diff --git a/tests/testthat/test-restrictToCodesInUse.R b/tests/testthat/test-restrictToCodesInUse.R
@@ -3,6 +3,8 @@ test_that("restrict to codes in use", {
   startCl <- list(a = c(4,5,6),
                   b = c(1,2))
   endCl <- restrictToCodesInUse(startCl, cdm)
+  endCl2 <- subsetToCodesInUse(startCl, cdm)
+  expect_identical(endCl, endCl2)
 
   expect_true(all(c(4,5) %in% endCl[["a"]]))
   expect_false(c(6) %in% endCl[["a"]])