Merge pull request #116 from OHDSI/develop

Prep v2.1.1 release

Author: mdlavallee92

.github/workflows/R_CMD_check_Hades.yaml

@@ -22,7 +22,7 @@ jobs:
         config:
           - {os: windows-latest, r: 'release'}
           - {os: macOS-latest, r: 'release'}
-          - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
+          - {os: ubuntu-24.04, r: 'release'}
 
     env:
       GITHUB_PAT: ${{ secrets.GH_TOKEN }}
@@ -76,7 +76,7 @@ jobs:
           while read -r cmd
           do
             eval sudo $cmd
-          done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))')
+          done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "22.04"))')
 
       - uses: r-lib/actions/setup-r-dependencies@v2
         with:

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: Capr
 Title: Cohort Definition Application Programming
-Version: 2.1.0
+Version: 2.1.1
 Authors@R: c(
     person("Martin", "Lavallee", , "martin.lavallee@boehringer-ingelheim.com", role = c("aut", "cre")),
     person("Adam", "Black", , "black@ohdsi.org", role = c("aut")),

NAMESPACE

@@ -12,6 +12,7 @@ export(cohort)
 export(compile)
 export(conditionEra)
 export(conditionOccurrence)
+export(conditionSourceConcept)
 export(conditionStatus)
 export(conditionType)
 export(continuousObservation)
@@ -26,6 +27,7 @@ export(drugExit)
 export(drugExposure)
 export(drugQuantity)
 export(drugRefills)
+export(drugSourceConcept)
 export(drugType)
 export(duringInterval)
 export(endDate)
@@ -60,16 +62,20 @@ export(observation)
 export(observationExit)
 export(observationPeriod)
 export(observationPeriodType)
+export(observationSourceConcept)
 export(observationType)
 export(procedure)
+export(procedureSourceConcept)
 export(procedureType)
 export(rangeHigh)
 export(rangeLow)
 export(readConceptSet)
 export(startDate)
 export(toCirce)
+export(valueAsConcept)
 export(valueAsNumber)
 export(visit)
+export(visitSourceConcept)
 export(visitType)
 export(withAll)
 export(withAny)

NEWS.md

@@ -1,3 +1,10 @@
+Capr 2.1.1
+==========
+- add functions to include source concepts as attributes to a query
+- add demographic criteria for Inclusion rules
+- add value as concept attribute
+
+
 Capr 2.1.0
 ==========
 - add observation period query 

R/Capr.R

@@ -1,4 +1,4 @@
-# Copyright 2025 Observational Health Data Sciences and Informatics
+# Copyright 2026 Observational Health Data Sciences and Informatics
 #
 # This file is part of Capr
 #

R/attributes-concept.R

@@ -1,3 +1,27 @@
+# Concept Set Attribute class ----------------------------
+
+#' An S4 class for a concept set attribute that holds a reference to a concept set ID
+#' @slot
+#' name the name of the attribute
+#' @slot
+#' conceptSet a ConceptSet object that provides the ID reference
+#' @include conceptSet.R
+setClass("conceptSetAttribute",
+         slots = c(name = "character",
+                   conceptSet = "ConceptSet"),
+  prototype = list(name = NA_character_, conceptSet = new("ConceptSet")))
+
+setValidity("conceptSetAttribute", function(object) {
+  stopifnot(is.character(object@name), length(object@name) == 1)
+  TRUE
+})
+
+# Console Print ---------------
+
+setMethod("show", "conceptSetAttribute", function(object) {
+  cli::cat_bullet(paste("Capr Concept Set Attribute:", object@name, "- ID:", object@conceptSet@id), bullet = "sup_plus")
+})
+
 # Concept Attribute class ----------------------------
 
 #' An S4 class for a concept attribute
@@ -107,6 +131,23 @@ buildConceptAttribute <- function(ids, attributeName, connection, vocabularyData
   return(attr_concept)
 }
 
+
+#' Add a value as concept attribute
+#' @param ids the concept ids for the attribute
+#' @param connection a connection to an OMOP dbms to get vocab info about the concept
+#' @param vocabularyDatabaseSchema the database schema for the vocabularies
+#' @return
+#' An attribute that can be used in a query function
+#' @export
+#'
+valueAsConcept <- function(ids, connection, vocabularyDatabaseSchema) {
+  res <- buildConceptAttribute(ids = ids, attributeName = "ValueAsConcept",
+                               connection = connection,
+                               vocabularyDatabaseSchema = vocabularyDatabaseSchema)
+  return(res)
+}
+
+
 #' Add a drug type attribute to determine the provenance of the record
 #' @param ids the concept ids for the attribute
 #' @param connection a connection to an OMOP dbms to get vocab info about the concept
@@ -217,6 +258,94 @@ conditionStatus <- function(ids, connection, vocabularyDatabaseSchema) {
   return(res)
 }
 
+#' Add a condition source concept attribute
+#' @param conceptSet a ConceptSet object containing the source concepts
+#' @return
+#' An attribute that can be used in a query function
+#' @export
+#'
+conditionSourceConcept <- function(conceptSet) {
+  if (!methods::is(conceptSet, "ConceptSet")) {
+    rlang::abort("conditionSourceConcept requires a ConceptSet object")
+  }
+
+  res <- methods::new("conceptSetAttribute",
+                      name = "ConditionSourceConcept",
+                      conceptSet = conceptSet)
+  return(res)
+}
+
+#' Add a drug source concept attribute
+#' @param conceptSet a ConceptSet object containing the source concepts
+#' @return
+#' An attribute that can be used in a query function
+#' @export
+#'
+drugSourceConcept <- function(conceptSet) {
+  if (!methods::is(conceptSet, "ConceptSet")) {
+    rlang::abort("drugSourceConcept requires a ConceptSet object")
+  }
+
+  res <- methods::new("conceptSetAttribute",
+                      name = "DrugSourceConcept",
+                      conceptSet = conceptSet)
+  return(res)
+}
+
+
+#' Add a procedure source concept attribute
+#' @param conceptSet a ConceptSet object containing the source concepts
+#' @return
+#' An attribute that can be used in a query function
+#' @export
+#'
+procedureSourceConcept <- function(conceptSet) {
+  if (!methods::is(conceptSet, "ConceptSet")) {
+    rlang::abort("procedureSourceConcept requires a ConceptSet object")
+  }
+
+  res <- methods::new("conceptSetAttribute",
+                      name = "ProcedureSourceConcept",
+                      conceptSet = conceptSet)
+  return(res)
+}
+
+
+
+#' Add a observation source concept attribute
+#' @param conceptSet a ConceptSet object containing the source concepts
+#' @return
+#' An attribute that can be used in a query function
+#' @export
+#'
+observationSourceConcept <- function(conceptSet) {
+  if (!methods::is(conceptSet, "ConceptSet")) {
+    rlang::abort("observationSourceConcept requires a ConceptSet object")
+  }
+
+  res <- methods::new("conceptSetAttribute",
+                      name = "ObservationSourceConcept",
+                      conceptSet = conceptSet)
+  return(res)
+}
+
+#' Add a visit source concept attribute
+#' @param conceptSet a ConceptSet object containing the source concepts
+#' @return
+#' An attribute that can be used in a query function
+#' @export
+#'
+visitSourceConcept <- function(conceptSet) {
+  if (!methods::is(conceptSet, "ConceptSet")) {
+    rlang::abort("visitSourceConcept requires a ConceptSet object")
+  }
+
+  res <- methods::new("conceptSetAttribute",
+                      name = "VisitSourceConcept",
+                      conceptSet = conceptSet)
+  return(res)
+}
+
 #' Add a observation period type attribute to determine the provenance of the record
 #' @param ids the concept ids for the attribute
 #' @param connection a connection to an OMOP dbms to get vocab info about the concept
@@ -281,6 +410,11 @@ measurementUnit <- function(x) {
 
 # Coercion ------------------
 
+setMethod("as.list", "conceptSetAttribute", function(x) {
+  nm <- x@name
+  tibble::lst(`:=`(!!nm, x@conceptSet@id))
+})
+
 setMethod("as.list", "conceptAttribute", function(x) {
 
   concepts <- purrr::map(x@conceptSet, ~as.list(.x))

R/collectCodesetId.R

@@ -15,6 +15,17 @@ replaceGuid <- function(x, y) {
 
 setGeneric("collectGuid", function(x) standardGeneric("collectGuid"))
 
+setMethod("collectGuid", "conceptSetAttribute", function(x) {
+  getGuid(x)
+})
+
+setMethod("collectGuid", "conceptAttribute", function(x) {
+  return(NULL)
+})
+
+setMethod("collectGuid", "opAttributeSuper", function(x) {
+  return(NULL)
+})
 
 # setMethod("collectGuid", "Query", function(x) {
 #   getGuid(x)
@@ -37,6 +48,14 @@ setMethod("collectGuid", "Query", function(x) {
 
     ids <- dplyr::bind_rows(ids, id2)
   }
+  
+  # collect guids for conceptSetAttribute objects
+  conceptSetAttrs <- purrr::keep(x@attributes, ~methods::is(.x, "conceptSetAttribute"))
+  if (length(conceptSetAttrs) > 0) {
+    conceptSetIds <- purrr::map_dfr(conceptSetAttrs, ~collectGuid(.x))
+    ids <- dplyr::bind_rows(ids, conceptSetIds)
+  }
+  
   return(ids)
 
 })
@@ -99,6 +118,29 @@ setMethod("collectGuid", "Cohort", function(x) {
 ## TODO HASH table implementation of find/replace
 setGeneric("replaceCodesetId", function(x, guidTable) standardGeneric("replaceCodesetId"))
 
+setMethod("replaceCodesetId", "conceptSetAttribute", function(x, guidTable) {
+  
+  if (nrow(getGuid(x)) > 0) {
+    y <- getGuid(x) |>
+      dplyr::inner_join(guidTable, by = c("guid")) |>
+      dplyr::pull(.data$codesetId)
+  } else {
+    y <- NULL
+  }
+  
+  x <- replaceGuid(x, y)
+  
+  return(x)
+})
+
+setMethod("replaceCodesetId", "conceptAttribute", function(x, guidTable) {
+  return(x)
+})
+
+setMethod("replaceCodesetId", "opAttributeSuper", function(x, guidTable) {
+  return(x)
+})
+
 
 setMethod("replaceCodesetId", "Query", function(x, guidTable) {
 
@@ -122,6 +164,14 @@ setMethod("replaceCodesetId", "Query", function(x, guidTable) {
 
     x@attributes[[ii]]@group <- nest
   }
+  
+  # replace codeset ids for conceptSetAttribute objects
+  conceptSetAttrIndices <- which(purrr::map_lgl(x@attributes, ~methods::is(.x, "conceptSetAttribute")))
+  if (length(conceptSetAttrIndices) > 0) {
+    for (i in conceptSetAttrIndices) {
+      x@attributes[[i]] <- replaceCodesetId(x@attributes[[i]], guidTable)
+    }
+  }
 
   return(x)
 })
@@ -204,6 +254,19 @@ setMethod("replaceCodesetId", "Cohort", function(x, guidTable = guidTable) {
 
 setGeneric("listConceptSets", function(x) standardGeneric("listConceptSets"))
 
+setMethod("listConceptSets", "conceptSetAttribute", function(x) {
+  as.list(x@conceptSet)
+})
+
+setMethod("listConceptSets", "conceptAttribute", function(x) {
+  return(NULL)
+})
+
+setMethod("listConceptSets", "opAttributeSuper", function(x) {
+  return(NULL)
+})
+
+
 #' @include query.R
 setMethod("listConceptSets", "Query", function(x) {
   qs <- as.list(x@conceptSet)
@@ -219,6 +282,13 @@ setMethod("listConceptSets", "Query", function(x) {
   } else {
     out <- list(qs)
   }
+  
+  # handle listing concept sets from conceptSetAttribute objects
+  conceptSetAttrs <- purrr::keep(x@attributes, ~methods::is(.x, "conceptSetAttribute"))
+  if (length(conceptSetAttrs) > 0) {
+    conceptSetsFromAttrs <- purrr::map(conceptSetAttrs, ~listConceptSets(.x))
+    out <- c(out, conceptSetsFromAttrs)
+  }
 
   return(out)
 })

R/conceptSet.R

@@ -114,10 +114,7 @@ setClass("ConceptSet",
                    Expression = "list"))
 
 setValidity("ConceptSet", function(object) {
-  stopifnot(is.character(object@id),
-            length(object@id) == 1,
-            #is.character(object@id),
-            length(object@id) == 1,
+  stopifnot(length(object@id) == 1,
             is.list(object@Expression),
             all(purrr::map_lgl(object@Expression, ~is(., "ConceptSetItem")))
             )

R/criteria.R

@@ -60,11 +60,11 @@ setClass("Group",
 
 # Class Type ----
 is.Criteria <- function(x) {
-  methods::is(x) == "Criteria"
+  any(methods::is(x) == "Criteria")
 }
 
 is.Group <- function(x) {
-  methods::is(x) == "Group"
+  any(methods::is(x) == "Group")
 }
 
 # Constructors -----------------------