Merge remote-tracking branch 'origin/main' into ggplot_suggests

OHDSI · Nov 21, 2024 · 50bf377 · 50bf377
2 parents aa9febe + ca04b0c
commit 50bf377
Show file tree

Hide file tree

Showing 25 changed files with 471 additions and 87 deletions.
diff --git a/R/checks.R b/R/checks.R
@@ -120,7 +120,7 @@ checkCountBy <- function(countBy, call = parent.frame()){
 #' @noRd
 validateStudyPeriod <- function(cdm, studyPeriod, call = parent.frame()) {
   if(is.null(studyPeriod)) {
-    studyPeriod <- c(NA,NA)
+    return(NULL)
   }
   # First date checks
   if(!is.na(studyPeriod[1]) & !is.na(studyPeriod[2]) & studyPeriod[1] > studyPeriod[2]) {
@@ -166,7 +166,7 @@ validateStudyPeriod <- function(cdm, studyPeriod, call = parent.frame()) {
                               dplyr::pull("maxobs")))
     }
     if(studyPeriod[2] > clock::date_today(zone = "GMT")) {
-      cli::cli_alert(paste0("The observation period in the cdm ends after current date."))
+      cli::cli_alert(paste0("The given date range ends after current date."))
     }
   }
 

diff --git a/R/restrictStudyPeriod.R b/R/restrictStudyPeriod.R
@@ -0,0 +1,33 @@
+restrictStudyPeriod <- function(omopTable, dateRange){
+
+
+  if(is.null(dateRange)){
+
+    return(omopTable)
+  }
+
+  start_date_table <- startDate(omopgenerics::tableName(omopTable))
+  end_date_table <- endDate(omopgenerics::tableName(omopTable))
+  start_date <- dateRange[1]
+  end_date <-dateRange[2]
+
+  omopTable <- omopTable |>
+    dplyr::filter(
+      (.data[[start_date_table]]>= .env$start_date & .data[[start_date_table]] <= .env$end_date) &
+        (.data[[end_date_table]] >= .env$start_date & .data[[end_date_table]] <= .env$end_date)
+    )
+  # maybe the end date check is not needed
+
+  warningEmptyStudyPeriod(omopTable)
+
+
+  return(omopTable)
+}
+
+warningEmptyStudyPeriod <- function (omopTable) {
+  if (omopgenerics::isTableEmpty(omopTable)){
+    cli::cli_warn(paste0(omopgenerics::tableName(omopTable), " omop table is empty after application of date range."))
+    return(invisible(NULL))
+  }
+  return(invisible(TRUE))
+}
diff --git a/R/summariseAllConceptCounts.R b/R/summariseAllConceptCounts.R
@@ -39,6 +39,8 @@ checkFeasibility <- function(omopTable, tableName, conceptId){
   return(TRUE)
 }
 
+
+
 #' Summarise concept use in patient-level data
 #'
 #' @param cdm A cdm object
