Change summariseTableCount() name to summariseRecordCounts()

NAMESPACE

@@ -6,7 +6,7 @@ export(summariseEntryCharacteristics)
 export(summariseObservationPeriod)
 export(summariseOmopTable)
 export(summarisePersonDays)
-export(summariseTableCounts)
+export(summariseRecordCount)
 export(suppress)
 export(tableOmopTable)
 importFrom(magrittr,"%>%")

R/checks.R

@@ -0,0 +1,121 @@
+#' @noRd
+checkAgeGroup <- function(ageGroup, overlap = FALSE) {
+  checkmate::assertList(ageGroup, min.len = 1, null.ok = TRUE)
+  if (!is.null(ageGroup)) {
+    if (is.numeric(ageGroup[[1]])) {
+      ageGroup <- list("age_group" = ageGroup)
+    }
+    for (k in seq_along(ageGroup)) {
+      invisible(checkCategory(ageGroup[[k]], overlap))
+      if (any(ageGroup[[k]] |> unlist() |> unique() < 0)) {
+        cli::cli_abort("ageGroup can't contain negative values")
+      }
+    }
+    if (is.null(names(ageGroup))) {
+      names(ageGroup) <- paste0("age_group_", 1:length(ageGroup))
+    }
+    if ("" %in% names(ageGroup)) {
+      id <- which(names(ageGroup) == "")
+      names(ageGroup)[id] <- paste0("age_group_", id)
+    }
+  }
+  return(invisible(ageGroup))
+}
+
+#' @noRd
+checkOmopTable <- function(omopTable){
+  assertClass(omopTable, "omop_table")
+  omopTable |>
+    omopgenerics::tableName() |>
+    assertChoice(choices = tables$table_name)
+}
+
+#' @noRd
+checkUnit <- function(unit){
+  inherits(unit, "character")
+  assertLength(unit, 1)
+  if(!unit %in% c("year","month")){
+    cli::cli_abort("units value is not valid. Valid options are year or month.")
+  }
+}
+
+#' @noRd
+checkUnitInterval <- function(unitInterval){
+  inherits(unitInterval, c("numeric", "integer"))
+  assertLength(unitInterval, 1)
+  if(unitInterval < 1){
+    cli::cli_abort("unitInterval input has to be equal or greater than 1.")
+  }
+  if(!(unitInterval%%1 == 0)){
+    cli::cli_abort("unitInterval has to be an integer.")
+  }
+}
+
+
+#' @noRd
+checkCategory <- function(category, overlap = FALSE, type = "numeric") {
+  checkmate::assertList(
+    category,
+    types = type, any.missing = FALSE, unique = TRUE,
+    min.len = 1
+  )
+
+  if (is.null(names(category))) {
+    names(category) <- rep("", length(category))
+  }
+
+  # check length
+  category <- lapply(category, function(x) {
+    if (length(x) == 1) {
+      x <- c(x, x)
+    } else if (length(x) > 2) {
+      cli::cli_abort(
+        paste0(
+          "Categories should be formed by a lower bound and an upper bound, ",
+          "no more than two elements should be provided."
+        ),
+        call. = FALSE
+      )
+    }
+    invisible(x)
+  })
+
+  # check lower bound is smaller than upper bound
+  checkLower <- unlist(lapply(category, function(x) {
+    x[1] <= x[2]
+  }))
+  if (!(all(checkLower))) {
+    cli::cli_abort("Lower bound should be equal or smaller than upper bound")
+  }
+
+  # built tibble
+  result <- lapply(category, function(x) {
+    dplyr::tibble(lower_bound = x[1], upper_bound = x[2])
+  }) |>
+    dplyr::bind_rows() |>
+    dplyr::mutate(category_label = names(.env$category)) |>
+    dplyr::mutate(category_label = dplyr::if_else(
+      .data$category_label == "",
+      dplyr::case_when(
+        is.infinite(.data$lower_bound) & is.infinite(.data$upper_bound) ~ "any",
+        is.infinite(.data$lower_bound) ~ paste(.data$upper_bound, "or below"),
+        is.infinite(.data$upper_bound) ~ paste(.data$lower_bound, "or above"),
+        TRUE ~ paste(.data$lower_bound, "to", .data$upper_bound)
+      ),
+      .data$category_label
+    )) |>
+    dplyr::arrange(.data$lower_bound)
+
+  # check overlap
+  if (!overlap) {
+    if (nrow(result) > 1) {
+      lower <- result$lower_bound[2:nrow(result)]
+      upper <- result$upper_bound[1:(nrow(result) - 1)]
+      if (!all(lower > upper)) {
+        cli::cli_abort("There can not be overlap between categories")
+      }
+    }
+  }
+
+  invisible(result)
+}

