Merge pull request #187 from darwin-eu/stratifyByRouteCategory

add stratifyByRouteCategory

NAMESPACE

@@ -21,6 +21,7 @@ export(getVocabularies)
 export(mockVocabRef)
 export(restrictToCodesInUse)
 export(sourceCodesInUse)
+export(stratifyByRouteCategory)
 export(subsetOnRouteCategory)
 export(summariseAchillesCodeUse)
 export(summariseCodeUse)

R/stratifyByRoute.R

@@ -0,0 +1,93 @@
+# Copyright 2024 DARWIN EU®
+#
+# This file is part of CodelistGenerator
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+#     http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+
+#' Stratify a codelist by route category
+#'
+#' @param x A codelist
+#' @param cdm A cdm reference
+#'
+#' @return A codelist
+#' @export
+#'
+stratifyByRouteCategory <- function(x, cdm){
+
+  x <- omopgenerics::newCodelist(x)
+
+  if(isFALSE(inherits(cdm, "cdm_reference"))){
+    cli::cli_abort("cdm must be a cdm reference")
+  }
+
+  doseRouteData <- get0("doseFormToRoute", envir = asNamespace("CodelistGenerator"))
+
+  tableCodelist <- paste0(omopgenerics::uniqueTableName(),
+                          omopgenerics::uniqueId())
+
+  result <- list()
+
+  for(i in seq_along(x)){
+    cdm <- omopgenerics::insertTable(cdm = cdm,
+                                     name = tableCodelist,
+                                     table = dplyr::tibble(concept_id = x[[i]]),
+                                     overwrite = TRUE,
+                                     temporary = FALSE)
+
+    workingName <- names(x)[i]
+
+    workingCodesWithRoute <- cdm[[tableCodelist]] |>
+      dplyr::inner_join(cdm$concept_relationship |>
+                          dplyr::filter(.data$relationship_id == "RxNorm has dose form"),
+                        by = c("concept_id" = "concept_id_1")
+      ) |>
+      dplyr::select("concept_id",
+                    "concept_id_2") |>
+      dplyr::collect() |>
+      dplyr::left_join(
+        doseRouteData, by = c("concept_id_2" = "dose_form_concept_id")
+      ) |>
+      dplyr::mutate(route_category = dplyr::if_else(
+        is.na(.data$route_category),
+        "unclassified route",
+        .data$route_category
+      )) |>
+      dplyr::select("concept_id", "route_category") |>
+      dplyr::distinct() |>
+      dplyr::collect()
+
+    workingCodesWithRoute <- split(
+      workingCodesWithRoute,
+      workingCodesWithRoute[, c("route_category")]
+    )
+
+    names(workingCodesWithRoute) <- paste0(workingName, "_",
+                                           names(workingCodesWithRoute))
+
+    for(j in seq_along(workingCodesWithRoute)){
+      workingCodesWithRoute[[j]] <- sort(workingCodesWithRoute[[j]] |>
+                                           dplyr::pull("concept_id"))
+    }
+
+    result[[i]] <- workingCodesWithRoute
+  }
+
+  result <- purrr:::list_flatten(result) |>
+    vctrs::list_drop_empty()
+
+  CDMConnector::dropTable(cdm = cdm, name = tableCodelist)
+
+  result
+
+}

_pkgdown.yml

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

tests/testthat/test-dbms.R

@@ -336,6 +336,12 @@ test_that("postgres", {
   expect_true(length(drug_codes_subset) == 2)
   expect_identical(drug_codes_subset, drug_codes2)
 
+  # can stratify by route
+  expect_no_error(drug_codes_stratified_by_route <-  getDrugIngredientCodes(cdm,,
+                                               name = c("metformin","diclofenac")) |>
+    stratifyByRouteCategory(cdm = cdm))
+
+
   # make sure no extra domains added to the results
   codes <- getCandidateCodes(
     cdm = cdm,

tests/testthat/test-stratifyByRouteCategory.R

@@ -0,0 +1,21 @@
+test_that("stratify by route works", {
+  backends <- c("database", "data_frame")
+
+  for (i in seq_along(backends)) {
+    cdm <- mockVocabRef(backends[[i]])
+    ing_codes <- getDrugIngredientCodes(cdm)
+
+    ing_codes_str <- stratifyByRouteCategory(ing_codes, cdm)
+    # all will are unclassified
+   expect_true( all(stringr::str_detect(names(ing_codes_str),
+                                        "unclassified")))
+
+    # expected errors
+    expect_error(stratifyByRouteCategory("a",  cdm))
+    expect_error(stratifyByRouteCategory(ing_codes,  "a"))
+
+    if (backends[[i]] == "database") {
+      CDMConnector::cdm_disconnect(cdm)
+    }
+  }
+})