v0.5

.github/workflows/r-cmd-check-ubuntu.yaml

@@ -12,7 +12,6 @@ jobs:
   R-CMD-check:
     runs-on: ubuntu-latest
     env:
-      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
       R_KEEP_PKG_SOURCE: yes
     steps:
       - uses: actions/checkout@v3

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: CohortSurvival
 Title: Estimate Survival from Common Data Model Cohorts
-Version: 0.4.0
+Version: 0.5.0
 Authors@R: c(
     person("Edward", "Burn", email = "[email protected]", 
     role = c("aut", "cre"), 
@@ -23,7 +23,7 @@ Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.1
 Imports: 
     CDMConnector (>= 1.3.0),
-    omopgenerics,
+    omopgenerics (>= 0.2.0),
     checkmate,
     cli,
     DBI,
@@ -33,7 +33,7 @@ Imports:
     lubridate,
     broom,
     PatientProfiles,
-    visOmopResults,
+    visOmopResults (>= 0.3.0),
     rlang (>= 0.4.11),
     survival,
     scales,
@@ -48,7 +48,11 @@ Suggests:
     tictoc,
     rmarkdown,
     ggplot2,
-    duckdb
+    patchwork,
+    cmprsk,
+    duckdb,
+    gt,
+    flextable
 Config/testthat/edition: 3
 Config/testthat/parallel: true
 VignetteBuilder: knitr

NAMESPACE

@@ -4,6 +4,7 @@ export("%>%")
 export(":=")
 export(.data)
 export(addCohortSurvival)
+export(addCompetingRiskCohortSurvival)
 export(asSurvivalResult)
 export(as_label)
 export(as_name)
@@ -14,8 +15,8 @@ export(estimateCompetingRiskSurvival)
 export(estimateSingleEventSurvival)
 export(generateDeathCohortSet)
 export(mockMGUS2cdm)
+export(optionsTableSurvival)
 export(plotSurvival)
-export(splitNameLevel)
 export(summariseCharacteristics)
 export(survivalParticipants)
 export(tableSurvival)

R/addCohortSurvival.R

@@ -199,6 +199,150 @@ addCohortSurvival <- function(x,
   return(x)
 }
 
+#' Add competing risk survival information to a cohort table
+#' @param x cohort table to add survival information
+#' @param cdm CDM reference
+#' @param outcomeCohortTable The outcome cohort table of interest.
+#' @param outcomeCohortId ID of event cohorts to include. Only one outcome
+#' (and so one ID) can be considered.
+#' @param outcomeDateVariable Variable containing date of outcome event
+#' @param outcomeWashout Washout time in days for the outcome
+#' @param outcomeCensorOnCohortExit If TRUE, an individual's follow up will be
+#' censored at their cohort exit
+#' @param outcomeCensorOnDate if not NULL, an individual's follow up will be censored
+#' at the given date
+#' @param outcomeFollowUpDays Number of days to follow up individuals (lower bound 1,
+#' upper bound Inf)
+#' @param competingOutcomeCohortTable The outcome cohort table of interest.
+#' @param competingOutcomeCohortId ID of event cohorts to include. Only one outcome
+#' (and so one ID) can be considered.
+#' @param competingOutcomeDateVariable Variable containing date of competing outcome event
+#' @param competingOutcomeWashout Washout time in days for the competing outcome
+#' @param competingOutcomeCensorOnCohortExit If TRUE, an individual's follow up will be
+#' censored at their cohort exit
+#' @param competingOutcomeCensorOnDate if not NULL, an individual's follow up will be censored
+#' at the given date
+#' @param competingOutcomeFollowUpDays Number of days to follow up individuals (lower bound 1,
+#' upper bound Inf)
+#'
+#' @return Two additional columns will be added to x. The "time" column will
+#' contain number of days to censoring. The "status" column will indicate
+#' whether the patient had the outcome event (value: 1), competing event (value:2)
+#' or did not have the event/is censored (value: 0)
+#' @export
+#'
+#' @examples
+#' \donttest{
+#'
+#' cdm <- mockMGUS2cdm()
+#' crsurvivaldata <- cdm$mgus_diagnosis %>%
+#'   addCompetingRiskCohortSurvival(
+#'     cdm = cdm,
+#'     outcomeCohortTable = "progression",
+#'     outcomeCohortId = 1,
+#'     competingOutcomeCohortTable = "death_cohort",
+#'     competingOutcomeCohortId = 1
+#'   )
+#'   }
+#'
+addCompetingRiskCohortSurvival <- function(x,
+                                           cdm,
+                                           outcomeCohortTable,
+                                           outcomeCohortId = 1,
+                                           outcomeDateVariable = "cohort_start_date",
+                                           outcomeWashout = Inf,
+                                           outcomeCensorOnCohortExit = FALSE,
+                                           outcomeCensorOnDate = NULL,
+                                           outcomeFollowUpDays = Inf,
+                                           competingOutcomeCohortTable,
+                                           competingOutcomeCohortId = 1,
+                                           competingOutcomeDateVariable = "cohort_start_date",
+                                           competingOutcomeWashout = Inf,
+                                           competingOutcomeCensorOnCohortExit = FALSE,
+                                           competingOutcomeCensorOnDate = NULL,
+                                           competingOutcomeFollowUpDays = Inf) {
+
+  validateExtractSurvivalInputs(
+    cdm = cdm,
+    cohortTable = x,
+    outcomeCohortTable = outcomeCohortTable,
+    outcomeCohortId = outcomeCohortId,
+    outcomeWashout = outcomeWashout,
+    censorOnCohortExit = outcomeCensorOnCohortExit,
+    censorOnDate = outcomeCensorOnDate,
+    followUpDays = outcomeFollowUpDays
+  )
+
+  validateExtractSurvivalInputs(
+    cdm = cdm,
+    cohortTable = x,
+    outcomeCohortTable = competingOutcomeCohortTable,
+    outcomeCohortId = competingOutcomeCohortId,
+    outcomeWashout = competingOutcomeWashout,
+    censorOnCohortExit = competingOutcomeCensorOnCohortExit,
+    censorOnDate = competingOutcomeCensorOnDate,
+    followUpDays = competingOutcomeFollowUpDays
+  )
+
+  # drop columns if they already exist
+  x <- x %>%
+    dplyr::select(!dplyr::any_of(c("days_to_exit",
+                                   "time",
+                                   "status")))
+  x <- x %>%
+    addCohortSurvival(
+      cdm,
+      outcomeCohortTable,
+      outcomeCohortId,
+      outcomeDateVariable,
+      outcomeWashout,
+      outcomeCensorOnCohortExit,
+      outcomeCensorOnDate,
+      outcomeFollowUpDays
+    ) %>%
+    dplyr::rename(
+      "outcome_time" = "time",
+      "outcome_status" = "status"
+    ) %>%
+    addCohortSurvival(
+      cdm,
+      competingOutcomeCohortTable,
+      competingOutcomeCohortId,
+      competingOutcomeDateVariable,
+      competingOutcomeWashout,
+      competingOutcomeCensorOnCohortExit,
+      competingOutcomeCensorOnDate,
+      competingOutcomeFollowUpDays
+    ) %>%
+    dplyr::rename(
+      "competing_risk_time" = "time",
+      "competing_risk_status" = "status"
+    ) %>%
+    dplyr::collect()
+
+  x <- x %>%
+    addCompetingRiskVars(
+      time1 = "outcome_time",
+      status1 = "outcome_status",
+      time2 = "competing_risk_time",
+      status2 = "competing_risk_status",
+      nameOutTime = "outcome_or_competing_time",
+      nameOutStatus = "outcome_or_competing_status"
+    )  %>%
+    dplyr::select(
+      - "outcome_status",
+      - "outcome_time",
+      - "competing_risk_status",
+      - "competing_risk_time"
+    ) %>%
+    dplyr::rename(
+      "time" = "outcome_or_competing_time",
+      "status" = "outcome_or_competing_status"
+    )
+
+  return(x)
+}
+
 
 validateExtractSurvivalInputs <- function(cdm,
                                           cohortTable,

R/asSurvivalResult.R

@@ -43,13 +43,16 @@ asSurvivalResult <- function(result) {
     cli::cli_abort("result is not a valid `summarised_result` object.")
   }
   result <- result %>%
-#    suppress(minCellCount = minCellCount) %>%
+    visOmopResults::addSettings() %>%
+    #    suppress(minCellCount = minCellCount) %>%
     dplyr::select(-c("package_name", "package_version", "estimate_type")) %>%
     visOmopResults::splitAdditional() %>%
     visOmopResults::splitGroup() %>%
     dplyr::mutate(estimate_value = as.numeric(.data$estimate_value))
   estimates <- result %>%
-    dplyr::filter(.data$result_type == 'survival_estimate') %>%
+    dplyr::filter(.data$variable_name %in%
+                    c("survival_probability",
+                      "cumulative_failure_probability")) %>%
     dplyr::select(-dplyr::any_of('eventgap')) %>%
     dplyr::mutate(time = as.numeric(.data$time))
   if("competing_outcome" %in% colnames(estimates)) {
@@ -61,10 +64,10 @@ asSurvivalResult <- function(result) {
       dplyr::relocate("outcome", .after = "cohort")
   }
   summary <- result %>%
-    dplyr::filter(.data$result_type == 'survival_summary') %>%
+    dplyr::filter(.data$variable_name == 'survival_summary') %>%
     dplyr::select(-dplyr::any_of(c('variable_name', 'time', 'eventgap')))
   events <- result %>%
-    dplyr::filter(.data$result_type == 'survival_events') %>%
+    dplyr::filter(.data$variable_name == 'survival_events') %>%
     dplyr::select(-dplyr::any_of('variable_name')) %>%
     dplyr::distinct() %>%
     dplyr::mutate(time = as.numeric(.data$time))