R/plotObservationPeriod.R

@@ -29,7 +29,8 @@ plotObservationPeriod <- function(summarisedObservationPeriod){
     ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, vjust = 0.5, hjust=1)) +
     ggplot2::xlab("Time interval") +
     ggplot2::ylab("Individuals in observation") +
-    ggplot2::labs(color = "CDM table")
+    ggplot2::labs(color = "CDM table") +
+    ggplot2::theme_bw()
 
 }
 

R/plotTableCounts.R

@@ -30,5 +30,6 @@ plotTableCounts <- function(summarisedTableCounts) {
     ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, vjust = 0.5, hjust=1)) +
     ggplot2::xlab("Time") +
     ggplot2::ylab("Counts") +
-    ggplot2::labs(color = "Omop table")
+    ggplot2::labs(color = "Omop table") +
+    ggplot2::theme_bw()
 }

R/summariseObservationPeriod.R

@@ -32,8 +32,8 @@ summariseObservationPeriod <- function(observationPeriod, unit = "year", unitInt
   if(missing(unit)){unit <- "year"}
   if(missing(unitInterval)){unitInterval <- 1}
 
-  unitChecks(unit)
-  unitIntervalChecks(unitInterval)
+  checkUnit(unit)
+  checkUnitInterval(unitInterval)
 
   cdm <- omopgenerics::cdmReference(observationPeriod)
 
@@ -70,7 +70,7 @@ summariseObservationPeriod <- function(observationPeriod, unit = "year", unitInt
       "cdm_name" = omopgenerics::cdmName(omopgenerics::cdmReference(observationPeriod)),
       "group_name"  = "omop_table",
       "group_level" = name,
-      "variable_level" = gsub(" to.*","",strata_level),
+      "variable_level" = gsub(" to.*","",.data$strata_level),
       "estimate_name" = "count",
       "estimate_type" = "integer",
       "additional_name" = "overall",

R/summariseOmopTable.R

@@ -299,7 +299,7 @@ addVariables <- function(x, variables) {
 
   x <- x |>
     dplyr::select(dplyr::all_of(variables)) |>
-    dplyr::mutate(across(everything(), ~as.character(.)))
+    dplyr::mutate(dplyr::across(dplyr::everything(), ~as.character(.)))
 
   return(x)
 }

R/summariseTableCounts.R → R/summariseRecordCounts.R

@@ -3,22 +3,24 @@
 #' @param omopTable A summarised_result object with the output from summariseOmopTable().
 #' @param unit Whether to stratify by "year" or by "month"
 #' @param unitInterval Number of years or months to stratify with
+#' @param ageGroup A list of age groups to stratify results by.
 #'
 #' @return A summarised_result object with the summarised data.
 #'
 #' @importFrom rlang :=
 #' @export
 #'
-summariseTableCounts<- function(omopTable, unit = "year", unitInterval = 1) {
+summariseRecordCount <- function(omopTable, unit = "year", unitInterval = 1, ageGroup = NULL) {
 
   # Initial checks ----
-  omopTableChecks(omopTable)
+  checkOmopTable(omopTable)
 
   if(missing(unit)){unit <- "year"}
   if(missing(unitInterval)){unitInterval <- 1}
 
-  unitChecks(unit)
-  unitIntervalChecks(unitInterval)
+  checkUnit(unit)
+  checkUnitInterval(unitInterval)
+  checkAgeGroup(ageGroup)
 
   cdm <- omopgenerics::cdmReference(omopTable)
   omopTable <- omopTable |> dplyr::ungroup()
@@ -32,9 +34,15 @@ summariseTableCounts<- function(omopTable, unit = "year", unitInterval = 1) {
     return(result)
   }
 
+  # Create strata variable ----
+  strata <- dplyr::if_else(is.null(ageGroup), NA, "age_group")
+  if(is.na(strata)){strata <- NULL}
+
   # Incidence counts ----
   omopTable <- omopTable |>
-    dplyr::select(dplyr::all_of(date), "person_id")
+    dplyr::select(dplyr::all_of(date), "person_id") |>
+    PatientProfiles::addAgeQuery(indexDate = date, ageGroup = ageGroup) |>
+    dplyr::select(-c("age"))
 
   if (name != "observation_period") {
     omopTable <- omopTable |>
@@ -52,31 +60,46 @@ summariseTableCounts<- function(omopTable, unit = "year", unitInterval = 1) {
   result <- cdm$interval |>
     dplyr::cross_join(
       omopTable |>
-        dplyr::rename("incidence_date" = dplyr::all_of(date))) |>
+        dplyr::rename("incidence_date" = dplyr::all_of(date))
+      ) |>
     dplyr::filter(.data$incidence_date >= .data$interval_start_date &
                     .data$incidence_date <= .data$interval_end_date) |>
-    dplyr::group_by(.data$interval_group)  |>
+    dplyr::group_by(.data$interval_group, dplyr::across(dplyr::all_of(strata))) |>
     dplyr::summarise("estimate_value" = dplyr::n(), .groups = "drop") |>
     dplyr::collect() |>
     dplyr::ungroup()
 
+  if(!is.null(strata)){
+    result <- result |>
+      rbind(
+        result |>
+          dplyr::group_by(.data$interval_group) |>
+          dplyr::summarise(estimate_value = sum(.data$estimate_value), .groups = "drop") |>
+          dplyr::mutate(age_group = "overall")
+      ) |>
+      dplyr::rename() |>
+      dplyr::mutate()
+  }else{
+    result <- result |>
+      dplyr::mutate("age_group" = "overall")
+  }
+
   result <- result |>
     dplyr::mutate(
       "estimate_value" = as.character(.data$estimate_value),
       "variable_name" = "incidence_records",
     ) |>
-    dplyr::rename("time_interval" = "interval_group") |>
-    visOmopResults::uniteStrata(cols = "time_interval") |>
+    dplyr::rename("variable_level" = "interval_group") |>
+    visOmopResults::uniteStrata(cols = "age_group") |>
     dplyr::mutate(
       "result_id" = as.integer(1),
       "cdm_name" = omopgenerics::cdmName(omopgenerics::cdmReference(omopTable)),
       "group_name"  = "omop_table",
       "group_level" = name,
-      "variable_level" = gsub(" to.*","",strata_level),
       "estimate_name" = "count",
       "estimate_type" = "integer",
-      "additional_name" = "overall",
-      "additional_level" = "overall"
+      "additional_name" = "time_interval",
+      "additional_level" = gsub(" to.*","",.data$variable_level)
     ) |>
     omopgenerics::newSummarisedResult(settings = dplyr::tibble(
       "result_id" = 1L,
@@ -92,33 +115,8 @@ summariseTableCounts<- function(omopTable, unit = "year", unitInterval = 1) {
   return(result)
 }
 
-omopTableChecks <- function(omopTable){
-  assertClass(omopTable, "omop_table")
-  omopTable |>
-    omopgenerics::tableName() |>
-    assertChoice(choices = tables$table_name)
-}
-
-unitChecks <- function(unit){
-  inherits(unit, "character")
-  assertLength(unit, 1)
-  if(!unit %in% c("year","month")){
-    cli::cli_abort("units value is not valid. Valid options are year or month.")
-  }
-}
-
-unitIntervalChecks <- function(unitInterval){
-  inherits(unitInterval, c("numeric", "integer"))
-  assertLength(unitInterval, 1)
-  if(unitInterval < 1){
-    cli::cli_abort("unitInterval input has to be equal or greater than 1.")
-  }
-  if(!(unitInterval%%1 == 0)){
-    cli::cli_abort("unitInterval has to be an integer.")
-  }
-}
 
-filterInObservation <- function(x, indexDate) {
+filterInObservation <- function(x, indexDate){
   cdm <- omopgenerics::cdmReference(x)
   id <- c("person_id", "subject_id")
   id <- id[id %in% colnames(x)]

tests/testthat/test-summariseOmopTable.R

@@ -76,4 +76,3 @@ test_that("tableOmopTable() works", {
 
 })
 
-