Merge pull request #14 from oxford-pharmacoepi/mah_tableOmopTable()

TableOmopTable() release

DESCRIPTION

@@ -22,6 +22,7 @@ Imports:
     cli,
     CohortCharacteristics,
     dplyr,
+    gt,
     IncidencePrevalence (>= 0.7.0),
     lubridate,
     magrittr,

NAMESPACE

@@ -4,6 +4,7 @@ export(summariseEntryCharacteristics)
 export(summariseOmopTable)
 export(summarisePersonDays)
 export(suppress)
+export(tableOmopTable)
 importFrom(magrittr,"%>%")
 importFrom(omopgenerics,suppress)
 importFrom(rlang,.data)

R/summariseOmopTable.R

@@ -10,7 +10,7 @@
 #' @param inObservation Whether to include the percentage of records in
 #' observation.
 #' @param standardConcept Whether to summarise standard concept.
-#' @param sourceVocabulary Whether to summarise source concept.
+#' @param sourceVocabulary Whether to summarise source vocabulary.
 #' @param domainId Whether to summarise domain id of standard concept id.
 #' @param typeConcept Whether to summarise type concept id field.
 #'
@@ -48,15 +48,21 @@ summariseOmopTable <- function(omopTable,
 
   if ("observation_period" == omopgenerics::tableName(omopTable)) {
     if(standardConcept){
-      cli::cli_warn("standardConcept turned to FALSE, as omopTable provided is observation_period")
+      if(!missing(standardConcept)){
+        cli::cli_warn("standardConcept turned to FALSE, as omopTable provided is observation_period")
+      }
       standardConcept <- FALSE
     }
     if(sourceVocabulary){
-      cli::cli_warn("sourceVocabulary turned to FALSE, as omopTable provided is observation_period")
+      if(!missing(sourceVocabulary)){
+        cli::cli_warn("sourceVocabulary turned to FALSE, as omopTable provided is observation_period")
+      }
       sourceVocabulary <- FALSE
     }
     if(domainId){
-      cli::cli_warn("domainId turned to FALSE, as omopTable provided is observation_period")
+      if(!missing(domainId)){
+        cli::cli_warn("domainId turned to FALSE, as omopTable provided is observation_period")
+      }
       domainId <- FALSE
     }
   }
@@ -68,7 +74,8 @@ summariseOmopTable <- function(omopTable,
   result <- omopgenerics::emptySummarisedResult()
 
   if(omopTable |> dplyr::tally() |> dplyr::pull("n") == 0){
-    cli::cli_abort(paste0(omopgenerics::tableName(omopTable), " omop table is empty."))
+    cli::cli_warn(paste0(omopgenerics::tableName(omopTable), " omop table is empty. Returning an empty summarised omop table."))
+    return(result)
   }
 
   # Counts summary ----
@@ -85,6 +92,12 @@ summariseOmopTable <- function(omopTable,
       addRecordsPerPerson(omopTable, recordsPerPerson, cdm)
   }
 
+  denominator <- result |>
+    dplyr::filter(.data$variable_name == "number_records") |>
+    dplyr::pull("estimate_value") |>
+    as.integer()
+
+
   # Summary concepts ----
   if (inObservation | standardConcept | sourceVocabulary | domainId | typeConcept) {
     cli::cli_inform(c("i" = "Summarising concepts"))
@@ -93,13 +106,8 @@ summariseOmopTable <- function(omopTable,
       inObservation, standardConcept, sourceVocabulary, domainId, typeConcept
     )
 
-    denominator <- result |>
-      dplyr::filter(.data$variable_name == "number_records") |>
-      dplyr::pull("estimate_value") |>
-      as.integer()
-
     result <- result |>
-      dplyr::full_join(
+      dplyr::bind_rows(
         omopTable |>
           addVariables(variables) |>
           dplyr::group_by(dplyr::across(dplyr::all_of(variables))) |>
@@ -112,11 +120,14 @@ summariseOmopTable <- function(omopTable,
 
   # Format output as a summarised result
   result <- result |>
+    dplyr::mutate(variable_name = dplyr::if_else(.data$variable_name == "number_records", "Number of records", .data$variable_name),
+                  variable_name = dplyr::if_else(.data$variable_name == "number_subjects", "Number of subjects", .data$variable_name),
+                  variable_name = dplyr::if_else(.data$variable_name == "records_per_person", "Records per person", .data$variable_name)) |>
     dplyr::mutate(
       "result_id" = 1L,
       "cdm_name" = omopgenerics::cdmName(cdm),
-      "group_name" = "overall",
-      "group_level" = "overall",
+      "group_name" = "omop_table",
+      "group_level" = omopgenerics::tableName(omopTable),
       "strata_name" = "overall",
       "strata_level" = "overall",
       "additional_name" = "overall",
@@ -135,8 +146,10 @@ summariseOmopTable <- function(omopTable,
 # Functions -----
 getNumberPeopleInCdm <- function(cdm){
   cdm[["person"]] |>
-    dplyr::pull("person_id") |>
-    dplyr::n_distinct()
+    dplyr::ungroup() |>
+    dplyr::summarise(x = dplyr::n_distinct(.data$person_id)) |>
+    dplyr::pull("x") |>
+    as.integer()
 }
 
 addNumberSubjects <- function(result, omopTable){
@@ -145,7 +158,12 @@ addNumberSubjects <- function(result, omopTable){
       "variable_name"  = "number_subjects",
       "estimate_name"  = "count",
       "estimate_type"  = "integer",
-      "estimate_value" = as.character(omopTable |> dplyr::pull(.data$person_id) |> dplyr::n_distinct())
+      "estimate_value" = as.character(
+        omopTable |>
+          dplyr::summarise(x = dplyr::n_distinct(.data$person_id)) |>
+          dplyr::pull("x") |>
+          as.integer()
+      )
     )
 }
 addNumberRecords  <- function(result, omopTable){
@@ -154,25 +172,29 @@ addNumberRecords  <- function(result, omopTable){
       "variable_name"  = "number_records",
       "estimate_name"  = "count",
       "estimate_type"  = "integer",
-      "estimate_value" = as.character(omopTable |> dplyr::tally() |> dplyr::pull(.data$n))
+      "estimate_value" = as.character(omopTable |> dplyr::tally() |> dplyr::pull("n"))
     )
 }
+
 addSubjectsPercentage <- function(result, omopTable, people){
   result |>
     dplyr::add_row(
-      "variable_name"  = "subjects_percentage",
+      "variable_name"  = "number_subjects",
       "estimate_name"  = "percentage",
       "estimate_type"  = "percentage",
       "estimate_value" = as.character(
-        100* (omopTable |> dplyr::pull(.data$person_id) |> dplyr::n_distinct()) / .env$people
+        100* (omopTable |>
+                dplyr::summarise(x = dplyr::n_distinct(.data$person_id)) |>
+                dplyr::pull("x") |>
+                as.integer()) / .env$people
       )
     )
 }
 
 addRecordsPerPerson <- function(result, omopTable, recordsPerPerson, cdm){
   suppressMessages(
     result |>
-      dplyr::union_all(
+      dplyr::bind_rows(
         cdm[["person"]] |>
           dplyr::select("person_id") |>
           dplyr::left_join(

R/tableOmopTable.R

@@ -0,0 +1,104 @@
+#' Summarise an omop_table from a cdm_reference object. You will obtain
+#' information related to the number of records, number of subjects, whether the
+#' records are in observation, number of present domains and number of present
+#' concepts.
+#'
+#' @param summarisedOmopTable A summarised_result object with the output from summariseOmopTable().
+#'
+#' @return A gt object with the summarised data.
+#'
+#' @export
+#'
+tableOmopTable <- function(summarisedOmopTable) {
+
+  # Initial checks ----
+  assertClass(summarisedOmopTable, "summarised_result")
+
+  if(summarisedOmopTable |> dplyr::tally() |> dplyr::pull("n") == 0){
+    cli::cli_warn("summarisedOmopTable is empty.")
+
+    return(
+      summarisedOmopTable |>
+      visOmopResults::splitGroup() |>
+      visOmopResults::formatHeader(header = "cdm_name") |>
+      dplyr::select(-c("estimate_type", "result_id",
+                       "additional_name", "additional_level",
+                       "strata_name", "strata_level")) |>
+      dplyr::rename(
+        "Variable" = "variable_name", "Level" = "variable_level",
+        "Estimate" = "estimate_name"
+      ) |>
+      gt::gt()
+    )
+  }
+
+  t <- summarisedOmopTable |>
+    dplyr::mutate(order = dplyr::case_when(
+      variable_name == "Number of subjects"  ~ 1,
+      variable_name == "Number of records" ~ 2,
+      variable_name == "Records per person" ~ 3,
+      variable_name == "In observation" ~ 4,
+      variable_name == "Standard concept" ~ 5,
+      variable_name == "Source vocabulary" ~ 6,
+      variable_name == "Domain" ~ 7,
+      variable_name == "Type concept id" ~ 8
+    )) |>
+    dplyr::arrange(order) |>
+    visOmopResults::splitGroup() |>
+    visOmopResults::formatEstimateValue() |>
+    visOmopResults::formatEstimateName(
+      estimateNameFormat = c(
+        "N (%)" = "<count> (<percentage>%)",
+        "N"     = "<count>",
+        "median [IQR]" = "<median> [<q25> - <q75>]",
+        "mean (sd)" = "<mean> (<sd>)"
+      ),
+      keepNotFormatted = FALSE
+    ) |>
+    suppressMessages() |>
+    visOmopResults::formatHeader(header = "cdm_name") |>
+    dplyr::select(-c("estimate_type", "order","result_id",
+                     "additional_name", "additional_level",
+                     "strata_name", "strata_level")) |>
+    dplyr::rename(
+      "Variable" = "variable_name", "Level" = "variable_level",
+      "Estimate" = "estimate_name"
+    )
+
+  names <- t |> colnames()
+
+  t |>
+    visOmopResults::gtTable(
+      groupColumn = "omop_table",
+      colsToMergeRows = c("Variable", "Level")
+    ) |>
+    gt::tab_style(
+      style = gt::cell_borders(
+        sides = c("left"),
+        color = NULL,
+        style = "solid",
+        weight = gt::px(2)
+      ),
+      locations = list(
+        gt::cells_body(
+          columns = .data$Variable,
+          rows = gt::everything()
+        )
+      )
+    ) |>
+    gt::tab_style(
+      style = gt::cell_borders(
+        sides = c("right"),
+        color = NULL,
+        style = "solid",
+        weight = gt::px(2)
+      ),
+      locations = list(
+        gt::cells_body(
+          columns = names[length(names)],
+          rows = gt::everything()
+        )
+      )
+    )
+
+}

tests/testthat/test-summariseOmopTable.R

@@ -19,15 +19,16 @@ test_that("summariseOmopTable() works", {
   )
 
   # Check all tables work ----
-  expect_warning(summariseOmopTable(cdm$observation_period))
+  expect_true(inherits(summariseOmopTable(cdm$observation_period),"summarised_result"))
+  expect_no_error(summariseOmopTable(cdm$observation_period))
   expect_no_error(summariseOmopTable(cdm$visit_occurrence))
   expect_no_error(summariseOmopTable(cdm$condition_occurrence))
   expect_no_error(summariseOmopTable(cdm$drug_exposure))
   expect_no_error(summariseOmopTable(cdm$procedure_occurrence))
-  expect_error(summariseOmopTable(cdm$device_exposure))
+  expect_warning(summariseOmopTable(cdm$device_exposure))
   expect_no_error(summariseOmopTable(cdm$measurement))
   expect_no_error(summariseOmopTable(cdm$observation))
-  expect_error(summariseOmopTable(cdm$death))
+  expect_warning(summariseOmopTable(cdm$death))
 
 
   # Check inputs ----
@@ -69,6 +70,35 @@ test_that("summariseOmopTable() works", {
                                  domainId = FALSE,
                                  typeConcept = FALSE) |>
                 dplyr::tally() |> dplyr::pull() == 3)
+
+
+  DBI::dbDisconnect(db)
 })
 
 
+test_that("tableOmopTable() works", {
+  # Load mock database ----
+  dbName <- "GiBleed"
+  pathEunomia <- here::here("Eunomia")
+  if (!dir.exists(pathEunomia)) {
+    dir.create(pathEunomia)
+  }
+  CDMConnector::downloadEunomiaData(datasetName = dbName, pathToData = pathEunomia)
+  Sys.setenv("EUNOMIA_DATA_FOLDER" = pathEunomia)
+
+  db <- DBI::dbConnect(duckdb::duckdb(), CDMConnector::eunomia_dir())
+
+  cdm <- CDMConnector::cdmFromCon(
+    con = db,
+    cdmSchema = "main",
+    writeSchema = "main",
+    cdmName = dbName
+  )
+
+  # Check that works ----
+  expect_no_error(x <- tableOmopTable(summariseOmopTable(cdm$condition_occurrence)))
+  expect_true(inherits(x,"gt_tbl"))
+  expect_warning(tableOmopTable(summariseOmopTable(cdm$death)))
+  expect_true(inherits(tableOmopTable(summariseOmopTable(cdm$death)),"gt_tbl"))
+})
+