@@ -50,6 +52,8 @@ checkFeasibility <- function(omopTable, tableName, conceptId){
 #' @param sex TRUE or FALSE. If TRUE code use will be summarised by sex.
 #' @param ageGroup A list of ageGroup vectors of length two. Code use will be
 #' thus summarised by age groups.
+#' @param dateRange A list containing the minimum and the maximum dates
+#' defining the time range within which the analysis is performed.
 #' @return A summarised_result object with results overall and, if specified, by
 #' strata.
 #' @export
@@ -58,7 +62,8 @@ summariseAllConceptCounts <- function(cdm,
                             countBy = "record",
                             year = FALSE,
                             sex = FALSE,
-                            ageGroup = NULL){
+                            ageGroup = NULL,
+                            dateRange = NULL){
 
   omopgenerics::validateCdmArgument(cdm)
   checkCountBy(countBy)
@@ -67,7 +72,7 @@ summariseAllConceptCounts <- function(cdm,
   omopgenerics::assertChoice(omopTableName,choices = omopgenerics::omopTables(), unique = TRUE)
 
   ageGroup <- omopgenerics::validateAgeGroupArgument(ageGroup, ageGroupName = "")[[1]]
-
+  dateRange <- validateStudyPeriod(cdm, dateRange)
   strata <- my_getStrataList(sex = sex, year = year, ageGroup = ageGroup)
 
   stratification <- omopgenerics::combineStrata(strata)
@@ -87,6 +92,8 @@ summariseAllConceptCounts <- function(cdm,
     return(NULL)
   }
 
+  omopTable <- restrictStudyPeriod(omopTable, dateRange)
+
 
   indexDate <- startDate(omopgenerics::tableName(omopTable))
 
@@ -103,6 +110,7 @@ summariseAllConceptCounts <- function(cdm,
     x <- x|> dplyr::mutate(year = as.character(clock::get_year(.data[[indexDate]])))
   }
 
+
   level <- c(conceptId, "concept_name")
 
   groupings <- c(list(level), purrr::map(stratification, ~ c(level, .x)))
@@ -172,14 +180,8 @@ summariseAllConceptCounts <- function(cdm,
   #   dplyr::select(!c())
 
 
-  settings <- dplyr::tibble(
-    result_id = unique(sr$result_id),
-    package_name = "omopSketch",
-    package_version = as.character(utils::packageVersion("OmopSketch")),
-    result_type = "summarise_all_concept_counts"
-  )
   sr <- sr |>
-    omopgenerics::newSummarisedResult(settings = settings)
+    omopgenerics::newSummarisedResult(settings = createSettings(result_type = "summarise_all_concept_counts", study_period = dateRange))
 
   return(sr)
 

diff --git a/R/summariseClinicalRecords.R b/R/summariseClinicalRecords.R
@@ -22,6 +22,8 @@
 #' @param ageGroup A list of age groups to stratify results by.
 #' @param sex Boolean variable. Whether to stratify by sex (TRUE) or not
 #' (FALSE).
+#' @param dateRange A list containing the minimum and the maximum dates
+#' defining the time range within which the analysis is performed.
 #' @return A summarised_result object.
 #' @export
 #' @examples
@@ -52,13 +54,14 @@ summariseClinicalRecords <- function(cdm,
                                      domainId = TRUE,
                                      typeConcept = TRUE,
                                      sex = FALSE,
-                                     ageGroup = NULL) {
+                                     ageGroup = NULL,
+                                     dateRange = NULL) {
   # Initial checks ----
   omopgenerics::validateCdmArgument(cdm)
   opts <- omopgenerics::omopTables()
   opts <- opts[opts %in% names(cdm)]
   omopgenerics::assertChoice(omopTableName, choices = opts)
-
+  dateRange <- validateStudyPeriod(cdm, dateRange)
   estimates <- PatientProfiles::availableEstimates(
     variableType = "numeric", fullQuantiles = TRUE) |>
     dplyr::pull("estimate_name")
@@ -89,7 +92,8 @@ summariseClinicalRecords <- function(cdm,
       domainId = domainId,
       typeConcept = typeConcept,
       sex = sex,
-      ageGroup = ageGroup
+      ageGroup = ageGroup,
+      dateRange = dateRange
     )
   }) |>
     omopgenerics::bind()
@@ -108,6 +112,7 @@ summariseClinicalRecord <- function(omopTableName,
                                     typeConcept,
                                     sex,
                                     ageGroup,
+                                    dateRange,
                                     call = parent.frame(3)) {
 
   tablePrefix <-  omopgenerics::tmpPrefix()
@@ -120,6 +125,11 @@ summariseClinicalRecord <- function(omopTableName,
   omopTable <- cdm[[omopTableName]] |>
     dplyr::ungroup()
 
+  omopTable <- restrictStudyPeriod(omopTable, dateRange)
+  if(omopgenerics::isTableEmpty(omopTable)) {
+    return(omopgenerics::emptySummarisedResult())
+  }
+
   omopTable <- filterPersonId(omopTable) |>
     addStrataToOmopTable(date, ageGroup, sex)
 
@@ -176,6 +186,7 @@ summariseClinicalRecord <- function(omopTableName,
       )
   }
 
+
   # Format output as a summarised result
   result <- result |>
     dplyr::mutate(
@@ -186,12 +197,8 @@ summariseClinicalRecord <- function(omopTableName,
       "additional_name" = "overall",
       "additional_level" = "overall"
     ) |>
-    omopgenerics::newSummarisedResult(settings = dplyr::tibble(
-      "result_id" = 1L,
-      "result_type" = "summarise_clinical_records",
-      "package_name" = "OmopSketch",
-      "package_version" = as.character(utils::packageVersion("OmopSketch"))
-    ))
+    omopgenerics::newSummarisedResult(settings = createSettings(result_type = "summarise_clinical_records", study_period = dateRange)
+    )
 
   CDMConnector::dropTable(cdm, name = dplyr::starts_with(tablePrefix))
 

diff --git a/R/summariseConceptCounts.R b/R/summariseConceptCounts.R
@@ -10,6 +10,8 @@
 #' @param sex TRUE or FALSE. If TRUE code use will be summarised by sex.
 #' @param ageGroup A list of ageGroup vectors of length two. Code use will be
 #' thus summarised by age groups.
+#' @param dateRange A list containing the minimum and the maximum dates
+#' defining the time range within which the analysis is performed.
 #' @return A summarised_result object with results overall and, if specified, by
 #' strata.
 #' @export
@@ -34,7 +36,8 @@ summariseConceptCounts <- function(cdm,
                                    concept = TRUE,
                                    interval = "overall",
                                    sex = FALSE,
-                                   ageGroup = NULL){
+                                   ageGroup = NULL,
+                                   dateRange = NULL){
 
   omopgenerics::validateCdmArgument(cdm)
   omopgenerics::assertList(conceptId, named = TRUE)
@@ -48,7 +51,7 @@ summariseConceptCounts <- function(cdm,
   omopgenerics::assertLogical(concept, length = 1)
   omopgenerics::assertLogical(sex, length = 1)
   ageGroup <- omopgenerics::validateAgeGroupArgument(ageGroup, ageGroupName = "")[[1]]
-
+  dateRange <- validateStudyPeriod(cdm, dateRange)
   # Get all concepts in concept table if conceptId is NULL
   # if(is.null(conceptId)) {
   #   conceptId <- cdm$concept |>
@@ -70,7 +73,8 @@ summariseConceptCounts <- function(cdm,
                                interval = interval,
                                unitInterval = unitInterval,
                                sex = sex,
-                               ageGroup = ageGroup)
+                               ageGroup = ageGroup,
+                               dateRange = dateRange)
     Sys.sleep(i/length(conceptId))
     cli::cli_progress_update()
   }
@@ -90,12 +94,7 @@ summariseConceptCounts <- function(cdm,
 
   codeUse <- codeUse %>%
     omopgenerics::newSummarisedResult(
-      settings = dplyr::tibble(
-        result_id = 1L,
-        result_type = "summarise_concept_counts",
-        package_name = "OmopSketch",
-        package_version = as.character(utils::packageVersion("OmopSketch"))
-      )
+createSettings(result_type = "summarise_concept_counts", study_period = dateRange)
     )
   return(codeUse)
 }
@@ -108,6 +107,7 @@ getCodeUse <- function(x,
                        unitInterval,
                        sex,
                        ageGroup,
+                       dateRange,
                        call = parent.frame()){
 
   tablePrefix <-  omopgenerics::tmpPrefix()
@@ -159,9 +159,22 @@ getCodeUse <- function(x,
     return(omopgenerics::emptySummarisedResult())
   }
 
+  if (!is.null(dateRange))
+  {
+  records <- records |>
+    dplyr::filter(
+      as.Date(date) >= !!dateRange[1]& as.Date(date) <= !!dateRange[2]
+    )
+  if (is.null(warningEmptyStudyPeriod(records))){
+     return(tibble::tibble())
+  }
+
+  }
   records <- addStrataToOmopTable(records, "date", ageGroup, sex)
   strata  <- getStrataList(sex, ageGroup)
 
+
+
   if(interval != "overall"){
     intervalTibble <- getIntervalTibble(omopTable = records,
                                         start_date_name = "date",

diff --git a/R/summariseInObservation.R b/R/summariseInObservation.R
@@ -10,6 +10,8 @@
 #' @param ageGroup A list of age groups to stratify results by.
 #' @param sex Boolean variable. Whether to stratify by sex (TRUE) or not
 #' (FALSE).
+#' @param dateRange A list containing the minimum and the maximum dates
+#' defining the time range within which the analysis is performed.
 #' @return A summarised_result object.
 #' @export
 #' @examples
@@ -36,13 +38,14 @@ summariseInObservation <- function(observationPeriod,
                                    interval = "overall",
                                    output = "records",
                                    ageGroup = NULL,
-                                   sex = FALSE){
+                                   sex = FALSE, dateRange = NULL){
 
   tablePrefix <-  omopgenerics::tmpPrefix()
 
   # Initial checks ----
   omopgenerics::assertClass(observationPeriod, "omop_table")
   omopgenerics::assertTrue(omopgenerics::tableName(observationPeriod) == "observation_period")
+  dateRange <- validateStudyPeriod(omopgenerics::cdmReference(observationPeriod), dateRange)
 
   if(omopgenerics::isTableEmpty(observationPeriod)){
     cli::cli_warn("observation_period table is empty. Returning an empty summarised result.")
@@ -62,7 +65,7 @@ summariseInObservation <- function(observationPeriod,
 
   # Create initial variables ----
   cdm <- omopgenerics::cdmReference(observationPeriod)
-  observationPeriod <- addStrataToPeopleInObservation(cdm, ageGroup, sex, tablePrefix)
+  observationPeriod <- addStrataToPeopleInObservation(cdm, ageGroup, sex, tablePrefix, dateRange)
   strata <- getStrataList(sex, ageGroup)
 
   # Calculate denominator ----
@@ -89,7 +92,7 @@ summariseInObservation <- function(observationPeriod,
   result <- addSexOverall(result, sex)
 
   # Create summarisedResult
-  result <- createSummarisedResultObservationPeriod(result, observationPeriod, name, denominator, original_interval)
+  result <- createSummarisedResultObservationPeriod(result, observationPeriod, name, denominator,dateRange, original_interval)
 
   CDMConnector::dropTable(cdm, name = dplyr::starts_with(tablePrefix))
   return(result)
@@ -244,7 +247,12 @@ if(output == "records" | output == "all"){
   return(x)
 }
 
-createSummarisedResultObservationPeriod <- function(result, observationPeriod, name, denominator, original_interval){
+createSummarisedResultObservationPeriod <- function(result, observationPeriod, name, denominator, dateRange,original_interval){
+  if (dim(result)[1] == 0) {
+    result<-omopgenerics::emptySummarisedResult() |>
+      omopgenerics::newSummarisedResult(settings = createSettings(result_type = "summarise_in_observation", study_period = dateRange)|>
+                                          dplyr::mutate("interval" = .env$original_interval))
+  }else{
   result <- result |>
     dplyr::mutate("estimate_value" = as.character(.data$estimate_value)) |>
     visOmopResults::uniteStrata(cols = c("sex", "age_group")) |>
@@ -266,18 +274,14 @@ createSummarisedResultObservationPeriod <- function(result, observationPeriod, n
     dplyr::mutate(estimate_value = dplyr::if_else(.data$estimate_type == "percentage", as.character(as.numeric(.data$estimate_value)/denominator*100), .data$estimate_value)) |>
     dplyr::select(-c("denominator")) |>
     dplyr::mutate(estimate_name = dplyr::if_else(.data$estimate_type == "percentage", "percentage", .data$estimate_name)) |>
-    omopgenerics::newSummarisedResult(settings = dplyr::tibble(
-      "result_id" = 1L,
-      "result_type" = "summarise_in_observation",
-      "package_name" = "OmopSketch",
-      "package_version" = as.character(utils::packageVersion("OmopSketch")),
-      "interval" = .env$original_interval
-    ))
-
+    omopgenerics::newSummarisedResult(settings = createSettings(result_type = "summarise_in_observation", study_period = dateRange)|>
+                                        dplyr::mutate("interval" = .env$original_interval)
+    )
+}
   return(result)
 }
 
-addStrataToPeopleInObservation <- function(cdm, ageGroup, sex, tablePrefix) {
+addStrataToPeopleInObservation <- function(cdm, ageGroup, sex, tablePrefix, dateRange) {
   demographics <- cdm |>
     CohortConstructor::demographicsCohort(
       name = paste0(tablePrefix, "demographics_table"),
@@ -287,6 +291,11 @@ addStrataToPeopleInObservation <- function(cdm, ageGroup, sex, tablePrefix) {
     ) |>
     suppressMessages()
 
+  if (!is.null(dateRange)) {
+    demographics <- demographics |>
+      CohortConstructor::requireInDateRange(dateRange = dateRange)
+    warningEmptyStudyPeriod(demographics)
+  }
   if (sex) {
     demographics <- demographics |>
       PatientProfiles::addSexQuery()