R/stratifyByRoute.R

In oxford-pharmacoepi/CodelistGenerator: Identify Relevant Clinical Codes and Evaluate Their Use

# Copyright 2025 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.
#'
#' @inheritParams xDoc
#' @inheritParams cdmDoc
#' @inheritParams keepOriginalDoc
#'
#' @return The codelist with the required stratifications, as different elements
#' of the list.
#' @export
#' @examples
#' \donttest{
#' library(CodelistGenerator)
#' cdm <- mockVocabRef()
#' codes <- list("concepts" = c(20,21))
#' new_codes <- stratifyByRouteCategory(x = codes,
#'                                      cdm = cdm,
#'                                      keepOriginal = TRUE)
#' new_codes
#'}
stratifyByRouteCategory <- function(x, cdm, keepOriginal = FALSE){

  # initial checks
  omopgenerics::assertList(x)
  cdm <- omopgenerics::validateCdmArgument(cdm = cdm)
  omopgenerics::assertLogical(keepOriginal, length = 1)

  if(inherits(x, "codelist_with_details")){
    x_original <- x
    withDetails <- TRUE
    x <- codelistFromCodelistWithDetails(x)
  } else {
    omopgenerics::newCodelist(x)
    withDetails <- FALSE
  }

  x <- omopgenerics::newCodelist(x)

  doseRouteData <- doseFormToRoute
  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::left_join(cdm$concept |>
                         dplyr::select("concept_id", "domain_id"),
                       by = "concept_id") |>
      dplyr::left_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",
                    "domain_id") |>
      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) & (tolower(.data$domain_id) == "drug"),
        "unclassified_route",
        .data$route_category
      )) |>
      dplyr::select("concept_id", "route_category") |>
      dplyr::distinct() |>
      dplyr::filter(!is.na(.data$route_category)) |>
      dplyr::collect()

    if(isTRUE(withDetails)){
      workingCodesWithRoute <-  x_original[[i]] |>
          dplyr::inner_join(workingCodesWithRoute,
                            by = "concept_id")
    }

    workingCodesWithRoute <- split(
      workingCodesWithRoute,
      workingCodesWithRoute[, c("route_category")]
    )

    if(length(workingCodesWithRoute) > 0){
    names(workingCodesWithRoute) <- paste0(workingName, "_",
                                           names(workingCodesWithRoute))
    }

    if(isFALSE(withDetails)){
    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()

  if(isTRUE(keepOriginal)){
    result <- purrr::list_flatten(list(x, result))
  }

  CDMConnector::dropTable(cdm = cdm, name = tableCodelist)

  result <- result[order(names(result))]

  if(isFALSE(withDetails)){
    result <- omopgenerics::newCodelist(result)
  } else{
    result <- omopgenerics::newCodelistWithDetails(result)
  }

  result

}