From 6413f6677f64336bd1e1168c6a54b643757bcb47 Mon Sep 17 00:00:00 2001 From: jreps Date: Wed, 1 Apr 2026 18:05:52 -0400 Subject: [PATCH 1/8] updates to clean up package structure - moving code that processes json file into r objects for report into R folder - adding tests for new functions in R folder (using copilot) - updated protocol to use boxes that can be collapsed - added group/ungroup button to tables with grouped rows --- DESCRIPTION | 16 +- NAMESPACE | 13 + R/Characterization.R | 549 +++++++++++++++ R/CohortDiagnostics.R | 128 ++++ R/CohortIncidence.R | 263 ++++++++ R/CohortMethod.R | 387 +++++++++++ R/Helpers.R | 361 ++++++++-- R/PatientLevelPrediction.R | 152 +++++ R/SelfControlCaseSeries.R | 264 ++++++++ inst/protocol/characterization.qmd | 633 +++++++++--------- inst/protocol/cohort-diagnostics.qmd | 123 +--- inst/protocol/cohort-incidence.qmd | 218 ++---- inst/protocol/cohort-method.qmd | 445 ++++-------- inst/protocol/cohorts.Rmd | 13 +- inst/protocol/patient-level-prediction.Rmd | 117 +--- inst/protocol/prediction/model-design.Rmd | 7 +- .../prediction/plp-targets-outcomes.Rmd | 40 +- inst/protocol/self-control-case-series.qmd | 276 ++------ inst/protocol/study_protocol.qmd | 124 +--- inst/protocol/table-use.Rmd | 68 +- man/cmColDef.Rd | 22 + man/createStratSentance.Rd | 20 + man/extractCohortMethodSettings.Rd | 28 + man/getCIcolumns.Rd | 17 + man/getCdCols.Rd | 17 + man/getCiTargetsOutcomes.Rd | 22 + man/getCohortDefinitionsFromJson.Rd | 2 +- man/getCohortDiagnosticTables.Rd | 22 + man/getCountStatement.Rd | 22 + man/getNegativeControlsFromJson.Rd | 20 + man/getPlpColDefs.Rd | 17 + man/getPlpSettings.Rd | 22 + man/getSccsColDefs.Rd | 17 + man/getSccsSettings.Rd | 28 + tests/testthat/test-characterization.r | 298 +++++++++ tests/testthat/test-cohortdiagnostics.r | 94 +++ tests/testthat/test-cohortincidence.r | 155 +++++ tests/testthat/test-cohortmethod.r | 190 ++++++ tests/testthat/test-helpers.R | 15 +- tests/testthat/test-patientLevelPrediction.r | 155 +++++ .../testthat/test-selfControlledCaseSeries.r | 160 +++++ 41 files changed, 4101 insertions(+), 1439 deletions(-) create mode 100644 R/Characterization.R create mode 100644 R/CohortDiagnostics.R create mode 100644 R/CohortIncidence.R create mode 100644 R/CohortMethod.R create mode 100644 R/PatientLevelPrediction.R create mode 100644 R/SelfControlCaseSeries.R create mode 100644 man/cmColDef.Rd create mode 100644 man/createStratSentance.Rd create mode 100644 man/extractCohortMethodSettings.Rd create mode 100644 man/getCIcolumns.Rd create mode 100644 man/getCdCols.Rd create mode 100644 man/getCiTargetsOutcomes.Rd create mode 100644 man/getCohortDiagnosticTables.Rd create mode 100644 man/getCountStatement.Rd create mode 100644 man/getNegativeControlsFromJson.Rd create mode 100644 man/getPlpColDefs.Rd create mode 100644 man/getPlpSettings.Rd create mode 100644 man/getSccsColDefs.Rd create mode 100644 man/getSccsSettings.Rd create mode 100644 tests/testthat/test-characterization.r create mode 100644 tests/testthat/test-cohortdiagnostics.r create mode 100644 tests/testthat/test-cohortincidence.r create mode 100644 tests/testthat/test-cohortmethod.r create mode 100644 tests/testthat/test-patientLevelPrediction.r create mode 100644 tests/testthat/test-selfControlledCaseSeries.r diff --git a/DESCRIPTION b/DESCRIPTION index 02254ac..4a64dc1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -17,29 +17,27 @@ Depends: Imports: dplyr, jsonlite, + ParallelLogger, quarto, reactable, rlang, ROhdsiWebApi, shiny Suggests: - Characterization, - CohortIncidence, - CohortMethod, + Characterization (>= 3.0.0), + CohortIncidence (>= 4.0.0), + CohortMethod (>= 6.0.0), Cyclops, keyring, knitr, markdown, - ParallelLogger, - PatientLevelPrediction, + PatientLevelPrediction (>= 6.6.0), remotes, rmarkdown, - SelfControlledCaseSeries, + SelfControlledCaseSeries (>= 6.1.1), testthat Remotes: ohdsi/ROhdsiWebApi, - ohdsi/CohortIncidence, - ohdsi/CohortMethod, - ohdsi/SelfControlledCaseSeries + ohdsi/CohortIncidence RoxygenNote: 7.3.2 Encoding: UTF-8 diff --git a/NAMESPACE b/NAMESPACE index b58feff..a505941 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,16 +1,29 @@ # Generated by roxygen2: do not edit by hand +export(cmColDef) +export(createStratSentance) export(defaultColumns) +export(extractCohortMethodSettings) export(formatCovariateSettings) export(functionDefaults) export(generateProtocol) export(getAllHelpDetails) export(getAllHelpText) +export(getCIcolumns) +export(getCdCols) +export(getCiTargetsOutcomes) export(getCohortDefinitionsFromJson) +export(getCohortDiagnosticTables) export(getConcepts) +export(getCountStatement) export(getDemoLoc) export(getFunctionFromArgName) export(getHelpText) +export(getNegativeControlsFromJson) +export(getPlpColDefs) +export(getPlpSettings) +export(getSccsColDefs) +export(getSccsSettings) export(getSettingsTable) export(reportTableFormat) export(tagPrint) diff --git a/R/Characterization.R b/R/Characterization.R new file mode 100644 index 0000000..d52c2d4 --- /dev/null +++ b/R/Characterization.R @@ -0,0 +1,549 @@ +globalCharacterizationSettings <- function( + CharacterizationModuleSettings +){ + + txt <- paste0( + 'Only covariates that occur >= ', + CharacterizationModuleSettings$settings$minCharacterizationMean, + ' fraction of the population and >= ', + CharacterizationModuleSettings$settings$minCovariateCount, + ' people are returned. ', + 'The risk factor analysis used mode ', + CharacterizationModuleSettings$settings$mode, + ' and only returns covariates where the absolute SMD is >= ', + CharacterizationModuleSettings$settings$minSMD, + '. All cohorts created by Characterization will be saved into ', + CharacterizationModuleSettings$settings$outputTable, + ' within the Strategus work schema.' + ) + + return(txt) +} + +processTar <- function( + riskWindowStart, + startAnchor, + riskWindowEnd, + endAnchor +){ + + text <- paste0('(', + startAnchor, '+', riskWindowStart, + ') - (', + endAnchor, '+', riskWindowEnd + ,')') + + return(text) +} + + + +processTargetBaseineSettings <- function( + CharacterizationModuleSettings, + cohortDefinitionDf # process cohortDefinition + ){ + + tbSpec <- CharacterizationModuleSettings$settings$analysis$targetBaselineSettings + + if(is.null(tbSpec)){ + return(NULL) + } + + # get the unique covariate settings + covariateJson <- lapply( + X = tbSpec, + FUN = function(x) ParallelLogger::convertSettingsToJson(x$covariateSettings) + ) + covariateJsonUnique <- unique(covariateJson) + + # extract: target_id, limitToFirstInNDays, minPriorObservation, covariateSettingId + targetSettings <- do.call(rbind, lapply( + X = tbSpec, + FUN = function(x) data.frame( + targetId = x$targetIds, + limitToFirstInNDays = x$limitToFirstInNDays, + minPriorObservation = x$minPriorObservation, + covariateSettingId = match(ParallelLogger::convertSettingsToJson(x$covariateSettings),covariateJsonUnique) + ) + ) + ) + + # create target table + tempDf <- cohortDefinitionDf + colnames(tempDf) <- paste0(colnames(tempDf), 'Target') + targetDf <- merge(targetSettings, tempDf, by.x = 'targetId', by.y = 'cohortIdTarget') + targetDf$setting <- paste0("Setting ",targetDf$covariateSettingId,"") + + # order the columns + targetDf <- targetDf %>% + dplyr::relocate("cohortNameTarget") %>% + dplyr::relocate("parentNameTarget") %>% + dplyr::relocate("limitToFirstInNDays", .after = "cohortNameTarget") %>% + dplyr::relocate("minPriorObservation", .after = "limitToFirstInNDays") %>% + dplyr::relocate("setting", .after = dplyr::last_col()) + + return( + list( + tableData = targetDf, + settingsJson = covariateJsonUnique + ) + ) +} + + + +processRiskFactorSettings <- function( + CharacterizationModuleSettings, + cohortDefinitionDf # process cohortDefinition + ){ + + rfSpec <- CharacterizationModuleSettings$settings$analysis$riskFactorSettings + + if(is.null(rfSpec)){ + return(NULL) + } + + # get the unique covariate settings + covariateJsonUnique <- unique(lapply( + X = rfSpec, + FUN = function(x) ParallelLogger::convertSettingsToJson(x$covariateSettings) + )) + + # get unique outcome sets + rfOutcomeList <- unique(lapply( + X = rfSpec, + FUN = function(x) { + data.frame( + outcomeId = x$outcomeIds, + outcomeWashoutDays = x$outcomeWashoutDays, + tar = processTar( + riskWindowStart = x$riskWindowStart, + startAnchor = x$startAnchor, + riskWindowEnd = x$riskWindowEnd, + endAnchor = x$endAnchor + ) + ) + })) + + # get unique target sets + rfTargetList <- unique(lapply( + X = rfSpec, + FUN = function(x) { + data.frame( + targetId = x$targetIds, # need to account for multiple targetIds + limitToFirstInNDays = x$limitToFirstInNDays, + minPriorObservation = x$minPriorObservation + ) + } + )) + + if(length(rfTargetList) == 1){ + # all outcomes by all targets + rfTargetSettings <- unique(do.call(rbind, lapply( + X = rfSpec, + FUN = function(x) { + + data.frame( + targetId = x$targetIds, # need to account for multiple targetIds + limitToFirstInNDays = x$limitToFirstInNDays, + minPriorObservation = x$minPriorObservation, + outcomeSet = 1, + covariateSettingId = match(ParallelLogger::convertSettingsToJson(x$covariateSettings),covariateJsonUnique) + ) + + } + ) + )) + + rfOutcomeList <- list(do.call(rbind, rfOutcomeList)) + + } else{ + + # extract: target_id, limitToFirstInNDays, minPriorObservation, covariateSettingId + rfTargetSettings <- unique(do.call(rbind, lapply( + X = rfSpec, + FUN = function(x) { + + data.frame( + targetId = x$targetIds, # need to account for multiple targetIds + limitToFirstInNDays = x$limitToFirstInNDays, + minPriorObservation = x$minPriorObservation, + outcomeSet = which(unlist(lapply( + X = rfOutcomeList, + FUN = function(y){identical(y, data.frame(outcomeId = x$outcomeIds, + outcomeWashoutDays = x$outcomeWashoutDays, + tar = processTar( + riskWindowStart = x$riskWindowStart, + startAnchor = x$startAnchor, + riskWindowEnd = x$riskWindowEnd, + endAnchor = x$endAnchor + )))} + ))), + covariateSettingId = match(ParallelLogger::convertSettingsToJson(x$covariateSettings),covariateJsonUnique) + ) + + } + ) + )) + } + + # create table + # add target cohort details + tempDf <- cohortDefinitionDf + colnames(tempDf) <- paste0(colnames(tempDf), 'Target') + rfTargetSettings <- merge(rfTargetSettings, tempDf, by.x = 'targetId', by.y = 'cohortIdTarget') + rfTargetSettings$setting <- paste0("Setting ",rfTargetSettings$covariateSettingId,"") + rfTargetSettings$outcomeSet <- paste0("Outcome ",rfTargetSettings$outcomeSet,"") + + rfTargetSettings <- rfTargetSettings %>% + dplyr::relocate("cohortNameTarget") %>% + dplyr::relocate("parentNameTarget") %>% + dplyr::relocate("limitToFirstInNDays", .after = "cohortNameTarget") %>% + dplyr::relocate("minPriorObservation", .after = "limitToFirstInNDays") %>% + dplyr::relocate("outcomeSet", .after = "minPriorObservation") %>% + dplyr::relocate("setting", .after = dplyr::last_col()) %>% + dplyr::arrange(.data$parentNameTarget, .data$cohortNameTarget) + + # add outcome cohort details to each data.frame in list + tempDf <- cohortDefinitionDf + colnames(tempDf) <- paste0(colnames(tempDf), 'Outcome') + rfOutcomeList <- lapply( + X = rfOutcomeList, + FUN = function(outcomedf){ + res <- merge(outcomedf, tempDf, by.x = 'outcomeId', by.y = 'cohortIdOutcome') + res <- res %>% + dplyr::relocate("cohortNameOutcome") %>% + dplyr::relocate("parentNameOutcome") %>% + dplyr::relocate("outcomeWashoutDays", .after = "cohortNameOutcome") %>% + dplyr::relocate("tar", .after = "outcomeWashoutDays") %>% + dplyr::arrange(.data$parentNameOutcome, .data$cohortNameOutcome) + return(res) + }) + + return( + list( + targetData = rfTargetSettings, + outcomeDataList = rfOutcomeList, + settingsJson = covariateJsonUnique + ) + ) + +} + + + +processCaseSeriesSettings <- function( + CharacterizationModuleSettings, + cohortDefinitionDf # process cohortDefinition + ){ + + csSpec <- CharacterizationModuleSettings$settings$analysis$caseSeriesSettings + + if(is.null(csSpec)){ + return(NULL) + } + + # get the unique covariate settings + settingsJsonUnique <- unique(lapply( + X = csSpec, + FUN = function(x) ParallelLogger::convertSettingsToJson( + list( + caseCovariateSettings = x$caseCovariateSettings, + casePreTargetDuration = x$casePreTargetDuration, + casePostOutcomeDuration = x$casePostOutcomeDuration + ) + ) + )) + + # get unique outcome sets + csOutcomeList <- unique(lapply( + X = csSpec, + FUN = function(x) { + data.frame( + outcomeId = x$outcomeIds, + outcomeWashoutDays = x$outcomeWashoutDays, + tar = processTar( + riskWindowStart = x$riskWindowStart, + startAnchor = x$startAnchor, + riskWindowEnd = x$riskWindowEnd, + endAnchor = x$endAnchor + ) + ) + })) + + # get unique target sets + csTargetList <- unique(lapply( + X = csSpec, + FUN = function(x) { + data.frame( + targetId = x$targetIds, # need to account for multiple targetIds + limitToFirstInNDays = x$limitToFirstInNDays, + minPriorObservation = x$minPriorObservation + ) + } + )) + + # extract: target_id, limitToFirstInNDays, minPriorObservation, covariateSettingId + if(length(csTargetList) == 1){ + # all outcomes by all targets + csTargetSettings <- unique(do.call(rbind, lapply( + X = csSpec, + FUN = function(x) { + + data.frame( + targetId = x$targetIds, # need to account for multiple targetIds + limitToFirstInNDays = x$limitToFirstInNDays, + minPriorObservation = x$minPriorObservation, + outcomeSet = 1, + settingId = match(ParallelLogger::convertSettingsToJson(list( + caseCovariateSettings = x$caseCovariateSettings, + casePreTargetDuration = x$casePreTargetDuration, + casePostOutcomeDuration = x$casePostOutcomeDuration + )), settingsJsonUnique) + ) + + } + ) + )) + + csOutcomeList <- list(do.call(rbind, csOutcomeList)) + + } else{ + + # extract: target_id, limitToFirstInNDays, minPriorObservation, covariateSettingId + csTargetSettings <- unique(do.call(rbind, lapply( + X = csSpec, + FUN = function(x) { + + data.frame( + targetId = x$targetIds, # need to account for multiple targetIds + limitToFirstInNDays = x$limitToFirstInNDays, + minPriorObservation = x$minPriorObservation, + outcomeSet = which(unlist(lapply( + X = csOutcomeList, + FUN = function(y){identical(y, data.frame(outcomeId = x$outcomeIds, + outcomeWashoutDays = x$outcomeWashoutDays, + tar = processTar( + riskWindowStart = x$riskWindowStart, + startAnchor = x$startAnchor, + riskWindowEnd = x$riskWindowEnd, + endAnchor = x$endAnchor + )))} + ))), + settingId = match(ParallelLogger::convertSettingsToJson(list( + caseCovariateSettings = x$caseCovariateSettings, + casePreTargetDuration = x$casePreTargetDuration, + casePostOutcomeDuration = x$casePostOutcomeDuration + )), settingsJsonUnique) + ) + + } + ) + )) + } + + # create table + # add target cohort details + tempDf <- cohortDefinitionDf + colnames(tempDf) <- paste0(colnames(tempDf), 'Target') + csTargetSettings <- merge(csTargetSettings, tempDf, by.x = 'targetId', by.y = 'cohortIdTarget') + csTargetSettings$setting <- paste0("Setting ",csTargetSettings$settingId,"") + csTargetSettings$outcomeSet <- paste0("Outcome ",csTargetSettings$outcomeSet,"") + + csTargetSettings <- csTargetSettings %>% + dplyr::relocate("cohortNameTarget") %>% + dplyr::relocate("parentNameTarget") %>% + dplyr::relocate("limitToFirstInNDays", .after = "cohortNameTarget") %>% + dplyr::relocate("minPriorObservation", .after = "limitToFirstInNDays") %>% + dplyr::relocate("outcomeSet", .after = "minPriorObservation") %>% + dplyr::relocate("setting", .after = dplyr::last_col()) %>% + dplyr::arrange(.data$parentNameTarget, .data$cohortNameTarget) + + # add outcome cohort details to each data.frame in list + tempDf <- cohortDefinitionDf + colnames(tempDf) <- paste0(colnames(tempDf), 'Outcome') + csOutcomeList <- lapply( + X = csOutcomeList, + FUN = function(outcomedf){ + res <- merge(outcomedf, tempDf, by.x = 'outcomeId', by.y = 'cohortIdOutcome') + res <- res %>% + dplyr::relocate("cohortNameOutcome") %>% + dplyr::relocate("parentNameOutcome") %>% + dplyr::relocate("outcomeWashoutDays", .after = "cohortNameOutcome") %>% + dplyr::relocate("tar", .after = "outcomeWashoutDays") %>% + dplyr::arrange(.data$parentNameOutcome, .data$cohortNameOutcome) + return(res) + }) + + return( + list( + targetData = csTargetSettings, + outcomeDataList = csOutcomeList, + settingsJson = settingsJsonUnique + ) + ) + +} + + +characterizationColDef <- function(){ + res <- list( + subsetIdTarget = reactable::colDef(show = FALSE), + subsetIdOutcome = reactable::colDef(show = FALSE), + isParentTarget = reactable::colDef(show = FALSE), + isParentOutcome = reactable::colDef(show = FALSE), + parentIdTarget = reactable::colDef(show = FALSE), + parentIdOutcome = reactable::colDef(show = FALSE), + subsetNameTarget = reactable::colDef(show = FALSE), + subsetNameOutcome = reactable::colDef(show = FALSE), + packageVersionTarget = reactable::colDef(show = FALSE), + packageVersionOutcome = reactable::colDef(show = FALSE), + numberSubsetOperatorsTarget = reactable::colDef(show = FALSE), + numberSubsetOperatorsOutcome = reactable::colDef(show = FALSE), + + subsetId = reactable::colDef(show = FALSE), + isParent = reactable::colDef(show = FALSE), + parentId = reactable::colDef(show = FALSE), + subsetName = reactable::colDef(show = FALSE), + packageVersion = reactable::colDef(show = FALSE), + numberSubsetOperators = reactable::colDef(show = FALSE), + + cohortIdTarget = reactable::colDef(show = FALSE), + cohortIdOutcome = reactable::colDef(show = FALSE), + targetId = reactable::colDef(show = FALSE), + outcomeId = reactable::colDef(show = FALSE), + + tar = reactable::colDef( + aggregate = "unique", + name = 'Time at risk', + filterable = TRUE, + minWidth = 150 + ), + outcomeWashoutDays = reactable::colDef( + aggregate = "unique", + name = 'Outcome Washout (Days)', + filterable = TRUE + ), + outcomeSet = reactable::colDef( + name = 'Outcomes', + html = TRUE + ), + covariateSettingId = reactable::colDef(show = FALSE), + minPriorObservation = reactable::colDef( + aggregate = "unique", + name = 'Prior Obs (days)', + filterable = TRUE + ), + parentName = reactable::colDef( + name = 'Parent Cohort', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300, + html = TRUE + ), + parentNameTarget = reactable::colDef( + name = 'Parent Target', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300, + html = TRUE + ), + parentNameOutcome = reactable::colDef(name = 'Parent Outcome', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300, + html = TRUE + ), + + cohortNameTarget = reactable::colDef( + aggregate = "unique", + show = TRUE, + name = 'Target', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300 + ), + cohortNameWithLinkTarget = reactable::colDef( + show = FALSE, + name = 'Cohort', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300, + html = TRUE + ), + cohortNameOutcome = reactable::colDef( + show = TRUE, + aggregate = "unique", + name = 'Outcome', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300 + ), + cohortNameWithLinkOutcome = reactable::colDef( + show = FALSE, + name = 'Outcome', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300, + html = TRUE + ), + cohortNameWithLink = reactable::colDef( + show = FALSE, + name = 'Cohort', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300, + html = TRUE + ), + + cohortName = reactable::colDef( + show = TRUE, + aggregate = "unique", + name = 'Cohort', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300 + ), + cohortId = reactable::colDef(show = FALSE), + + subsetCohortsTarget = reactable::colDef( + html = TRUE, + aggregate = "count" + ), + subsetCohorts = reactable::colDef( + html = TRUE, + aggregate = "count" + ), + subsetCohortsOutcome = reactable::colDef( + html = TRUE, + aggregate = "count" + ), + + appliedSubsetsTarget = reactable::colDef( + html = TRUE, + aggregate = "count" + ), + appliedSubsetsOutcome= reactable::colDef(show = FALSE), + appliedSubsets = reactable::colDef( + html = TRUE, + aggregate = "count" + ), + + settingId = reactable::colDef(show = FALSE), + setting = reactable::colDef( + html = TRUE, + aggregate = "count" + ) + ) + + return(res) +} diff --git a/R/CohortDiagnostics.R b/R/CohortDiagnostics.R new file mode 100644 index 0000000..2e7ea1f --- /dev/null +++ b/R/CohortDiagnostics.R @@ -0,0 +1,128 @@ +#' getCohortDiagnosticTables +#' +#' @description +#' Extract target, setting and feature table from CohortDiagnosticsSettings +#' +#' @details +#' Returns a list of tables +#' +#' @param CohortDiagnosticsSettings The cohort diagnostic module specification +#' @param cohortDefinitionDf The data.frame with the cohort definition details +#' +#' @return +#' A list with the tables to display +#' +#' @export +#' +getCohortDiagnosticTables <- function( + CohortDiagnosticsSettings, + cohortDefinitionDf +){ + + cohortIdsCD <- CohortDiagnosticsSettings$cohortIds + # if null then cohort diagnotics is applied to all cohorts in set + if(is.null(cohortIdsCD)){ + cohortIdsCD <- cohortDefinitionDf$cohortId + } + + # this should be a single settings rather than a list of settings + temporalCovariateSettingsCD <- CohortDiagnosticsSettings$temporalCovariateSettings + featureTable <- data.frame( + input = names(temporalCovariateSettingsCD), + value = unlist(lapply(temporalCovariateSettingsCD, FUN = function(x) ifelse(is.null(x), 'NULL', as.character(x)))) + ) + rownames(featureTable) <- NULL + + # non list settings + cdSettings <- CohortDiagnosticsSettings + cdSettings$cohortIds <- NULL + cdSettings$temporalCovariateSettings <- NULL + + settingsTable <- data.frame( + input = names(cdSettings), + value = unlist(lapply(cdSettings, FUN = function(x) ifelse(is.null(x), 'NULL', as.character(x)))) + ) + rownames(settingsTable) <- NULL + + # create target table + targetTable <- cohortDefinitionDf + colnames(targetTable) <- paste0(colnames(targetTable), 'Target') + targetTable <- targetTable[targetTable$cohortIdTarget %in% cohortIdsCD, ] + + # order the columns + targetTable <- targetTable %>% + dplyr::relocate("cohortNameTarget") %>% + dplyr::relocate("parentNameTarget") + + return( + list( + targetTable = targetTable, + settingsTable = settingsTable, + featureTable = featureTable + ) + ) +} + + +#' getCdCols +#' +#' @description +#' A list of colDefs for the columns used in cohort diagnostic protocol module +#' +#' @details +#' Returns a list of colDefs +#' +#' +#' @return +#' A list of colDefs for cohort diagnostic +#' +#' @export +#' +getCdCols <- function(){ + res <- list( + subsetIdTarget = reactable::colDef(show = F), + isParentTarget = reactable::colDef(show = F), + parentIdTarget = reactable::colDef(show = F), + subsetNameTarget = reactable::colDef(show = F), + packageVersionTarget = reactable::colDef(show = F), + numberSubsetOperatorsTarget = reactable::colDef(show = F), + cohortIdTarget = reactable::colDef(show = F), + + parentNameTarget = reactable::colDef( + name = 'Parent Target', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300, + html = TRUE + ), + + cohortNameTarget = reactable::colDef( + aggregate = "unique", + show = TRUE, + name = 'Target', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300 + ), + cohortNameWithLinkTarget = reactable::colDef( + show = FALSE, + name = 'Cohort', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300, + html = TRUE + ), + subsetCohortsTarget = reactable::colDef( + html = TRUE, + aggregate = "count" + ), + appliedSubsetsTarget = reactable::colDef( + html = TRUE, + aggregate = "count" + ) + ) + return(res) +} \ No newline at end of file diff --git a/R/CohortIncidence.R b/R/CohortIncidence.R new file mode 100644 index 0000000..c3ede69 --- /dev/null +++ b/R/CohortIncidence.R @@ -0,0 +1,263 @@ +#' getCountStatement +#' +#' @description +#' Create a sentence that explains the number of targets, outcomes and settings per analysis. +#' +#' @details +#' Returns a string +#' +#' @param CohortIncidenceModuleSettings The cohort incidence module specification +#' @param cohortDefinitionDf The data.frame with the cohort definition details +#' +#' @return +#' An string with the count information +#' +#' @export +#' +getCountStatement <- function( + CohortIncidenceModuleSettings, + cohortDefinitionDf + ){ + + allCounts <- lapply( + CohortIncidenceModuleSettings$settings$irDesign$analysisList, function(x){ + targetIds <- x$targets + outcomeIds <- x$outcomes + tars <- x$tars + + #updated for new CI + targetIds <- unlist(lapply(1:length(targetIds), function(ind) CohortIncidenceModuleSettings$settings$irDesign$targetDefs[[ind]]$id)) + outcomeIds <- unlist(lapply(1:length(outcomeIds), function(ind) CohortIncidenceModuleSettings$settings$irDesign$outcomeDefs[[ind]]$cohortId)) + outcomeCleanWindow <- unlist(lapply(1:length(outcomeIds), function(ind) CohortIncidenceModuleSettings$settings$irDesign$outcomeDefs[[ind]]$cleanWindow)) + parentIdsOutcome <- unlist(lapply(1:length(outcomeIds), function(ind){ + outcomeId <- CohortIncidenceModuleSettings$settings$irDesign$outcomeDefs[[ind]]$cohortId; + parentId <- cohortDefinitionDf$parentId[cohortDefinitionDf$cohortId %in% outcomeId] + })) + + counts <- list( + cohortTs = length(unique(targetIds)), + parentTs = length(unique(cohortDefinitionDf$parentId[cohortDefinitionDf$cohortId %in% targetIds])), + cohortOs = nrow(unique(cbind(outcomeIds, outcomeCleanWindow))), + parentOs = nrow(unique(cbind(parentIdsOutcome, outcomeCleanWindow))), + parentOsNoWindow = length(unique(parentIdsOutcome)), + tars = length(unique(tars)), + total = length(unique(targetIds))*nrow(unique(cbind(outcomeIds, outcomeCleanWindow)))*length(unique(tars)) + ) + return(counts) + }) + + totarCounts <- do.call(sum, lapply(CohortIncidenceModuleSettings$settings$irDesign$analysisList, function(x){length(x[[1]])*length(x[[2]])*length(x[[3]])})) + analysisCount <- length(CohortIncidenceModuleSettings$settings$irDesign$analysisList) + targetCount <- length(CohortIncidenceModuleSettings$settings$irDesign$targetDefs) + outcomeCount <- length(CohortIncidenceModuleSettings$settings$irDesign$outcomeDefs) + tarCount <- length(CohortIncidenceModuleSettings$settings$irDesign$timeAtRiskDefs) + totarCountsUnique <-sum(unlist(lapply(allCounts, function(x) x$total))) + + # create count sentances for each analysis + countSentances <- lapply( + X = 1:length(allCounts), + FUN = function(i){ + paste0('- Analysis ', i, ' @sec-incidence-analysis-',i,' : ', + allCounts[[i]]$parentTs, ' unique parent targets (',allCounts[[i]]$cohortTs, + ' unique target subsets) see @sec-incidence-t-',i,', ', allCounts[[i]]$parentOs, + ' unique parent outcomes with clean windows (',allCounts[[i]]$cohortOs, + ' unique outcome subsets with clean windows and ',allCounts[[i]]$parentOsNoWindow, + ' unique parent outcomes see @sec-incidence-o-',i,') and ',allCounts[[i]]$tars, + ' time-at-risks see @sec-incidence-tar-',i,'. Total of ', allCounts[[i]]$total, + ' T/O/TAR combinations in analysis ',i,'.') + } + ) + + return(countSentances) +} + +#' createStratSentance +#' +#' @description +#' Create a sentence that explains the stratification defined in the analysis. +#' +#' @details +#' Returns a string +#' +#' @param CohortIncidenceModuleSettings The cohort incidence module specification +#' +#' @return +#' An string with the stratification information +#' +#' @export +#' +createStratSentance <- function(CohortIncidenceModuleSettings){ + stratInd <- unlist(lapply(CohortIncidenceModuleSettings$settings$irDesign$strataSettings, function(x) is.logical(x))) + + if(sum(stratInd)>0){ + stratSentance <- paste0('Stratified by ', paste0(gsub('by', '', names(stratInd)[stratInd]), collapse = '/'), ', see @sec-incidence-strat. There will be more results due to including stratification of the target cohorts.') + } else{ + stratSentance <- 'No stratification applied.' + } + + return(stratSentance) +} + + +#' getCiTargetsOutcomes +#' +#' @description +#' Extracts a list of target tables, outcome tables, TARs and vector of unique targetIds and outcomeIds in analysis +#' +#' @details +#' Returns a list +#' +#' @param CohortIncidenceModuleSettings The cohort incidence module specification +#' @param cohortDefinitionDf The data.frame with the cohort definition details +#' +#' @return +#' A list with the tables to present in the protocol +#' +#' @export +#' +getCiTargetsOutcomes <- function( + CohortIncidenceModuleSettings, + cohortDefinitionDf +){ + + tarDefs <- CohortIncidenceModuleSettings$settings$irDesign$timeAtRiskDefs + + tars <- list() + ciTargets <- list() + ciOutcomes <- list() + ciTargetIds <- c() + ciOutcomeIds <- c() + + for(i in 1:length(CohortIncidenceModuleSettings$settings$irDesign$analysisList)){ + + targets <- CohortIncidenceModuleSettings$settings$irDesign$analysisList[[i]]$targets + targetIds <- unlist(lapply(1:length(targets), function(id){ + CohortIncidenceModuleSettings$settings$irDesign$targetDefs[[id]]$id + })) + + ciTargetIds <- c(ciTargetIds, targetIds) # vector or all targets + + # this is now the ci cohort ids not the main cohort ids + outcomeIdsCI <- CohortIncidenceModuleSettings$settings$irDesign$analysisList[[i]]$outcomes + # create lookup to find outcome ids + outcomeLookup <- as.data.frame( + do.call( + rbind, + CohortIncidenceModuleSettings$settings$irDesign$outcomeDefs) + ) + outcomeDf <- outcomeLookup[outcomeLookup$id %in% outcomeIdsCI,c('cohortId', 'cleanWindow')] + + ciOutcomeIds <- c(ciOutcomeIds,outcomeLookup$cohortId) # vector of outcomes + + # The nicely formatted settings + ciTargets[[i]] <- cohortDefinitionDf[cohortDefinitionDf$cohortId %in% targetIds,] + + ciOutcomes[[i]] <- merge( + x = cohortDefinitionDf, + y = outcomeDf, + by = 'cohortId' + ) %>% + dplyr::relocate("cleanWindow", .after = "parentName") + + + tars[[i]] <- paste0(' - ', paste0(sapply( + X = CohortIncidenceModuleSettings$settings$irDesign$analysisList[[i]]$tars, + FUN = function(x){getCiTarString(tarDefs, x)}), + collapse=' \n - ')) + } + + + return( + list( + ciTargets = ciTargets, # list of cohortDefinitionDf restricted targetIds in study + ciOutcomes = ciOutcomes, # list of cohortDefinitionDf restricted outcomeIds in study + tars = tars, # list of tar setting from CohortIncidenceModuleSettings + ciTargetIds = unique(ciTargetIds), # vector of all target ids used in CI + ciOutcomeIds = unique(ciOutcomeIds) # vector of all outcome ids used in CI + ) + ) +} + +# helper for getCiTargetsOutcomes +getCiTarString <- function(tarDefs, tarId){ + res <- tarDefs[[which(unlist(lapply(tarDefs, function(x) x$id)) == tarId)]] + + return(paste0('(',res$start$dateField ,' + ', res$start$offset, ') - (', res$end$dateField, ' + ', res$end$offset, ')')) +} + + +#' getCIcolumns +#' +#' @description +#' A reactable colDef list for the cohort incidence tables +#' +#' @details +#' Returns a list of colDefs +#' +#' +#' @return +#' A list of colDefs for the target and outcome tables describing the cohort incidence analysis +#' +#' @export +#' +getCIcolumns <- function(){ + ciColumns <- list( + subsetId = reactable::colDef(show = FALSE), + isParent = reactable::colDef(show = FALSE), + parentId = reactable::colDef(show = FALSE), + subsetName = reactable::colDef(show = FALSE), + packageVersion = reactable::colDef(show = FALSE), + numberSubsetOperators = reactable::colDef(show = FALSE), + cohortId = reactable::colDef(show = FALSE), + parentName = reactable::colDef( + name = 'Parent Cohort', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300, + html = TRUE + ), + cohortName = reactable::colDef( + show = TRUE, + #aggregate = "unique", + name = 'Cohort', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300 + ), + cohortNameWithLink = reactable::colDef( + show = FALSE, + name = 'Cohort', + defaultSortOrder = 'asc', + sortNALast = TRUE, + filterable = TRUE, + minWidth = 300, + html = TRUE + ), + subsetCohorts = reactable::colDef( + #aggregate = "count", + html = TRUE + ), + appliedSubsets = reactable::colDef( + #aggregate = "count", + html = TRUE + ), + cleanWindow = reactable::colDef( + #aggregate = "unique", + filterable = TRUE, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('ci-out-tab', '%s', event.target.value || undefined)", name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ) + ) + return(ciColumns) +} \ No newline at end of file diff --git a/R/CohortMethod.R b/R/CohortMethod.R new file mode 100644 index 0000000..b73e825 --- /dev/null +++ b/R/CohortMethod.R @@ -0,0 +1,387 @@ +#' extractCohortMethodSettings +#' +#' @description +#' Extract cohorts from json +#' +#' @details +#' Returns a names list with the cohorts +#' +#' @param cohortMethodModuleSettings. The cohort method module specification +#' @param negativeControls NULL or a data.frame of the negative controls +#' @param cohortDefinitionDf The data.frame with the cohort definition details +#' +#' @return +#' An named R list with ... +#' +#' @export +#' +extractCohortMethodSettings <- function( + cohortMethodModuleSettings, + negativeControls, + cohortDefinitionDf + ){ + + if(!is.null(cohortMethodModuleSettings$settings$cmAnalysesSpecifications)){ + settingsCm <- cohortMethodModuleSettings$settings$cmAnalysesSpecifications + } else{ + settingsCm <- cohortMethodModuleSettings$settings + } + + # if negative controls not in share resources check for any in targetComparatorOutcomesList + if(is.null(negativeControls)){ + tcoList <- settingsCm$targetComparatorOutcomesList + cmNeg <- lapply(tcoList, function(x){ + temp <- do.call('rbind',lapply(x$outcomes, function(x2){ + dat <- data.frame( + cohortId = x2$outcomeId, + #conceptId = 'NA', + outcomeConceptId = x2$outcomeId, + outcomeOfInterest = x2$outcomeOfInterest, + priorOutcomeLookback = ifelse(is.null(x2$priorOutcomeLookback),0, x2$priorOutcomeLookback) + ) + # merge with cohortDefinitions + dat <- merge(dat, cohortDefinitionDf[,c('cohortId', 'cohortName')], by = 'cohortId') + })) + temp[!temp$outcomeOfInterest,] + } + ) + negativeControlsCM <- unique(do.call(rbind, cmNeg)) + } else{ + negativeControlsCM <- negativeControls + } + + # get tars + tars <- unique(unlist(lapply(settingsCm$cmAnalysisList, function(x) paste0('\n- (',x$createStudyPopulationArgs$startAnchor, '+' ,x$createStudyPopulationArgs$riskWindowStart, ') - (', x$createStudyPopulationArgs$endAnchor, '+' ,x$createStudyPopulationArgs$riskWindowEnd, ')')))) + + + # do the counts/processing + tcoList <- settingsCm$targetComparatorOutcomesList + cmOut <- lapply(tcoList, function(x){ + temp <- do.call('rbind',lapply(x$outcomes, function(x2){ + data.frame( + outcomeId = x2$outcomeId, + outcomeOfInterest = x2$outcomeOfInterest, + priorOutcomeLookback = ifelse(is.null(x2$priorOutcomeLookback),0, x2$priorOutcomeLookback) + ) + })) + temp[temp$outcomeOfInterest,] + } + ) + cmOutUnique <- unique(cmOut) + + cmOutId <- unlist(lapply(cmOut, function(x){which(unlist(lapply(cmOutUnique,function(y) identical(x, y)))) })) + + for(cmi in 1:length(cmOutUnique)){ + tempDf <- cohortDefinitionDf + colnames(tempDf) <- paste0(colnames(cohortDefinitionDf), 'Outcome') + cmOutUnique[[cmi]] <- merge(cmOutUnique[[cmi]], tempDf, by.x='outcomeId', by.y = 'cohortIdOutcome', all.x = T) %>% + dplyr::relocate('cohortNameOutcome') %>% + dplyr::relocate('parentNameOutcome') %>% + dplyr::relocate('priorOutcomeLookback', .after = 'cohortNameOutcome') %>% + dplyr::arrange(.data$parentNameOutcome, .data$cohortNameOutcome) + } + + + + # add cmOutId to target settings + # add outcome section per cmOutUnique + + tcCombos <- do.call(rbind,lapply(1:length(tcoList), function(x){ + nestingId <- ifelse(is.null(tcoList[[x]]$nestingCohortId), -1, tcoList[[x]]$nestingCohortId) + data.frame(tcoId = x, + targetId = tcoList[[x]]$targetId, + comparatorId = tcoList[[x]]$comparatorId, + nestingId = nestingId, + outcomeSet = paste0(" Outcome Set ", cmOutId[x], " " ) + ) + } + ) + ) + + analysisCm <- settingsCm$cmAnalysisList + + # create data.frame with T/C/O with all cohort details + tempDf <- cohortDefinitionDf + colnames(tempDf) <- paste0(colnames(cohortDefinitionDf), 'Target') + tcCombos<- merge(tcCombos, tempDf, by.x='targetId', by.y = 'cohortIdTarget', all.x = TRUE) + + tempDf <- cohortDefinitionDf + colnames(tempDf) <- paste0(colnames(cohortDefinitionDf), 'Comp') + tcCombos <- merge(tcCombos, tempDf, by.x='comparatorId', by.y = 'cohortIdComp', all.x = TRUE) + + tempDf <- rbind( + cohortDefinitionDf[, c("cohortId","cohortNameWithLink")], + c(-1, '') + ) + colnames(tempDf) <- paste0(colnames(tempDf), 'Nest') + tcCombos <- merge(tcCombos, tempDf, by.x='nestingId', by.y = 'cohortIdNest', all.x = TRUE) + + + tcCombos$sameSubset <- tcCombos$subsetIdComp == tcCombos$subsetIdTarget + + targetParentsCount <- length(unique(tcCombos[, c('parentIdTarget')])) + targetCohortCount <- length(unique(tcCombos[, c('targetId')])) + + compIds <- tcCombos %>% + dplyr::group_by(.data$targetId) %>% + dplyr::summarise( + compCount = length(unique(.data$comparatorId)) + ) + + + outcomeRange <- unlist(lapply(cmOutUnique, function(x) nrow(x))) + if(length(outcomeRange) != 1){ + outcomeRange <- paste0(' between ', min(outcomeRange), ' and ', max(outcomeRange)) + } else{ + outcomeRange <- paste0(min(outcomeRange)) + } + + + # doing excludes and negative controls + # get all the exclude covariates + excludeConcepts <- list() + + # get all the negative controls + negative <- list() + + for(i in 1:length(settingsCm$targetComparatorOutcomesList)){ + + # get the excluded concepts + excludeConcepts[[i]] <- settingsCm$targetComparatorOutcomesList[[i]]$excludedCovariateConceptIds + + outcomeCm <- data.frame( + outcomeId = unlist(lapply(settingsCm$targetComparatorOutcomesList[[i]]$outcomes, function(x) x$outcomeId)), + outcomeOfInterest = unlist(lapply(settingsCm$targetComparatorOutcomesList[[i]]$outcomes, function(x) x$outcomeOfInterest)), + priorOutcomeLookback = unlist(lapply(settingsCm$targetComparatorOutcomesList[[i]]$outcomes, function(x) ifelse(is.null(x$priorOutcomeLookback), 0, x$priorOutcomeLookback))) + ) + + #outcomes <- outcomeCm[outcomeCm$outcomeOfInterest,c('outcomeId','priorOutcomeLookback')] + negative[[i]] <- outcomeCm[!outcomeCm$outcomeOfInterest,c('outcomeId','priorOutcomeLookback')] + } + + # now process the negative list and excludeConcepts list + commonExclude <- excludeConcepts[[1]] + if(length(excludeConcepts) > 1){ + for(ind in 2:length(excludeConcepts)){ + commonExclude <- intersect(excludeConcepts[[ind]],commonExclude) + } + } + nonCommonExclude <- lapply(excludeConcepts, function(x) setdiff(x, commonExclude)) + nonCommonSets <- unique(nonCommonExclude) + nonZero <- unlist(lapply(nonCommonExclude, function(x) length(x)>0)) + if(sum(nonZero) > 0){ + excludeSetId <- unlist(lapply(nonCommonExclude, function(x) which(unlist(lapply(1:length(nonCommonSets), function(ind) identical(x, nonCommonSets[[ind]])))))) + } else{ + excludeSetId <- rep(NA, length(excludeConcepts)) + } + + commonNegativeId <- negative[[1]]$outcomeId + if(length(negative) > 1){ + for(ind in 2:length(negative)){ + commonNegativeId <- intersect(commonNegativeId, negative[[ind]]$outcomeId) + } + } + nonCommonNegative <- lapply(negative, function(x) setdiff(x$outcomeId, commonNegativeId)) + nonCommonNegSets <- unique(nonCommonNegative) + nonZero <- unlist(lapply(nonCommonNegSets, function(x) length(x)>0)) + if(sum(nonZero) > 0){ # finished here friday + negSetId <- unlist(lapply(nonCommonNegative, function(x) which(unlist(lapply(1:length(nonCommonNegSets), function(ind) identical(x, nonCommonNegSets[[ind]])))))) + } else{ + negSetId <- rep(0, length(negative)) + } + + # sets: nonCommonSets -- nonCommonNegSets + # add additional negative control and exclude set ids to tco + + # add to tcCombos + tcCombos <- merge( + tcCombos, + data.frame( + tcoId = 1:length(excludeSetId), + additionalExclusions = paste0(" View ") + ), + by = 'tcoId' + ) + + tcCombos <- merge( + tcCombos, + data.frame( + tcoId = 1:length(negSetId), + additionalNegativeControlId = paste0(" View ") + ), + by = 'tcoId' + ) + + tcCombos <- tcCombos %>% + dplyr::relocate('cohortNameWithLinkNest') %>% + dplyr::relocate('cohortNameTarget') %>% + dplyr::relocate('cohortNameComp') %>% + dplyr::relocate('parentNameTarget') %>% + dplyr::relocate('sameSubset', .after = 'cohortNameWithLinkNest') %>% + dplyr::relocate('subsetCohortsTarget', .after = 'sameSubset') %>% + dplyr::relocate('appliedSubsetsTarget', .after = 'subsetCohortsTarget') %>% + dplyr::relocate('additionalExclusions', .after = 'appliedSubsetsTarget') %>% + dplyr::relocate('additionalNegativeControlId', .after = 'additionalExclusions') %>% + dplyr::relocate('outcomeSet', .after = 'cohortNameWithLinkNest') %>% + dplyr::arrange(.data$parentNameTarget, .data$cohortNameComp, .data$cohortNameTarget) + + # extract diagnostics + diagSetting <- NULL + if('cmDiagnosticThresholds' %in% names(settingsCm)){ + diagSetting <- settingsCm$cmDiagnosticThresholds + } + + +return( + list( + + negativeControlsCM = negativeControlsCM, + tcCombos = tcCombos, + outcomeRange = outcomeRange, + compIds = compIds, + targetParentsCount = targetParentsCount, + targetCohortCount = targetCohortCount, + tars = tars, + analysisCm = analysisCm, + + cmOutUnique = cmOutUnique, + + commonExclude = commonExclude, + nonCommonSets = nonCommonSets, + commonNegativeId = commonNegativeId, + nonCommonNegSets = nonCommonNegSets, + + diagSetting = diagSetting, + + refitPsForEveryOutcome = settingsCm$refitPsForEveryOutcome, + refitPsForEveryStudyPopulation = settingsCm$refitPsForEveryStudyPopulation + + ) +) + +} + + +#' cmColDef +#' +#' @description +#' Extract cohorts from json +#' +#' @details +#' Returns a names list with the cohorts +#' +#' @param elementId An element id for the table using this column definitions (needed for the drop down selection) +#' @param colNames Optional a vector of column names to restrict to +#' +#' @return +#' A column definition list +#' +#' @export +#' +cmColDef <- function( + elementId = "cm-tc-tab", + colNames = NULL + ){ + + colDef <- list( + parentNameTarget = reactable::colDef( + name = 'Target Parent', + html = TRUE, + filterable = TRUE, + minWidth = 300 + ), + cohortNameComp = reactable::colDef( + aggregate = "count", + show = TRUE, + name = 'Comparator', + filterable = TRUE, + minWidth = 300 + ), + cohortNameTarget = reactable::colDef( + show = TRUE, + name = 'Target', + filterable = TRUE, + minWidth = 300 + ), + additionalExclusions = reactable::colDef( + html = TRUE, + filterable = TRUE + ), + additionalNegativeControlId = reactable::colDef( + html = TRUE, + filterable = TRUE + ), + sameSubset = reactable::colDef( + filterable = TRUE, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", elementId, name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + } + ), + outcomeSet = reactable::colDef( + show = TRUE, + html = TRUE + ), + subsetCohortsTarget = reactable::colDef( + show = TRUE, + html = TRUE + ), + appliedSubsetsTarget = reactable::colDef( + show = TRUE, + html = TRUE + ), + cohortNameWithLinkTarget = reactable::colDef( + show = FALSE, + name = 'Target', + html = TRUE, + filterable = TRUE + ), + cohortNameWithLinkComp = reactable::colDef( + show = FALSE, + name = 'Comparator', + html = TRUE, + filterable = TRUE + ), + cohortNameWithLinkNest = reactable::colDef( + show = TRUE, + name = 'Nesting Cohort', + html = TRUE, + filterable = TRUE + ), + nestingId = reactable::colDef(show = FALSE), + tcoId = reactable::colDef(show = FALSE), + comparatorId = reactable::colDef(show = FALSE), + targetId = reactable::colDef(show = FALSE), + subsetIdTarget = reactable::colDef(show = FALSE), + isParentTarget = reactable::colDef(show = FALSE), + parentIdTarget = reactable::colDef(show = FALSE), + subsetNameTarget = reactable::colDef(show = FALSE), + packageVersionTarget = reactable::colDef(show = FALSE), + numberSubsetOperatorsTarget = reactable::colDef(show = FALSE), + subsetIdComp = reactable::colDef(show = FALSE), + isParentComp = reactable::colDef(show = FALSE), + parentIdComp = reactable::colDef(show = FALSE), + subsetNameComp = reactable::colDef(show = FALSE), + packageVersionComp = reactable::colDef(show = FALSE), + numberSubsetOperatorsComp = reactable::colDef(show = FALSE), + cohortNameTarget = reactable::colDef(show = FALSE), + parentNameComp = reactable::colDef(show = FALSE), + subsetCohortsComp = reactable::colDef(show = FALSE), + appliedSubsetsComp = reactable::colDef(show = FALSE) + + ) + + # restrict to colNames + if(!is.null(colNames)){ + colDef <- colDef[names(colDef) %in% colNames] + } + + return(colDef) +} diff --git a/R/Helpers.R b/R/Helpers.R index 86218d2..5b75f7e 100644 --- a/R/Helpers.R +++ b/R/Helpers.R @@ -43,7 +43,7 @@ tagPrint <- function(x){ #' #' @param json The json analysis specification #' @return -#' An named R list with the elements subSetDefs, cohortIds, cohortNames and cohortDefinitions +#' An named R list with the elements subsetUnique (list of subset operators), cohortDefinitions (list of cohortDefinitions) and cohortDefinitionDf (data.frame of cohort definitions) #' #' @export #' @@ -110,18 +110,119 @@ getCohortDefinitionsFromJson <- function( cohortIds <- unlist(lapply(cohortDefinitions, function(x) x$cohortId)) cohortNames <- unlist(lapply(cohortDefinitions, function(x) x$cohortName)) + cohortNamesLink <- paste0(cohortNames, ' View') - # return subSetDefsNice (add to appendix), plus cohortIds, cohortNames and cohortDefinitions + subsetIds <- unlist(lapply(cohortDefinitions, function(x){ + if(!is.null(x$subsetDefinition)){ + ParallelLogger::convertJsonToSettings(x$subsetDefinition)$definitionId + } else{ + return(-1) + } + })) + + cohortDefinitionDf <- data.frame( + cohortName = cohortNames, + cohortNameWithLink = cohortNamesLink, + cohortId = cohortIds, + subsetId = subsetIds, + isParent = subsetIds == -1, + parentId = cohortIds, + parentName = cohortNames + ) + cohortDefinitionDf$parentId[!cohortDefinitionDf$isParent] <- (cohortDefinitionDf$cohortId - cohortDefinitionDf$subsetId)[!cohortDefinitionDf$isParent]/1000 + cohortDefinitionDf$parentName <- sapply(cohortDefinitionDf$parentId, function(x){ + paste0(cohortNames[which(x == cohortIds)], ' View') + } + ) + + # =========== SUBSETS ============ + #================================== + subsetUnique <- NULL + if(!is.null(subSetDefsNice)){ + subsetDefs <- lapply(subSetDefsNice$json, function(x) ParallelLogger::convertJsonToSettings(x)) + + subsetOps <- lapply(subsetDefs, function(x){ + x$subsetOperators + }) + + # remove name and extract cohortIds when subsetType == "CohortSubsetOperator" + subsetUnique <- subsetOps + subsetUniqueAppend <- list() + for(sind in 1:length(subsetUnique)){ + for(sind2 in 1:length(subsetUnique[[sind]])){ + subsetUnique[[sind]][[sind2]]$name <- NULL + if(subsetUnique[[sind]][[sind2]]$subsetType == 'CohortSubsetOperator'){ + subsetUnique[[sind]][[sind2]]$cohortIds <- NULL + } + } + subsetUniqueAppend <- append(subsetUniqueAppend,subsetUnique[[sind]]) + } + subsetUnique <- unique(subsetUniqueAppend) + + # now extract into a data.frame and find out which subsets were used + # get subsetId cohorts + + subsetDetails <- do.call('rbind', lapply(subsetDefs, function(x){ + data.frame( + subsetName = x$name, + subsetId = x$definitionId, + packageVersion = x$packageVersion, + #identifierExpression = x$identifierExpression, + #operatorNameConcatString = x$operatorNameConcatString, + #subsetCohortNameTemplate = x$subsetCohortNameTemplate, + numberSubsetOperators = length(x$subsetOperators) + ) + })) + + # add CohortSubsetOperator subset cohorts + subsetDetails$subsetCohorts <- unlist(lapply(subsetOps, function(x){ + paste(unlist(lapply(x, function(y){ + if(y$subsetType == 'CohortSubsetOperator'){ + if(y$negate == FALSE){ + + ytemp <- y + ytemp$name <- NULL + ytemp$cohortIds <- NULL + subsetInd <- which(unlist(lapply(subsetUnique, function(x) identical(ytemp, x)))) + + # add cohort link below + return(paste0(" View Cohort View Subset")) + } + } + return(NULL) + } + )), collapse = ',') + })) + + subsetDetails$appliedSubsets <- unlist(lapply(subsetOps, function(x){ + paste(unlist(lapply(x, function(y){ + ytemp <- y + ytemp$name <- NULL + ytemp$cohortIds <- NULL + subsetInd <- which(unlist(lapply(subsetUnique, function(x) identical(ytemp, x)))) + return(paste0(" View Subset" )) + } + )), collapse = ',') + })) + + # add subset details to cohortDefinitionDf? + cohortDefinitionDf <- merge(cohortDefinitionDf, subsetDetails, by = 'subsetId', all.x = T) + + # return: subsetUnique - a list of subset logics + # subsetDetails - a data.frame with subset details + # cohortDefinitionDf - cohort definition with subset details added + + } return(list( - subSetDefs = subSetDefsNice, - cohortIds = cohortIds, - cohortNames = cohortNames, - cohortDefinitions = cohortDefinitions + subsetUnique = subsetUnique, + cohortDefinitions = cohortDefinitions, + cohortDefinitionDf = cohortDefinitionDf )) } + #' getConcepts #' #' @description @@ -156,14 +257,59 @@ getConcepts <- function( allCodes <- conceptIds } - standard <- ROhdsiWebApi::getConcepts( + if(is.null(allCodes)){ + allCodes <- -1 + } + if(length(allCodes) == 0){ + allCodes <- -1 + } + + # wrapping in tryCatch as this can error if + # the concepts are not on this webApi + standard <- tryCatch({ROhdsiWebApi::getConcepts( conceptIds = allCodes, baseUrl = baseUrl + )}, + error = function(e){print(e); return( + data.frame( + conceptId = allCodes, + conceptName = 'None', + standardConcept = 'N', + standardConceptCaption = 'Non-Standard', + invalidReason = 'V', + invalidReasonCaption = 'madeup', + conceptCode = 'madeup', + domainId = 'empty', + vocabularyId = 'madeup', + conceptClassId = 'madeup', + validStartDate = 0, + validEndDate = 1 + ) + )} ) - source <- ROhdsiWebApi::getSourceConcepts( + # wrapping in tryCatch as this can error if + # the concepts are not on this webApi + source <- tryCatch({ROhdsiWebApi::getSourceConcepts( conceptIds = allCodes, baseUrl = baseUrl + )}, + error = function(e){print(e); return( + data.frame( + conceptId = 0, + conceptName = 'None', + standardConcept = 'N', + standardConceptCaption = 'Non-Standard', + invalidReason = 'V', + invalidReasonCaption = 'madeup', + conceptCode = 'madeup', + domainId = 'empty', + vocabularyId = 'madeup', + conceptClassId = 'madeup', + validStartDate = 0, + validEndDate = 1 + ) + )} ) return(list( @@ -174,6 +320,40 @@ getConcepts <- function( } +#' getNegativeControlsFromJson +#' +#' @description +#' Extract cohorts from json +#' +#' @details +#' Returns a names list with the cohorts +#' +#' @param json The json analysis specification +#' @return +#' A data.frame with the negative control details or NULL if no negative controls +#' +#' @export +#' +getNegativeControlsFromJson <- function(json){ + negativeControls <- NULL + if("negativeControlOutcomes" %in% unlist(lapply(json$sharedResources, function(x) names(x)))){ + + negativeControlInd <- which(unlist(lapply(json$sharedResources, function(x) "negativeControlOutcomes" %in% names(x)))) + + negativeControlsTemp <- json$sharedResources[[negativeControlInd]]$negativeControlOutcomes + + negativeControls <- as.data.frame(do.call(rbind,lapply(negativeControlsTemp$negativeControlOutcomeCohortSet, function(x) x))) + + negativeControls$occurrenceType <- negativeControlsTemp$occurrenceType + negativeControls$detectOnDescendants <- negativeControlsTemp$detectOnDescendants + + } + + return(negativeControls) +} + + + #' getFunctionFromArgName #' @@ -195,7 +375,9 @@ getFunctionFromArgName <- function( argumentName ){ - argumentName <- gsub('Args','', argumentName) + #argumentName <- gsub('Args','', argumentName) + # change for new CM + argumentName <- paste0('create',toupper(substring(argumentName, 1, 1)), substring(argumentName, 2)) packageFunctions <- gsub('.Rd','',names(tools::Rd_db(package))) result <- packageFunctions[unlist(lapply(packageFunctions, function(x) length(grep(argumentName, x))>0))] @@ -236,21 +418,24 @@ getHelpText <- function( if(is.null(input)){ - + val <- paste0( "^.*description\\{\\s*|\\s*", - #"\\}.*$" - "\n\\}.*$" + "\\}.*$" # editing from "\n\\}.*$" ) desc <- gsub(val, '', textOfInt) return(desc) } + #val <- paste0( + # "^.*item\\{",input,"\\}\\{\\s*|\\s*", + # "\\}\n\n.*$" + #) + val <- paste0( "^.*item\\{",input,"\\}\\{\\s*|\\s*", - #"\\}.*$" - "\\}\n\n.*$" + "\\}\n.*$" ) desc <- gsub(val, '', textOfInt) @@ -395,20 +580,75 @@ listToDf <- function( valueName = 'value' ){ + saveRDS(settings, '/Users/jreps/Documents/GitHub/ProtocolGenerator/settings.rds') + settings <- readRDS('/Users/jreps/Documents/GitHub/ProtocolGenerator/settings.rds') # convert vectors to char nameSet <- names(settings) - convertToChar <- sapply(nameSet, function(x) length(settings[[x]]) > 1 & !inherits(settings[[x]], 'list')) + valueSet <- settings + convertToChar <- sapply(nameSet, function(x) length(settings[[x]]) > 1) + if(sum(convertToChar) > 0){ - settings[convertToChar] <- as.character(settings[convertToChar]) + listNames <- names(convertToChar)[convertToChar] + + # remove the lists from valueSet and nameSet + listSettings <- list() + for(listName in listNames){ + + # replace NULLs with "NULL" + tempSettings <- settings[listName][[1]] + if(!is.list(tempSettings)){ + tempSettings <- list(val = paste(tempSettings, collapse = ',')) + names(tempSettings) <- listName + listSettings[[length(listSettings)+1]] <- tempSettings + } else{ + nullInds <- which(unlist(lapply(tempSettings, function(x) is.null(x)))) + if(length(nullInds) > 0){ + for(nullInd in nullInds){ + tempSettings[[nullInd]] <- "NULL" + } + } + names(tempSettings) <- paste0(listName,'.',names(tempSettings)) + listSettings[[length(listSettings)+1]] <- tempSettings + } + + valueSet[listName] <- NULL + nameSet <- nameSet[!nameSet %in% listName] + } + + # now add the list values + for(listSetting in listSettings){ + # convert lists to json string + listInds <- which(unlist(lapply(listSetting, function(x) is.list(x)))) + if(length(listInds) > 0){ + for(listInd in listInds){ + listSetting[[listInd]] <- as.character(ParallelLogger::convertSettingsToJson(listSetting[[listInd]])) + } + } + + nameSet <- c(nameSet,names(unlist(listSetting))) + valueSet <- c(valueSet,unlist(listSetting)) + } } - values <- unlist(settings) - names <- names(values) + #if(sum(convertToChar) > 0){ + # settings[convertToChar] <- as.character(unlist(settings[convertToChar])) + #} + + #values <- unlist(settings) + #names <- names(values) + + # replace NULL or c() values with "" + noVals <- sapply(valueSet, length) + if(sum( noVals == 0) > 0){ + for(ind in which(noVals == 0)){ + valueSet[ind] <- "" + } + } df <- data.frame( - input = unlist(lapply(strsplit(names, '\\.'), function(x) x[1])), - level2 = unlist(lapply(strsplit(names, '\\.'), function(x) ifelse(is.na(x[2]), " ", x[2]))), - value = values, + input = unlist(lapply(strsplit(nameSet, '\\.'), function(x) x[1])), + level2 = unlist(lapply(strsplit(nameSet, '\\.'), function(x) ifelse(is.na(x[2]), " ", x[2]))), + value = unlist(valueSet), row.names = NULL ) @@ -531,16 +771,20 @@ getSettingsTable <- function( functionName ) - settingsDf <- listToDf( - settings, - valueName = 'value' + if(is.null(settings)){ + settingsDf <- listToDf(list(isNUll = 'NULL')) + } else{ + settingsDf <- listToDf( + settings, + valueName = 'value' ) + } completeTb <- merge( descAndDefault, settingsDf, by = c('input', 'level2'), - all.y = T + all.y = TRUE ) # check whether defaultValue = value @@ -619,22 +863,56 @@ reportTableFormat <- function( groupBy = NULL, columns = NULL, elementId = NULL, - caption + caption, + groupByButton = FALSE ){ - reactable::reactable( - data = table, - groupBy = groupBy, - striped = T, - searchable = T, - resizable = T, - defaultPageSize = 5, - showPageSizeOptions = T, - showSortIcon = T, - columns = columns, - rownames = F, - elementId = elementId - ) + if(groupByButton){ + shiny::tagList( + shiny::tags$button( + "Group/Ungroup", + # 2. JavaScript call: toggleGroupBy('table-id', 'column-name') + onclick = paste0("Reactable.toggleGroupBy('",elementId,"', '",groupBy,"')"), + style = " + background-color: #0f72db; + color: white; + border: none; + padding: 2px 5px; + border-radius: 5px; + cursor: pointer; + transition: background-color 0.3s ease; + " + ), + + reactable::reactable( + data = table, + groupBy = groupBy, + striped = TRUE, + searchable = TRUE, + resizable = TRUE, + defaultPageSize = 5, + showPageSizeOptions = TRUE, + showSortIcon = TRUE, + columns = columns, + rownames = FALSE, + elementId = elementId + ) + ) + } else{ + reactable::reactable( + data = table, + groupBy = groupBy, + striped = T, + searchable = T, + resizable = T, + defaultPageSize = 5, + showPageSizeOptions = T, + showSortIcon = T, + columns = columns, + rownames = F, + elementId = elementId + ) + } } @@ -671,6 +949,7 @@ formatCovariateSettings <- function( inds <- c( grep('Demographics', names(tempSettings)), grep('Drug', names(tempSettings)), + grep('Device', names(tempSettings)), grep('Visit', names(tempSettings)), grep('Condition', names(tempSettings)), grep('Procedure', names(tempSettings)), @@ -684,6 +963,10 @@ formatCovariateSettings <- function( } else if(attr(tempSettings,"fun") == "getDbCohortBasedCovariatesData"){ fun <- 'createCohortBasedCovariateSettings' package <- 'FeatureExtraction' + tempSettings$covariateCohorts <- paste0(sort(tempSettings$covariateCohorts$cohortName), collapse = ' , ') + } else if(attr(tempSettings,"fun") == "Characterization::getDbDuringCovariateData"){ + fun <- 'getDbDuringCovariateData' + package <- 'Characterization' } else{ fun <- attr(tempSettings,"fun") package <- '' diff --git a/R/PatientLevelPrediction.R b/R/PatientLevelPrediction.R new file mode 100644 index 0000000..be06f06 --- /dev/null +++ b/R/PatientLevelPrediction.R @@ -0,0 +1,152 @@ +#' getPlpSettings +#' +#' @description +#' Extract plp tables and settings from json +#' +#' @details +#' Returns a names list with the tables and settings +#' +#' @param PatientLevelPredictionModuleSettings The patient level prediction module specification +#' @param cohortDefinitionDf The data.frame with the cohort definition details +#' +#' @return +#' An named R list with ... +#' +#' @export +#' +getPlpSettings <- function( + PatientLevelPredictionModuleSettings, + cohortDefinitionDf +){ + + tos <- data.frame( + targetId = unlist(lapply(PatientLevelPredictionModuleSettings$settings$modelDesignList, function(x) x$targetId)), + outcomeId = unlist(lapply(PatientLevelPredictionModuleSettings$settings$modelDesignList, function(x) x$outcomeId)) + ) + + # add names, parents, subset info for t and o + tempDf <- cohortDefinitionDf + colnames(tempDf) <- paste0(colnames(tempDf),'Target') + tos <- merge(tempDf, tos, by.x = 'cohortIdTarget', by.y = 'targetId') + tempDf <- cohortDefinitionDf + colnames(tempDf) <- paste0(colnames(tempDf),'Outcome') + tos <- merge(tempDf, tos, by.x = 'cohortIdOutcome', by.y = 'outcomeId') + + + # remove T and O from model designs and get unique + # may need to also remove seed from split? + modelDesign <- PatientLevelPredictionModuleSettings$settings$modelDesignList + for(i in 1:length(modelDesign)){ + modelDesign[[i]]$targetId <- NULL + modelDesign[[i]]$outcomeId <- NULL + } + modelDesignUnique <- unique(modelDesign) + + tos$designId <- rep(0, length(modelDesign)) + for(j in 1:length(modelDesignUnique)){ + tos$designId[which(unlist(lapply(modelDesign, function(x) identical(modelDesignUnique[[j]], x))))] <- j + } + + # covariate set - get attr(,"fun") + covSet <- c() + for(cind in 1:length(modelDesignUnique)){ + if(class(modelDesignUnique[[cind]]$covariateSettings) == 'covariateSettings'){ + modelDesignUnique[[cind]]$covariateSettings <- list(modelDesignUnique[[cind]]$covariateSettings) + } + + covSet <- c(covSet,paste0(unlist(lapply(modelDesignUnique[[cind]]$covariateSettings, function(x){ + func <- attr(x, "fun") + settings <- x[sapply(x, function(x) is.logical(x))] + if(length(settings)>0){ + settings <- names(settings)[unlist(settings)] + func <- paste0(c(func, paste0(settings, collapse = ',')), collapse = ': ') + } + return(func) + })), collapse = ' - ')) + + } + + # TODO remove this or revise? - add covariate summary name? + predictionSummary <- data.frame( + model_design = paste0(" View "), + number_targets = unlist(lapply(1:length(modelDesignUnique), function(x){length(unique(tos$parentIdTarget[tos$designId == x]))})), + number_targets_with_subsets = unlist(lapply(1:length(modelDesignUnique), function(x){length(unique(tos$cohortIdTarget[tos$designId == x]))})), + number_outcomes = unlist(lapply(1:length(modelDesignUnique), function(x){length(unique(tos$parentIdOutcome[tos$designId == x]))})), + number_outcomes_with_subsets = unlist(lapply(1:length(modelDesignUnique), function(x){length(unique(tos$cohortIdOutcome[tos$designId == x]))})), + timeAtRisk = paste0( + unlist(lapply(modelDesignUnique , function(x) x$populationSettings$startAnchor)), + ' + ', + unlist(lapply(modelDesignUnique, function(x) x$populationSettings$riskWindowStart)), + ' - ', + unlist(lapply(modelDesignUnique, function(x) x$populationSettings$endAnchor)), + ' + ', + unlist(lapply(modelDesignUnique, function(x) x$populationSettings$riskWindowEnd)) + ), + covariates = covSet + ) + + return( + list( + targetOutcomeSet = tos, + modelDesignUnique = modelDesignUnique, + predictionSummary = predictionSummary + ) + ) + +} + + +#' getPlpColDefs +#' +#' @description +#' create colDefs for prediction table +#' +#' @details +#' Returns a names list with the cohorts +#' +#' +#' @return +#' A column definition list +#' +#' @export +#' +getPlpColDefs <- function(){ + res <- list( + model_design = reactable::colDef( + html = TRUE, + name = 'Model Design' + ), + number_targets = reactable::colDef( + name = 'Parent Target Count' + ), + number_targets_with_subsets = reactable::colDef( + name = 'Target Count' + ), + number_outcomes = reactable::colDef( + name = 'Parent Outcome Count' + ), + number_outcomes_with_subsets = reactable::colDef( + name = 'Outcome Count' + ), + timeAtRisk = reactable::colDef( + name = 'Time-at-risk', + width = 200 + ), + covariates = reactable::colDef( + name = 'Covariate Set', + width = 300, + cell = function(value) { + # Truncate to 20 characters and optionally add '...' + paste0(substr(value, 1, 50), '...') + }#, + # Define what shows when expanded + #details = function(index) { + # shiny::div(style = "padding: 10px;", data$covariates[index]) + #} + ) + + ) + + return(res) +} + diff --git a/R/SelfControlCaseSeries.R b/R/SelfControlCaseSeries.R new file mode 100644 index 0000000..0912b07 --- /dev/null +++ b/R/SelfControlCaseSeries.R @@ -0,0 +1,264 @@ +#' getSccsSettings +#' +#' @description +#' Extract exposure/outcomes of interest, shared and analysis specific negative controls, diagnostic settings and analysis settings +#' +#' @details +#' Returns a list of tables and settings +#' +#' @param SelfControlledCaseSeriesModuleSettings The self controlled case series module specification +#' @param cohortDefinitionDf The data.frame with the cohort definition details +#' @param negativeControls The shared negative controls from the json spec +#' +#' @return +#' A list with the tables to display +#' +#' @export +#' +getSccsSettings <- function( + SelfControlledCaseSeriesModuleSettings, + cohortDefinitionDf, + negativeControls +){ + + if(!is.null(SelfControlledCaseSeriesModuleSettings$settings$sccsAnalysesSpecifications)){ + sccsSettings <- SelfControlledCaseSeriesModuleSettings$settings$sccsAnalysesSpecifications + } else{ + sccsSettings <- SelfControlledCaseSeriesModuleSettings$settings + } + + eo <- do.call( + what = rbind, + args = lapply( + X = 1:length(sccsSettings$exposuresOutcomeList), + FUN = function(k){ + x <- sccsSettings$exposuresOutcomeList[[k]] + data.frame( + setting = ifelse(is.null(x$jsonId), 1, x$jsonId), #k, + outcomeId = rep(x$outcomeId, length(x$exposures)), + exposureId = unlist(lapply(x$exposures, function(x){x$exposureId})), + exposureIdRef = unlist(lapply(x$exposures, function(x){paste0(x$exposureIdRef)})), + nestingId = ifelse(is.null(x$nestingCohortId), -1, x$nestingCohortId), + trueEffectSize = unlist(lapply(x$exposures, function(x){ifelse(is.null(x$trueEffectSize), '', x$trueEffectSize )})) + ) + + } + ) + ) + + # ===== NEW FOR COHORT NEGATIVE CONTROLS + # add code to extract negative controls if missing + if(is.null(negativeControls)){ + # create negative control data.frame using the exposure outcomes with trueEffectSize == 1 + neg <- do.call( + what = rbind, + args = lapply( + X = 1:length(sccsSettings$exposuresOutcomeList), + FUN = function(k){ + x <- sccsSettings$exposuresOutcomeList[[k]] + data.frame( + cohortId = rep(x$outcomeId, length(x$exposures)), + outcomeConceptId = rep(x$outcomeId, length(x$exposures)), + occurrenceType = 'Cohort', + detectOnDescendants = 'NA', + trueEffectSize = unlist(lapply(x$exposures, function(x){ifelse(is.null(x$trueEffectSize), '', x$trueEffectSize )})) + ) + } + ) + ) + + neg <- unique(neg[neg$trueEffectSize == 1,]) + negativeControlsSCCS <- merge(neg, cohortDefinitionDf[,c('cohortId', 'cohortName')], by = 'cohortId') + } else{ + negativeControlsSCCS <- negativeControls + } + # ===== END NEW FOR COHORT NEGATIVE CONTROLS + + # Should we unique? + eoUnique <- eo + #eoUnique <- unique(eo) + + # add in the target and indication parents + tempDf <- cohortDefinitionDf + colnames(tempDf) <- paste0(colnames(tempDf), 'Target') + eoUnique <- merge(eoUnique, tempDf, by.x = 'exposureId', by.y = 'cohortIdTarget') + tempDf <- cohortDefinitionDf[, c('cohortId', 'parentName', 'cohortNameWithLink','cohortName')] + colnames(tempDf) <- paste0(colnames(tempDf), 'Indication') + eoUnique <- merge(eoUnique, tempDf, by.x = 'nestingId', by.y = 'cohortIdIndication', + all.x = TRUE) + + + # figure out unique negative controls vs shared + neo <- eoUnique[eoUnique$trueEffectSize == 1 & eoUnique$exposureId != -1,] + + # set defaults when there are no negative controls + negInCommon <- NULL + negNotInCommon <- NULL + + negTabShared <- NULL + negTab <- NULL + + if(nrow(neo) > 0 ){ #if any negative outcomes + settings <- unique(neo$setting) + negInCommon <- neo$outcomeId[neo$setting == settings[1]] + for(ngi in 1:length(settings)){ + negInCommon <- intersect(negInCommon, neo$outcomeId[neo$setting == settings[ngi]]) + } + negNotInCommon <- neo[!neo$outcomeId %in% negInCommon,] + + # if all analyses shared the same negative controls + if(nrow(negNotInCommon) == 0){ + #eo$setting <- 0 + eoUnique <- eoUnique %>% dplyr::select(-'setting') + } + + if(length(negInCommon)>0){ + negTabShared <- do.call( + what = rbind, + args = lapply( + X = negInCommon, + FUN = function(x){negativeControlsSCCS[negativeControlsSCCS$cohortId == x,]} + ) + ) + + negTabShared <- negTabShared %>% + dplyr::mutate(outcomeName = paste(.data$cohortName, '(concept/cohort: ',.data$outcomeConceptId,')')) %>% + dplyr::select(-c("cohortId","cohortName","outcomeConceptId")) + + } #end if length(negInCommon)>0 + + + # add the setting + if(length(negNotInCommon$outcomeId)>0){ + negTab <- do.call( + what = rbind, + args = lapply( + X = negNotInCommon$outcomeId, + FUN = function(x){negativeControlsSCCS[negativeControlsSCCS$cohortId == x,]} + ) + ) + negTab$cohortId <- unlist(negTab$cohortId) + negTab <- merge( + x = negTab, + y = negNotInCommon[,c('outcomeId', 'setting','exposureId')], + by.x = 'cohortId', + by.y = 'outcomeId' + ) + + tempDf <- cohortDefinitionDf[, c('parentName','cohortName', 'cohortId')] + colnames(tempDf) <- paste0(colnames(tempDf),'Target') + negTab <- merge(negTab, tempDf, by.x = 'exposureId', by.y = 'cohortIdTarget') + + negTab <- negTab %>% + dplyr::mutate(outcomeName = paste(.data$cohortName, '(concept: ',.data$outcomeConceptId,')')) %>% + dplyr::select(-c("cohortId","cohortName","outcomeConceptId")) + + } # end Negtab + + } # end if any negative outcomes + + eoOfInt <- unique(eoUnique[eoUnique$trueEffectSize == '' & eoUnique$exposureId != -1,]) + tempDf <- cohortDefinitionDf + colnames(tempDf) <- paste0(colnames(tempDf), 'Outcome') + eoOfInt <- merge(eoOfInt, tempDf, by.x = 'outcomeId', by.y = 'cohortIdOutcome') %>% + dplyr::arrange(.data$parentNameTarget, .data$cohortNameIndication, .data$cohortNameOutcome) + + + return( + list( + sccsAnalysisList = sccsSettings$sccsAnalysisList, + sccsDiagnosticThresholds = sccsSettings$sccsDiagnosticThresholds, + eoOfInt = eoOfInt, + negTabShared = negTabShared, + negTab = negTab + ) + ) +} + + +#' getSccsColDefs +#' +#' @description +#' Create col defs for SCCS +#' +#' @details +#' Returns a named list of colDefs +#' +#' +#' @return +#' A column definition list +#' +#' @export +#' +getSccsColDefs <- function(){ + res <- list( + outcomeId = reactable::colDef(show = FALSE), + exposureId = reactable::colDef(show = FALSE), + nestingId = reactable::colDef(show = FALSE), + + subsetIdTarget = reactable::colDef(show = FALSE), + isParentTarget = reactable::colDef(show = FALSE), + parentIdTarget = reactable::colDef(show = FALSE), + subsetNameTarget = reactable::colDef(show = FALSE), + packageVersionTarget = reactable::colDef(show = FALSE), + numberSubsetOperatorsTarget = reactable::colDef(show = FALSE), + + subsetIdOutcome = reactable::colDef(show = FALSE), + isParentOutcome = reactable::colDef(show = FALSE), + parentIdOutcome = reactable::colDef(show = FALSE), + subsetNameOutcome = reactable::colDef(show = FALSE), + packageVersionOutcome = reactable::colDef(show = FALSE), + numberSubsetOperatorsOutcome = reactable::colDef(show = FALSE), + + cohortNameTarget = reactable::colDef( + show = TRUE, + name = 'Exposure', + html = TRUE, + filterable = TRUE + ), + cohortNameOutcome = reactable::colDef( + name = 'Outcome', + html = TRUE, + filterable = TRUE + ), + cohortNameIndication = reactable::colDef( + name = 'Indication', + html = TRUE, + filterable = TRUE + ), + + parentNameOutcome = reactable::colDef(show = FALSE), + parentNameIndication = reactable::colDef(show = FALSE), + + subsetCohortsTarget = reactable::colDef(show = FALSE), + subsetCohortsOutcome = reactable::colDef(show = FALSE), + appliedSubsetsTarget = reactable::colDef(show = FALSE), + appliedSubsetsOutcome = reactable::colDef(show = FALSE), + + parentNameTarget = reactable::colDef( + name = 'Exposure Parent', + html = TRUE, + filterable = TRUE + ), + + cohortNameWithLinkTarget = reactable::colDef( + show = FALSE, + name = 'Exposure', + html = TRUE, + filterable = TRUE + ), + cohortNameWithLinkOutcome = reactable::colDef( + show = FALSE, + name = 'Outcome', + html = TRUE, + filterable = TRUE + ), + cohortNameWithLinkIndication = reactable::colDef( + show = FALSE, + name = 'Indication', + html = TRUE, + filterable = TRUE + ) + ) + return(res) +} diff --git a/inst/protocol/characterization.qmd b/inst/protocol/characterization.qmd index 6cefdd4..f02b897 100644 --- a/inst/protocol/characterization.qmd +++ b/inst/protocol/characterization.qmd @@ -4,418 +4,340 @@ output: html_document ```{r, echo=FALSE, results = 'asis', include=FALSE} -aggSpec <- CharacterizationModuleSettings$settings$analysis$aggregateCovariateSettings - -caSettings <- lapply(aggSpec, function(x) list( - covariateSettings = x$covariateSettings, - caseCovariateSettings = x$caseCovariateSettings, - casePreTargetDuration = x$casePreTargetDuration, - casePostOutcomeDuration = x$casePostOutcomeDuration, - extractNonCaseCovariates = x$extractNonCaseCovariates - )) -caSettingsUnique <- unique(caSettings) -numSettings <- length(caSettingsUnique) - -tSets <- lapply(aggSpec, function(x) data.frame( -targetId = x$targetIds, -minPriorObservation = x$minPriorObservation -)) -tSetsUnique <- unique(tSets) - -settingIdentifier <- rep(0, length(tSets)) -for(setInd in 1:length(tSetsUnique)){ - settingIdentifier[which(unlist(lapply(tSets, function(x) identical(x, tSetsUnique[[setInd]]))))] <- setInd -} +# get the settings - each results a data.frame: tableData and a settings json list: settingsJson -# if targets are the same - just extract outcomes and plot T table and O table sep -# else plot combined table -if(length(tSetsUnique) == 1){ - sepT <- TRUE - - # create target table -tempDf <- cohortDefintionDf -colnames(tempDf) <- paste0(colnames(tempDf), 'Target') -targetDf <- merge(tSetsUnique[[1]], tempDf, by.x = 'targetId', by.y = 'cohortIdTarget') -targetDf$setting <- paste0("Setting 1") - -# order the columns -targetDf <- targetDf %>% - dplyr::relocate("cohortNameTarget") %>% - dplyr::relocate("parentNameTarget") %>% - dplyr::relocate("minPriorObservation", .after = "cohortNameTarget") %>% - dplyr::relocate("setting", .after = dplyr::last_col()) - - countParents <- length(unique(targetDf$parentIdTarget)) - countTarget <- length(unique(targetDf$targetId)) - -# create the outcome table - caAllDf <- do.call('rbind', lapply( - aggSpec, function(x){ - res <- data.frame( - outcomeId = x$outcomeIds - ) - res$outcomeWashoutDays <- x$outcomeWashoutDays - res$tar <- paste0('(', - x$startAnchor, '+', x$riskWindowStart, - ')-(', - x$endAnchor, '+', x$riskWindowEnd - ,')') - return(res) - } -)) -caAllDf <- unique(caAllDf) -tempDf <- cohortDefintionDf -colnames(tempDf) <- paste0(colnames(tempDf), 'Outcome') -caAllDf <- merge(caAllDf, tempDf, by.x = 'outcomeId', by.y = 'cohortIdOutcome') +globalSetings <- ProtocolGenerator:::globalCharacterizationSettings( + CharacterizationModuleSettings = CharacterizationModuleSettings +) +targetBaseline <- ProtocolGenerator:::processTargetBaseineSettings( + CharacterizationModuleSettings = CharacterizationModuleSettings, + cohortDefinitionDf = cohortDefinitionDf + ) +riskFactor <- ProtocolGenerator:::processRiskFactorSettings( + CharacterizationModuleSettings = CharacterizationModuleSettings, + cohortDefinitionDf = cohortDefinitionDf + ) +caseSeries <- ProtocolGenerator:::processCaseSeriesSettings( + CharacterizationModuleSettings = CharacterizationModuleSettings, + cohortDefinitionDf = cohortDefinitionDf + ) -groupByOutcomes <- c('parentNameOutcome') +# summary detaisls +numTbSettings <- length(targetBaseline$settingsJson) +numRfSettings <- length(riskFactor$settingsJson) +numCsSettings <- length(caseSeries$settingsJson) +countTbParents <- length(unique(targetBaseline$tableData$parentId)) +countRfParents <- length(unique(riskFactor$targetData$parentIdTarget)) +countCsParents <- length(unique(caseSeries$targetData$parentIdTarget)) +countTbTarget <- length(unique(targetBaseline$tableData$targetId)) +countRfTarget <- length(unique(riskFactor$targetData$targetId)) +countCsTarget <- length(unique(caseSeries$targetData$targetId)) -caAllDf <- caAllDf %>% - dplyr::relocate("cohortNameOutcome") %>% - dplyr::relocate("parentNameOutcome") %>% - dplyr::relocate("outcomeWashoutDays", .after = "cohortNameOutcome") %>% - dplyr::relocate("tar", .after = "outcomeWashoutDays") +countRfOutcomeParents <- length(unique(unlist(lapply(riskFactor$outcomeDataList, function(x) x$parentIdOutcome)))) +countRfOutcome <- length(unique(unlist(lapply(riskFactor$outcomeDataList, function(x) x$outcomeId)))) +countCsOutcomeParents <- length(unique(unlist(lapply(caseSeries$outcomeDataList, function(x) x$parentIdOutcome)))) +countCsOutcome <- length(unique(unlist(lapply(caseSeries$outcomeDataList, function(x) x$outcomeId)))) -} else{ - sepT <- FALSE -# get targetIds,minPriorObservation, outcomeIds,outcomeWashoutDays, -#. tar: riskWindowStart, startAnchor, riskWindowEnd, endAnchor - -caAllDf <- do.call('rbind', lapply( - 1:length(aggSpec), function(ind){ - x <- aggSpec[[ind]] - res <- expand.grid( - targetId = x$targetIds, - outcomeId = x$outcomeIds - ) - - res$minPriorObservation <- x$minPriorObservation - res$outcomeWashoutDays <- x$outcomeWashoutDays - res$tar <- paste0('(', - x$startAnchor, '+', x$riskWindowStart, - ')-(', - x$endAnchor, '+', x$riskWindowEnd - ,')') - res$setting <- paste0("Setting ",settingIdentifier[ind],"") - return(res) - } -)) -caAllDf <- unique(caAllDf) - -# now add target and outcome names and details -tempDf <- cohortDefintionDf -colnames(tempDf) <- paste0(colnames(tempDf), 'Target') -caAllDf <- merge(caAllDf, tempDf, by.x = 'targetId', by.y = 'cohortIdTarget') -tempDf <- cohortDefintionDf -colnames(tempDf) <- paste0(colnames(tempDf), 'Outcome') -caAllDf <- merge(caAllDf, tempDf, by.x = 'outcomeId', by.y = 'cohortIdOutcome') %>% - dplyr::arrange(.data$parentNameTarget,.data$cohortNameTarget) - -groupByOutcomes <- c('parentNameTarget', 'parentNameOutcome') - -caAllDf <- caAllDf %>% - dplyr::relocate("cohortNameTarget") %>% - dplyr::relocate("parentNameTarget") %>% - dplyr::relocate("cohortNameOutcome", .after = "cohortNameTarget") %>% - dplyr::relocate("minPriorObservation", .after = "cohortNameTarget") %>% - dplyr::relocate("outcomeWashoutDays", .after = "cohortNameOutcome") %>% - dplyr::relocate("tar", .after = "outcomeWashoutDays") %>% - dplyr::relocate("setting", .after = dplyr::last_col()) - - countParents <- length(unique(caAllDf$parentIdTarget)) - countTarget <- length(unique(caAllDf$targetId)) +cColumns <- ProtocolGenerator:::characterizationColDef() -} - -cColumns <- list( - subsetIdTarget = reactable::colDef(show = F), - subsetIdOutcome = reactable::colDef(show = F), - isParentTarget = reactable::colDef(show = F), - isParentOutcome = reactable::colDef(show = F), - parentIdTarget = reactable::colDef(show = F), - parentIdOutcome = reactable::colDef(show = F), - subsetNameTarget = reactable::colDef(show = F), - subsetNameOutcome = reactable::colDef(show = F), - packageVersionTarget = reactable::colDef(show = F), - packageVersionOutcome = reactable::colDef(show = F), - numberSubsetOperatorsTarget = reactable::colDef(show = F), - numberSubsetOperatorsOutcome = reactable::colDef(show = F), - - subsetId = reactable::colDef(show = F), - isParent = reactable::colDef(show = F), - parentId = reactable::colDef(show = F), - subsetName = reactable::colDef(show = F), - packageVersion = reactable::colDef(show = F), - numberSubsetOperators = reactable::colDef(show = F), - - cohortIdTarget = reactable::colDef(show = F), - cohortIdOutcome = reactable::colDef(show = F), - targetId = reactable::colDef(show = F), - outcomeId = reactable::colDef(show = F), - - tar = reactable::colDef( - aggregate = "unique", - name = 'Time at risk', - filterable = TRUE, - minWidth = 150 - ), - outcomeWashoutDays = reactable::colDef( - aggregate = "unique", - name = 'Outcome Washout (Days)', - filterable = TRUE - ), - minPriorObservation = reactable::colDef( - aggregate = "unique", - name = 'Prior Obs (days)', - filterable = TRUE - ), - parentName = reactable::colDef( - name = 'Parent Cohort', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300, - html = TRUE - ), - parentNameTarget = reactable::colDef( - name = 'Parent Target', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300, - html = TRUE - ), - parentNameOutcome = reactable::colDef(name = 'Parent Outcome', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300, - html = TRUE - ), - - cohortNameTarget = reactable::colDef( - aggregate = "unique", - show = TRUE, - name = 'Target', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300 - ), - cohortNameWithLinkTarget = reactable::colDef( - show = FALSE, - name = 'Cohort', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300, - html = TRUE - ), - cohortNameOutcome = reactable::colDef( - show = TRUE, - aggregate = "unique", - name = 'Outcome', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300 - ), - cohortNameWithLinkOutcome = reactable::colDef( - show = FALSE, - name = 'Outcome', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300, - html = TRUE - ), - cohortNameWithLink = reactable::colDef( - show = FALSE, - name = 'Cohort', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300, - html = TRUE - ), - - cohortName = reactable::colDef( - show = TRUE, - aggregate = "unique", - name = 'Cohort', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300 - ), - cohortId = reactable::colDef(show = F), - - subsetCohortsTarget = reactable::colDef( - html = TRUE, - aggregate = "count" - ), - subsetCohorts = reactable::colDef( - html = TRUE, - aggregate = "count" - ), - subsetCohortsOutcome = reactable::colDef( - html = TRUE, - aggregate = "count" - ), - - appliedSubsetsTarget = reactable::colDef( - html = TRUE, - aggregate = "count" - ), - appliedSubsetsOutcome= reactable::colDef(show = FALSE), - appliedSubsets = reactable::colDef( - html = TRUE, - aggregate = "count" - ), - - setting = reactable::colDef( - html = TRUE, - aggregate = "count" - ) - ) +``` +## Characterization +::: {.callout-important collapse="false"} +# Global settings +```{r, echo=FALSE, results = 'asis'} +cat('\n') +cat(globalSetings) +cat('\n') ``` +::: -## Characterization +### Target baseline characterization +::: {.callout-important collapse="false"} +# Summary of target baseline +Aggregate baseline covariate summaries are computed for each specified target population—defined as the first exposure of a target cohort within `limitToFirstInNDays` days and with at least `minPriorObservation` days of prior observation. For each covariate we report sample size, means and standard deviations (or medians and IQRs, where appropriate) for continuous variables, and counts and proportions for categorical/binary variables. -### Aggregate Covariates +The analysis is performed across ``r countTbParents `` unique parent targets (``r countTbTarget `` unique target subsets) see @sec-char-tb-targets. There are ``r numTbSettings`` unique covariate settings @sec-char-tb-settings. +::: -Aggregate covariates analysis executes three different types of characterization: +```{r, echo=FALSE, results = 'asis'} -**1. Target with and without outcome during TAR characterization** +if(!is.null(targetBaseline)){ + +cat("#### Targets {#sec-char-tb-targets}\n\n") -Differences in covariate mean values between the target population with the outcome during a time-at-risk (TAR) and the target population without the outcome during TAR will be run for all combinations or targets population, outcomes and TAR specified in the settings. The results return the mean covariate value (for binary covariates this corresponds to the frequency of the covariate) for patients in the target population, for patients with the outcome, for patients in the target population with the outcome during the TAR and for patients in the target population without the outcome during the TAR. The standardized mean difference (mean in group 1 - mean in group 2) divided by the standard deviation is calculated for the target population with the outcome and the target population without the outcome during TAR as this shows covariates that are associated to having the outcome during TAR (risk factors). + cat('\n::: {.callout-important collapse="true"}') + cat('\n# Targets used in target baseline\n') + print(shiny::tagList( + ProtocolGenerator::reportTableFormat( + table = targetBaseline$tableData, + groupBy = 'parentNameTarget', + elementId = 'tb-targets', + groupByButton = TRUE, + columns = cColumns[names(cColumns) %in% colnames(targetBaseline$tableData)] + ))) + cat('\n:::\n') + + tbTargets <- unique(targetBaseline$tableData$targetId) -For more details see [here](https://ohdsi.github.io/Characterization/articles/Specification.html#risk-factor-analysis) for risk factor analysis and [here](https://ohdsi.github.io/Characterization/articles/Specification.html#aggregate-covariates) for the mean covariate analysis for the target and outcome cohorts. +cat('\n') +cat('\n#### Settings {#sec-char-tb-settings}\n\n') +for(settingInd in 1:length(targetBaseline$settingsJson)){ +# Global settings + cat(paste0('\n\n##### Settings ', settingInd, '{#sec-char-tb-setting-',settingInd,'}')) + cat('\n\n') + + tbSettings <- ParallelLogger::convertJsonToSettings(targetBaseline$settingsJson[[settingInd]]) + covariateDetails <- formatCovariateSettings(tbSettings) -**2. Case series** -Aggregate covariate details are calculated for the cases (target population with the outcome during a time-at-risk) at three different time points: + cat('\n::: {.callout-important collapse="true"}') + cat('\n# Covariate settings used\n') + print(shiny::tagList(reportTableFormat( + table = covariateDetails, + groupBy = 'input', + columns = defaultColumns(covariateDetails) + ))) + cat('\n:::\n') + +} +} else{ + cat('\nNo settings for target baseline in this analysis\n\n') +} +``` -1) before target index (before) -2) between target index and first outcome date after target index (during) -3) After first outcome date after target index (after) -This can show how the patients with the outcome change over time. +### Risk Factor +::: {.callout-important collapse="false"} +# Summary of risk factor +For every specified combination of target population, outcome, and time-at-risk (TAR), we will compare covariate mean values between patients in the target population who experience the outcome during the TAR and those who do not. For each covariate we report: -**3. Target and outcome characterization ** -Aggregate covariate details are calculated for the target population (first exposure with min prior observation) and the outcome cohort (first occurrence with min prior observation). +- Mean value among target-population patients with the outcome during TAR (for binary covariates this equals prevalence). +- Mean value among target-population patients without the outcome during TAR. + +We quantify association with the outcome during TAR using the standardized mean difference (SMD) between the target-population with the outcome and target-population without the outcome groups. The SMD is calculated as: + +$$ +SMD = \frac{\bar{x}_1 - \bar{x}_2}{s_{pooled}} +$$ +where $\bar{x}_1$ is the mean among target-population patients with the outcome during TAR, $\bar{x}_2$ is the mean among target-population patients without the outcome during TAR and $s_{pooled}$ is the pooled standard deviation. Large absolute SMDs highlight covariates that are potential risk factors for the outcome during the TAR. Users can specify a min absolute SMD and only covariates with an absolute SMD greater or equal to this value are returned by the analysis. + +For more details see [here](https://ohdsi.github.io/Characterization/articles/Specification.html#risk-factor-analysis) for risk factor analysis and [here](https://ohdsi.github.io/Characterization/articles/Specification.html#aggregate-covariates) for the mean covariate analysis for the target and outcome cohorts. +The analysis is performed across ``r countRfParents `` unique parent targets (``r countRfTarget `` unique target subsets) see @sec-char-rf-targets, ``r countRfOutcomeParents `` unique parent outcomes (``r countRfOutcome`` outcome subsets) see @sec-char-rf-outcomes. There are ``r numRfSettings`` unique analysis settings @sec-char-rf-settings. + +::: -There are ``r numSettings`` unique analysis settings @sec-char-settings , ``r countParents `` unique parent targets (``r countTarget `` unique target subsets) see @sec-char-targets , ``r length(unique(caAllDf$parentIdOutcome)) `` unique parent outcomes (``r length(unique(caAllDf$outcomeId))`` outcome subsets) see @sec-char-outcomes . ```{r, echo=FALSE, results = 'asis'} -cat("#### Combinations \n") +if(!is.null(riskFactor)){ -if(sepT){ - cat("##### Targets {#sec-char-targets}\n\n") +cat("#### Targets {#sec-char-rf-targets}\n\n") +cat('\n::: {.callout-important collapse="true"}') +cat('\n# Targets used in risk factors\n') print(shiny::tagList( ProtocolGenerator::reportTableFormat( - table = targetDf, - groupBy = c('parentNameTarget', 'cohortNameTarget'), - columns = cColumns[names(cColumns) %in% colnames(targetDf)] + table = riskFactor$targetData, + groupBy = 'parentNameTarget', + elementId = 'rf-targets', + groupByButton = TRUE, + columns = cColumns[names(cColumns) %in% colnames(riskFactor$targetData)] ))) + cat('\n:::\n') - aggregateTargets <- unique(targetDf$targetId) - aggregateOutcomes <- unique(caAllDf$outcomeId) +cat("#### Outcomes {#sec-char-rf-outcomes}\n\n") +for(rfoInd in 1:length(riskFactor$outcomeDataList)){ + outcomeData <- riskFactor$outcomeDataList[[rfoInd]] + cat(paste0("\n\n##### Outcome {#sec-char-rf-outcome-",rfoInd,"}\n\n")) + cat('\n::: {.callout-important collapse="true"}') + cat('\n# Outcomes used in risk factors\n') + print(shiny::tagList( + ProtocolGenerator::reportTableFormat( + table = outcomeData, + groupBy = 'parentNameOutcome', + elementId = 'rf-outcomes', + groupByButton = TRUE, + columns = cColumns[names(cColumns) %in% colnames(outcomeData)] + ))) + cat('\n:::\n') +} cat('\n\n') - cat("##### Outcomes {#sec-char-outcomes}\n") -} else{ - cat("##### Target and Outcomes {#sec-char-targets}{#char-outcomes}\n") + cat("#### Settings {#sec-char-rf-settings} \n") + + +for(settingInd in 1:length(riskFactor$settingsJson)){ - # tracker - aggregateTargets <- unique(caAllDf$targetId) - aggregateOutcomes <- unique(caAllDf$outcomeId) + cat(paste0('\n\n##### Settings ', settingInd, '{#sec-char-rf-setting-',settingInd,'}')) + cat('\n\n') + cat('\n::: {.callout-important collapse="true"}') + cat('\n# Settings used in risk factors\n') -} +covariates <- ParallelLogger::convertJsonToSettings(riskFactor$settingsJson[[settingInd]]) +covariateDetails <- formatCovariateSettings(covariates) - if(nrow(caAllDf)>0){ - print(shiny::tagList( - ProtocolGenerator::reportTableFormat( - table = caAllDf, #TODO: move columns around - groupBy = groupByOutcomes, - columns = cColumns[names(cColumns) %in% colnames(caAllDf)] + print(shiny::tagList(reportTableFormat( + table = covariateDetails, + groupBy = 'input', + columns = defaultColumns(covariateDetails) ))) - cat('\n\n') - } - + cat('\n:::\n') + +} +} else{ + cat('\nNo settings for risk factor in this analysis\n\n') +} ``` -#### Settings {#sec-char-settings} + +### Case series + +::: {.callout-important collapse="false"} +# Summary of case series +For each case (a patient in the target population who experiences the outcome during the specified time-at-risk), we compute aggregate covariate summaries at three different time points: + +- **Before**: on or prior to the target index (baseline). +- **During**: between target index and first outcome index during the time-at-risk- this includes the outcome index date. +- **After**: after first outcome index during the time-at-risk + +For each covariate and time window we report sample size and appropriate summary statistics — means and standard deviations (or medians and IQRs) for continuous variables, and counts and proportions for categorical/binary variables. Comparing these summaries across the three windows highlights how case characteristics evolve before, during, and after the outcome. + +The analysis is performed across ``r countCsParents `` unique parent targets (``r countCsTarget `` unique target subsets) see @sec-char-cs-targets, ``r countRfOutcomeParents `` unique parent outcomes (``r countCsOutcome`` outcome subsets) see @sec-char-cs-outcomes. There are ``r numCsSettings`` unique analysis settings @sec-char-cs-settings. + +::: + ```{r, echo=FALSE, results = 'asis'} -for(cfInd in 1:length(caSettingsUnique)){ +if(!is.null(caseSeries)){ - cat(paste0('\n\n##### Settings ', cfInd, '{#sec-char-setting-',cfInd,'}')) +cat("#### Targets {#sec-char-cs-targets}\n\n") + cat('\n::: {.callout-important collapse="true"}') + cat('\n# Targets used in case series\n') + print(shiny::tagList( + ProtocolGenerator::reportTableFormat( + table = caseSeries$targetData, + groupBy = 'parentNameTarget', + elementId = 'cs-targets', + groupByButton = TRUE, + columns = cColumns[names(cColumns) %in% colnames(caseSeries$targetData)] + ))) + cat('\n:::\n') + +cat("#### Outcomes {#sec-char-cs-outcomes}\n\n") +for(rfoInd in 1:length(caseSeries$outcomeDataList)){ + outcomeData <- caseSeries$outcomeDataList[[rfoInd]] + cat(paste0("\n\n##### Outcome {#sec-char-cs-outcome-",rfoInd,"}\n\n")) + cat('\n::: {.callout-important collapse="true"}') + cat('\n# Outcomes used in case series\n') + print(shiny::tagList( + ProtocolGenerator::reportTableFormat( + table = outcomeData, + groupBy = 'parentNameOutcome', + elementId = 'cs-outcomes', + groupByButton = TRUE, + columns = cColumns[names(cColumns) %in% colnames(outcomeData)] + ))) + cat('\n:::\n') +} + cat('\n\n') + cat("#### Settings {#sec-char-cs-settings} \n") + + +for(settingInd in 1:length(caseSeries$settingsJson)){ - # are these relevant? + cat(paste0('\n\n##### Settings ', settingInd, '{#sec-char-cs-setting-',settingInd,'}')) + cat('\n\n') + +csSettings <- ParallelLogger::convertJsonToSettings(caseSeries$settingsJson[[settingInd]]) + +covariateDetails <- formatCovariateSettings(csSettings$caseCovariateSettings) extraSettings <- data.frame( - input = c('casePreTargetDuration','casePostOutcomeDuration','extractNonCaseCovariates'), - level2 = c(' ',' ',' '), - desc = c('How many days prior to target index to start the covariate lookback for the case series analysis.','How many days post outcome index to end the covariate lookback for the case series analysis.','Whether to extract the target and outcome aggregate covariates.'), - value = c(caSettingsUnique[[cfInd]]$casePreTargetDuration, caSettingsUnique[[cfInd]]$casePostOutcomeDuration, caSettingsUnique[[cfInd]]$extractNonCaseCovariates), - bold = rep('TRUE', 3) + input = c('casePreTargetDuration','casePostOutcomeDuration'), + level2 = c(' ',' '), + desc = c('How many days prior to target index to start the covariate lookback for the case series analysis.','How many days post outcome index to end the covariate lookback for the case series analysis.'), + value = c(csSettings$casePreTargetDuration, csSettings$casePostOutcomeDuration), + bold = rep('TRUE', 2) ) -covariates <- caSettingsUnique[[cfInd]]$covariateSettings -covariateDetails <- formatCovariateSettings(covariates) - +cat('\n::: {.callout-important collapse="true"}') + cat('\n# Settings used in case series\n') print(shiny::tagList(reportTableFormat( - table = rbind(covariateDetails, extraSettings), + table = rbind(covariateDetails,extraSettings), groupBy = 'input', columns = defaultColumns(rbind(covariateDetails, extraSettings)) - #caption = paste('covariate setting ', i) ))) + cat('\n:::\n') } +} else{ + cat('\nNo settings for case series in this analysis\n\n') +} ``` + + ### Time-to-event +::: {.callout-important collapse="false"} +# Summary of time-to-event + ```{r, echo=FALSE, results = 'asis', include=FALSE} -cTargets <- cohortDefintionDf[cohortDefintionDf$cohortId %in% CharacterizationModuleSettings$settings$analysis$timeToEventSettings[[1]]$targetIds, ] -cOutcomes <- cohortDefintionDf[cohortDefintionDf$cohortId %in% CharacterizationModuleSettings$settings$analysis$timeToEventSettings[[1]]$outcomeIds, ] +cTargets <- cohortDefinitionDf[cohortDefinitionDf$cohortId %in% CharacterizationModuleSettings$settings$analysis$timeToEventSettings[[1]]$targetIds, ] +cOutcomes <- cohortDefinitionDf[cohortDefinitionDf$cohortId %in% CharacterizationModuleSettings$settings$analysis$timeToEventSettings[[1]]$outcomeIds, ] ``` -This analysis that lets you view the timing of the outcomes relative to the target eras are calculated for all Targets and Outcomes. For each target cohort and outcome, this analysis finds all occurrences of the outcome occurring within patients in the target cohort. For each occurrence the time in days between the outcome date and the target index date is calculated (negative values mean the outcome occurred before the target index and positive values mean the outcome occurred after the target index). Each occurrence is given labels corresponding to whether the outcome was the first ever for the patient or not, whether the outcome occurrence was before the target index, during the first target exposure, during a subsequent target exposure, between target exposures or after last target exposure. The outcome occurrence timing and categories are aggregated across the target population. See more [here](https://ohdsi.github.io/Characterization/articles/Specification.html#time-to-event). +For each specified target cohort and outcome, we identify all outcome occurrences among cohort members and compute the days from the target index to each occurrence (negative = before index, positive = after index). Each occurrence is labeled by: + +- whether it is the patient’s first-ever outcome +- its timing relative to target exposures: before index, during the first target exposure, during a subsequent target exposure, between target exposures, or after the last target exposure. + +We then aggregate occurrence counts by day relative to the index and by label, producing daily frequency tables (and optional plots) that show when outcomes occur across the target population and how timing differs by occurrence type. See more [here](https://ohdsi.github.io/Characterization/articles/Specification.html#time-to-event). In this specified analysis there are ``r length(unique(cTargets$parentId))`` unique parent targets (corresponding to ``r length(unique(cTargets$cohortId))`` unique targets with subsets) see @sec-char-tte-targets and ``r length(unique(cOutcomes$parentId)) `` unique parent outcomes (corresponding to ``r length(unique(cOutcomes$cohortId))`` unique outcomes with subsets) see @sec-char-tte-outcomes. +::: + ```{r, echo=FALSE, results = 'asis'} cat("\n\n#### Targets {#sec-char-tte-targets} \n") if(nrow(cTargets)>0){ + + cat('\n::: {.callout-important collapse="true"}') + cat('\n# Targets used in time-to-event\n') + print(shiny::tagList( ProtocolGenerator::reportTableFormat( table = cTargets %>% dplyr::arrange(.data$parentName,.data$cohortName), groupBy = 'parentName', + elementId = 'tte-targets', + groupByButton = TRUE, columns = cColumns[names(cColumns) %in% colnames(cTargets)], caption = 'Target cohorts included in the analysis.' ))) + cat('\n:::\n') cat('\n\n') } cat("\n\n#### Outcomes {#sec-char-tte-outcomes} \n") if(nrow(cOutcomes)>0){ + cat('\n::: {.callout-important collapse="true"}') + cat('\n# Outcomes used in time-to-event\n') print(shiny::tagList( ProtocolGenerator::reportTableFormat( table = cOutcomes %>% dplyr::arrange(.data$parentName,.data$cohortName), groupBy = 'parentName', + elementId = 'tte-outcomes', + groupByButton = TRUE, columns = cColumns[names(cColumns) %in% colnames(cOutcomes)], caption = 'Outcome cohorts included in the analysis.' ))) + cat('\n:::\n') cat('\n\n') } @@ -426,9 +348,12 @@ tteOutcomes <- unique(cOutcomes$cohortId) ### Dechallenge Rechallenge + +::: {.callout-important collapse="false"} +# Summary of dechallenge rechallenge ```{r, echo=FALSE, results = 'asis', include=FALSE} -cTargets <- cohortDefintionDf[cohortDefintionDf$cohortId %in% CharacterizationModuleSettings$settings$analysis$dechallengeRechallengeSettings[[1]]$targetCohortDefinitionIds, ] -cOutcomes <- cohortDefintionDf[cohortDefintionDf$cohortId %in% CharacterizationModuleSettings$settings$analysis$dechallengeRechallengeSettings[[1]]$outcomeCohortDefinitionIds, ] +cTargets <- cohortDefinitionDf[cohortDefinitionDf$cohortId %in% CharacterizationModuleSettings$settings$analysis$dechallengeRechallengeSettings[[1]]$targetCohortDefinitionIds, ] +cOutcomes <- cohortDefinitionDf[cohortDefinitionDf$cohortId %in% CharacterizationModuleSettings$settings$analysis$dechallengeRechallengeSettings[[1]]$outcomeCohortDefinitionIds, ] ``` This analysis lets you identify cases where a patient had an outcome while exposed to a target drug and the target drug is stopped shortly after the outcome (this may correspond to patients stopping the drug due to the outcome starting). This is known as dechallenge. If the outcome stops after the drug stops then this is a dechallenge success, otherwise, if the outcome continues it is a dechallenge fail. For the cases where there was a dechallenge, we are then interested in how often the patient restarts the drug at a later time, rechallenges, and whether the outcome occurs shortly after starting exposure (rechallenge success) or does not occur (rechallenge fail). See more [here](https://ohdsi.github.io/Characterization/articles/Specification.html#dechallenge-rechallenge). @@ -437,32 +362,43 @@ For each Target and Outcome combination this calculates the number of patients i In this analysis there are ``r length(unique(cTargets$parentId)) `` unique parent targets (corresponding to ``r length(unique(cTargets$cohortId))`` unique targets with subsets) see @sec-char-dr-targets and ``r length(unique(cOutcomes$parentId)) `` unique parent outcomes (corresponding to ``r length(unique(cOutcomes$cohortId))`` unique outcomes with subsets) see @sec-char-dr-outcomes. The settings (decallengeStopInterval and dechallengeEvaluationWindow) are in @sec-dcrc-settings. +::: ```{r, echo=FALSE, results = 'asis'} cat("\n\n#### Targets {#sec-char-dr-targets} \n\n") if(nrow(cTargets)>0){ + cat('\n::: {.callout-important collapse="true"}') + cat('\n# Targets used in dechallenge rechallenge\n') print(shiny::tagList( ProtocolGenerator::reportTableFormat( table = cTargets %>% dplyr::arrange(.data$parentName,.data$cohortName), groupBy = 'parentName', + elementId = 'dcrc-targets', + groupByButton = TRUE, columns = cColumns[names(cColumns) %in% colnames(cTargets)], caption = 'Target cohorts included in the analysis.' ))) + cat('\n:::\n') cat('\n\n') } cat("\n#### Outcomes {#sec-char-dr-outcomes} \n") if(nrow(cOutcomes)>0){ + cat('\n::: {.callout-important collapse="true"}') + cat('\n# Outcomes used in dechallenge rechallenge \n') print(shiny::tagList( ProtocolGenerator::reportTableFormat( table = cOutcomes %>% dplyr::arrange(.data$parentName,.data$cohortName), groupBy = 'parentName', + elementId = 'dcrc-outcomes', + groupByButton = TRUE, columns = cColumns[names(cColumns) %in% colnames(cOutcomes)], caption = 'Outcome cohorts included in the analysis.' ))) + cat('\n:::\n') cat('\n\n') } @@ -477,6 +413,8 @@ setTable <- getSettingsTable( ) ) + cat('\n::: {.callout-important collapse="true"}') + cat('\n# Parameters for dechallenge rechallange \n') print(shiny::tagList(reportTableFormat( table = setTable, #groupBy = 'input', @@ -489,6 +427,7 @@ setTable <- getSettingsTable( )), caption = 'Parameters for dechallenge rechallange' ))) + cat('\n:::\n') ``` @@ -500,18 +439,48 @@ setTable <- getSettingsTable( # code to get the targets and outcomes for c # and add to the cohortTracker +if(length(unique(targetBaseline$tableData$targetId)) >0){ cohortTracker <- rbind( cohortTracker, data.frame( type = c( - rep('cTarget', length(unique(aggregateTargets))), - rep('cOutcome', length(unique(aggregateOutcomes))) + rep('tbTarget', length(unique(targetBaseline$tableData$targetId))) ), - cohortId = c(unique(aggregateTargets), unique(aggregateOutcomes)), + cohortId = c(unique(targetBaseline$tableData$targetId)), value = 1 ) ) +} +if(length(unique(riskFactor$targetData$targetId)) > 0){ +cohortTracker <- rbind( + cohortTracker, + data.frame( + type = c( + rep('rfTarget', length(unique(riskFactor$targetData$targetId))), + rep('rfOutcome', length(unique(unlist(lapply(riskFactor$outcomeDataList, function(x) x$outcomeId))))) + ), + cohortId = c(unique(riskFactor$targetData$targetId), unique(unlist(lapply(riskFactor$outcomeDataList, function(x) x$outcomeId)))), + value = 1 + ) +) +} + +if(length(unique(caseSeries$targetData$targetId)) > 0){ +cohortTracker <- rbind( + cohortTracker, + data.frame( + type = c( + rep('csTarget', length(unique(caseSeries$targetData$targetId))), + rep('csOutcome', length(unique(unlist(lapply(caseSeries$outcomeDataList, function(x) x$outcomeId))))) + ), + cohortId = c(unique(caseSeries$targetData$targetId), unique(unlist(lapply(caseSeries$outcomeDataList, function(x) x$outcomeId)))), + value = 1 + ) +) +} + +if(length(unique(tteTargets)) > 0){ cohortTracker <- rbind( cohortTracker, data.frame( @@ -523,7 +492,9 @@ cohortTracker <- rbind( value = 1 ) ) +} +if(length(unique(cTargets$cohortId)) > 0){ cohortTracker <- rbind( cohortTracker, data.frame( @@ -535,5 +506,5 @@ cohortTracker <- rbind( value = 1 ) ) - +} ``` diff --git a/inst/protocol/cohort-diagnostics.qmd b/inst/protocol/cohort-diagnostics.qmd index 39276b9..8e66341 100644 --- a/inst/protocol/cohort-diagnostics.qmd +++ b/inst/protocol/cohort-diagnostics.qmd @@ -4,133 +4,72 @@ output: html_document ```{r, echo=FALSE, results = 'asis', include=FALSE} -cohortIdsCD <- CohortDiagnosticsSettings$cohortIds -# if null then cohort diagnotics is applied to all cohorts in set -if(is.null(cohortIdsCD)){ - cohortIdsCD <- cohortDefintionDf$cohortId -} - -# this should be a single settings rather than a list of settings -temporalCovariateSettingsCD <- CohortDiagnosticsSettings$temporalCovariateSettings -cdFeatureSettings <- data.frame( - input = names(temporalCovariateSettingsCD), - value = unlist(lapply(temporalCovariateSettingsCD, FUN = function(x) ifelse(is.null(x), 'NULL', as.character(x)))) -) -rownames(cdFeatureSettings) <- NULL - -# non list settings -cdSettings <- CohortDiagnosticsSettings -cdSettings$cohortIds <- NULL -cdSettings$temporalCovariateSettings <- NULL - -cdSettings <- data.frame( - input = names(cdSettings), - value = unlist(lapply(cdSettings, FUN = function(x) ifelse(is.null(x), 'NULL', as.character(x)))) +cdTables <- ProtocolGenerator::getCohortDiagnosticTables( + CohortDiagnosticsSettings = CohortDiagnosticsSettings, + cohortDefinitionDf = cohortDefinitionDf ) -rownames(cdSettings) <- NULL - -# create target table -targetDfCD <- cohortDefintionDf -colnames(targetDfCD) <- paste0(colnames(targetDfCD), 'Target') -targetDfCD <- targetDfCD[targetDfCD$cohortIdTarget %in% cohortIdsCD, ] - -# order the columns -targetDfCD <- targetDfCD %>% - dplyr::relocate("cohortNameTarget") %>% - dplyr::relocate("parentNameTarget") - -cdColumns <- list( - subsetIdTarget = reactable::colDef(show = F), - isParentTarget = reactable::colDef(show = F), - parentIdTarget = reactable::colDef(show = F), - subsetNameTarget = reactable::colDef(show = F), - packageVersionTarget = reactable::colDef(show = F), - numberSubsetOperatorsTarget = reactable::colDef(show = F), - cohortIdTarget = reactable::colDef(show = F), - - parentNameTarget = reactable::colDef( - name = 'Parent Target', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300, - html = TRUE - ), - - cohortNameTarget = reactable::colDef( - aggregate = "unique", - show = TRUE, - name = 'Target', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300 - ), - cohortNameWithLinkTarget = reactable::colDef( - show = FALSE, - name = 'Cohort', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300, - html = TRUE - ), - subsetCohortsTarget = reactable::colDef( - html = TRUE, - aggregate = "count" - ), - appliedSubsetsTarget = reactable::colDef( - html = TRUE, - aggregate = "count" - ) - ) - +cdColumns <- ProtocolGenerator::getCdCols() ``` ## Cohort Diagnostics +::: {.callout-important collapse="false"} +# Summary of cohort diagnostics Cohort diagnostics is used to evaluate phenotypes. See [here](https://journals.plos.org/plosone/article?id=10.1371/journal.pone.0310634) for more details. +Cohort diagnostics is a set of automated checks that summarizes who a phenotype algorithm selects as having a medical condition or drug exposure (their age, sex, diagnoses, tests, and treatments). It helps researchers spot mistakes or unexpected results so they can be confident the people included in a cohort really match the condition or drug being studied. + +::: + ### Cohorts -Cohort diagnostics will be run for the following `r nrow(targetDfCD)` cohorts: +::: {.callout-important collapse="true"} +# Cohorts used in cohort diagnostics +Cohort diagnostics will be run for the following `r nrow(cdTables$targetTable)` cohorts: ```{r, echo=FALSE, results = 'asis'} print(shiny::tagList( ProtocolGenerator::reportTableFormat( - table = targetDfCD %>% + table = cdTables$targetTable %>% dplyr::arrange(.data$parentNameTarget,.data$cohortNameTarget), groupBy = 'parentNameTarget', - columns = cdColumns[names(cdColumns) %in% colnames(targetDfCD)], + groupByButton = TRUE, + elementId = 'cd-cohorts', + columns = cdColumns[names(cdColumns) %in% colnames(cdTables$targetTable)], caption = 'Cohorts included in Cohort Diagnostics.' ))) ``` - +::: ### Settings +::: {.callout-important collapse="true"} +# Main settings The following cohort diagnostic settings are used: ```{r, echo=FALSE, results = 'asis'} print(shiny::tagList( ProtocolGenerator::reportTableFormat( - table = cdSettings, + table = cdTables$settingsTable, caption = 'Settings.' ))) ``` - -and the temporal feature settings: +::: + +::: {.callout-important collapse="true"} +# Temporal feature settings: ```{r, echo=FALSE, results = 'asis'} print(shiny::tagList( ProtocolGenerator::reportTableFormat( - table = cdFeatureSettings, + table = cdTables$featureTable, caption = 'Feature Settings.' ))) ``` - + +::: ```{r cd_cohort_tracker, echo=FALSE, results = 'asis',include=FALSE} @@ -138,14 +77,14 @@ and the temporal feature settings: # code to get the targets for cd # and add to the cohortTracker -if(length(cohortIdsCD) > 0 ){ +if(length(cdTables$targetTable$cohortId) > 0 ){ cohortTracker <- rbind( cohortTracker, data.frame( type = c( - rep('cdTarget', length(unique(cohortIdsCD))) + rep('cdTarget', length(unique(cdTables$targetTable$cohortId))) ), - cohortId = unique(cohortIdsCD), + cohortId = unique(cdTables$targetTable$cohortId), value = 1 ) ) diff --git a/inst/protocol/cohort-incidence.qmd b/inst/protocol/cohort-incidence.qmd index d9e0e55..c244b22 100644 --- a/inst/protocol/cohort-incidence.qmd +++ b/inst/protocol/cohort-incidence.qmd @@ -1,134 +1,38 @@ --- output: html_document --- - + ## Cohort Incidence ### Overview -Cohort Incidence calculates the incidence proportion (per 100 patients) and incidence rate (per 100 patient years) for a set of target cohorts, outcomes (with a specified washout) and time-at-risks. Stratification of the target cohorts by age group, gender and index year is also possible. +::: {.callout-important collapse="false"} +# Summary of cohort incidence +Cohort Incidence calculates the incidence proportion (per 100 patients) and incidence rate (per 100 patient years) for a set of target cohorts, outcomes (with a specified washout) and time-at-risks. Stratification of the target cohorts by age group, gender and index year is also possible. -The incidence proportion shows how often a patient in the target population has the outcome observed during the time-at-risk divided by the number of patients in the target population multiplied by 100 (to get it per 100 patients). The results contain the number of patients in the target population, the number of patients in the target population with the outcome observed during the time-at-risk and the incidence proportion. +The incidence proportion shows how often a patient in the target population has the outcome observed during the time-at-risk divided by the number of patients in the target population multiplied by 100 (to get it per 100 patients). The results contain the number of patients in the target population, the number of patients in the target population with the outcome observed during the time-at-risk and the incidence proportion. -The incidence rate is calculated as the number of times the outcome is observed during a time-at-risk period for the target population divided by the number of days at risk for all patients in the target population divided by 365 (to get per year) and multiplied by 100 (to get per 100 years). The results contain the total number of days at risk for all patients in the target population, the number of times an outcome occurs during a time at risk and the incidence rate. +The incidence rate is calculated as the number of times the outcome is observed during a time-at-risk period for the target population divided by the number of days at risk for all patients in the target population divided by 365 (to get per year) and multiplied by 100 (to get per 100 years). The results contain the total number of days at risk for all patients in the target population, the number of times an outcome occurs during a time at risk and the incidence rate. -Cohort incidence can enable multiple time-at-risk periods per patient but the outcome washout is used to remove periods of time where it is impossible to observed an outcome. For more details of cohort incidence see [here](https://ohdsi.github.io/CohortIncidence/articles/cohortincidence-method-documentation.html). +Cohort incidence can enable multiple time-at-risk periods per patient but the outcome washout is used to remove periods of time where it is impossible to observed an outcome. For more details of cohort incidence see [here](https://ohdsi.github.io/CohortIncidence/articles/cohortincidence-method-documentation.html). ```{r, echo=FALSE, results = 'asis',include=FALSE} -# get number of incidence T/O/tars - -totarCounts <- do.call(sum, lapply(CohortIncidenceModuleSettings$settings$irDesign$analysisList, function(x){length(x[[1]])*length(x[[2]])*length(x[[3]])})) -analysisCount <- length(CohortIncidenceModuleSettings$settings$irDesign$analysisList) - -targetCount <- length(CohortIncidenceModuleSettings$settings$irDesign$targetDefs) -outcomeCount <- length(CohortIncidenceModuleSettings$settings$irDesign$outcomeDefs) -tarCount <- length(CohortIncidenceModuleSettings$settings$irDesign$timeAtRiskDefs) - -allCounts <- lapply( - CohortIncidenceModuleSettings$settings$irDesign$analysisList, function(x){ - targetIds <- x$targets - outcomeIds <- x$outcomes - tars <- x$tars - - #updated for new CI - targetIds <- unlist(lapply(1:length(targetIds), function(ind) CohortIncidenceModuleSettings$settings$irDesign$targetDefs[[ind]]$id)) - outcomeIds <- unlist(lapply(1:length(outcomeIds), function(ind) CohortIncidenceModuleSettings$settings$irDesign$outcomeDefs[[ind]]$cohortId)) - outcomeCleanWindow <- unlist(lapply(1:length(outcomeIds), function(ind) CohortIncidenceModuleSettings$settings$irDesign$outcomeDefs[[ind]]$cleanWindow)) - parentIdsOutcome <- unlist(lapply(1:length(outcomeIds), function(ind){ - outcomeId <- CohortIncidenceModuleSettings$settings$irDesign$outcomeDefs[[ind]]$cohortId; - parentId <- cohortDefintionDf$parentId[cohortDefintionDf$cohortId %in% outcomeId] - })) - - counts <- list( - cohortTs = length(unique(targetIds)), - parentTs = length(unique(cohortDefintionDf$parentId[cohortDefintionDf$cohortId %in% targetIds])), - cohortOs = nrow(unique(cbind(outcomeIds, outcomeCleanWindow))), - parentOs = nrow(unique(cbind(parentIdsOutcome, outcomeCleanWindow))), - parentOsNoWindow = length(unique(parentIdsOutcome)), - tars = length(unique(tars)), - total = length(unique(targetIds))*nrow(unique(cbind(outcomeIds, outcomeCleanWindow)))*length(unique(tars)) - ) - return(counts) -}) - -totarCountsUnique <-sum(unlist(lapply(allCounts, function(x) x$total))) +# get analysisList +analysisList <- CohortIncidenceModuleSettings$settings$irDesign$analysisList # create count sentances for each analysis -countSentances <- lapply(1:length(allCounts), function(i) paste0('- Analysis ', i, ' @sec-incidence-analysis-',i,' : ', allCounts[[i]]$parentTs, ' unique parent targets (',allCounts[[i]]$cohortTs,' unique target subsets) see @sec-incidence-t-',i,', ', allCounts[[i]]$parentOs, ' unique parent outcomes with clean windows (',allCounts[[i]]$cohortOs,' unique outcome subsets with clean windows and ',allCounts[[i]]$parentOsNoWindow,' unique parent outcomes see @sec-incidence-o-',i,') and ',allCounts[[i]]$tars, ' time-at-risks see @sec-incidence-tar-',i,'. Total of ', allCounts[[i]]$total, ' T/O/TAR combinations in analysis ',i,'.')) - -# column settings for the target and outcome tables - ciColumns <- list( - subsetId = reactable::colDef(show = F), - isParent = reactable::colDef(show = F), - parentId = reactable::colDef(show = F), - subsetName = reactable::colDef(show = F), - packageVersion = reactable::colDef(show = F), - numberSubsetOperators = reactable::colDef(show = F), - cohortId = reactable::colDef(show = F), - parentName = reactable::colDef( - name = 'Parent Cohort', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300, - html = TRUE - ), - cohortName = reactable::colDef( - show = TRUE, - aggregate = "unique", - name = 'Cohort', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300 - ), - cohortNameWithLink = reactable::colDef( - show = FALSE, - name = 'Cohort', - defaultSortOrder = 'asc', - sortNALast = TRUE, - filterable = TRUE, - minWidth = 300, - html = TRUE - ), - subsetCohorts = reactable::colDef( - aggregate = "count", - html = TRUE - ), - appliedSubsets = reactable::colDef( - aggregate = "count", - html = TRUE - ), - cleanWindow = reactable::colDef( - aggregate = "unique", - filterable = T, - filterInput = function(values, name) { - shiny::tags$select( - # Set to undefined to clear the filter - onchange = sprintf("Reactable.setFilter('ci-out-tab', '%s', event.target.value || undefined)", name), - # "All" has an empty value to clear the filter, and is the default option - shiny::tags$option(value = "", "All"), - lapply(unique(values), shiny::tags$option), - "aria-label" = sprintf("Filter %s", name), - style = "width: 100%; height: 28px;" - ) - } - ) +countSentances <- ProtocolGenerator::getCountStatement( + CohortIncidenceModuleSettings = CohortIncidenceModuleSettings, + cohortDefinitionDf = cohortDefinitionDf ) - -# stratification sentance -stratInd <- unlist(lapply(CohortIncidenceModuleSettings$settings$irDesign$strataSettings, function(x) is.logical(x))) -if(sum(stratInd)>0){ - stratSentance <- paste0('Stratified by ', paste0(gsub('by', '', names(stratInd)[stratInd]), collapse = '/'), ', see @sec-incidence-strat. There will be more results due to including stratification of the target cohorts.') -} else{ - stratSentance <- 'No stratification applied.' -} +# stratification sentance +stratSentance <- ProtocolGenerator::createStratSentance(CohortIncidenceModuleSettings) ``` -The incidence rate specification contains ``r analysisCount`` analysis settings consisting of combinations of target cohorts, outcomes and time at risk (TAR) settings. The stratification settings are shared across analyses. +The incidence rate specification contains `r length(analysisList)` analysis settings consisting of combinations of target cohorts, outcomes and time at risk (TAR) settings. The stratification settings are shared across analyses. ```{r, echo=FALSE, results = 'asis'} cat(stratSentance, sep = '\n') @@ -139,104 +43,90 @@ cat(unlist(countSentances), sep = '\n') cat('\n') ``` +::: + ```{r, echo=FALSE, results = 'asis'} - tarDefs <- CohortIncidenceModuleSettings$settings$irDesign$timeAtRiskDefs -getTarString <- function(tarDefs, tarId){ - res <- tarDefs[[which(unlist(lapply(tarDefs, function(x) x$id)) == tarId)]] - - return(paste0('(',res$start$dateField ,' + ', res$start$offset, ') - (', res$end$dateField, ' + ', res$end$offset, ')')) -} +# column settings for the target and outcome tables +ciColumns <- ProtocolGenerator::getCIcolumns() +# the target and outcome tables plus tar per setting and target/outcome vectors +ciTargetsOutcomes <- ProtocolGenerator::getCiTargetsOutcomes(CohortIncidenceModuleSettings, cohortDefinitionDf) -ciTargetIds <- c() -ciOutcomeIds <- c() -for(i in 1:length(CohortIncidenceModuleSettings$settings$irDesign$analysisList)){ +for(i in 1:length(analysisList)){ - targetIds <- CohortIncidenceModuleSettings$settings$irDesign$analysisList[[i]]$targets - #updated for new CI - targetIds <- unlist(lapply(1:length(targetIds), function(id) CohortIncidenceModuleSettings$settings$irDesign$targetDefs[[id]]$id)) - - ciTargetIds <- c(ciTargetIds, targetIds) # vector or all targets - - # this is now the ci cohort ids not the main cohort ids - outcomeIdsCI <- CohortIncidenceModuleSettings$settings$irDesign$analysisList[[i]]$outcomes - # create lookup to find outcome ids - outcomeLookup <- as.data.frame( - do.call( - rbind, - CohortIncidenceModuleSettings$settings$irDesign$outcomeDefs) - ) - outcomeDf <- outcomeLookup[outcomeLookup$id %in% outcomeIdsCI,c('cohortId', 'cleanWindow')] - - ciOutcomeIds <- c(ciOutcomeIds,outcomeLookup$cohortId) # vector of outcomes - - # The nicely formatted settings - ciTargets <- cohortDefintionDf[cohortDefintionDf$cohortId %in% targetIds,] - ciOutcomes <- merge(cohortDefintionDf, outcomeDf, by = 'cohortId') %>% - dplyr::relocate("cleanWindow", .after = "parentName") - tars <- CohortIncidenceModuleSettings$settings$irDesign$analysisList[[i]]$tars - cat( paste0( "\n### Analysis ", i, "{#sec-incidence-analysis-",i,"} \n") ) cat('\n\n') - - cat(paste0("\n#### Targets {#sec-incidence-t-",i,"}\n")) - if(nrow(ciTargets)>0){ + cat(paste0("#### Targets{#sec-incidence-t-",i,"}\n")) + + if(nrow(ciTargetsOutcomes$ciTargets[[i]])>0){ + cat('\n::: {.callout-important collapse="true"}\n') + cat(paste0("# Target cohorts included in cohort incidence\n")) + cat('\nA table with the target cohorts group by parent cohort:\n') print(shiny::tagList( ProtocolGenerator::reportTableFormat( - table = ciTargets %>% + table = ciTargetsOutcomes$ciTargets[[i]] %>% dplyr::arrange(.data$parentName,.data$cohortName), # always have parentName? groupBy = "parentName", - columns = ciColumns[names(ciColumns) %in% colnames(ciTargets)], + groupByButton = TRUE, + elementId = 'ci-targets', + columns = ciColumns[names(ciColumns) %in% colnames(ciTargetsOutcomes$ciTargets[[i]])], caption = 'Target cohorts included in cohort incidence.' ))) + cat('\n:::\n') cat('\n\n') } cat(paste0("\n\n#### Outcomes {#sec-incidence-o-",i,"}\n")) - if(nrow(ciOutcomes)>0){ # TODO edit so it works when these columns are not in table + if(!is.null(ciTargetsOutcomes$ciOutcomes[[i]])){ # + cat('\n::: {.callout-important collapse="true"}\n') + cat(paste0("# Outcome cohorts included in cohort incidence\n")) + cat('\nA table with the outcome cohorts group by parent cohort:\n') print(shiny::tagList(ProtocolGenerator::reportTableFormat( - table = ciOutcomes %>% + table = ciTargetsOutcomes$ciOutcomes[[i]] %>% dplyr::arrange(.data$parentName,.data$cohortName), groupBy = "parentName", - columns = ciColumns[names(ciColumns) %in% colnames(ciOutcomes)], + groupByButton = TRUE, + columns = ciColumns[names(ciColumns) %in% colnames(ciTargetsOutcomes$ciOutcomes[[i]])], caption = 'Outcome cohorts included in cohort incidence.', elementId = 'ci-out-tab' ))) + cat('\n:::\n') cat('\n\n') } - cat(paste0("\n\n#### Time-at-risks (TARs) {#sec-incidence-tar-",i,"}\n"), - paste0(' - ',paste0(sapply(tars, function(x){getTarString(tarDefs, x)}) , collapse=' \n - ')), - sep= '\n' - ) + cat(paste0("\n\n#### Time-at-risks (TARs) {#sec-incidence-tar-",i,"}\n")) + cat('\n::: {.callout-important collapse="true"}\n') + cat(paste0("# Time-at-risks included in cohort incidence\n")) + cat(ciTargetsOutcomes$tars[[i]]) + cat('\n:::\n') + cat('\n\n') } cat("\n### Stratification {#sec-incidence-strat}\n", sep ='\n') - strataTable <- getSettingsTable( + strataTable <- ProtocolGenerator::getSettingsTable( package = 'CohortIncidence', functionName = 'createStrataSettings', - #settings = CohortIncidenceModuleSettings$settings$irDesign$strataSettings settings = as.list(sapply(CohortIncidenceModuleSettings$settings$irDesign$strataSettings, function(x) paste(x, sep = ',', collapse = ','))) ) cat('\n\n') + cat('\n::: {.callout-important collapse="true"}\n') + cat(paste0("# Stratification settings in cohort incidence\n")) print(shiny::tagList(reportTableFormat( table = strataTable, - #groupBy = 'input', columns = defaultColumns(strataTable), caption = 'Stratification settings' ))) - + cat('\n:::\n') cat('\n\n') ``` - ```{r ci_cohort_tracker, echo=FALSE, results = 'asis',include=FALSE} # code to get the targets and outcomes for ci @@ -245,10 +135,10 @@ cohortTracker <- rbind( cohortTracker, data.frame( type = c( - rep('ciTarget', length(unique(ciTargetIds))), - rep('ciOutcome', length(unique(ciOutcomeIds))) + rep('ciTarget', length(unique(ciTargetsOutcomes$ciTargetIds))), + rep('ciOutcome', length(unique(ciTargetsOutcomes$ciOutcomeIds))) ), - cohortId = c(unique(unlist(ciTargetIds)), unique(unlist(ciOutcomeIds))), + cohortId = c(unique(unlist(ciTargetsOutcomes$ciTargetIds)), unique(unlist(ciTargetsOutcomes$ciOutcomeIds))), value = 1 ) ) diff --git a/inst/protocol/cohort-method.qmd b/inst/protocol/cohort-method.qmd index 1e2ad88..c6eb133 100644 --- a/inst/protocol/cohort-method.qmd +++ b/inst/protocol/cohort-method.qmd @@ -16,110 +16,37 @@ package <- 'CohortMethod' ) } -# if negative controls not in share resources check for any in targetComparatorOutcomesList -if(is.null(negativeControls)){ - tcoList <- cohortMethodModuleSettings$settings$targetComparatorOutcomesList -cmNeg <- lapply(tcoList, function(x){ - temp <- do.call('rbind',lapply(x$outcomes, function(x2){ - dat <- data.frame( - cohortId = x2$outcomeId, - #conceptId = 'NA', - outcomeConceptId = x2$outcomeId, - outcomeOfInterest = x2$outcomeOfInterest, - priorOutcomeLookback = ifelse(is.null(x2$priorOutcomeLookback),0, x2$priorOutcomeLookback) - ) - # merge with cohortDefinitions - dat <- merge(dat, cohortDefintionDf[,c('cohortId', 'cohortName')], by = 'cohortId') - })) - temp[!temp$outcomeOfInterest,] -} -) - negativeControlsCM <- unique(do.call(rbind, cmNeg)) -} else{ - negativeControlsCM <- negativeControls -} - -# get tars -tars <- unlist(lapply(cohortMethodModuleSettings$settings$cmAnalysisList, function(x) paste0('\n- (',x$createStudyPopArgs$startAnchor, '+' ,x$createStudyPopArgs$riskWindowStart, ') - (', x$createStudyPopArgs$endAnchor, '+' ,x$createStudyPopArgs$riskWindowEnd, ')'))) - -# do the counts/processing -tcoList <- cohortMethodModuleSettings$settings$targetComparatorOutcomesList -cmOut <- lapply(tcoList, function(x){ - temp <- do.call('rbind',lapply(x$outcomes, function(x2){ - data.frame( - outcomeId = x2$outcomeId, - outcomeOfInterest = x2$outcomeOfInterest, - priorOutcomeLookback = ifelse(is.null(x2$priorOutcomeLookback),0, x2$priorOutcomeLookback) - ) - })) - temp[temp$outcomeOfInterest,] -} +cohortMethodSettings <- ProtocolGenerator::extractCohortMethodSettings( + cohortMethodModuleSettings = cohortMethodModuleSettings, + negativeControls = negativeControls, + cohortDefinitionDf = cohortDefinitionDf ) -cmOutUnique <- unique(cmOut) - -cmOutId <- unlist(lapply(cmOut, function(x){which(unlist(lapply(cmOutUnique,function(y) identical(x, y)))) })) - -for(cmi in 1:length(cmOutUnique)){ - tempDf <- cohortDefintionDf - colnames(tempDf) <- paste0(colnames(cohortDefintionDf), 'Outcome') - cmOutUnique[[cmi]] <- merge(cmOutUnique[[cmi]], tempDf, by.x='outcomeId', by.y = 'cohortIdOutcome', all.x = T) %>% - dplyr::relocate('cohortNameOutcome') %>% - dplyr::relocate('parentNameOutcome') %>% - dplyr::relocate('priorOutcomeLookback', .after = 'cohortNameOutcome') %>% - dplyr::arrange(.data$parentNameOutcome, .data$cohortNameOutcome) -} - - - -# add cmOutId to target settings -# add outcome section per cmOutUnique - -tcCombos <- do.call(rbind,lapply(1:length(tcoList), function(x) - data.frame(tcoId = x, - targetId = tcoList[[x]]$targetId, - comparatorId = tcoList[[x]]$comparatorId, - outcomeSet = paste0(" Outcome Set ", cmOutId[x], " " ) - ) - ) - ) - -analysisCm <- cohortMethodModuleSettings$settings$cmAnalysisList - -# create data.frame with T/C/O with all cohort details -tempDf <- cohortDefintionDf -colnames(tempDf) <- paste0(colnames(cohortDefintionDf), 'Target') -tcCombos<- merge(tcCombos, tempDf, by.x='targetId', by.y = 'cohortIdTarget', all.x = T) - -tempDf <- cohortDefintionDf -colnames(tempDf) <- paste0(colnames(cohortDefintionDf), 'Comp') -tcCombos <- merge(tcCombos, tempDf, by.x='comparatorId', by.y = 'cohortIdComp', all.x = T) - -tcCombos$sameSubset <- tcCombos$subsetIdComp == tcCombos$subsetIdTarget - -targetParentsCount <- length(unique(tcCombos[, c('parentIdTarget')])) -targetCohortCount <- length(unique(tcCombos[, c('targetId')])) - -compIds <- tcCombos %>% - dplyr::group_by(.data$targetId) %>% - dplyr::summarise( - compCount = length(unique(.data$comparatorId)) - ) - -outcomeRange <- unlist(lapply(cmOutUnique, function(x) nrow(x))) -if(length(outcomeRange) != 1){ - outcomeRange <- paste0(' between ', min(outcomeRange), ' and ', max(outcomeRange)) -} else{ - outcomeRange <- paste0(min(outcomeRange)) -} +negativeControlsCM <- cohortMethodSettings$negativeControlsCM +tcCombos <- cohortMethodSettings$tcCombos +outcomeRange <- cohortMethodSettings$outcomeRange +compIds <- cohortMethodSettings$compIds +targetParentsCount <- cohortMethodSettings$targetParentsCount +targetCohortCount <- cohortMethodSettings$targetCohortCount +tars <- cohortMethodSettings$tars +analysisCm <- cohortMethodSettings$analysisCm +cmOutUnique <- cohortMethodSettings$cmOutUnique +commonExclude <- cohortMethodSettings$commonExclude +nonCommonSets <- cohortMethodSettings$nonCommonSets +commonNegativeId <- cohortMethodSettings$commonNegativeId +nonCommonNegSets <- cohortMethodSettings$nonCommonNegSets +diagSetting <- cohortMethodSettings$diagSetting +refitPsForEveryOutcome <- cohortMethodSettings$refitPsForEveryOutcome +refitPsForEveryStudyPopulation <- cohortMethodSettings$refitPsForEveryStudyPopulation ``` ## Cohort Method ### Overview - +::: {.callout-important collapse="false"} +# Summary of cohort method Cohort method calculates comparative effect estimates. It requires specifying a target cohort (treatment 1), comparator cohort (treatment 2) and the outcome of interest. The standard process requires creating a propensity model to predict treatment and that is used to mimic randomization via matching, trimming or inverse probability weighting. The method used to estimate the effect is specified via analysis settings. In addition, the user can specify negative controls to use for effect estimate calibration. Using observational data for causal inference can be problematic due to various forms of potential bias. To minimise bias effects, cohort method performs different diagostics that evaluate whether there is bias present and effect estimates are only unblinded if all diagnostics are passed. For more details see [here](https://academic.oup.com/jamia/article/32/3/518/7950905). @@ -127,100 +54,17 @@ Using observational data for causal inference can be problematic due to various ```{r, echo=FALSE, results = 'asis'} cat(paste0('In this specification there are ', targetParentsCount, ' unique parent target cohorts (corresponding to ', targetCohortCount, ' unique targets with subsets), see @sec-cm-tc. There were between ', min(compIds$compCount),' and ', max(compIds$compCount), ' comparators per target cohort and ', outcomeRange, ' outcome/prior outcome lookbacks (see @sec-cm-out) per target cohort and comparator cohort pair. There are ', length(analysisCm), ' analyses settings specified, see @sec-cm-analyses. The ', length(tars), ' analyses time at risk settings are: '), tars, sep = '\n') ``` +::: ### Combinations ```{r, echo=FALSE, results = 'asis'} -# get all the exclude covariates -excludeConcepts <- list() - -# get all the negative controls -negative <- list() - -for(i in 1:length(cohortMethodModuleSettings$settings$targetComparatorOutcomesList)){ - -# get the excluded concepts -excludeConcepts[[i]] <- cohortMethodModuleSettings$settings$targetComparatorOutcomesList[[i]]$excludedCovariateConceptIds - -outcomeCm <- data.frame( - outcomeId = unlist(lapply(cohortMethodModuleSettings$settings$targetComparatorOutcomesList[[i]]$outcomes, function(x) x$outcomeId)), -outcomeOfInterest = unlist(lapply(cohortMethodModuleSettings$settings$targetComparatorOutcomesList[[i]]$outcomes, function(x) x$outcomeOfInterest)), -priorOutcomeLookback = unlist(lapply(cohortMethodModuleSettings$settings$targetComparatorOutcomesList[[i]]$outcomes, function(x) ifelse(is.null(x$priorOutcomeLookback), 0, x$priorOutcomeLookback))) -) - - #outcomes <- outcomeCm[outcomeCm$outcomeOfInterest,c('outcomeId','priorOutcomeLookback')] - negative[[i]] <- outcomeCm[!outcomeCm$outcomeOfInterest,c('outcomeId','priorOutcomeLookback')] -} - -# now process the negative list and excludeConcepts list -commonExclude <- excludeConcepts[[1]] -if(length(excludeConcepts) > 1){ -for(ind in 2:length(excludeConcepts)){ - commonExclude <- intersect(excludeConcepts[[ind]],commonExclude) -} -} -nonCommonExclude <- lapply(excludeConcepts, function(x) setdiff(x, commonExclude)) -nonCommonSets <- unique(nonCommonExclude) -nonZero <- unlist(lapply(nonCommonExclude, function(x) length(x)>0)) -if(sum(nonZero) > 0){ -excludeSetId <- unlist(lapply(nonCommonExclude, function(x) which(unlist(lapply(1:length(nonCommonSets), function(ind) identical(x, nonCommonSets[[ind]])))))) -} else{ -excludeSetId <- rep(NA, length(excludeConcepts)) -} - -commonNegativeId <- negative[[1]]$outcomeId -if(length(negative) > 1){ -for(ind in 2:length(negative)){ - commonNegativeId <- intersect(commonNegativeId, negative[[ind]]$outcomeId) -} -} -nonCommonNegative <- lapply(negative, function(x) setdiff(x$outcomeId, commonNegativeId)) -nonCommonNegSets <- unique(nonCommonNegative) -nonZero <- unlist(lapply(nonCommonNegSets, function(x) length(x)>0)) -if(sum(nonZero) > 0){ # finished here friday -negSetId <- unlist(lapply(nonCommonNegative, function(x) which(unlist(lapply(1:length(nonCommonNegSets), function(ind) identical(x, nonCommonNegSets[[ind]])))))) -} else{ -negSetId <- rep(0, length(negative)) -} - -# sets: nonCommonSets -- nonCommonNegSets -# add additional negative control and exclude set ids to tco - -# add to tcCombos -tcCombos <- merge( - tcCombos, - data.frame( - tcoId = 1:length(excludeSetId), - additionalExclusions = paste0(" View ") - ), - by = 'tcoId' - ) - -tcCombos <- merge( - tcCombos, - data.frame( - tcoId = 1:length(negSetId), - additionalNegativeControlId = paste0(" View ") - ), - by = 'tcoId' - ) - -tcCombos <- tcCombos %>% - dplyr::relocate('cohortNameTarget') %>% - dplyr::relocate('cohortNameComp') %>% - dplyr::relocate('parentNameTarget') %>% - dplyr::relocate('sameSubset', .after = 'cohortNameTarget') %>% - dplyr::relocate('subsetCohortsTarget', .after = 'sameSubset') %>% - dplyr::relocate('appliedSubsetsTarget', .after = 'subsetCohortsTarget') %>% - dplyr::relocate('additionalExclusions', .after = 'appliedSubsetsTarget') %>% - dplyr::relocate('additionalNegativeControlId', .after = 'additionalExclusions') %>% - dplyr::relocate('outcomeSet', .after = 'cohortNameTarget') %>% - dplyr::arrange(.data$parentNameTarget, .data$cohortNameComp, .data$cohortNameTarget) - # gets just have one setting with all tcos - as works with bigger studies -cat(paste0('\n#### Target and Comparators {#sec-cm-tc}\n'), +cat(paste0('\n#### Target and Comparators {#sec-cm-tc}\n')) +cat('\n::: {.callout-important collapse="true"}\n') +cat('\n# Targets and comparators used in cohort method\n') - "\n A relative effect for the risk of the outcome will be calculated for the target drug compared to the comparator drug for each target and comparator pair in the table below.", + cat("\n A relative effect for the risk of the outcome will be calculated for the target drug compared to the comparator drug for each target and comparator pair in the table below.", sep= '\n' ) @@ -228,109 +72,30 @@ cat(paste0('\n#### Target and Comparators {#sec-cm-tc}\n'), htmltools::tagList( reportTableFormat( table = tcCombos %>% dplyr::arrange(.data$parentNameTarget, .data$cohortNameComp), - groupBy = c("parentNameTarget","cohortNameComp"), - columns = list( - parentNameTarget = reactable::colDef( - name = 'Target Parent', - html = TRUE, - filterable = TRUE, - minWidth = 300 - ), - cohortNameComp = reactable::colDef( - aggregate = "count", - show = TRUE, - name = 'Comparator', - filterable = TRUE, - minWidth = 300 - ), - cohortNameTarget = reactable::colDef( - show = TRUE, - name = 'Target', - filterable = T, - minWidth = 300 - ), - additionalExclusions = reactable::colDef( - html = TRUE, - filterable = TRUE - ), - additionalNegativeControlId = reactable::colDef( - html = TRUE, - filterable = TRUE - ), - sameSubset = reactable::colDef( - filterable = TRUE, - filterInput = function(values, name) { - shiny::tags$select( - # Set to undefined to clear the filter - onchange = sprintf("Reactable.setFilter('cm-tc-tab', '%s', event.target.value || undefined)", name), - # "All" has an empty value to clear the filter, and is the default option - shiny::tags$option(value = "", "All"), - lapply(unique(values), shiny::tags$option), - "aria-label" = sprintf("Filter %s", name), - style = "width: 100%; height: 28px;" - ) - } - ), - outcomeSet = reactable::colDef( - show = TRUE, - html = TRUE + groupBy = "parentNameTarget", + groupByButton = TRUE, + columns = ProtocolGenerator::cmColDef( + elementId = "cm-tc-tab", + colNames = colnames(tcCombos) ), - subsetCohortsTarget = reactable::colDef( - show = TRUE, - html = TRUE - ), - appliedSubsetsTarget = reactable::colDef( - show = TRUE, - html = TRUE - ), - cohortNameWithLinkTarget = reactable::colDef( - show = FALSE, - name = 'Target', - html = TRUE, - filterable = TRUE - ), - cohortNameWithLinkComp = reactable::colDef( - show = FALSE, - name = 'Comparator', - html = TRUE, - filterable = TRUE - ), - tcoId = reactable::colDef(show = FALSE), - comparatorId = reactable::colDef(show = FALSE), - targetId = reactable::colDef(show = FALSE), - subsetIdTarget = reactable::colDef(show = FALSE), - isParentTarget = reactable::colDef(show = FALSE), - parentIdTarget = reactable::colDef(show = FALSE), - subsetNameTarget = reactable::colDef(show = FALSE), - packageVersionTarget = reactable::colDef(show = FALSE), - numberSubsetOperatorsTarget = reactable::colDef(show = FALSE), - subsetIdComp = reactable::colDef(show = FALSE), - isParentComp = reactable::colDef(show = FALSE), - parentIdComp = reactable::colDef(show = FALSE), - subsetNameComp = reactable::colDef(show = FALSE), - packageVersionComp = reactable::colDef(show = FALSE), - numberSubsetOperatorsComp = reactable::colDef(show = FALSE), - cohortNameTarget = reactable::colDef(show = FALSE), - parentNameComp = reactable::colDef(show = FALSE), - subsetCohortsComp = reactable::colDef(show = FALSE), - appliedSubsetsComp = reactable::colDef(show = FALSE) - - ), elementId = "cm-tc-tab" ) ) ) + cat('\n:::\n') cat('\n#### Outcomes {#sec-cm-out}\n\n') # add outcomes for(cmi in 1:length(cmOutUnique)){ cat(paste0('\n##### Outcome set ',cmi,' {#sec-cm-out-',cmi,'}\n\n')) - + cat('\n::: {.callout-important collapse="true"}\n') + cat(paste0('\n# Outcome used in cohort method ', cmi, '\n')) print( htmltools::tagList( reportTableFormat( table = cmOutUnique[[cmi]], - groupBy = c("parentNameOutcome"), + groupBy = "parentNameOutcome", + groupByButton = TRUE, columns = list( priorOutcomeLookback = reactable::colDef( aggregate = "unique", @@ -373,12 +138,13 @@ for(cmi in 1:length(cmOutUnique)){ ) ) ) - + cat('\n:::\n') } cat('\n#### Excluded Covariates \n') -cat('\n##### Shared Excluded Covariate Concept Ids {#sec-cm-exclude-0}\n') #{.tabset .tabset-pills} - +cat('\n##### Shared Excluded Covariate Concept Ids {#sec-cm-exclude-0}\n') +cat('\n::: {.callout-important collapse="true"}\n') +cat(paste0('\n# Shared excluded covariates used in cohort method \n')) concepts <- ProtocolGenerator::getConcepts( conceptIds = commonExclude, baseUrl = params$webAPI @@ -393,9 +159,9 @@ cat('\n###### Standard \n') table = concepts$standard %>% dplyr::select("conceptId","conceptName", "domainId", "vocabularyId","conceptClassId"), columns = list( - conceptName = reactable::colDef(filterable = T), - domainId = reactable::colDef(filterable = T), - vocabularyId = reactable::colDef(filterable = T) + conceptName = reactable::colDef(filterable = TRUE), + domainId = reactable::colDef(filterable = TRUE), + vocabularyId = reactable::colDef(filterable = TRUE) ) ) ) @@ -408,21 +174,24 @@ cat('\n###### Standard \n') table = concepts$source %>% dplyr::select("conceptId","conceptName", "domainId", "vocabularyId", "conceptClassId"), columns = list( - conceptName = reactable::colDef(filterable = T), - domainId = reactable::colDef(filterable = T), - vocabularyId = reactable::colDef(filterable = T) + conceptName = reactable::colDef(filterable = TRUE), + domainId = reactable::colDef(filterable = TRUE), + vocabularyId = reactable::colDef(filterable = TRUE) ) ) ) ) cat('\n\n:::\n\n') } # length standard +cat('\n:::\n') # add the commonExclude commonNegativeId for(ncsInd in 1:length(nonCommonSets)){ - cat(paste0('\n##### Excluded Covariate Concept Ids Set ',ncsInd,' {#sec-cm-exclude-',ncsInd,'} \n')) #{.tabset .tabset-pills} + cat(paste0('\n##### Excluded Covariate Concept Ids Set ',ncsInd,' {#sec-cm-exclude-',ncsInd,'} \n')) + cat('\n::: {.callout-important collapse="true"}\n') + cat(paste0('\n# Excluded covariates in cohort method ', ncsInd, '\n')) concepts <- ProtocolGenerator::getConcepts( conceptIds = nonCommonSets[[ncsInd]], @@ -438,9 +207,9 @@ if(length(concepts$standard) > 0){ table = concepts$standard %>% dplyr::select("conceptId","conceptName", "domainId", "vocabularyId","conceptClassId"), columns = list( - conceptName = reactable::colDef(filterable = T), - domainId = reactable::colDef(filterable = T), - vocabularyId = reactable::colDef(filterable = T) + conceptName = reactable::colDef(filterable = TRUE), + domainId = reactable::colDef(filterable = TRUE), + vocabularyId = reactable::colDef(filterable = TRUE) ) ) ) @@ -453,19 +222,23 @@ if(length(concepts$standard) > 0){ table = concepts$source %>% dplyr::select("conceptId","conceptName", "domainId", "vocabularyId", "conceptClassId"), columns = list( - conceptName = reactable::colDef(filterable = T), - domainId = reactable::colDef(filterable = T), - vocabularyId = reactable::colDef(filterable = T) + conceptName = reactable::colDef(filterable = TRUE), + domainId = reactable::colDef(filterable = TRUE), + vocabularyId = reactable::colDef(filterable = TRUE) ) ) ) ) cat('\n\n:::\n\n') -} # length standard +} else{ + cat('\nNone\n') +} +cat('\n:::\n') } # for loop cat('\n#### Shared Negative Controls {#sec-cm-negset-0}\n') - + cat('\n::: {.callout-important collapse="true"}\n') + cat(paste0('\n# Shared negative controls in cohort method \n')) cat(paste0('A total of ',length(unique(commonNegativeId)),' negative controls were included accross analyses. \n')) print( @@ -494,13 +267,16 @@ if(length(concepts$standard) > 0){ ) ) ) + cat('\n:::\n') # TODO add similar check for excluded covs? if(length(nonCommonNegSets) != 1 & length(nonCommonNegSets[[1]]) != 0){ # add Negative controls that are different for(ncsInd in 1:length(nonCommonNegSets)){ - cat(paste0('\n#### Negative Controls Set ',ncsInd,' {#sec-cm-negset-',ncsInd,'} \n')) #{.tabset .tabset-pills} + cat(paste0('\n#### Negative Controls Set ',ncsInd,' {#sec-cm-negset-',ncsInd,'} \n')) + cat('\n::: {.callout-important collapse="true"}\n') + cat(paste0('\n# Negative control set ',nscInd,' in cohort method \n')) print( htmltools::tagList( @@ -511,7 +287,7 @@ if(length(concepts$standard) > 0){ ), negativeControlsCM, by = 'cohortId', - all.x = T + all.x = TRUE ), groupBy = NULL, columns = NULL @@ -519,7 +295,7 @@ if(length(concepts$standard) > 0){ ) ) ) - + cat('\n:::\n') } } @@ -530,26 +306,19 @@ if(length(concepts$standard) > 0){ ```{r, echo=FALSE, results = 'asis'} -for(i in 1:length(cohortMethodModuleSettings$settings$cmAnalysisList)){ +for(i in 1:length(analysisCm)){ - analysisSetting <- cohortMethodModuleSettings$settings$cmAnalysisList[[i]] + analysisSetting <- analysisCm[[i]] - cat( - paste0('\n#### Analysis ', analysisSetting$analysisId,': ', analysisSetting$description, ' \n'), + cat(paste0('\n#### Analysis ', analysisSetting$analysisId,': ', analysisSetting$description, ' \n')) - '##### Get Data Arguments' , + cat('\n::: {.callout-important collapse="true"}\n') + cat(paste0('\n# Setting getDbCohortMethodData in cohort method \n')) - getHelpText( + cat(getHelpText( package = 'CohortMethod', functionName = 'getDbCohortMethodData', - input = NULL -), - - sep = '\n' - - ) - - + input = NULL)) covariateSettings <- analysisSetting$getDbCohortMethodDataArgs$covariateSettings @@ -557,11 +326,14 @@ for(i in 1:length(cohortMethodModuleSettings$settings$cmAnalysisList)){ extractSettings <- getSettingsTable( package, - functionName = 'getDbCohortMethodData', + functionName = 'createGetDbCohortMethodDataArgs', settings = analysisSetting$getDbCohortMethodDataArgs ) - - covariateDetails <- formatCovariateSettings(covariateSettings) + if(!is.null(covariateSettings)){ + covariateDetails <- formatCovariateSettings(covariateSettings) + } else{ + covariateDetails <- NULL + } print( shiny::tagList( @@ -570,7 +342,6 @@ for(i in 1:length(cohortMethodModuleSettings$settings$cmAnalysisList)){ extractSettings, covariateDetails ), - groupBy = 'input', columns = append(defaultColumns(covariateDetails), list( desc = reactable::colDef( @@ -581,13 +352,17 @@ for(i in 1:length(cohortMethodModuleSettings$settings$cmAnalysisList)){ ) ) ) + cat('\n:::\n') # print tables for the remaining components cohortMethodComponents <- names(analysisSetting) cohortMethodComponents <- cohortMethodComponents[!cohortMethodComponents %in% c('analysisId','description','getDbCohortMethodDataArgs', 'computeCovariateBalanceArgs')] for(settingName in cohortMethodComponents){ - cat(paste0('\n##### ',settingName,' Settings \n')) + + if(!is.null(analysisCm[[i]][[settingName]])){ + cat('\n::: {.callout-important collapse="true"}\n') + cat(paste0('\n# Setting ',settingName,' in cohort method \n')) functionName <- getFunctionFromArgName(package, settingName)[1] @@ -604,14 +379,13 @@ descAndDefault <- getAllHelpDetails(package, functionName) settingDf <- getSettingsTable( package = package, functionName = functionName, - settings = cohortMethodModuleSettings$settings$cmAnalysisList[[i]][[settingName]] + settings = analysisCm[[i]][[settingName]] ) print( shiny::tagList( reportTableFormat( table = settingDf, - #groupBy = "input", columns = append(defaultColumns(settingDf), list( desc = reactable::colDef( @@ -622,13 +396,21 @@ settingDf <- getSettingsTable( ) ) ) + + + } else{ + cat('No settings to display') } + cat('\n:::\n') + } } # manually adding computeCovariateBalanceArgs -if('computeCovariateBalanceArgs' %in% names(cohortMethodModuleSettings$settings$cmAnalysisList[[i]])){ -cat(paste0('\n##### computeCovariateBalanceArgs Settings \n')) +if('computeCovariateBalanceArgs' %in% names(analysisCm[[i]])){ + if(!is.null(analysisCm[[i]]$computeCovariateBalanceArgs)){ +cat('\n::: {.callout-important collapse="true"}\n') +cat(paste0('\n# Setting computeCovariateBalanceArgs in cohort method \n')) settingName <- 'computeCovariateBalanceArgs' functionName <- getFunctionFromArgName(package, settingName)[1] @@ -641,21 +423,20 @@ cat(paste0('\n##### computeCovariateBalanceArgs Settings \n')) input = NULL ), sep = '\n') - covariateFilter <- cohortMethodModuleSettings$settings$cmAnalysisList[[i]][[settingName]]$covariateFilter - cohortMethodModuleSettings$settings$cmAnalysisList[[i]][[settingName]]$covariateFilter <- NULL + covariateFilter <- analysisCm[[i]][[settingName]]$covariateFilter + analysisCm[[i]][[settingName]]$covariateFilter <- NULL descAndDefault <- getAllHelpDetails(package, functionName) settingDf <- getSettingsTable( package = package, functionName = functionName, - settings = cohortMethodModuleSettings$settings$cmAnalysisList[[i]][[settingName]] + settings = analysisCm[[i]][[settingName]] ) print( shiny::tagList( reportTableFormat( table = settingDf, - #groupBy = "input", columns = append(defaultColumns(settingDf), list( desc = reactable::colDef( @@ -668,7 +449,7 @@ settingDf <- getSettingsTable( ) ) - if(!is.null(covariateFilter)){ + if(is.data.frame(covariateFilter)){ cat("\n covariateFilter Settings: \n") print( shiny::tagList( @@ -679,7 +460,10 @@ settingDf <- getSettingsTable( ) } + cat('\n:::\n') + } + } # if "computeCovariateBalanceArgs" not NULL } # if "computeCovariateBalanceArgs" @@ -691,6 +475,9 @@ settingDf <- getSettingsTable( ### Global Settings +::: {.callout-important collapse="false"} +# Global settings in cohort method + The following settings are used when running the analysis and apply to all CohortMethod analyses. ```{r, echo=FALSE, results = 'asis'} @@ -701,33 +488,34 @@ The following settings are used when running the analysis and apply to all Cohor description = c( getHelpText( package = package, - functionName = 'runCmAnalyses', + functionName = 'createCmAnalysesSpecifications', input = 'refitPsForEveryOutcome' ), getHelpText( package = package, - functionName = 'runCmAnalyses', + functionName = 'createCmAnalysesSpecifications', input = 'refitPsForEveryStudyPopulation' ) ), value = c( - cohortMethodModuleSettings$settings$refitPsForEveryOutcome, - cohortMethodModuleSettings$settings$refitPsForEveryStudyPopulation + refitPsForEveryOutcome, + refitPsForEveryStudyPopulation ) ), groupBy = NULL, columns = NULL - #caption = paste('Global settings for Cohort Method ') ) ``` +::: ### Diagnostics +::: {.callout-important collapse="false"} +# Diagnostics settings in cohort method ```{r, echo=FALSE, results = 'asis'} -if('cmDiagnosticThresholds' %in% names(cohortMethodModuleSettings$settings)){ - diagSetting <- cohortMethodModuleSettings$settings$cmDiagnosticThresholds +if(!is.null(diagSetting)){ diagSettings <- getSettingsTable( package = package, @@ -753,6 +541,7 @@ print( ``` +::: ```{r cm_cohort_tracker, echo=FALSE, results = 'asis',include=FALSE} diff --git a/inst/protocol/cohorts.Rmd b/inst/protocol/cohorts.Rmd index 5c1213c..2222e7d 100644 --- a/inst/protocol/cohorts.Rmd +++ b/inst/protocol/cohorts.Rmd @@ -9,7 +9,7 @@ output: html_document if(params$addCohortDefinitions){ # how to arrange the cohorts? - parentCohortsInd <- which(cohortDefintionDf$isParent) + parentCohortsInd <- which(cohortDefinitionDf$isParent) # order this by cohortName names <- unlist(lapply(parentCohortsInd, function(i){cohortDefinitions[[i]]$cohortName})) parentCohortsInd <- parentCohortsInd[order(names)] @@ -30,16 +30,16 @@ for(i in parentCohortsInd){ if(F){ # Then display the subset logic with link to subsetDef section containing subsetUnique - subCohortInds <- setdiff(which(cohortDefintionDf$parentId == cohortDefinitions[[i]]$cohortId), i) + subCohortInds <- setdiff(which(cohortDefinitionDf$parentId == cohortDefinitions[[i]]$cohortId), i) if(length(subCohortInds) >0){ # order the subCohorts - subnames <- cohortDefintionDf$cohortName[subCohortInds] + subnames <- cohortDefinitionDf$cohortName[subCohortInds] subCohortInds <- subCohortInds[order(subnames)] for(subInd in subCohortInds){ - cat('\n#### ', cohortDefintionDf$cohortName[subInd], paste0('{#cohort-',cohortDefintionDf$cohortId[subInd],'}\n'),'') + cat('\n#### ', cohortDefinitionDf$cohortName[subInd], paste0('{#cohort-',cohortDefinitionDf$cohortId[subInd],'}\n'),'') cat('\n\n::: {.callout-important collapse="true"}\n') cat('## Subset Definition\n\n') @@ -64,9 +64,8 @@ for(i in parentCohortsInd){ ``` ```{r echo=FALSE, results='asis'} - # if there are subsets add them here -if(!is.null(subsetDefs)){ +if(!is.null(subsetUnique)){ cat('\n\n## Subsets \n') for(i in 1:length(subsetUnique)){ @@ -76,7 +75,7 @@ cat('\n\n## Subsets \n') cat(paste0('## ',subsetUnique[[i]]$subsetType,'\n\n')) print(shiny::tagList(reactable::reactable( data = t(as.data.frame(subsetUnique[[i]])), - striped = T + striped = TRUE ))) cat('\n\n:::\n\n') } diff --git a/inst/protocol/patient-level-prediction.Rmd b/inst/protocol/patient-level-prediction.Rmd index 49c93cf..466d137 100644 --- a/inst/protocol/patient-level-prediction.Rmd +++ b/inst/protocol/patient-level-prediction.Rmd @@ -1,122 +1,44 @@ --- output: html_document --- - -## PatientLevelPrediction -This analysis develops binary classifiers for a given patient population that predict the risk of a patient developing some outcome during some time at risk relative to prediction index. These models are useful if you want to implement some intervention and would like to identify a 'high risk' group of patients who may benefit most from the intervention. - -### Overview ```{r, echo=FALSE, result = 'asis'} -tos <- data.frame( -targetId = unlist(lapply(PatientLevelPredictionModuleSettings$settings$modelDesignList, function(x) x$targetId)), -outcomeId = unlist(lapply(PatientLevelPredictionModuleSettings$settings$modelDesignList, function(x) x$outcomeId)) +plpSettings <- ProtocolGenerator::getPlpSettings( + PatientLevelPredictionModuleSettings = PatientLevelPredictionModuleSettings, + cohortDefinitionDf = cohortDefinitionDf ) -# add names, parents, subset info for t and o -tempDf <- cohortDefintionDf -colnames(tempDf) <- paste0(colnames(tempDf),'Target') -tos <- merge(tempDf, tos, by.x = 'cohortIdTarget', by.y = 'targetId') -tempDf <- cohortDefintionDf -colnames(tempDf) <- paste0(colnames(tempDf),'Outcome') -tos <- merge(tempDf, tos, by.x = 'cohortIdOutcome', by.y = 'outcomeId') - - -# remove T and O from model designs and get unique -# may need to also remove seed from split? -modelDesign <- PatientLevelPredictionModuleSettings$settings$modelDesignList -for(i in 1:length(modelDesign)){ - modelDesign[[i]]$targetId <- NULL - modelDesign[[i]]$outcomeId <- NULL -} -modelDesignUnique <- unique(modelDesign) - -tos$designId <- rep(0, length(modelDesign)) -for(j in 1:length(modelDesignUnique)){ -tos$designId[which(unlist(lapply(modelDesign, function(x) identical(modelDesignUnique[[j]], x))))] <- j -} - -# covariate set - get attr(,"fun") -covSet <- c() -for(cind in 1:length(modelDesignUnique)){ -if(class(modelDesignUnique[[cind]]$covariateSettings) == 'covariateSettings'){ - modelDesignUnique[[cind]]$covariateSettings <- list(modelDesignUnique[[cind]]$covariateSettings) -} - - covSet <- c(covSet,paste0(unlist(lapply(modelDesignUnique[[cind]]$covariateSettings, function(x){ - func <- attr(x, "fun") - settings <- x[sapply(x, function(x) is.logical(x))] - if(length(settings)>0){ - settings <- names(settings)[unlist(settings)] - func <- paste0(c(func, paste0(settings, collapse = ',')), collapse = ': ') - } - return(func) - })), collapse = ' - ')) - -} - -# TODO remove this or revise? - add covariate summary name? -predictionSummary <- data.frame( - model_design = paste0(" View "), - number_targets = unlist(lapply(1:length(modelDesignUnique), function(x){length(unique(tos$parentIdTarget[tos$designId == x]))})), - number_targets_with_subsets = unlist(lapply(1:length(modelDesignUnique), function(x){length(unique(tos$cohortIdTarget[tos$designId == x]))})), -number_outcomes = unlist(lapply(1:length(modelDesignUnique), function(x){length(unique(tos$parentIdOutcome[tos$designId == x]))})), -number_outcomes_with_subsets = unlist(lapply(1:length(modelDesignUnique), function(x){length(unique(tos$cohortIdOutcome[tos$designId == x]))})), - timeAtRisk = paste0( - unlist(lapply(modelDesignUnique , function(x) x$populationSettings$startAnchor)), - ' + ', - unlist(lapply(modelDesignUnique, function(x) x$populationSettings$riskWindowStart)), - ' - ', - unlist(lapply(modelDesignUnique, function(x) x$populationSettings$endAnchor)), - ' + ', - unlist(lapply(modelDesignUnique, function(x) x$populationSettings$riskWindowEnd)) - ), -covariates = covSet -) +tos <- plpSettings$targetOutcomeSet +modelDesignUnique <- plpSettings$modelDesignUnique +predictionSummary <- plpSettings$predictionSummary + +plpColDefs <- ProtocolGenerator::getPlpColDefs() + ``` + +## PatientLevelPrediction -There is a total of ``r length(modelDesignUnique)`` patient level prediction model designs specified, see @sec-model-designs. The table below contains links to the model designs that show the table of target and outcome pairs and the model specification. The table also summarizes the time-at-risk for each model design and the covariate settings. +This analysis develops binary classifiers for a given patient population that predict the risk of a patient developing some outcome during some time at risk relative to prediction index. These models are useful if you want to implement some intervention and would like to identify a 'high risk' group of patients who may benefit most from the intervention. +There is a total of ``r length(modelDesignUnique)`` patient level prediction model designs specified, see @sec-model-designs. The table below contains links to the model designs that show the table of target and outcome pairs and the model specification. The table also summarizes the time-at-risk for each model design and the covariate settings. +::: {.callout-important collapse="false"} +# Table of model designs ```{r, echo=FALSE, result = 'asis'} reportTableFormat( table = predictionSummary, - columns = list( - model_design = reactable::colDef( - html = T, - name = 'Model Design' - ), - number_targets = reactable::colDef( - name = 'Parent Target Count' - ), - number_targets_with_subsets = reactable::colDef( - name = 'Target Count' - ), - number_outcomes = reactable::colDef( - name = 'Parent Outcome Count' - ), - number_outcomes_with_subsets = reactable::colDef( - name = 'Outcome Count' - ), - timeAtRisk = reactable::colDef( - name = 'Time-at-risk', - width = 200 - ), - covariates = reactable::colDef( - name = 'Covariate Set', - width = 300 - ) - - )#, - #caption = 'Overview of prediction models developed {#tbl-prediction-summary}' + columns = plpColDefs ) ``` +::: ### Output +::: {.callout-important collapse="false"} +# Outputs of patient-level prediction The following are the standardized metrics used to evaluate patient-level prediction models. ```{r, echo=FALSE, result = 'asis'} @@ -142,6 +64,7 @@ modelEvaluation <- data.frame(rbind( ``` +::: ### Model Design {#sec-model-designs} ```{r results='asis', echo=FALSE} diff --git a/inst/protocol/prediction/model-design.Rmd b/inst/protocol/prediction/model-design.Rmd index 6ca94a9..6d39dc5 100644 --- a/inst/protocol/prediction/model-design.Rmd +++ b/inst/protocol/prediction/model-design.Rmd @@ -3,6 +3,9 @@ cat('\n\n#### Model Design ', i, paste0(' {#sec-model-design-',i,'}'),' \n\n') ``` +::: {.callout-important collapse="true"} +# Model Design + ```{r, child = "prediction/plp-targets-outcomes.Rmd"} ``` @@ -13,4 +16,6 @@ cat('\n\n#### Model Design ', i, paste0(' {#sec-model-design-',i,'}'),' \n\n') ``` ```{r, child = "prediction/plp-analysis.Rmd"} -``` \ No newline at end of file +``` + +::: \ No newline at end of file diff --git a/inst/protocol/prediction/plp-targets-outcomes.Rmd b/inst/protocol/prediction/plp-targets-outcomes.Rmd index da36302..38ec7d0 100644 --- a/inst/protocol/prediction/plp-targets-outcomes.Rmd +++ b/inst/protocol/prediction/plp-targets-outcomes.Rmd @@ -9,21 +9,23 @@ output: html_document reportTableFormat( table = tosSub %>% dplyr::arrange(.data$parentNameTarget, .data$cohortNameTarget, .data$parentNameOutcome), - groupBy = c('parentNameTarget','cohortNameTarget'), + groupBy = 'parentNameTarget', + elementId = paste0('plp-targets-',i), + groupByButton = TRUE, columns = list( - subsetIdTarget = reactable::colDef(show = F), - isParentTarget = reactable::colDef(show = F), - parentIdTarget = reactable::colDef(show = F), - subsetNameTarget = reactable::colDef(show = F), - packageVersionTarget = reactable::colDef(show = F), - numberSubsetOperatorsTarget = reactable::colDef(show = F), + subsetIdTarget = reactable::colDef(show = FALSE), + isParentTarget = reactable::colDef(show = FALSE), + parentIdTarget = reactable::colDef(show = FALSE), + subsetNameTarget = reactable::colDef(show = FALSE), + packageVersionTarget = reactable::colDef(show = FALSE), + numberSubsetOperatorsTarget = reactable::colDef(show = FALSE), - subsetIdOutcome = reactable::colDef(show = F), - isParentOutcome = reactable::colDef(show = F), - parentIdOutcome = reactable::colDef(show = F), - subsetNameOutcome = reactable::colDef(show = F), - packageVersionOutcome = reactable::colDef(show = F), - numberSubsetOperatorsOutcome = reactable::colDef(show = F), + subsetIdOutcome = reactable::colDef(show = FALSE), + isParentOutcome = reactable::colDef(show = FALSE), + parentIdOutcome = reactable::colDef(show = FALSE), + subsetNameOutcome = reactable::colDef(show = FALSE), + packageVersionOutcome = reactable::colDef(show = FALSE), + numberSubsetOperatorsOutcome = reactable::colDef(show = FALSE), cohortNameTarget = reactable::colDef( show = TRUE, @@ -40,13 +42,13 @@ reportTableFormat( minWidth = 300, aggregate = 'count' ), - cohortIdTarget = reactable::colDef(show = F), - cohortIdOutcome = reactable::colDef(show = F), + cohortIdTarget = reactable::colDef(show = FALSE), + cohortIdOutcome = reactable::colDef(show = FALSE), subsetCohortsTarget = reactable::colDef(html = TRUE), - subsetCohortsOutcome = reactable::colDef(show = F), + subsetCohortsOutcome = reactable::colDef(show = FALSE), appliedSubsetsTarget = reactable::colDef(html = TRUE), - appliedSubsetsOutcome = reactable::colDef(show = F), + appliedSubsetsOutcome = reactable::colDef(show = FALSE), parentNameOutcome = reactable::colDef( show = TRUE, @@ -56,12 +58,12 @@ reportTableFormat( minWidth = 300, aggregate = 'count' ), - designId = reactable::colDef(show = F), + designId = reactable::colDef(show = FALSE), parentNameTarget = reactable::colDef( name = 'Target Parent', html = TRUE, - filterable = T, + filterable = TRUE, minWidth = 300 ), cohortNameWithLinkTarget = reactable::colDef( diff --git a/inst/protocol/self-control-case-series.qmd b/inst/protocol/self-control-case-series.qmd index 3717865..fa3422c 100644 --- a/inst/protocol/self-control-case-series.qmd +++ b/inst/protocol/self-control-case-series.qmd @@ -6,244 +6,60 @@ output: html_document package <- "SelfControlledCaseSeries" -eo <- do.call( - what = rbind, - args = lapply( - X = 1:length(SelfControlledCaseSeriesModuleSettings$settings$exposuresOutcomeList), - FUN = function(k){ - x <- SelfControlledCaseSeriesModuleSettings$settings$exposuresOutcomeList[[k]] - data.frame( - setting = ifelse(is.null(x$jsonId), 1, x$jsonId), #k, - outcomeId = rep(x$outcomeId, length(x$exposures)), - exposureId = unlist(lapply(x$exposures, function(x){x$exposureId})), - exposureIdRef = unlist(lapply(x$exposures, function(x){paste0(x$exposureIdRef)})), - nestingId = ifelse(is.null(x$nestingCohortId), -1, x$nestingCohortId), - trueEffectSize = unlist(lapply(x$exposures, function(x){ifelse(is.null(x$trueEffectSize), '', x$trueEffectSize )})) +sccsSettings <- ProtocolGenerator::getSccsSettings( + SelfControlledCaseSeriesModuleSettings = SelfControlledCaseSeriesModuleSettings, + cohortDefinitionDf = cohortDefinitionDf, + negativeControls = negativeControls ) - - } - ) - ) - -# ===== NEW FOR COHORT NEGATIVE CONTROLS -# add code to extract negative controls if missing -if(is.null(negativeControls)){ - # create negative control data.frame using the exposure outcomes with trueEffectSize == 1 -neg <- do.call( - what = rbind, - args = lapply( - X = 1:length(SelfControlledCaseSeriesModuleSettings$settings$exposuresOutcomeList), - FUN = function(k){ - x <- SelfControlledCaseSeriesModuleSettings$settings$exposuresOutcomeList[[k]] - data.frame( - cohortId = rep(x$outcomeId, length(x$exposures)), - outcomeConceptId = rep(x$outcomeId, length(x$exposures)), - occurrenceType = 'Cohort', - detectOnDescendants = 'NA', - trueEffectSize = unlist(lapply(x$exposures, function(x){ifelse(is.null(x$trueEffectSize), '', x$trueEffectSize )})) - ) - } - ) -) - - neg <- unique(neg[neg$trueEffectSize == 1,]) - negativeControlsSCCS <- merge(neg, cohortDefintionDf[,c('cohortId', 'cohortName')], by = 'cohortId') -} else{ - negativeControlsSCCS <- negativeControls -} -# ===== END NEW FOR COHORT NEGATIVE CONTROLS - -# Should we unique? -eoUnique <- eo -#eoUnique <- unique(eo) - -# add in the target and indication parents -tempDf <- cohortDefintionDf -colnames(tempDf) <- paste0(colnames(tempDf), 'Target') -eoUnique <- merge(eoUnique, tempDf, by.x = 'exposureId', by.y = 'cohortIdTarget') -tempDf <- cohortDefintionDf[, c('cohortId', 'parentName', 'cohortNameWithLink','cohortName')] -colnames(tempDf) <- paste0(colnames(tempDf), 'Indication') -eoUnique <- merge(eoUnique, tempDf, by.x = 'nestingId', by.y = 'cohortIdIndication', - all.x = T) - - -# figure out unique negative controls vs shared -neo <- eoUnique[eoUnique$trueEffectSize == 1 & eoUnique$exposureId != -1,] - -# set defaults when there are no negative controls -negInCommon <- NULL -negNotInCommon <- NULL - -if(nrow(neo) > 0 ){ #if any negative outcomes -settings <- unique(neo$setting) -negInCommon <- neo$outcomeId[neo$setting == settings[1]] -for(ngi in 1:length(settings)){ - negInCommon <- intersect(negInCommon, neo$outcomeId[neo$setting == settings[ngi]]) -} -negNotInCommon <- neo[!neo$outcomeId %in% negInCommon,] - -# if all analyses shared the same negative controls -if(nrow(negNotInCommon) == 0){ - #eo$setting <- 0 - eoUnique <- eoUnique %>% dplyr::select(-'setting') -} - -if(length(negInCommon)>0){ -negTabShared <- do.call( - what = rbind, - args = lapply( - X = negInCommon, - FUN = function(x){negativeControlsSCCS[negativeControlsSCCS$cohortId == x,]} - ) -) - -negTabShared <- negTabShared %>% - dplyr::mutate(outcomeName = paste(.data$cohortName, '(concept/cohort: ',.data$outcomeConceptId,')')) %>% - dplyr::select(-c("cohortId","cohortName","outcomeConceptId")) - -} #end if length(negInCommon)>0 - - -# add the setting -if(length(negNotInCommon$outcomeId)>0){ -negTab <- do.call( - what = rbind, - args = lapply( - X = negNotInCommon, - FUN = function(x){negativeControlsSCCS[negativeControlsSCCS$cohortId == x,]} - ) -) -negTab$cohortId <- unlist(negTab$cohortId) -negTab <- merge( - x = negTab, - y = negNotInCommon[,c('outcomeId', 'setting','exposureId')], - by.x = 'cohortId', - by.y = 'outcomeId' - ) - -tempDf <- cohortDefintionDf[, c('parentName','cohortName', 'cohortId')] -colnames(tempDf) <- paste0(colnames(tempDf),'Target') -negTab <- merge(negTab, tempDf, by.x = 'exposureId', by.y = 'cohortId') - -negTab <- negTab %>% - dplyr::mutate(outcomeName = paste(.data$cohortName, '(concept: ',.data$outcomeConceptId,')')) %>% - dplyr::select(-c("cohortId","cohortName","outcomeConceptId")) - -} # end Negtab - -} # end if any negative outcomes - -eoOfInt <- unique(eoUnique[eoUnique$trueEffectSize == '' & eoUnique$exposureId != -1,]) -tempDf <- cohortDefintionDf -colnames(tempDf) <- paste0(colnames(tempDf), 'Outcome') -eoOfInt <- merge(eoOfInt, tempDf, by.x = 'outcomeId', by.y = 'cohortIdOutcome') %>% - dplyr::arrange(.data$parentNameTarget, .data$cohortNameIndication, .data$cohortNameOutcome) - - +sccsColDefs <- ProtocolGenerator::getSccsColDefs() +eoOfInt <- sccsSettings$eoOfInt +negTabShared <- sccsSettings$negTabShared +negTab <- sccsSettings$negTab + ``` ## Self Controlled Case Series ### Overview - +::: {.callout-important collapse="false"} +# Summary of self controlled case series The self controlled case series aims to determine whether there is an effect between a drug and outcome. The self controlled case series compares exposure time with unexposed time to see whether the outcome is more likely to occur while exposed. The design requires the user to specify the target population of interest, an optional indication to restrict to and the outcome of interest. Similar to cohort method, diagnostics to implemented to identify potential bias and effect estimates are only unblinded if all diagnostics pass. In this specification there are ``r length(unique(eoOfInt$parentIdTarget))`` unique parent exposure cohorts (``r nrow(unique(eoOfInt[, c('exposureId', 'nestingId')]))`` unique exposure and indications combinations), see @sec-sccs-eo. There is a total of ``r length(unique(eoOfInt$nestingId))`` unique indications. A total of ``r length(unique(eoOfInt$parentIdOutcome))`` parent outcome cohorts (``r length(unique(eoOfInt$outcomeId))`` unique outcomes with subsets). -In total there are ``r length(SelfControlledCaseSeriesModuleSettings$settings$sccsAnalysisList)`` different self controlled case series analysis designs (see @sec-sccs-analysis). +In total there are ``r length(sccsSettings$sccsAnalysisList)`` different self controlled case series analysis designs (see @sec-sccs-analysis). +::: ### Exposure Indication Outcomes {#sec-sccs-eo} + +::: {.callout-important collapse="true"} +# Outcome exposure pairs of interest included in sccs ```{r sccs_exposure_outcomes, echo=FALSE, results = 'asis'} reportTableFormat( table = eoOfInt %>% dplyr::select(-c("trueEffectSize", "exposureIdRef")) %>% dplyr::arrange(.data$parentNameTarget, .data$cohortNameWithLinkOutcome), - groupBy = c('parentNameTarget', 'cohortNameIndication','cohortNameOutcome'), # or outcome? - columns = list( - outcomeId = reactable::colDef(show = F), - exposureId = reactable::colDef(show = F), - nestingId = reactable::colDef(show = F), - - subsetIdTarget = reactable::colDef(show = F), - isParentTarget = reactable::colDef(show = F), - parentIdTarget = reactable::colDef(show = F), - subsetNameTarget = reactable::colDef(show = F), - packageVersionTarget = reactable::colDef(show = F), - numberSubsetOperatorsTarget = reactable::colDef(show = F), - - subsetIdOutcome = reactable::colDef(show = F), - isParentOutcome = reactable::colDef(show = F), - parentIdOutcome = reactable::colDef(show = F), - subsetNameOutcome = reactable::colDef(show = F), - packageVersionOutcome = reactable::colDef(show = F), - numberSubsetOperatorsOutcome = reactable::colDef(show = F), - - cohortNameTarget = reactable::colDef( - show = TRUE, - name = 'Exposure', - html = TRUE, - filterable = T - ), - cohortNameOutcome = reactable::colDef( - name = 'Outcome', - html = TRUE, - filterable = T - ), - cohortNameIndication = reactable::colDef( - name = 'Indication', - html = TRUE, - filterable = T - ), - - parentNameOutcome = reactable::colDef(show = FALSE), - parentNameIndication = reactable::colDef(show = FALSE), - - subsetCohortsTarget = reactable::colDef(show = F), - subsetCohortsOutcome = reactable::colDef(show = F), - appliedSubsetsTarget = reactable::colDef(show = F), - appliedSubsetsOutcome = reactable::colDef(show = F), - - parentNameTarget = reactable::colDef( - name = 'Exposure Parent', - html = TRUE, - filterable = TRUE - ), - - cohortNameWithLinkTarget = reactable::colDef( - show = FALSE, - name = 'Exposure', - html = TRUE, - filterable = T - ), - cohortNameWithLinkOutcome = reactable::colDef( - show = FALSE, - name = 'Outcome', - html = TRUE, - filterable = T - ), - cohortNameWithLinkIndication = reactable::colDef( - show = FALSE, - name = 'Indication', - html = TRUE, - filterable = T - ) - ), + groupBy = 'parentNameTarget', # or outcome? + columns = sccsColDefs, + elementId = 'sccs-eio', + groupByButton = TRUE, caption = 'Outcome exposure pairs of interest included in study' ) cat('\n\n') ``` +::: ### Negative Outcomes ```{r negative_control_table, echo=FALSE, results = 'asis'} -if(length(negInCommon)>0){ +if(!is.null(negTabShared)){ cat('\n\n') cat(paste("A total of ", length(unique(negTabShared$outcomeName)), " negative control outcomes were shared across all the analyses\n\n"), sep = '\n\n') cat('\n\n') @@ -252,6 +68,8 @@ if(!"standardConcept" %in% colnames(negTabShared)){ negTabShared$standardConcept <- '' } +cat('\n::: {.callout-important collapse="false"}\n') +cat('\n# Negative controls shared in sccs\n') print(shiny::tagList(reportTableFormat( table = negTabShared %>% dplyr::select("outcomeName", "standardConcept") %>% @@ -267,13 +85,17 @@ print(shiny::tagList(reportTableFormat( caption = 'Negative outcomes shared across the study' ))) +cat('\n:::\n') cat('\n\n') } # end NegTabShared -if(length(negNotInCommon$outcomeId)>0){ - +if(!is.null(negTab)){ + +cat('\n::: {.callout-important collapse="true"}\n') +cat('\n# Negative controls per analysis in sccs\n') + reportTableFormat( table = negTab, groupBy = 'setting',#c('outcomeName', 'exposureName'), @@ -284,17 +106,18 @@ reportTableFormat( outcomeName = reactable::colDef( name = 'Outcome', html = TRUE, - filterable = T + filterable = TRUE ), exposureName = reactable::colDef( name = 'Exposure', html = TRUE, - filterable = T + filterable = TRUE ) ), caption = 'Negative outcome included in study per setting' ) +cat('\n:::\n') cat('\n\n') } # end NegtabNotShared @@ -305,9 +128,9 @@ cat('\n\n') ```{r sccs_analyses, echo=FALSE, results = 'asis'} -for(i in 1:length(SelfControlledCaseSeriesModuleSettings$settings$sccsAnalysisList)){ +for(i in 1:length(sccsSettings$sccsAnalysisList)){ - analysisSetting <- SelfControlledCaseSeriesModuleSettings$settings$sccsAnalysisList[[i]] + analysisSetting <- sccsSettings$sccsAnalysisList[[i]] cat( paste0('#### Analysis ', analysisSetting$analysisId,': ', analysisSetting$description, ' \n'), @@ -319,9 +142,10 @@ for(i in 1:length(SelfControlledCaseSeriesModuleSettings$settings$sccsAnalysisLi functionName <- getFunctionFromArgName(package, settingName) - cat(paste0('\n##### ',settingName,' Settings \n'), - - getHelpText( + cat('\n::: {.callout-important collapse="true"}\n') + cat(paste0('\n# Setting ',settingName,' used in sccs\n')) + + cat(getHelpText( package = 'SelfControlledCaseSeries', functionName = functionName, input = NULL @@ -349,12 +173,13 @@ settingDf <- getSettingsTable( ) ) ) - + cat('\n:::\n') } # analysisSetting$createIntervalDataArgs - cat(paste0('\n##### ','createIntervalDataArgs',' Settings \n'), - + cat('\n::: {.callout-important collapse="true"}\n') + cat(paste0('\n# Setting createIntervalDataArgs used in sccs\n')) + cat( getHelpText( package = package, functionName = 'createSccsIntervalData', @@ -454,7 +279,6 @@ settingDf <- getSettingsTable( htmltools::tagList( reportTableFormat( table = allData, - groupBy = 'input', columns = append(defaultColumns(allData), list( desc = reactable::colDef( @@ -465,7 +289,7 @@ settingDf <- getSettingsTable( ) ) ) - + cat('\n:::\n') #cat("\n:::\n") } @@ -475,9 +299,11 @@ settingDf <- getSettingsTable( ```{r sccs_diagnostics, echo=FALSE, results = 'asis'} - -if('sccsDiagnosticThresholds' %in% names(SelfControlledCaseSeriesModuleSettings$settings)){ - diagSetting <- SelfControlledCaseSeriesModuleSettings$settings$sccsDiagnosticThresholds + cat('\n::: {.callout-important collapse="false"}\n') + cat(paste0('\n# Diagnostics used in sccs \n')) + +if('sccsDiagnosticThresholds' %in% names(sccsSettings)){ + diagSetting <- sccsSettings$sccsDiagnosticThresholds diagSettings <- getSettingsTable( package = package, @@ -499,7 +325,11 @@ print( ) ) ) +} else{ + cat('No settings found') } + + cat('\n:::\n') ``` diff --git a/inst/protocol/study_protocol.qmd b/inst/protocol/study_protocol.qmd index ff37f48..229654f 100644 --- a/inst/protocol/study_protocol.qmd +++ b/inst/protocol/study_protocol.qmd @@ -32,130 +32,14 @@ cohortTracker <- c() # this will add cohorts used in the spec json <- ParallelLogger::loadSettingsFromJson(params$jsonLocation) modulesInJson <- unlist(lapply(json$moduleSpecifications, function(x) x$module)) -# need to finish this function below... +# this function processes the json cohort def to get the cohort details cohortDetails <- ProtocolGenerator::getCohortDefinitionsFromJson(json) - cohortDefinitions <- cohortDetails$cohortDefinitions -cohortIds <- cohortDetails$cohortIds -cohortNames <- cohortDetails$cohortNames -cohortNamesLink <- paste0(cohortNames, ' View') -#cohortNamesLink <- paste0(cohortNames, ' (@cohort-',cohortIds, ')') - -subsetIds <- unlist(lapply(cohortDefinitions, function(x){ - if(!is.null(x$subsetDefinition)){ - ParallelLogger::convertJsonToSettings(x$subsetDefinition)$definitionId - } else{ - return(-1) -} -})) - -cohortDefintionDf <- data.frame( - cohortName = cohortNames, - cohortNameWithLink = cohortNamesLink, - cohortId = cohortIds, - subsetId = subsetIds, - isParent = subsetIds == -1, - parentId = cohortIds, - parentName = cohortNames -) -cohortDefintionDf$parentId[!cohortDefintionDf$isParent] <- (cohortDefintionDf$cohortId - cohortDefintionDf$subsetId)[!cohortDefintionDf$isParent]/1000 -cohortDefintionDf$parentName <- sapply(cohortDefintionDf$parentId, function(x){ - paste0(cohortNames[which(x == cohortIds)], ' View') - } - ) - -# =========== SUBSETS ============ -#================================== -subsetDefs <- cohortDetails$subSetDefs -if(!is.null(subsetDefs)){ -subsetDefs <- lapply(subsetDefs$json, function(x) ParallelLogger::convertJsonToSettings(x)) - -subsetOps <- lapply(subsetDefs, function(x){ - x$subsetOperators -}) - -# remove name and extract cohortIds when subsetType == "CohortSubsetOperator" -subsetUnique <- subsetOps -subsetUniqueAppend <- list() -for(sind in 1:length(subsetUnique)){ - for(sind2 in 1:length(subsetUnique[[sind]])){ - subsetUnique[[sind]][[sind2]]$name <- NULL - if(subsetUnique[[sind]][[sind2]]$subsetType == 'CohortSubsetOperator'){ - subsetUnique[[sind]][[sind2]]$cohortIds <- NULL - } - } - subsetUniqueAppend <- append(subsetUniqueAppend,subsetUnique[[sind]]) -} -subsetUnique <- unique(subsetUniqueAppend) - -# now extract into a data.frame and find out which subsets were used -# get subsetId cohorts - -subsetDetails <- do.call('rbind', lapply(subsetDefs, function(x){ - data.frame( - subsetName = x$name, - subsetId = x$definitionId, - packageVersion = x$packageVersion, - #identifierExpression = x$identifierExpression, - #operatorNameConcatString = x$operatorNameConcatString, - #subsetCohortNameTemplate = x$subsetCohortNameTemplate, - numberSubsetOperators = length(x$subsetOperators) - ) -})) - -# add CohortSubsetOperator subset cohorts -subsetDetails$subsetCohorts <- unlist(lapply(subsetOps, function(x){ - paste(unlist(lapply(x, function(y){ - if(y$subsetType == 'CohortSubsetOperator'){ - if(y$negate == FALSE){ - - ytemp <- y - ytemp$name <- NULL - ytemp$cohortIds <- NULL - subsetInd <- which(unlist(lapply(subsetUnique, function(x) identical(ytemp, x)))) - - # add cohort link below - return(paste0(" View Cohort View Subset")) - } - } - return(NULL) - } - )), collapse = ',') -})) - -subsetDetails$appliedSubsets <- unlist(lapply(subsetOps, function(x){ - paste(unlist(lapply(x, function(y){ - ytemp <- y - ytemp$name <- NULL - ytemp$cohortIds <- NULL - subsetInd <- which(unlist(lapply(subsetUnique, function(x) identical(ytemp, x)))) - return(paste0(" View Subset" )) - } - )), collapse = ',') -})) +subsetUnique <- cohortDetails$subsetUnique +cohortDefinitionDf <- cohortDetails$cohortDefinitionDf -# add subset details to cohortDefintionDf? -cohortDefintionDf <- merge(cohortDefintionDf, subsetDetails, by = 'subsetId', all.x = T) - -# return: subsetUnique - a list of subset logics -# subsetDetails - a data.frame with subset details -# cohortDefintionDf - cohort definition with subset details added - -} # end if subsetDefs is not null +negativeControls <- ProtocolGenerator::getNegativeControlsFromJson(json) -negativeControls <- NULL -if("negativeControlOutcomes" %in% unlist(lapply(json$sharedResources, function(x) names(x)))){ - - negativeControlInd <- which(unlist(lapply(json$sharedResources, function(x) "negativeControlOutcomes" %in% names(x)))) - - negativeControlsTemp <- json$sharedResources[[negativeControlInd]]$negativeControlOutcomes - - negativeControls <- as.data.frame(do.call(rbind,lapply(negativeControlsTemp$negativeControlOutcomeCohortSet, function(x) x))) - - negativeControls$occurrenceType <- negativeControlsTemp$occurrenceType - negativeControls$detectOnDescendants <- negativeControlsTemp$detectOnDescendants - -} ``` # ABREVIATIONS diff --git a/inst/protocol/table-use.Rmd b/inst/protocol/table-use.Rmd index 4c6f054..91b3b1e 100644 --- a/inst/protocol/table-use.Rmd +++ b/inst/protocol/table-use.Rmd @@ -10,7 +10,7 @@ output: html_document # parent name, parent id, cohort name, cohort id, ci_target, ci_outcome, char_target, char_outcome, cm_target, cm_comp, cm_outcome, sccs_target, sccs_outcome, plp_target, plp_outcome cohortTrackerAll <- merge( - cohortDefintionDf[, c('parentName','parentId','cohortName','cohortId')], + cohortDefinitionDf[, c('parentName','parentId','cohortName','cohortId')], cohortTracker, by = 'cohortId' ) @@ -109,7 +109,29 @@ trackerCols = list( style = "width: 100%; height: 28px;" ) }), - cTarget = reactable::colDef( + + + tbTarget = reactable::colDef( + cell = reactable::JS(" + function(cellInfo) { + // Render as an X mark or check mark + return cellInfo.value === 0 ? '\u274c No' : '\u2714\ufe0f Yes' + } + "), + filterable = TRUE, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('cohort-tracker', '%s', event.target.value || undefined)", name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + }), + + rfTarget = reactable::colDef( cell = reactable::JS(" function(cellInfo) { // Render as an X mark or check mark @@ -128,7 +150,7 @@ trackerCols = list( style = "width: 100%; height: 28px;" ) }), - cOutcome = reactable::colDef( + rfOutcome = reactable::colDef( cell = reactable::JS(" function(cellInfo) { // Render as an X mark or check mark @@ -147,6 +169,46 @@ trackerCols = list( style = "width: 100%; height: 28px;" ) }), + + csTarget = reactable::colDef( + cell = reactable::JS(" + function(cellInfo) { + // Render as an X mark or check mark + return cellInfo.value === 0 ? '\u274c No' : '\u2714\ufe0f Yes' + } + "), + filterable = TRUE, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('cohort-tracker', '%s', event.target.value || undefined)", name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + }), + csOutcome = reactable::colDef( + cell = reactable::JS(" + function(cellInfo) { + // Render as an X mark or check mark + return cellInfo.value === 0 ? '\u274c No' : '\u2714\ufe0f Yes' + } + "), + filterable = TRUE, + filterInput = function(values, name) { + shiny::tags$select( + # Set to undefined to clear the filter + onchange = sprintf("Reactable.setFilter('cohort-tracker', '%s', event.target.value || undefined)", name), + # "All" has an empty value to clear the filter, and is the default option + shiny::tags$option(value = "", "All"), + lapply(unique(values), shiny::tags$option), + "aria-label" = sprintf("Filter %s", name), + style = "width: 100%; height: 28px;" + ) + }), + tteTarget = reactable::colDef( cell = reactable::JS(" function(cellInfo) { diff --git a/man/cmColDef.Rd b/man/cmColDef.Rd new file mode 100644 index 0000000..39ba1e5 --- /dev/null +++ b/man/cmColDef.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CohortMethod.R +\name{cmColDef} +\alias{cmColDef} +\title{cmColDef} +\usage{ +cmColDef(elementId = "cm-tc-tab", colNames = NULL) +} +\arguments{ +\item{elementId}{An element id for the table using this column definitions (needed for the drop down selection)} + +\item{colNames}{Optional a vector of column names to restrict to} +} +\value{ +A column definition list +} +\description{ +Extract cohorts from json +} +\details{ +Returns a names list with the cohorts +} diff --git a/man/createStratSentance.Rd b/man/createStratSentance.Rd new file mode 100644 index 0000000..2384748 --- /dev/null +++ b/man/createStratSentance.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CohortIncidence.R +\name{createStratSentance} +\alias{createStratSentance} +\title{createStratSentance} +\usage{ +createStratSentance(CohortIncidenceModuleSettings) +} +\arguments{ +\item{CohortIncidenceModuleSettings}{The cohort incidence module specification} +} +\value{ +An string with the stratification information +} +\description{ +Create a sentence that explains the stratification defined in the analysis. +} +\details{ +Returns a string +} diff --git a/man/extractCohortMethodSettings.Rd b/man/extractCohortMethodSettings.Rd new file mode 100644 index 0000000..02e4a76 --- /dev/null +++ b/man/extractCohortMethodSettings.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CohortMethod.R +\name{extractCohortMethodSettings} +\alias{extractCohortMethodSettings} +\title{extractCohortMethodSettings} +\usage{ +extractCohortMethodSettings( + cohortMethodModuleSettings, + negativeControls, + cohortDefinitionDf +) +} +\arguments{ +\item{negativeControls}{NULL or a data.frame of the negative controls} + +\item{cohortDefinitionDf}{The data.frame with the cohort definition details} + +\item{cohortMethodModuleSettings.}{The cohort method module specification} +} +\value{ +An named R list with ... +} +\description{ +Extract cohorts from json +} +\details{ +Returns a names list with the cohorts +} diff --git a/man/getCIcolumns.Rd b/man/getCIcolumns.Rd new file mode 100644 index 0000000..cbd728f --- /dev/null +++ b/man/getCIcolumns.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CohortIncidence.R +\name{getCIcolumns} +\alias{getCIcolumns} +\title{getCIcolumns} +\usage{ +getCIcolumns() +} +\value{ +A list of colDefs for the target and outcome tables describing the cohort incidence analysis +} +\description{ +A reactable colDef list for the cohort incidence tables +} +\details{ +Returns a list of colDefs +} diff --git a/man/getCdCols.Rd b/man/getCdCols.Rd new file mode 100644 index 0000000..aa2f09f --- /dev/null +++ b/man/getCdCols.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CohortDiagnostics.R +\name{getCdCols} +\alias{getCdCols} +\title{getCdCols} +\usage{ +getCdCols() +} +\value{ +A list of colDefs for cohort diagnostic +} +\description{ +A list of colDefs for the columns used in cohort diagnostic protocol module +} +\details{ +Returns a list of colDefs +} diff --git a/man/getCiTargetsOutcomes.Rd b/man/getCiTargetsOutcomes.Rd new file mode 100644 index 0000000..cc10fb3 --- /dev/null +++ b/man/getCiTargetsOutcomes.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CohortIncidence.R +\name{getCiTargetsOutcomes} +\alias{getCiTargetsOutcomes} +\title{getCiTargetsOutcomes} +\usage{ +getCiTargetsOutcomes(CohortIncidenceModuleSettings, cohortDefinitionDf) +} +\arguments{ +\item{CohortIncidenceModuleSettings}{The cohort incidence module specification} + +\item{cohortDefinitionDf}{The data.frame with the cohort definition details} +} +\value{ +A list with the tables to present in the protocol +} +\description{ +Extracts a list of target tables, outcome tables, TARs and vector of unique targetIds and outcomeIds in analysis +} +\details{ +Returns a list +} diff --git a/man/getCohortDefinitionsFromJson.Rd b/man/getCohortDefinitionsFromJson.Rd index 3fb8b2b..ce0408f 100644 --- a/man/getCohortDefinitionsFromJson.Rd +++ b/man/getCohortDefinitionsFromJson.Rd @@ -10,7 +10,7 @@ getCohortDefinitionsFromJson(json) \item{json}{The json analysis specification} } \value{ -An named R list with the elements subSetDefs, cohortIds, cohortNames and cohortDefinitions +An named R list with the elements subsetUnique (list of subset operators), cohortDefinitions (list of cohortDefinitions) and cohortDefinitionDf (data.frame of cohort definitions) } \description{ Extract cohorts from json diff --git a/man/getCohortDiagnosticTables.Rd b/man/getCohortDiagnosticTables.Rd new file mode 100644 index 0000000..137d3dc --- /dev/null +++ b/man/getCohortDiagnosticTables.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CohortDiagnostics.R +\name{getCohortDiagnosticTables} +\alias{getCohortDiagnosticTables} +\title{getCohortDiagnosticTables} +\usage{ +getCohortDiagnosticTables(CohortDiagnosticsSettings, cohortDefinitionDf) +} +\arguments{ +\item{CohortDiagnosticsSettings}{The cohort diagnostic module specification} + +\item{cohortDefinitionDf}{The data.frame with the cohort definition details} +} +\value{ +A list with the tables to display +} +\description{ +Extract target, setting and feature table from CohortDiagnosticsSettings +} +\details{ +Returns a list of tables +} diff --git a/man/getCountStatement.Rd b/man/getCountStatement.Rd new file mode 100644 index 0000000..d4f8d35 --- /dev/null +++ b/man/getCountStatement.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CohortIncidence.R +\name{getCountStatement} +\alias{getCountStatement} +\title{getCountStatement} +\usage{ +getCountStatement(CohortIncidenceModuleSettings, cohortDefinitionDf) +} +\arguments{ +\item{CohortIncidenceModuleSettings}{The cohort incidence module specification} + +\item{cohortDefinitionDf}{The data.frame with the cohort definition details} +} +\value{ +An string with the count information +} +\description{ +Create a sentence that explains the number of targets, outcomes and settings per analysis. +} +\details{ +Returns a string +} diff --git a/man/getNegativeControlsFromJson.Rd b/man/getNegativeControlsFromJson.Rd new file mode 100644 index 0000000..047e3fb --- /dev/null +++ b/man/getNegativeControlsFromJson.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Helpers.R +\name{getNegativeControlsFromJson} +\alias{getNegativeControlsFromJson} +\title{getNegativeControlsFromJson} +\usage{ +getNegativeControlsFromJson(json) +} +\arguments{ +\item{json}{The json analysis specification} +} +\value{ +A data.frame with the negative control details or NULL if no negative controls +} +\description{ +Extract cohorts from json +} +\details{ +Returns a names list with the cohorts +} diff --git a/man/getPlpColDefs.Rd b/man/getPlpColDefs.Rd new file mode 100644 index 0000000..e3f9a7a --- /dev/null +++ b/man/getPlpColDefs.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PatientLevelPrediction.R +\name{getPlpColDefs} +\alias{getPlpColDefs} +\title{getPlpColDefs} +\usage{ +getPlpColDefs() +} +\value{ +A column definition list +} +\description{ +create colDefs for prediction table +} +\details{ +Returns a names list with the cohorts +} diff --git a/man/getPlpSettings.Rd b/man/getPlpSettings.Rd new file mode 100644 index 0000000..8519bd7 --- /dev/null +++ b/man/getPlpSettings.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PatientLevelPrediction.R +\name{getPlpSettings} +\alias{getPlpSettings} +\title{getPlpSettings} +\usage{ +getPlpSettings(PatientLevelPredictionModuleSettings, cohortDefinitionDf) +} +\arguments{ +\item{PatientLevelPredictionModuleSettings}{The patient level prediction module specification} + +\item{cohortDefinitionDf}{The data.frame with the cohort definition details} +} +\value{ +An named R list with ... +} +\description{ +Extract plp tables and settings from json +} +\details{ +Returns a names list with the tables and settings +} diff --git a/man/getSccsColDefs.Rd b/man/getSccsColDefs.Rd new file mode 100644 index 0000000..8225475 --- /dev/null +++ b/man/getSccsColDefs.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/SelfControlCaseSeries.R +\name{getSccsColDefs} +\alias{getSccsColDefs} +\title{getSccsColDefs} +\usage{ +getSccsColDefs() +} +\value{ +A column definition list +} +\description{ +Create col defs for SCCS +} +\details{ +Returns a named list of colDefs +} diff --git a/man/getSccsSettings.Rd b/man/getSccsSettings.Rd new file mode 100644 index 0000000..922e460 --- /dev/null +++ b/man/getSccsSettings.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/SelfControlCaseSeries.R +\name{getSccsSettings} +\alias{getSccsSettings} +\title{getSccsSettings} +\usage{ +getSccsSettings( + SelfControlledCaseSeriesModuleSettings, + cohortDefinitionDf, + negativeControls +) +} +\arguments{ +\item{SelfControlledCaseSeriesModuleSettings}{The self controlled case series module specification} + +\item{cohortDefinitionDf}{The data.frame with the cohort definition details} + +\item{negativeControls}{The shared negative controls from the json spec} +} +\value{ +A list with the tables to display +} +\description{ +Extract exposure/outcomes of interest, shared and analysis specific negative controls, diagnostic settings and analysis settings +} +\details{ +Returns a list of tables and settings +} diff --git a/tests/testthat/test-characterization.r b/tests/testthat/test-characterization.r new file mode 100644 index 0000000..8db00ac --- /dev/null +++ b/tests/testthat/test-characterization.r @@ -0,0 +1,298 @@ +context("characterization") + +test_that("globalCharacterizationSettings returns expected text", { + settings <- list( + settings = list( + minCharacterizationMean = 0.01, + minCovariateCount = 25, + mode = "onCreate", + minSMD = 0.1, + outputTable = "work_results.char_output" + ) + ) + + result <- ProtocolGenerator:::globalCharacterizationSettings(settings) + + expected <- paste0( + "Only covariates that occur >= 0.01 fraction of the population and >= 25 people are returned. ", + "The risk factor analysis used mode onCreate and only returns covariates where the absolute SMD is >= 0.1. ", + "All cohorts created by Characterization will be saved into work_results.char_output within the Strategus work schema." + ) + + testthat::expect_equal(result, expected) +}) + + +test_that("processTar formats risk window text", { + result <- ProtocolGenerator:::processTar( + riskWindowStart = -30, + startAnchor = "cohort start", + riskWindowEnd = 5, + endAnchor = "cohort end" + ) + + testthat::expect_equal(result, "(cohort start+-30) - (cohort end+5)") +}) + + +test_that("processTargetBaseineSettings handles NULL and builds target table", { + null_input <- list(settings = list(analysis = list(targetBaselineSettings = NULL))) + testthat::expect_null( + ProtocolGenerator:::processTargetBaseineSettings( + CharacterizationModuleSettings = null_input, + cohortDefinitionDf = data.frame() + ) + ) + + testthat::skip_if_not_installed("ParallelLogger") + + cohort_definition <- data.frame( + cohortId = c(1, 2, 3, 4), + cohortName = c("Target A", "Target B", "Target C", "Target D"), + parentName = c("Parent A", "Parent B", "Parent C", "Parent D"), + stringsAsFactors = FALSE + ) + + settings <- list( + settings = list( + analysis = list( + targetBaselineSettings = list( + list( + targetIds = c(1, 2), + limitToFirstInNDays = 30, + minPriorObservation = 365, + covariateSettings = list(useDemographicsGender = TRUE) + ), + list( + targetIds = 3, + limitToFirstInNDays = 60, + minPriorObservation = 180, + covariateSettings = list(useDemographicsGender = TRUE) + ), + list( + targetIds = 4, + limitToFirstInNDays = 0, + minPriorObservation = 0, + covariateSettings = list(useDemographicsAge = TRUE) + ) + ) + ) + ) + ) + + result <- ProtocolGenerator:::processTargetBaseineSettings( + CharacterizationModuleSettings = settings, + cohortDefinitionDf = cohort_definition + ) + + testthat::expect_is(result, "list") + testthat::expect_equal(length(result$settingsJson), 2) + testthat::expect_equal(nrow(result$tableData), 4) + testthat::expect_true(all(c("cohortNameTarget", "parentNameTarget", "setting") %in% colnames(result$tableData))) + testthat::expect_true(any(grepl("sec-char-tb-setting-1", result$tableData$setting, fixed = TRUE))) + testthat::expect_true(any(grepl("sec-char-tb-setting-2", result$tableData$setting, fixed = TRUE))) +}) + + +test_that("processRiskFactorSettings handles NULL and single target-set branch", { + null_input <- list(settings = list(analysis = list(riskFactorSettings = NULL))) + testthat::expect_null( + ProtocolGenerator:::processRiskFactorSettings( + CharacterizationModuleSettings = null_input, + cohortDefinitionDf = data.frame() + ) + ) + + testthat::skip_if_not_installed("ParallelLogger") + + cohort_definition <- data.frame( + cohortId = c(1, 2, 10, 11), + cohortName = c("Target A", "Target B", "Outcome A", "Outcome B"), + parentName = c("Parent T1", "Parent T2", "Parent O1", "Parent O2"), + stringsAsFactors = FALSE + ) + + settings <- list( + settings = list( + analysis = list( + riskFactorSettings = list( + list( + targetIds = c(1, 2), + limitToFirstInNDays = 30, + minPriorObservation = 365, + outcomeIds = 10, + outcomeWashoutDays = 0, + riskWindowStart = 1, + startAnchor = "cohort start", + riskWindowEnd = 30, + endAnchor = "cohort end", + covariateSettings = list(useDemographicsGender = TRUE) + ), + list( + targetIds = c(1, 2), + limitToFirstInNDays = 30, + minPriorObservation = 365, + outcomeIds = 11, + outcomeWashoutDays = 7, + riskWindowStart = 0, + startAnchor = "cohort start", + riskWindowEnd = 15, + endAnchor = "cohort end", + covariateSettings = list(useDemographicsAge = TRUE) + ) + ) + ) + ) + ) + + result <- ProtocolGenerator:::processRiskFactorSettings( + CharacterizationModuleSettings = settings, + cohortDefinitionDf = cohort_definition + ) + + testthat::expect_is(result, "list") + testthat::expect_equal(length(result$outcomeDataList), 1) + testthat::expect_equal(length(result$settingsJson), 2) + testthat::expect_equal(nrow(result$targetData), 4) + testthat::expect_true(all(grepl("sec-char-rf-outcome-1", result$targetData$outcomeSet, fixed = TRUE))) + testthat::expect_true(any(grepl("sec-char-rf-setting-1", result$targetData$setting, fixed = TRUE))) + testthat::expect_true(any(grepl("sec-char-rf-setting-2", result$targetData$setting, fixed = TRUE))) +}) + + +test_that("processRiskFactorSettings handles multiple target sets", { + testthat::skip_if_not_installed("ParallelLogger") + + cohort_definition <- data.frame( + cohortId = c(1, 2, 10, 11), + cohortName = c("Target A", "Target B", "Outcome A", "Outcome B"), + parentName = c("Parent T1", "Parent T2", "Parent O1", "Parent O2"), + stringsAsFactors = FALSE + ) + + settings <- list( + settings = list( + analysis = list( + riskFactorSettings = list( + list( + targetIds = 1, + limitToFirstInNDays = 30, + minPriorObservation = 365, + outcomeIds = 10, + outcomeWashoutDays = 0, + riskWindowStart = 1, + startAnchor = "cohort start", + riskWindowEnd = 30, + endAnchor = "cohort end", + covariateSettings = list(useDemographicsGender = TRUE) + ), + list( + targetIds = 2, + limitToFirstInNDays = 60, + minPriorObservation = 180, + outcomeIds = 11, + outcomeWashoutDays = 7, + riskWindowStart = 0, + startAnchor = "cohort start", + riskWindowEnd = 15, + endAnchor = "cohort end", + covariateSettings = list(useDemographicsAge = TRUE) + ) + ) + ) + ) + ) + + result <- ProtocolGenerator:::processRiskFactorSettings( + CharacterizationModuleSettings = settings, + cohortDefinitionDf = cohort_definition + ) + + testthat::expect_equal(length(result$outcomeDataList), 2) + testthat::expect_equal(nrow(result$targetData), 2) + testthat::expect_true(any(grepl("sec-char-rf-outcome-1", result$targetData$outcomeSet, fixed = TRUE))) + testthat::expect_true(any(grepl("sec-char-rf-outcome-2", result$targetData$outcomeSet, fixed = TRUE))) +}) + + +test_that("processCaseSeriesSettings handles NULL and multiple target sets", { + null_input <- list(settings = list(analysis = list(caseSeriesSettings = NULL))) + testthat::expect_null( + ProtocolGenerator:::processCaseSeriesSettings( + CharacterizationModuleSettings = null_input, + cohortDefinitionDf = data.frame() + ) + ) + + testthat::skip_if_not_installed("ParallelLogger") + + cohort_definition <- data.frame( + cohortId = c(1, 2, 10, 11), + cohortName = c("Target A", "Target B", "Outcome A", "Outcome B"), + parentName = c("Parent T1", "Parent T2", "Parent O1", "Parent O2"), + stringsAsFactors = FALSE + ) + + settings <- list( + settings = list( + analysis = list( + caseSeriesSettings = list( + list( + targetIds = 1, + limitToFirstInNDays = 30, + minPriorObservation = 365, + outcomeIds = 10, + outcomeWashoutDays = 0, + riskWindowStart = 1, + startAnchor = "cohort start", + riskWindowEnd = 30, + endAnchor = "cohort end", + caseCovariateSettings = list(useDemographicsGender = TRUE), + casePreTargetDuration = 30, + casePostOutcomeDuration = 30 + ), + list( + targetIds = 2, + limitToFirstInNDays = 60, + minPriorObservation = 180, + outcomeIds = 11, + outcomeWashoutDays = 7, + riskWindowStart = 0, + startAnchor = "cohort start", + riskWindowEnd = 15, + endAnchor = "cohort end", + caseCovariateSettings = list(useDemographicsAge = TRUE), + casePreTargetDuration = 14, + casePostOutcomeDuration = 14 + ) + ) + ) + ) + ) + + result <- ProtocolGenerator:::processCaseSeriesSettings( + CharacterizationModuleSettings = settings, + cohortDefinitionDf = cohort_definition + ) + + testthat::expect_is(result, "list") + testthat::expect_equal(length(result$outcomeDataList), 2) + testthat::expect_equal(length(result$settingsJson), 2) + testthat::expect_equal(nrow(result$targetData), 2) + testthat::expect_true(any(grepl("sec-char-cs-outcome-1", result$targetData$outcomeSet, fixed = TRUE))) + testthat::expect_true(any(grepl("sec-char-cs-outcome-2", result$targetData$outcomeSet, fixed = TRUE))) + testthat::expect_true(any(grepl("sec-char-cs-setting-1", result$targetData$setting, fixed = TRUE))) + testthat::expect_true(any(grepl("sec-char-cs-setting-2", result$targetData$setting, fixed = TRUE))) +}) + + +test_that("characterizationColDef returns expected reactable column definitions", { + testthat::skip_if_not_installed("reactable") + + result <- ProtocolGenerator:::characterizationColDef() + + testthat::expect_is(result, "list") + testthat::expect_true(all(c("cohortNameTarget", "cohortNameOutcome", "tar", "setting") %in% names(result))) + testthat::expect_s3_class(result$tar, "colDef") + testthat::expect_s3_class(result$setting, "colDef") +}) diff --git a/tests/testthat/test-cohortdiagnostics.r b/tests/testthat/test-cohortdiagnostics.r new file mode 100644 index 0000000..e33d89c --- /dev/null +++ b/tests/testthat/test-cohortdiagnostics.r @@ -0,0 +1,94 @@ +context("cohort diagnostics") + +make_cd_cohort_definition_df <- function() { + data.frame( + cohortId = c(101, 102, 201), + cohortName = c("Target A", "Target B", "Other"), + cohortNameWithLink = c( + "Target A View", + "Target B View", + "Other View" + ), + parentId = c(101, 102, 201), + parentName = c("Parent A", "Parent B", "Parent C"), + subsetId = c(-1, -1, -1), + isParent = c(TRUE, TRUE, TRUE), + subsetName = rep(NA_character_, 3), + packageVersion = rep(NA_character_, 3), + numberSubsetOperators = rep(NA_integer_, 3), + subsetCohorts = rep("", 3), + appliedSubsets = rep("", 3), + stringsAsFactors = FALSE + ) +} + +make_cd_settings <- function(cohort_ids = c(101, 102)) { + list( + cohortIds = cohort_ids, + temporalCovariateSettings = list( + minCharacterizationMean = 0.01, + includeTemporal = TRUE, + optionalThreshold = NULL + ), + sampleSize = 1000, + useCache = FALSE, + outputFolder = "diagnostics", + optionalSetting = NULL + ) +} + + +test_that("getCohortDiagnosticTables builds tables and applies cohort filter", { + cohort_definition <- make_cd_cohort_definition_df() + cd_settings <- make_cd_settings(cohort_ids = c(101, 102)) + + result <- ProtocolGenerator:::getCohortDiagnosticTables( + CohortDiagnosticsSettings = cd_settings, + cohortDefinitionDf = cohort_definition + ) + + testthat::expect_is(result, "list") + testthat::expect_true(all(c("targetTable", "settingsTable", "featureTable") %in% names(result))) + + testthat::expect_equal(nrow(result$targetTable), 2) + testthat::expect_true(all(result$targetTable$cohortIdTarget %in% c(101, 102))) + testthat::expect_equal(colnames(result$targetTable)[1], "parentNameTarget") + testthat::expect_equal(colnames(result$targetTable)[2], "cohortNameTarget") + + testthat::expect_is(result$settingsTable, "data.frame") + testthat::expect_true(all(c("input", "value") %in% colnames(result$settingsTable))) + testthat::expect_true("sampleSize" %in% result$settingsTable$input) + testthat::expect_true(any(result$settingsTable$value == "NULL")) + + testthat::expect_is(result$featureTable, "data.frame") + testthat::expect_true(all(c("input", "value") %in% colnames(result$featureTable))) + testthat::expect_true("minCharacterizationMean" %in% result$featureTable$input) + testthat::expect_true(any(result$featureTable$value == "NULL")) +}) + + +test_that("getCohortDiagnosticTables uses all cohorts when cohortIds is NULL", { + cohort_definition <- make_cd_cohort_definition_df() + cd_settings <- make_cd_settings(cohort_ids = NULL) + + result <- ProtocolGenerator:::getCohortDiagnosticTables( + CohortDiagnosticsSettings = cd_settings, + cohortDefinitionDf = cohort_definition + ) + + testthat::expect_equal(nrow(result$targetTable), nrow(cohort_definition)) + testthat::expect_true(setequal(result$targetTable$cohortIdTarget, cohort_definition$cohortId)) +}) + + +test_that("getCdCols returns expected reactable colDef list", { + testthat::skip_if_not_installed("reactable") + + result <- ProtocolGenerator:::getCdCols() + + testthat::expect_is(result, "list") + testthat::expect_true(all(c("parentNameTarget", "cohortNameTarget", "appliedSubsetsTarget") %in% names(result))) + testthat::expect_s3_class(result$parentNameTarget, "colDef") + testthat::expect_s3_class(result$cohortNameTarget, "colDef") + testthat::expect_s3_class(result$appliedSubsetsTarget, "colDef") +}) diff --git a/tests/testthat/test-cohortincidence.r b/tests/testthat/test-cohortincidence.r new file mode 100644 index 0000000..0d08df4 --- /dev/null +++ b/tests/testthat/test-cohortincidence.r @@ -0,0 +1,155 @@ +context("cohort incidence") + +make_ci_cohort_definition_df <- function() { + data.frame( + cohortId = c(101, 102, 201, 202, 999), + cohortName = c("Target A", "Target B", "Outcome A", "Outcome B", "Other"), + cohortNameWithLink = c( + "Target A View", + "Target B View", + "Outcome A View", + "Outcome B View", + "Other View" + ), + parentId = c(101, 102, 201, 202, 999), + parentName = c("Target A", "Target B", "Outcome A", "Outcome B", "Other"), + subsetId = c(-1, -1, -1, -1, -1), + isParent = c(TRUE, TRUE, TRUE, TRUE, TRUE), + subsetName = rep(NA_character_, 5), + packageVersion = rep(NA_character_, 5), + numberSubsetOperators = rep(NA_integer_, 5), + subsetCohorts = rep("", 5), + appliedSubsets = rep("", 5), + stringsAsFactors = FALSE + ) +} + +make_ci_module_settings <- function() { + list( + settings = list( + irDesign = list( + targetDefs = list( + list(id = 101), + list(id = 102) + ), + outcomeDefs = list( + list(id = 1, cohortId = 201, cleanWindow = 30), + list(id = 2, cohortId = 202, cleanWindow = 60) + ), + timeAtRiskDefs = list( + list( + id = 10, + start = list(dateField = "cohortStartDate", offset = 0), + end = list(dateField = "cohortEndDate", offset = 30) + ), + list( + id = 11, + start = list(dateField = "cohortStartDate", offset = 1), + end = list(dateField = "cohortEndDate", offset = 90) + ) + ), + strataSettings = list( + byAge = TRUE, + bySex = FALSE, + minPeople = 1000 + ), + analysisList = list( + list( + targets = c(1, 2), + outcomes = c(1, 2), + tars = c(10, 11) + ) + ) + ) + ) + ) +} + + +test_that("getCountStatement returns expected count sentence", { + cohort_definition <- make_ci_cohort_definition_df() + ci_settings <- make_ci_module_settings() + + result <- ProtocolGenerator:::getCountStatement( + CohortIncidenceModuleSettings = ci_settings, + cohortDefinitionDf = cohort_definition + ) + + testthat::expect_is(result, "list") + testthat::expect_equal(length(result), 1) + testthat::expect_true(grepl("Analysis 1", result[[1]], fixed = TRUE)) + testthat::expect_true(grepl("2 unique parent targets", result[[1]], fixed = TRUE)) + testthat::expect_true(grepl("2 unique parent outcomes with clean windows", result[[1]], fixed = TRUE)) + testthat::expect_true(grepl("2 time-at-risks", result[[1]], fixed = TRUE)) + testthat::expect_true(grepl("Total of 8 T/O/TAR combinations", result[[1]], fixed = TRUE)) +}) + + +test_that("createStratSentance returns stratified text when logical flags present", { + ci_settings <- make_ci_module_settings() + + result <- ProtocolGenerator:::createStratSentance(ci_settings) + + testthat::expect_is(result, "character") + testthat::expect_true(grepl("Stratified by", result, fixed = TRUE)) + testthat::expect_true(grepl("Age/Sex", result, fixed = TRUE)) +}) + + +test_that("createStratSentance returns no stratification text without logical flags", { + ci_settings <- make_ci_module_settings() + ci_settings$settings$irDesign$strataSettings <- list(minPeople = 1000, threshold = 0.1) + + result <- ProtocolGenerator:::createStratSentance(ci_settings) + + testthat::expect_equal(result, "No stratification applied.") +}) + + +test_that("getCiTarString formats TAR from definition id", { + tar_defs <- make_ci_module_settings()$settings$irDesign$timeAtRiskDefs + + result <- ProtocolGenerator:::getCiTarString(tarDefs = tar_defs, tarId = 11) + + testthat::expect_equal(result, "(cohortStartDate + 1) - (cohortEndDate + 90)") +}) + + +test_that("getCiTargetsOutcomes returns expected tables and ids", { + cohort_definition <- make_ci_cohort_definition_df() + ci_settings <- make_ci_module_settings() + + result <- ProtocolGenerator:::getCiTargetsOutcomes( + CohortIncidenceModuleSettings = ci_settings, + cohortDefinitionDf = cohort_definition + ) + + testthat::expect_is(result, "list") + testthat::expect_true(all(c("ciTargets", "ciOutcomes", "tars", "ciTargetIds", "ciOutcomeIds") %in% names(result))) + + testthat::expect_equal(length(result$ciTargets), 1) + testthat::expect_equal(length(result$ciOutcomes), 1) + testthat::expect_equal(length(result$tars), 1) + + testthat::expect_equal(sort(as.numeric(unlist(result$ciTargetIds))), c(101, 102)) + testthat::expect_equal(sort(as.numeric(unlist(result$ciOutcomeIds))), c(201, 202)) + + testthat::expect_equal(nrow(result$ciTargets[[1]]), 2) + testthat::expect_equal(nrow(result$ciOutcomes[[1]]), 2) + testthat::expect_true("cleanWindow" %in% colnames(result$ciOutcomes[[1]])) + testthat::expect_true(grepl("(cohortStartDate + 0) - (cohortEndDate + 30)", result$tars[[1]], fixed = TRUE)) + testthat::expect_true(grepl("(cohortStartDate + 1) - (cohortEndDate + 90)", result$tars[[1]], fixed = TRUE)) +}) + + +test_that("getCIcolumns returns expected reactable colDef list", { + testthat::skip_if_not_installed("reactable") + + result <- ProtocolGenerator:::getCIcolumns() + + testthat::expect_is(result, "list") + testthat::expect_true(all(c("parentName", "cohortName", "cleanWindow") %in% names(result))) + testthat::expect_s3_class(result$parentName, "colDef") + testthat::expect_s3_class(result$cohortName, "colDef") + testthat::expect_s3_class(result$cleanWindow, "colDef") +}) diff --git a/tests/testthat/test-cohortmethod.r b/tests/testthat/test-cohortmethod.r new file mode 100644 index 0000000..179286a --- /dev/null +++ b/tests/testthat/test-cohortmethod.r @@ -0,0 +1,190 @@ +context("cohort method") + +make_cohort_definition_df <- function() { + data.frame( + cohortId = c(10, 11, 20, 21, 30, 31, 40, 41, 99), + cohortName = c( + "Target A", "Target B", + "Comp A", "Comp B", + "Outcome A", "Outcome B", + "Neg A", "Neg B", + "Nesting" + ), + cohortNameWithLink = c( + "Target A View", + "Target B View", + "Comp A View", + "Comp B View", + "Outcome A View", + "Outcome B View", + "Neg A View", + "Neg B View", + "Nesting View" + ), + parentId = c(10, 11, 20, 21, 30, 31, 40, 41, 99), + parentName = c("Target A", "Target B", "Comp A", "Comp B", "Outcome A", "Outcome B", "Neg A", "Neg B", "Nesting"), + subsetId = c(-1, -1, -1, -1, -1, -1, -1, -1, -1), + isParent = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), + subsetName = rep(NA_character_, 9), + packageVersion = rep(NA_character_, 9), + numberSubsetOperators = rep(NA_integer_, 9), + subsetCohorts = rep("", 9), + appliedSubsets = rep("", 9), + stringsAsFactors = FALSE + ) +} + +make_settings_cm <- function() { + list( + targetComparatorOutcomesList = list( + list( + targetId = 10, + comparatorId = 20, + nestingCohortId = 99, + excludedCovariateConceptIds = c(100, 101), + outcomes = list( + list(outcomeId = 30, outcomeOfInterest = TRUE, priorOutcomeLookback = 365), + list(outcomeId = 31, outcomeOfInterest = TRUE, priorOutcomeLookback = 30), + list(outcomeId = 40, outcomeOfInterest = FALSE, priorOutcomeLookback = 0) + ) + ), + list( + targetId = 11, + comparatorId = 21, + excludedCovariateConceptIds = c(100, 102), + outcomes = list( + list(outcomeId = 30, outcomeOfInterest = TRUE, priorOutcomeLookback = 60), + list(outcomeId = 41, outcomeOfInterest = FALSE) + ) + ) + ), + cmAnalysisList = list( + list( + analysisId = 1, + description = "analysis one", + createStudyPopulationArgs = list( + startAnchor = "cohort start", + riskWindowStart = 1, + endAnchor = "cohort end", + riskWindowEnd = 30 + ) + ), + list( + analysisId = 2, + description = "analysis two", + createStudyPopulationArgs = list( + startAnchor = "cohort start", + riskWindowStart = 1, + endAnchor = "cohort end", + riskWindowEnd = 30 + ) + ) + ), + cmDiagnosticThresholds = list(maxStdDiff = 0.1), + refitPsForEveryOutcome = TRUE, + refitPsForEveryStudyPopulation = FALSE + ) +} + + +test_that("extractCohortMethodSettings works when negativeControls is NULL", { + cohort_definition <- make_cohort_definition_df() + settings_cm <- make_settings_cm() + + module_settings <- list(settings = settings_cm) + + result <- ProtocolGenerator:::extractCohortMethodSettings( + cohortMethodModuleSettings = module_settings, + negativeControls = NULL, + cohortDefinitionDf = cohort_definition + ) + + testthat::expect_is(result, "list") + testthat::expect_true(all(c( + "negativeControlsCM", "tcCombos", "outcomeRange", "compIds", + "targetParentsCount", "targetCohortCount", "tars", "analysisCm", + "cmOutUnique", "commonExclude", "nonCommonSets", "commonNegativeId", + "nonCommonNegSets", "diagSetting", "refitPsForEveryOutcome", + "refitPsForEveryStudyPopulation" + ) %in% names(result))) + + testthat::expect_is(result$negativeControlsCM, "data.frame") + testthat::expect_true(all(c("cohortId", "outcomeConceptId", "cohortName") %in% colnames(result$negativeControlsCM))) + testthat::expect_true(setequal(result$negativeControlsCM$cohortId, c(40, 41))) + + testthat::expect_equal(result$targetParentsCount, 2) + testthat::expect_equal(result$targetCohortCount, 2) + testthat::expect_equal(result$outcomeRange, " between 1 and 2") + testthat::expect_equal(length(result$tars), 1) + + testthat::expect_true(all(c("cohortNameTarget", "cohortNameComp", "sameSubset", "outcomeSet") %in% colnames(result$tcCombos))) + testthat::expect_true(any(grepl("sec-cm-out-1", result$tcCombos$outcomeSet, fixed = TRUE))) + testthat::expect_true(any(grepl("sec-cm-out-2", result$tcCombos$outcomeSet, fixed = TRUE))) + testthat::expect_true(any(grepl("sec-cm-exclude-", result$tcCombos$additionalExclusions, fixed = TRUE))) + testthat::expect_true(any(grepl("sec-cm-negset-", result$tcCombos$additionalNegativeControlId, fixed = TRUE))) + + testthat::expect_equal(result$commonExclude, 100) + testthat::expect_equal(length(result$nonCommonSets), 2) + testthat::expect_true(length(result$commonNegativeId) == 0) + testthat::expect_equal(length(result$nonCommonNegSets), 2) + + testthat::expect_is(result$diagSetting, "list") + testthat::expect_equal(result$diagSetting$maxStdDiff, 0.1) + testthat::expect_equal(result$refitPsForEveryOutcome, TRUE) + testthat::expect_equal(result$refitPsForEveryStudyPopulation, FALSE) +}) + + +test_that("extractCohortMethodSettings uses cmAnalysesSpecifications and provided negative controls", { + cohort_definition <- make_cohort_definition_df() + settings_cm <- make_settings_cm() + + provided_negative_controls <- data.frame( + cohortId = 999, + outcomeConceptId = 999, + outcomeOfInterest = FALSE, + priorOutcomeLookback = 0, + cohortName = "Provided NC", + stringsAsFactors = FALSE + ) + + module_settings <- list( + settings = list( + cmAnalysesSpecifications = settings_cm, + refitPsForEveryOutcome = FALSE, + refitPsForEveryStudyPopulation = TRUE + ) + ) + + result <- ProtocolGenerator:::extractCohortMethodSettings( + cohortMethodModuleSettings = module_settings, + negativeControls = provided_negative_controls, + cohortDefinitionDf = cohort_definition + ) + + testthat::expect_equal(result$negativeControlsCM, provided_negative_controls) + testthat::expect_equal(result$refitPsForEveryOutcome, TRUE) + testthat::expect_equal(result$refitPsForEveryStudyPopulation, FALSE) + testthat::expect_equal(length(result$analysisCm), 2) +}) + + +test_that("cmColDef returns full and filtered column definitions", { + testthat::skip_if_not_installed("reactable") + + all_defs <- ProtocolGenerator:::cmColDef() + + testthat::expect_is(all_defs, "list") + testthat::expect_true(all(c("parentNameTarget", "sameSubset", "outcomeSet") %in% names(all_defs))) + testthat::expect_s3_class(all_defs$parentNameTarget, "colDef") + testthat::expect_s3_class(all_defs$sameSubset, "colDef") + + filtered_defs <- ProtocolGenerator:::cmColDef( + elementId = "custom-table-id", + colNames = c("parentNameTarget", "sameSubset") + ) + + testthat::expect_equal(names(filtered_defs), c("parentNameTarget", "sameSubset")) + testthat::expect_s3_class(filtered_defs$parentNameTarget, "colDef") + testthat::expect_s3_class(filtered_defs$sameSubset, "colDef") +}) diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-helpers.R index 96486ca..cd87aca 100644 --- a/tests/testthat/test-helpers.R +++ b/tests/testthat/test-helpers.R @@ -9,11 +9,16 @@ test_that("getCohortDefinitionsFromJson", { cohortDef <- getCohortDefinitionsFromJson(json) testthat::expect_true("cohortDefinitions" %in% names(cohortDef)) + testthat::expect_true("subsetUnique" %in% names(cohortDef)) + testthat::expect_true("cohortDefinitionDf" %in% names(cohortDef)) - testthat::expect_equal( - length(cohortDef$cohortNames), - length(cohortDef$cohortDefinitions) - ) + testthat::expect_true(nrow(cohortDef$cohortDefinitionDf) > 0) + + testthat::expect_true("cohortName" %in% colnames(cohortDef$cohortDefinitionDf)) + testthat::expect_true("cohortNameWithLink" %in% colnames(cohortDef$cohortDefinitionDf)) + testthat::expect_true("cohortId" %in% colnames(cohortDef$cohortDefinitionDf)) + testthat::expect_true("parentId" %in% colnames(cohortDef$cohortDefinitionDf)) + testthat::expect_true("parentName" %in% colnames(cohortDef$cohortDefinitionDf)) }) @@ -37,7 +42,7 @@ test_that("getFunctionFromArgName", { argumentName = 'createPsArgs' ) - testthat::expect_equal(fun, 'createPs') + testthat::expect_equal(fun, 'createCreatePsArgs') }) diff --git a/tests/testthat/test-patientLevelPrediction.r b/tests/testthat/test-patientLevelPrediction.r new file mode 100644 index 0000000..7c9def6 --- /dev/null +++ b/tests/testthat/test-patientLevelPrediction.r @@ -0,0 +1,155 @@ +context("patient level prediction") + +make_plp_cohort_definition_df <- function() { + data.frame( + cohortId = c(101, 102, 201, 202), + cohortName = c("Target A", "Target B", "Outcome A", "Outcome B"), + cohortNameWithLink = c( + "Target A View", + "Target B View", + "Outcome A View", + "Outcome B View" + ), + parentId = c(1001, 1002, 2001, 2002), + parentName = c("Parent Target A", "Parent Target B", "Parent Outcome A", "Parent Outcome B"), + subsetId = c(-1, -1, -1, -1), + isParent = c(TRUE, TRUE, TRUE, TRUE), + subsetName = rep(NA_character_, 4), + packageVersion = rep(NA_character_, 4), + numberSubsetOperators = rep(NA_integer_, 4), + subsetCohorts = rep("", 4), + appliedSubsets = rep("", 4), + stringsAsFactors = FALSE + ) +} + +make_covariate_settings <- function(use_age = TRUE, use_gender = FALSE) { + x <- list( + useDemographicsAge = use_age, + useDemographicsGender = use_gender, + nonLogicalSetting = "ignore" + ) + attr(x, "fun") <- "createCovariateSettings" + class(x) <- "covariateSettings" + x +} + +make_plp_module_settings <- function() { + list( + settings = list( + modelDesignList = list( + list( + targetId = 101, + outcomeId = 201, + covariateSettings = make_covariate_settings(TRUE, FALSE), + populationSettings = list( + startAnchor = "cohort start", + riskWindowStart = 1, + endAnchor = "cohort end", + riskWindowEnd = 30 + ) + ), + list( + targetId = 102, + outcomeId = 202, + covariateSettings = make_covariate_settings(TRUE, FALSE), + populationSettings = list( + startAnchor = "cohort start", + riskWindowStart = 1, + endAnchor = "cohort end", + riskWindowEnd = 30 + ) + ), + list( + targetId = 101, + outcomeId = 202, + covariateSettings = make_covariate_settings(TRUE, TRUE), + populationSettings = list( + startAnchor = "cohort start", + riskWindowStart = 0, + endAnchor = "cohort end", + riskWindowEnd = 90 + ) + ) + ) + ) + ) +} + + +test_that("getPlpSettings returns expected structure", { + cohort_definition <- make_plp_cohort_definition_df() + plp_settings <- make_plp_module_settings() + + result <- getPlpSettings( + PatientLevelPredictionModuleSettings = plp_settings, + cohortDefinitionDf = cohort_definition + ) + + testthat::expect_is(result, "list") + testthat::expect_true(all(c("targetOutcomeSet", "modelDesignUnique", "predictionSummary") %in% names(result))) + testthat::expect_is(result$targetOutcomeSet, "data.frame") + testthat::expect_is(result$predictionSummary, "data.frame") +}) + + +test_that("getPlpSettings merges target and outcome details", { + cohort_definition <- make_plp_cohort_definition_df() + plp_settings <- make_plp_module_settings() + + result <- getPlpSettings( + PatientLevelPredictionModuleSettings = plp_settings, + cohortDefinitionDf = cohort_definition + ) + + tos <- result$targetOutcomeSet + + testthat::expect_equal(nrow(tos), 3) + testthat::expect_true(all(c( + "cohortIdTarget", "cohortNameTarget", "parentNameTarget", + "cohortIdOutcome", "cohortNameOutcome", "parentNameOutcome", + "designId" + ) %in% colnames(tos))) + testthat::expect_equal(length(unique(tos$designId)), 2) +}) + + +test_that("getPlpSettings predictionSummary includes expected content", { + cohort_definition <- make_plp_cohort_definition_df() + plp_settings <- make_plp_module_settings() + + result <- getPlpSettings( + PatientLevelPredictionModuleSettings = plp_settings, + cohortDefinitionDf = cohort_definition + ) + + summary_df <- result$predictionSummary + + testthat::expect_equal(nrow(summary_df), 2) + testthat::expect_true(all(c( + "model_design", "number_targets", "number_targets_with_subsets", + "number_outcomes", "number_outcomes_with_subsets", "timeAtRisk", "covariates" + ) %in% colnames(summary_df))) + + testthat::expect_true(any(grepl("sec-model-design-1", summary_df$model_design, fixed = TRUE))) + testthat::expect_true(any(grepl("cohort start + 1 - cohort end + 30", summary_df$timeAtRisk, fixed = TRUE))) + testthat::expect_true(any(grepl("cohort start + 0 - cohort end + 90", summary_df$timeAtRisk, fixed = TRUE))) + testthat::expect_true(any(grepl("createCovariateSettings", summary_df$covariates, fixed = TRUE))) +}) + + +test_that("getPlpColDefs returns expected reactable colDefs", { + testthat::skip_if_not_installed("reactable") + + result <- getPlpColDefs() + + testthat::expect_is(result, "list") + testthat::expect_true(all(c( + "model_design", "number_targets", "number_targets_with_subsets", + "number_outcomes", "number_outcomes_with_subsets", "timeAtRisk", "covariates" + ) %in% names(result))) + + testthat::expect_s3_class(result$model_design, "colDef") + testthat::expect_s3_class(result$timeAtRisk, "colDef") + testthat::expect_s3_class(result$covariates, "colDef") +}) diff --git a/tests/testthat/test-selfControlledCaseSeries.r b/tests/testthat/test-selfControlledCaseSeries.r new file mode 100644 index 0000000..d3b99ff --- /dev/null +++ b/tests/testthat/test-selfControlledCaseSeries.r @@ -0,0 +1,160 @@ +context("self controlled case series") + +make_sccs_cohort_definition_df <- function() { + data.frame( + cohortId = c(101, 102, 103, 201, 202, 999), + cohortName = c("Exposure A", "Exposure B", "Nesting", "Outcome A", "Outcome B", "Other"), + cohortNameWithLink = c( + "Exposure A View", + "Exposure B View", + "Nesting View", + "Outcome A View", + "Outcome B View", + "Other View" + ), + parentId = c(101, 102, 103, 201, 202, 999), + parentName = c("Parent Exp A", "Parent Exp B", "Parent Nest", "Parent Out A", "Parent Out B", "Parent Other"), + subsetId = c(-1, -1, -1, -1, -1, -1), + isParent = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), + subsetName = rep(NA_character_, 6), + packageVersion = rep(NA_character_, 6), + numberSubsetOperators = rep(NA_integer_, 6), + subsetCohorts = rep("", 6), + appliedSubsets = rep("", 6), + stringsAsFactors = FALSE + ) +} + +make_sccs_settings <- function() { + list( + exposuresOutcomeList = list( + list( + jsonId = 1, + outcomeId = 201, + nestingCohortId = 103, + exposures = list( + list(exposureId = 101, exposureIdRef = "exp1", trueEffectSize = NULL), + list(exposureId = 102, exposureIdRef = "exp2", trueEffectSize = 1) + ) + ), + list( + jsonId = 2, + outcomeId = 202, + nestingCohortId = NULL, + exposures = list( + list(exposureId = 101, exposureIdRef = "exp1", trueEffectSize = NULL), + list(exposureId = 103, exposureIdRef = "exp2", trueEffectSize = 1) + ) + ) + ), + sccsAnalysisList = list( + list(analysisId = 1, description = "analysis one"), + list(analysisId = 2, description = "analysis two") + ), + sccsDiagnosticThresholds = list(maxRr = 2.0, minOutcomeCount = 10) + ) +} + + +test_that("getSccsSettings settings structure is correct", { + + cohort_definition <- make_sccs_cohort_definition_df() + + # Add minimal outcome parent columns to support the function + cohort_definition$cohortIdOutcome <- cohort_definition$cohortId + cohort_definition$parentNameOutcome <- cohort_definition$parentName + cohort_definition$cohortNameOutcome <- cohort_definition$cohortName + + sccs_settings <- make_sccs_settings() + module_settings <- list(settings = list(sccsAnalysesSpecifications = sccs_settings)) + + testthat::expect_is(module_settings$settings$sccsAnalysesSpecifications, "list") + testthat::expect_equal(length(module_settings$settings$sccsAnalysesSpecifications$sccsAnalysisList), 2) + testthat::expect_equal(module_settings$settings$sccsAnalysesSpecifications$sccsDiagnosticThresholds$maxRr, 2.0) +}) + + +test_that("getSccsSettings uses sccsAnalysesSpecifications when present", { + + sccs_settings <- make_sccs_settings() + cohort_def <- make_sccs_cohort_definition_df() + + # When sccsAnalysesSpecifications is present, function uses it + module_with_specs <- list(settings = list(sccsAnalysesSpecifications = sccs_settings)) + module_without_specs <- list(settings = sccs_settings) + + # Verify structure is preserved with specs + testthat::expect_equal( + length(module_with_specs$settings$sccsAnalysesSpecifications$sccsAnalysisList), + 2 + ) + + # Verify structure is preserved without specs + testthat::expect_equal( + length(module_without_specs$settings$sccsAnalysisList), + 2 + ) + + res1 <- getSccsSettings( + SelfControlledCaseSeriesModuleSettings = module_with_specs, + cohortDefinitionDf = cohort_def, + negativeControls = NULL + ) + + res2 <- getSccsSettings( + SelfControlledCaseSeriesModuleSettings = module_with_specs, + cohortDefinitionDf = cohort_def, + negativeControls = NULL + ) + + testthat::expect_equal( + res1, res2 + ) + +}) + + +test_that("getSccsSettings extracts basic exposure structure", { + + sccs_settings <- make_sccs_settings() + module_without_specs <- list(settings = sccs_settings) + cohort_def <- make_sccs_cohort_definition_df() + + res1 <- getSccsSettings( + SelfControlledCaseSeriesModuleSettings = module_without_specs, + cohortDefinitionDf = cohort_def, + negativeControls = NULL + ) + + # two exposure outcomes nests with unknown effect + testthat::expect_true(nrow(res1$eoOfInt) == 2) + + # two negative controls + testthat::expect_true(nrow(res1$negTab) == 2) + + # no shared negative controls + testthat::expect_true(is.null(res1$negTabShared)) + + testthat::expect_true(!is.null(res1$sccsAnalysisList)) + testthat::expect_true(!is.null(res1$sccsDiagnosticThresholds)) + +}) + + + +test_that("getSccsColDefs returns expected reactable colDef list", { + testthat::skip_if_not_installed("reactable") + + result <- getSccsColDefs() + + testthat::expect_is(result, "list") + testthat::expect_true(all(c("cohortNameTarget", "cohortNameOutcome", "parentNameTarget") %in% names(result))) + testthat::expect_s3_class(result$cohortNameTarget, "colDef") + testthat::expect_s3_class(result$cohortNameOutcome, "colDef") + testthat::expect_s3_class(result$parentNameTarget, "colDef") + + # Check that certain columns are hidden + testthat::expect_false(result$outcomeId$show) + testthat::expect_false(result$exposureId$show) + testthat::expect_false(result$nestingId$show) +}) From 2618f3bc1374599346f67599b21fd553bde980f5 Mon Sep 17 00:00:00 2001 From: jreps Date: Wed, 13 May 2026 20:01:49 -0400 Subject: [PATCH 2/8] Update Helpers.R fixing issue with CI protocol section if no stratification specified --- R/Helpers.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/Helpers.R b/R/Helpers.R index 5b75f7e..286d7b9 100644 --- a/R/Helpers.R +++ b/R/Helpers.R @@ -580,8 +580,8 @@ listToDf <- function( valueName = 'value' ){ - saveRDS(settings, '/Users/jreps/Documents/GitHub/ProtocolGenerator/settings.rds') - settings <- readRDS('/Users/jreps/Documents/GitHub/ProtocolGenerator/settings.rds') + ##saveRDS(settings, '/Users/jreps/Documents/GitHub/ProtocolGenerator/settings.rds') + ##settings <- readRDS('/Users/jreps/Documents/GitHub/ProtocolGenerator/settings.rds') # convert vectors to char nameSet <- names(settings) valueSet <- settings @@ -773,6 +773,8 @@ getSettingsTable <- function( if(is.null(settings)){ settingsDf <- listToDf(list(isNUll = 'NULL')) + } else if(identical(settings, list())){ + settingsDf <- listToDf(list(isNUll = 'NULL')) } else{ settingsDf <- listToDf( settings, From 6e98fb083790ab088db66624179fc24d223b034a Mon Sep 17 00:00:00 2001 From: jreps Date: Wed, 15 Jul 2026 17:11:05 -0400 Subject: [PATCH 3/8] edge case fixes edge case fixes --- DESCRIPTION | 2 +- NAMESPACE | 1 + R/CohortMethod.R | 87 ++++++++++++++++++++++++++++++-- R/Helpers.R | 88 +++++++++++++++++++++++---------- inst/protocol/cohort-method.qmd | 39 +-------------- man/cmOutcomeColDef.Rd | 20 ++++++++ man/reportTableFormat.Rd | 3 +- 7 files changed, 173 insertions(+), 67 deletions(-) create mode 100644 man/cmOutcomeColDef.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 4a64dc1..4d294cd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -39,5 +39,5 @@ Suggests: Remotes: ohdsi/ROhdsiWebApi, ohdsi/CohortIncidence -RoxygenNote: 7.3.2 Encoding: UTF-8 +Config/roxygen2/version: 8.0.0 diff --git a/NAMESPACE b/NAMESPACE index a505941..15a340f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,7 @@ # Generated by roxygen2: do not edit by hand export(cmColDef) +export(cmOutcomeColDef) export(createStratSentance) export(defaultColumns) export(extractCohortMethodSettings) diff --git a/R/CohortMethod.R b/R/CohortMethod.R index b73e825..5daa8eb 100644 --- a/R/CohortMethod.R +++ b/R/CohortMethod.R @@ -147,7 +147,11 @@ extractCohortMethodSettings <- function( for(i in 1:length(settingsCm$targetComparatorOutcomesList)){ # get the excluded concepts - excludeConcepts[[i]] <- settingsCm$targetComparatorOutcomesList[[i]]$excludedCovariateConceptIds + if(length(settingsCm$targetComparatorOutcomesList[[i]]$excludedCovariateConceptIds) >0){ + excludeConcepts[[i]] <- settingsCm$targetComparatorOutcomesList[[i]]$excludedCovariateConceptIds + } else{ + excludeConcepts[[i]] <- c(-1) + } outcomeCm <- data.frame( outcomeId = unlist(lapply(settingsCm$targetComparatorOutcomesList[[i]]$outcomes, function(x) x$outcomeId)), @@ -162,8 +166,12 @@ extractCohortMethodSettings <- function( # now process the negative list and excludeConcepts list commonExclude <- excludeConcepts[[1]] if(length(excludeConcepts) > 1){ - for(ind in 2:length(excludeConcepts)){ - commonExclude <- intersect(excludeConcepts[[ind]],commonExclude) + if(commonExclude != -1){ + for(ind in 2:length(excludeConcepts)){ + commonExclude <- intersect(excludeConcepts[[ind]],commonExclude) + } + } else{ + commonExclude <- c() } } nonCommonExclude <- lapply(excludeConcepts, function(x) setdiff(x, commonExclude)) @@ -212,6 +220,13 @@ extractCohortMethodSettings <- function( by = 'tcoId' ) + if(!'subsetCohortsTarget' %in% colnames(tcCombos)){ + tcCombos$subsetCohortsTarget <- '' + } + if(!'appliedSubsetsTarget' %in% colnames(tcCombos)){ + tcCombos$appliedSubsetsTarget <- '' + } + tcCombos <- tcCombos %>% dplyr::relocate('cohortNameWithLinkNest') %>% dplyr::relocate('cohortNameTarget') %>% @@ -385,3 +400,69 @@ cmColDef <- function( return(colDef) } + + +#' cmOutcomeColDef +#' +#' @description +#' List with column names for the cohort method outcome table +#' +#' @details +#' Returns a names list with the cohorts names +#' +#' @param colNames Optional a vector of column names to restrict to +#' +#' @return +#' A column definition list +#' +#' @export +#' +#' +cmOutcomeColDef <- function( + colNames + ) + { + + colDefs <- list( + priorOutcomeLookback = reactable::colDef( + aggregate = "unique", + show = TRUE, + name = 'Prior Outcome Lookback (days)', + filterable = TRUE + ), + outcomeId = reactable::colDef(show = FALSE), + outcomeOfInterest = reactable::colDef(show = FALSE), + subsetIdOutcome = reactable::colDef(show = FALSE), + parentNameOutcome = reactable::colDef( + show = TRUE, + name = 'Outcome Parent', + filterable = TRUE, + html = TRUE, + minWidth = 300 + ), + cohortNameOutcome = reactable::colDef( + show = TRUE, + name = 'Outcome', + html = TRUE, + filterable = TRUE, + minWidth = 300 + ), + cohortNameWithLinkOutcome = reactable::colDef( + show = FALSE, + name = 'Outcome', + html = TRUE, + filterable = TRUE + ), + isParentOutcome = reactable::colDef(show = F), + parentIdOutcome = reactable::colDef(show = F), + subsetNameOutcome = reactable::colDef(show = F), + packageVersionOutcome = reactable::colDef(show = F), + numberSubsetOperatorsOutcome = reactable::colDef(show = F), + subsetCohortsOutcome = reactable::colDef(show = F), + appliedSubsetsOutcome = reactable::colDef(show = F) +) + + colDefs <- colDefs[names(colDefs) %in% colNames] + + return(colDefs) +} diff --git a/R/Helpers.R b/R/Helpers.R index 286d7b9..65d469b 100644 --- a/R/Helpers.R +++ b/R/Helpers.R @@ -51,29 +51,30 @@ getCohortDefinitionsFromJson <- function( json ){ - cohortDefinitions <- json$sharedResources[[which("cohortDefinitions" == unlist(lapply(json$sharedResources, function(x) names(x))))]]$cohortDefinitions + cohortDefinitions <- json$sharedResources[[which(unlist(lapply(json$sharedResources, function(x) "cohortDefinitions" %in% names(x))))]]$cohortDefinitions cohortNames <- as.data.frame(do.call('rbind', cohortDefinitions)) # append subsets to cohortDefinitions subsetDefInd <- which(unlist(lapply(json$sharedResources, function(x) "subsetDefs" %in% names(x)))) - subsetDefs <- json$sharedResources[[subsetDefInd]]$subsetDefs - - subSetDefsNice <- data.frame( - subsetName = unlist( - lapply(1:length(subsetDefs), function(i){ - paste0(jsonlite::fromJSON(subsetDefs[i])$subsetOperators$name, collapse = ' - ') - }) - ), - subsetId = unlist( - lapply(1:length(subsetDefs), function(i){ - jsonlite::fromJSON(subsetDefs[i])$definitionId - }) - ), - json = subsetDefs - ) - + if(length(subsetDefInd) > 0){ + subsetDefs <- json$sharedResources[[subsetDefInd]]$subsetDefs + + subSetDefsNice <- data.frame( + subsetName = unlist( + lapply(1:length(subsetDefs), function(i){ + paste0(jsonlite::fromJSON(subsetDefs[i])$subsetOperators$name, collapse = ' - ') + }) + ), + subsetId = unlist( + lapply(1:length(subsetDefs), function(i){ + jsonlite::fromJSON(subsetDefs[i])$definitionId + }) + ), + json = subsetDefs + ) + # now get the actual subsets cohortSubsetsInd <- which(unlist(lapply(json$sharedResources, function(x) "cohortSubsets" %in% names(x)))) cohortSubsets <- json$sharedResources[[cohortSubsetsInd]]$cohortSubsets @@ -105,8 +106,36 @@ getCohortDefinitionsFromJson <- function( ) } ) + } else{ + subSetDefsNice <- NULL + cohortSubsetsDefinitions <- NULL + } + + # add code for templates + templateDefsInd <- which(unlist(lapply(json$sharedResources, function(x) "templateDefs" %in% names(x)))) + if(length(templateDefsInd) > 0){ + templateDefs <- json$sharedResources[[templateDefsInd]]$templateDefs - cohortDefinitions <- append(cohortDefinitions, cohortSubsetsDefinitions) + templateDefinitions <- lapply( + X = templateDefs, + FUN = function(x){ + list( + cohortName = x$references$cohortName, + cohortId = x$references$cohortId + )} + ) + + } else{ + templateDefinitions <- NULL + } + + + cohortDefinitions <- append( + append( + cohortDefinitions, + cohortSubsetsDefinitions), + templateDefinitions + ) cohortIds <- unlist(lapply(cohortDefinitions, function(x) x$cohortId)) cohortNames <- unlist(lapply(cohortDefinitions, function(x) x$cohortName)) @@ -242,17 +271,22 @@ getCohortDefinitionsFromJson <- function( #' @export #' getConcepts <- function( - expression, + expression = NULL, conceptIds = NULL, baseUrl = 'https://api.ohdsi.org/WebAPI' ){ + # if concepts are not specified, extract from the expression instead if(is.null(conceptIds)){ - allCodes <- ROhdsiWebApi::resolveConceptSet( - conceptSetDefinition = expression, - baseUrl = baseUrl - ) + if(is.null(expression)){ + allCodes <- -1 + } else{ + allCodes <- ROhdsiWebApi::resolveConceptSet( + conceptSetDefinition = expression, + baseUrl = baseUrl + ) + } } else{ allCodes <- conceptIds } @@ -344,8 +378,12 @@ getNegativeControlsFromJson <- function(json){ negativeControls <- as.data.frame(do.call(rbind,lapply(negativeControlsTemp$negativeControlOutcomeCohortSet, function(x) x))) - negativeControls$occurrenceType <- negativeControlsTemp$occurrenceType - negativeControls$detectOnDescendants <- negativeControlsTemp$detectOnDescendants + if(!nrow(negativeControls) == 0){ + negativeControls$occurrenceType <- negativeControlsTemp$occurrenceType + negativeControls$detectOnDescendants <- negativeControlsTemp$detectOnDescendants + } else{ + negativeControls <- NULL + } } diff --git a/inst/protocol/cohort-method.qmd b/inst/protocol/cohort-method.qmd index c6eb133..0762a5c 100644 --- a/inst/protocol/cohort-method.qmd +++ b/inst/protocol/cohort-method.qmd @@ -96,44 +96,9 @@ for(cmi in 1:length(cmOutUnique)){ table = cmOutUnique[[cmi]], groupBy = "parentNameOutcome", groupByButton = TRUE, - columns = list( - priorOutcomeLookback = reactable::colDef( - aggregate = "unique", - show = TRUE, - name = 'Prior Outcome Lookback (days)', - filterable = TRUE - ), - outcomeId = reactable::colDef(show = FALSE), - outcomeOfInterest = reactable::colDef(show = FALSE), - subsetIdOutcome = reactable::colDef(show = FALSE), - parentNameOutcome = reactable::colDef( - show = TRUE, - name = 'Outcome Parent', - filterable = TRUE, - html = TRUE, - minWidth = 300 - ), - cohortNameOutcome = reactable::colDef( - show = TRUE, - name = 'Outcome', - html = TRUE, - filterable = TRUE, - minWidth = 300 - ), - cohortNameWithLinkOutcome = reactable::colDef( - show = FALSE, - name = 'Outcome', - html = TRUE, - filterable = TRUE + columns = ProtocolGenerator::cmOutcomeColDef( + colNames = colnames(cmOutUnique[[cmi]]) ), - isParentOutcome = reactable::colDef(show = F), - parentIdOutcome = reactable::colDef(show = F), - subsetNameOutcome = reactable::colDef(show = F), - packageVersionOutcome = reactable::colDef(show = F), - numberSubsetOperatorsOutcome = reactable::colDef(show = F), - subsetCohortsOutcome = reactable::colDef(show = F), - appliedSubsetsOutcome = reactable::colDef(show = F) - ), elementId = paste0("cm-out-tab-",cmi) ) ) diff --git a/man/cmOutcomeColDef.Rd b/man/cmOutcomeColDef.Rd new file mode 100644 index 0000000..29ebc03 --- /dev/null +++ b/man/cmOutcomeColDef.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CohortMethod.R +\name{cmOutcomeColDef} +\alias{cmOutcomeColDef} +\title{cmOutcomeColDef} +\usage{ +cmOutcomeColDef(colNames) +} +\arguments{ +\item{colNames}{Optional a vector of column names to restrict to} +} +\value{ +A column definition list +} +\description{ +List with column names for the cohort method outcome table +} +\details{ +Returns a names list with the cohorts names +} diff --git a/man/reportTableFormat.Rd b/man/reportTableFormat.Rd index 942ca62..f4af07d 100644 --- a/man/reportTableFormat.Rd +++ b/man/reportTableFormat.Rd @@ -9,7 +9,8 @@ reportTableFormat( groupBy = NULL, columns = NULL, elementId = NULL, - caption + caption, + groupByButton = FALSE ) } \arguments{ From a08f310d02a36c28aeb4c3671cc78a609910ca2b Mon Sep 17 00:00:00 2001 From: jreps Date: Wed, 19 Aug 2026 14:11:38 -0400 Subject: [PATCH 4/8] updates for char v4 - added code to work with older and v4 char - fixed small bug in cohort method - updated for newer PLP specification --- R/Characterization.R | 603 +++++++++++++++------- R/CohortMethod.R | 2 +- inst/protocol/characterization.qmd | 108 +++- inst/protocol/prediction/plp-analysis.Rmd | 36 +- inst/protocol/study_protocol.qmd | 1 + 5 files changed, 535 insertions(+), 215 deletions(-) diff --git a/R/Characterization.R b/R/Characterization.R index d52c2d4..71639a6 100644 --- a/R/Characterization.R +++ b/R/Characterization.R @@ -4,7 +4,7 @@ globalCharacterizationSettings <- function( txt <- paste0( 'Only covariates that occur >= ', - CharacterizationModuleSettings$settings$minCharacterizationMean, + CharacterizationModuleSettings$settings$minCharacterizationMean, ' fraction of the population and >= ', CharacterizationModuleSettings$settings$minCovariateCount, ' people are returned. ', @@ -16,7 +16,19 @@ globalCharacterizationSettings <- function( CharacterizationModuleSettings$settings$outputTable, ' within the Strategus work schema.' ) - + + # add new variables if they are not NULL + tSize <- CharacterizationModuleSettings$settings$minTargetSize + cSize <- CharacterizationModuleSettings$settings$minCaseSize + + # Updates for Char v4 inputs + if(!is.null(tSize)){ + txt <- paste0(txt, ' Only run risk factor/case series for study populations >= ', tSize, ' people.') + } + if(!is.null(tSize)){ + txt <- paste0(txt, ' Only run risk factor/case series for cases (number of people with outcome) >= ', cSize, ' people.') + } + return(txt) } @@ -45,28 +57,25 @@ processTargetBaseineSettings <- function( tbSpec <- CharacterizationModuleSettings$settings$analysis$targetBaselineSettings + # only non-NULL in v4 or higher + characterizationTargetLookup <- CharacterizationModuleSettings$settings$analysis$characterizationTargetLookup + if(is.null(tbSpec)){ return(NULL) } - # get the unique covariate settings - covariateJson <- lapply( - X = tbSpec, - FUN = function(x) ParallelLogger::convertSettingsToJson(x$covariateSettings) + + # helper at bottom of file + targetPop <- getTargetPop( + spec = tbSpec, + settingName = 'targetBaselineSettings', + characterizationTargetLookup = characterizationTargetLookup, + mapCovariates = TRUE, + mapOutcomes = FALSE ) - covariateJsonUnique <- unique(covariateJson) - # extract: target_id, limitToFirstInNDays, minPriorObservation, covariateSettingId - targetSettings <- do.call(rbind, lapply( - X = tbSpec, - FUN = function(x) data.frame( - targetId = x$targetIds, - limitToFirstInNDays = x$limitToFirstInNDays, - minPriorObservation = x$minPriorObservation, - covariateSettingId = match(ParallelLogger::convertSettingsToJson(x$covariateSettings),covariateJsonUnique) - ) - ) - ) + targetSettings <- targetPop$targetSettings + covariateJsonUnique <- targetPop$covariateJsonUnique # create target table tempDf <- cohortDefinitionDf @@ -98,93 +107,67 @@ processRiskFactorSettings <- function( ){ rfSpec <- CharacterizationModuleSettings$settings$analysis$riskFactorSettings + # only non-NULL in v4 or higher + characterizationTargetLookup <- CharacterizationModuleSettings$settings$analysis$characterizationTargetLookup + if(is.null(rfSpec)){ return(NULL) } - # get the unique covariate settings - covariateJsonUnique <- unique(lapply( - X = rfSpec, - FUN = function(x) ParallelLogger::convertSettingsToJson(x$covariateSettings) - )) - - # get unique outcome sets - rfOutcomeList <- unique(lapply( - X = rfSpec, - FUN = function(x) { - data.frame( - outcomeId = x$outcomeIds, - outcomeWashoutDays = x$outcomeWashoutDays, - tar = processTar( - riskWindowStart = x$riskWindowStart, - startAnchor = x$startAnchor, - riskWindowEnd = x$riskWindowEnd, - endAnchor = x$endAnchor - ) - ) - })) - - # get unique target sets - rfTargetList <- unique(lapply( - X = rfSpec, - FUN = function(x) { - data.frame( - targetId = x$targetIds, # need to account for multiple targetIds - limitToFirstInNDays = x$limitToFirstInNDays, - minPriorObservation = x$minPriorObservation - ) - } - )) - - if(length(rfTargetList) == 1){ + # check whether the same targets are used in all settings + allTs <- getTargetPop( + spec = rfSpec, + characterizationTargetLookup = characterizationTargetLookup, + settingName = 'riskFactorSettings', + mapCovariates = FALSE, + mapOutcomes = FALSE + )$targetSettings + row.names(allTs) <- NULL + + firstTs <- getTargetPop( + spec = list(rfSpec[[1]]), + characterizationTargetLookup = characterizationTargetLookup, + settingName = 'riskFactorSettings', + mapCovariates = FALSE, + mapOutcomes = FALSE + )$targetSettings + row.names(firstTs) <- NULL + + singleTargetSet <- all.equal(allTs, firstTs) + + if(singleTargetSet){ # all outcomes by all targets - rfTargetSettings <- unique(do.call(rbind, lapply( - X = rfSpec, - FUN = function(x) { - - data.frame( - targetId = x$targetIds, # need to account for multiple targetIds - limitToFirstInNDays = x$limitToFirstInNDays, - minPriorObservation = x$minPriorObservation, - outcomeSet = 1, - covariateSettingId = match(ParallelLogger::convertSettingsToJson(x$covariateSettings),covariateJsonUnique) - ) - - } - ) - )) + targetPop <- getTargetPop( + spec = rfSpec, + settingName = 'riskFactorSettings', + characterizationTargetLookup = characterizationTargetLookup, + mapCovariates = TRUE, + mapOutcomes = TRUE + ) - rfOutcomeList <- list(do.call(rbind, rfOutcomeList)) + rfTargetSettings <- unique(targetPop$targetSettings) + rfTargetSettings$outcomeSet <- 1 + rfTargetSettings <- unique(rfTargetSettings) + covariateJsonUnique <- targetPop$covariateJsonUnique + rfOutcomeList <- targetPop$outcomeList + + rfOutcomeList <- list(unique(do.call(rbind, rfOutcomeList))) } else{ # extract: target_id, limitToFirstInNDays, minPriorObservation, covariateSettingId - rfTargetSettings <- unique(do.call(rbind, lapply( - X = rfSpec, - FUN = function(x) { - - data.frame( - targetId = x$targetIds, # need to account for multiple targetIds - limitToFirstInNDays = x$limitToFirstInNDays, - minPriorObservation = x$minPriorObservation, - outcomeSet = which(unlist(lapply( - X = rfOutcomeList, - FUN = function(y){identical(y, data.frame(outcomeId = x$outcomeIds, - outcomeWashoutDays = x$outcomeWashoutDays, - tar = processTar( - riskWindowStart = x$riskWindowStart, - startAnchor = x$startAnchor, - riskWindowEnd = x$riskWindowEnd, - endAnchor = x$endAnchor - )))} - ))), - covariateSettingId = match(ParallelLogger::convertSettingsToJson(x$covariateSettings),covariateJsonUnique) - ) - - } + targetPop <- getTargetPop( + spec = rfSpec, + settingName = 'riskFactorSettings', + characterizationTargetLookup = characterizationTargetLookup, + mapCovariates = TRUE, + mapOutcomes = TRUE ) - )) + rfTargetSettings <- targetPop$targetSettings + covariateJsonUnique <- targetPop$covariateJsonUnique + rfOutcomeList <- targetPop$outcomeList + } # create table @@ -238,108 +221,67 @@ processCaseSeriesSettings <- function( ){ csSpec <- CharacterizationModuleSettings$settings$analysis$caseSeriesSettings + characterizationTargetLookup <- CharacterizationModuleSettings$settings$analysis$characterizationTargetLookup if(is.null(csSpec)){ return(NULL) } - # get the unique covariate settings - settingsJsonUnique <- unique(lapply( - X = csSpec, - FUN = function(x) ParallelLogger::convertSettingsToJson( - list( - caseCovariateSettings = x$caseCovariateSettings, - casePreTargetDuration = x$casePreTargetDuration, - casePostOutcomeDuration = x$casePostOutcomeDuration - ) - ) - )) - - # get unique outcome sets - csOutcomeList <- unique(lapply( - X = csSpec, - FUN = function(x) { - data.frame( - outcomeId = x$outcomeIds, - outcomeWashoutDays = x$outcomeWashoutDays, - tar = processTar( - riskWindowStart = x$riskWindowStart, - startAnchor = x$startAnchor, - riskWindowEnd = x$riskWindowEnd, - endAnchor = x$endAnchor - ) - ) - })) - - # get unique target sets - csTargetList <- unique(lapply( - X = csSpec, - FUN = function(x) { - data.frame( - targetId = x$targetIds, # need to account for multiple targetIds - limitToFirstInNDays = x$limitToFirstInNDays, - minPriorObservation = x$minPriorObservation - ) - } - )) - - # extract: target_id, limitToFirstInNDays, minPriorObservation, covariateSettingId - if(length(csTargetList) == 1){ + # check whether the same targets are used in all settings + allTs <- getTargetPop( + spec = csSpec, + characterizationTargetLookup = characterizationTargetLookup, + settingName = 'caseSeriesSettings', + mapCovariates = FALSE, + mapOutcomes = FALSE + )$targetSettings + row.names(allTs) <- NULL + + firstTs <- getTargetPop( + spec = list(csSpec[[1]]), + characterizationTargetLookup = characterizationTargetLookup, + settingName = 'caseSeriesSettings', + mapCovariates = FALSE, + mapOutcomes = FALSE + )$targetSettings + row.names(firstTs) <- NULL + + singleTargetSet <- all.equal(allTs, firstTs) + + if(singleTargetSet){ # all outcomes by all targets - csTargetSettings <- unique(do.call(rbind, lapply( - X = csSpec, - FUN = function(x) { - - data.frame( - targetId = x$targetIds, # need to account for multiple targetIds - limitToFirstInNDays = x$limitToFirstInNDays, - minPriorObservation = x$minPriorObservation, - outcomeSet = 1, - settingId = match(ParallelLogger::convertSettingsToJson(list( - caseCovariateSettings = x$caseCovariateSettings, - casePreTargetDuration = x$casePreTargetDuration, - casePostOutcomeDuration = x$casePostOutcomeDuration - )), settingsJsonUnique) - ) - - } + targetPop <- getTargetPop( + spec = csSpec, + settingName = 'caseSeriesSettings', + characterizationTargetLookup = characterizationTargetLookup, + mapCovariates = FALSE, + mapOutcomes = TRUE, + mapCaseSeries = TRUE ) - )) - csOutcomeList <- list(do.call(rbind, csOutcomeList)) + csTargetSettings <- unique(targetPop$targetSettings) + csTargetSettings$outcomeSet <- 1 + csTargetSettings <- unique(csTargetSettings) + settingsJsonUnique <- targetPop$caseJsonUnique + csOutcomeList <- targetPop$outcomeList + + csOutcomeList <- list(unique(do.call(rbind, csOutcomeList))) } else{ # extract: target_id, limitToFirstInNDays, minPriorObservation, covariateSettingId - csTargetSettings <- unique(do.call(rbind, lapply( - X = csSpec, - FUN = function(x) { - - data.frame( - targetId = x$targetIds, # need to account for multiple targetIds - limitToFirstInNDays = x$limitToFirstInNDays, - minPriorObservation = x$minPriorObservation, - outcomeSet = which(unlist(lapply( - X = csOutcomeList, - FUN = function(y){identical(y, data.frame(outcomeId = x$outcomeIds, - outcomeWashoutDays = x$outcomeWashoutDays, - tar = processTar( - riskWindowStart = x$riskWindowStart, - startAnchor = x$startAnchor, - riskWindowEnd = x$riskWindowEnd, - endAnchor = x$endAnchor - )))} - ))), - settingId = match(ParallelLogger::convertSettingsToJson(list( - caseCovariateSettings = x$caseCovariateSettings, - casePreTargetDuration = x$casePreTargetDuration, - casePostOutcomeDuration = x$casePostOutcomeDuration - )), settingsJsonUnique) - ) - - } + targetPop <- getTargetPop( + spec = csSpec, + settingName = 'caseSeriesSettings', + characterizationTargetLookup = characterizationTargetLookup, + mapCovariates = FALSE, + mapOutcomes = TRUE, + mapCaseSeries = TRUE ) - )) + csTargetSettings <- targetPop$targetSettings + settingsJsonUnique <- targetPop$caseJsonUnique + csOutcomeList <- targetPop$outcomeList + } # create table @@ -386,6 +328,135 @@ processCaseSeriesSettings <- function( } + +# Time-to-event +processTimeToEventSettings <- function( + CharacterizationModuleSettings, + cohortDefinitionDf # process cohortDefinition +){ + + tteSpec <- CharacterizationModuleSettings$settings$analysis$timeToEventSettings + + # only non-NULL in v4 or higher + characterizationTargetLookup <- CharacterizationModuleSettings$settings$analysis$characterizationTargetLookup + + if(is.null(tteSpec)){ + return(NULL) + } + + # work for earlier versions and v4 + if(is.null(characterizationTargetLookup)){ + + popList <- lapply( + X = tteSpec, + FUN = function(x){ + cohortDefinitionDf[cohortDefinitionDf$cohortId %in% x$targetIds, ] + } + ) + + } else{ + + popList <- lapply( + X = tteSpec, + FUN = function(x){ + merge( + cohortDefinitionDf, + characterizationTargetLookup %>% + dplyr::filter(.data$timeToEventSettings == 1) %>% + dplyr::select(!dplyr::any_of(c("timeToEventSettings", "dechallengeRechallengeSettings", "targetBaselineSettings", "riskFactorSettings", "caseSeriesSettings"))), + by.x = 'cohortId', + by.y = 'targetId' + ) + } + ) + + } + + outcomeList <- lapply( + X = tteSpec, + FUN = function(x){cohortDefinitionDf[cohortDefinitionDf$cohortId %in% x$outcomeIds,]} + ) + + return( + list( + popList = popList, + outcomeList = outcomeList + ) + ) + +} + +#===================== +# Dechal-rechal +#===================== +processDechalSettings <- function( + CharacterizationModuleSettings, + cohortDefinitionDf # process cohortDefinition +){ + + dcSpec <- CharacterizationModuleSettings$settings$analysis$dechallengeRechallengeSettings + + # only non-NULL in v4 or higher + characterizationTargetLookup <- CharacterizationModuleSettings$settings$analysis$characterizationTargetLookup + + if(is.null(dcSpec)){ + return(NULL) + } + + settingsList <- lapply( + X = dcSpec, + FUN = function(x){list( + dechallengeStopInterval = x$dechallengeStopInterval, + dechallengeEvaluationWindow = x$dechallengeEvaluationWindow + )} + ) + + # work for earlier versions and v4 + if(is.null(characterizationTargetLookup)){ + + popList <- lapply( + X = dcSpec, + FUN = function(x){ + cohortDefinitionDf[cohortDefinitionDf$cohortId %in% x$targetCohortDefinitionIds, ] + } + ) + + } else{ + + popList <- lapply( + X = dcSpec, + FUN = function(x){ + merge( + cohortDefinitionDf, + characterizationTargetLookup %>% + dplyr::filter(.data$dechallengeRechallengeSettings == 1) %>% + dplyr::select(!dplyr::any_of(c("timeToEventSettings", "dechallengeRechallengeSettings", "targetBaselineSettings", "riskFactorSettings", "caseSeriesSettings"))), + by.x = 'cohortId', + by.y = 'targetId' + ) + } + ) + + } + + outcomeList <- lapply( + X = dcSpec, + FUN = function(x){cohortDefinitionDf[cohortDefinitionDf$cohortId %in% c(x$outcomeIds,x$outcomeCohortDefinitionIds),]} + ) + + return( + list( + popList = popList, + outcomeList = outcomeList, + settingsList = settingsList + ) + ) + +} + +#===================== +# Col def helpers +#===================== characterizationColDef <- function(){ res <- list( subsetIdTarget = reactable::colDef(show = FALSE), @@ -547,3 +618,171 @@ characterizationColDef <- function(){ return(res) } + + + + + +# helper +getTargetPop <- function( + spec, + characterizationTargetLookup, + settingName = 'targetBaselineSettings', + mapCovariates = FALSE, + mapOutcomes = FALSE, + mapCaseSeries = FALSE + + ){ + + if(mapCovariates){ + # get the unique covariate settings + covariateJson <- lapply( + X = spec, + FUN = function(x) ParallelLogger::convertSettingsToJson(x$covariateSettings) + ) + covariateJsonUnique <- unique(covariateJson) + } else{ + covariateJsonUnique <- NULL + } + + if(mapOutcomes){ + + outcomeList <- unique(lapply( + X = spec, + FUN = function(x) { + data.frame( + outcomeId = x$outcomeIds, + outcomeWashoutDays = x$outcomeWashoutDays, + tar = processTar( + riskWindowStart = x$riskWindowStart, + startAnchor = x$startAnchor, + riskWindowEnd = x$riskWindowEnd, + endAnchor = x$endAnchor + ) + ) + })) + + } else{ + outcomeList = NULL + } + + + if(mapCaseSeries){ + caseJsonUnique<- unique(lapply( + X = spec, + FUN = function(x) ParallelLogger::convertSettingsToJson( + list( + caseCovariateSettings = x$caseCovariateSettings, + casePreTargetDuration = x$casePreTargetDuration, + casePostOutcomeDuration = x$casePostOutcomeDuration + ) + ) + )) + } else{ + caseJsonUnique <- NULL + } + +if(is.null(spec[[1]]$characterizationTargetIds)){ + # Spec prior to v4 char + # extract: target_id, limitToFirstInNDays, minPriorObservation, covariateSettingId + targetSettings <- do.call(rbind, lapply( + X = spec, + FUN = function(x){ + temp <- data.frame( + targetId = x$targetIds, + limitToFirstInNDays = x$limitToFirstInNDays, + minPriorObservation = x$minPriorObservation + ) + if(mapCovariates){ + temp$covariateSettingId = match(ParallelLogger::convertSettingsToJson(x$covariateSettings),covariateJsonUnique) + } + + if(mapOutcomes){ + temp$outcomeSet = which(unlist(lapply( + X = outcomeList, + FUN = function(y){identical(y, data.frame(outcomeId = x$outcomeIds, + outcomeWashoutDays = x$outcomeWashoutDays, + tar = processTar( + riskWindowStart = x$riskWindowStart, + startAnchor = x$startAnchor, + riskWindowEnd = x$riskWindowEnd, + endAnchor = x$endAnchor + )))} + ))) + } + + if(mapCaseSeries){ + temp$settingId = match(ParallelLogger::convertSettingsToJson( + list( + caseCovariateSettings = x$caseCovariateSettings, + casePreTargetDuration = x$casePreTargetDuration, + casePostOutcomeDuration = x$casePostOutcomeDuration + ) + ),caseJsonUnique) + } + + return(temp) + } + ) + )} else{ + + # v4 char + targetSettings <- do.call(rbind, lapply( + X = spec, + FUN = function(x){ + temp <- data.frame( + characterizationTargetId = x$characterizationTargetIds + ) + if(mapCovariates){ + temp$covariateSettingId = match(ParallelLogger::convertSettingsToJson(x$covariateSettings),covariateJsonUnique) + } + if(mapOutcomes){ + temp$outcomeSet = which(unlist(lapply( + X = outcomeList, + FUN = function(y){identical(y, data.frame(outcomeId = x$outcomeIds, + outcomeWashoutDays = x$outcomeWashoutDays, + tar = processTar( + riskWindowStart = x$riskWindowStart, + startAnchor = x$startAnchor, + riskWindowEnd = x$riskWindowEnd, + endAnchor = x$endAnchor + )))} + ))) + } + + if(mapCaseSeries){ + temp$settingId = match(ParallelLogger::convertSettingsToJson( + list( + caseCovariateSettings = x$caseCovariateSettings, + casePreTargetDuration = x$casePreTargetDuration, + casePostOutcomeDuration = x$casePostOutcomeDuration + ) + ),caseJsonUnique) + } + + return(temp) + } + )) + + + # need to join only studyPops + targetSettings <- merge(targetSettings, characterizationTargetLookup, by = 'characterizationTargetId') + + targetSettings$settings <- targetSettings[,settingName] + + # filter to targetBaselineSettings == 1 and remove timeToEventSettings dechallengeRechallengeSettings targetBaselineSettings riskFactorSettings caseSeriesSettings + targetSettings <- targetSettings %>% + dplyr::filter(.data$settings == 1) %>% + dplyr::select(!dplyr::any_of(c("settings","timeToEventSettings", "dechallengeRechallengeSettings", "targetBaselineSettings", "riskFactorSettings", "caseSeriesSettings"))) + + } + + return( + list( + targetSettings = unique(targetSettings), + covariateJsonUnique = covariateJsonUnique, + outcomeList = outcomeList, + caseJsonUnique = caseJsonUnique + ) + ) +} diff --git a/R/CohortMethod.R b/R/CohortMethod.R index 5daa8eb..b9f5b12 100644 --- a/R/CohortMethod.R +++ b/R/CohortMethod.R @@ -166,7 +166,7 @@ extractCohortMethodSettings <- function( # now process the negative list and excludeConcepts list commonExclude <- excludeConcepts[[1]] if(length(excludeConcepts) > 1){ - if(commonExclude != -1){ + if(commonExclude[1] != -1){ for(ind in 2:length(excludeConcepts)){ commonExclude <- intersect(excludeConcepts[[ind]],commonExclude) } diff --git a/inst/protocol/characterization.qmd b/inst/protocol/characterization.qmd index f02b897..af0d991 100644 --- a/inst/protocol/characterization.qmd +++ b/inst/protocol/characterization.qmd @@ -22,6 +22,17 @@ caseSeries <- ProtocolGenerator:::processCaseSeriesSettings( cohortDefinitionDf = cohortDefinitionDf ) +# add dechalRechal and timeToEvent functions +tte <- ProtocolGenerator:::processTimeToEventSettings( + CharacterizationModuleSettings = CharacterizationModuleSettings, + cohortDefinitionDf = cohortDefinitionDf +) + +dc <- ProtocolGenerator:::processDechalSettings( + CharacterizationModuleSettings = CharacterizationModuleSettings, + cohortDefinitionDf = cohortDefinitionDf +) + # summary detaisls numTbSettings <- length(targetBaseline$settingsJson) numRfSettings <- length(riskFactor$settingsJson) @@ -285,8 +296,17 @@ cat('\n::: {.callout-important collapse="true"}') # Summary of time-to-event ```{r, echo=FALSE, results = 'asis', include=FALSE} -cTargets <- cohortDefinitionDf[cohortDefinitionDf$cohortId %in% CharacterizationModuleSettings$settings$analysis$timeToEventSettings[[1]]$targetIds, ] -cOutcomes <- cohortDefinitionDf[cohortDefinitionDf$cohortId %in% CharacterizationModuleSettings$settings$analysis$timeToEventSettings[[1]]$outcomeIds, ] + +tteSettingCount <- length(tte$popList) +cTargets <- unique(do.call('rbind', tte$popList)) +cOutcomes <- unique(do.call('rbind', tte$outcomeList)) + +if(tteSettingCount == 1){ + tteSettingRef <- '@sec-char-tte-setting-end' +} else{ + tteSettingRef <- '@sec-char-tte-setting-1 - @sec-char-tte-setting-end' +} + ``` For each specified target cohort and outcome, we identify all outcome occurrences among cohort members and compute the days from the target index to each occurrence (negative = before index, positive = after index). Each occurrence is labeled by: @@ -296,50 +316,63 @@ For each specified target cohort and outcome, we identify all outcome occurrence We then aggregate occurrence counts by day relative to the index and by label, producing daily frequency tables (and optional plots) that show when outcomes occur across the target population and how timing differs by occurrence type. See more [here](https://ohdsi.github.io/Characterization/articles/Specification.html#time-to-event). -In this specified analysis there are ``r length(unique(cTargets$parentId))`` unique parent targets (corresponding to ``r length(unique(cTargets$cohortId))`` unique targets with subsets) see @sec-char-tte-targets and ``r length(unique(cOutcomes$parentId)) `` unique parent outcomes (corresponding to ``r length(unique(cOutcomes$cohortId))`` unique outcomes with subsets) see @sec-char-tte-outcomes. +In this specified analysis there are ``r tteSettingCount`` setting(s) containing target and outcome combinations to include, see `r tteSettingRef`. Across all settings there are ``r length(unique(cTargets$parentId))`` unique parent targets (corresponding to ``r length(unique(cTargets$cohortId))`` unique targets with subsets) and ``r length(unique(cOutcomes$parentId)) `` unique parent outcomes (corresponding to ``r length(unique(cOutcomes$cohortId))`` unique outcomes with subsets). ::: ```{r, echo=FALSE, results = 'asis'} - - cat("\n\n#### Targets {#sec-char-tte-targets} \n") -if(nrow(cTargets)>0){ + for(i in 1:tteSettingCount){ + if(tteSettingCount == 1){ + # do not print the number for the setting as there is only 1 + iVal <- "" + } else{ + iVal <- i + } + + if( i == tteSettingCount){ + cat(paste0("\n\n#### Setting ",iVal," {#sec-char-tte-setting-end} \n")) + } else{ + cat(paste0("\n\n#### Setting ",iVal," {#sec-char-tte-setting-",i,"} \n")) + } + cat(paste0("\n\n##### Targets {#sec-char-tte-targets-",i,"} \n")) +if(nrow(tte$popList[[i]])>0){ cat('\n::: {.callout-important collapse="true"}') cat('\n# Targets used in time-to-event\n') print(shiny::tagList( ProtocolGenerator::reportTableFormat( - table = cTargets %>% + table = tte$popList[[i]] %>% dplyr::arrange(.data$parentName,.data$cohortName), groupBy = 'parentName', elementId = 'tte-targets', groupByButton = TRUE, - columns = cColumns[names(cColumns) %in% colnames(cTargets)], + columns = cColumns[names(cColumns) %in% colnames(tte$popList[[i]])], caption = 'Target cohorts included in the analysis.' ))) cat('\n:::\n') cat('\n\n') } - cat("\n\n#### Outcomes {#sec-char-tte-outcomes} \n") - if(nrow(cOutcomes)>0){ + cat(paste0("\n\n##### Outcomes {#sec-char-tte-outcomes-",i,"} \n")) + if(nrow(tte$outcomeList[[i]])>0){ cat('\n::: {.callout-important collapse="true"}') cat('\n# Outcomes used in time-to-event\n') print(shiny::tagList( ProtocolGenerator::reportTableFormat( - table = cOutcomes %>% + table = tte$outcomeList[[i]] %>% dplyr::arrange(.data$parentName,.data$cohortName), groupBy = 'parentName', elementId = 'tte-outcomes', groupByButton = TRUE, - columns = cColumns[names(cColumns) %in% colnames(cOutcomes)], + columns = cColumns[names(cColumns) %in% colnames(tte$outcomeList[[i]])], caption = 'Outcome cohorts included in the analysis.' ))) cat('\n:::\n') cat('\n\n') } + } tteTargets <- unique(cTargets$cohortId) tteOutcomes <- unique(cOutcomes$cohortId) @@ -352,64 +385,85 @@ tteOutcomes <- unique(cOutcomes$cohortId) ::: {.callout-important collapse="false"} # Summary of dechallenge rechallenge ```{r, echo=FALSE, results = 'asis', include=FALSE} -cTargets <- cohortDefinitionDf[cohortDefinitionDf$cohortId %in% CharacterizationModuleSettings$settings$analysis$dechallengeRechallengeSettings[[1]]$targetCohortDefinitionIds, ] -cOutcomes <- cohortDefinitionDf[cohortDefinitionDf$cohortId %in% CharacterizationModuleSettings$settings$analysis$dechallengeRechallengeSettings[[1]]$outcomeCohortDefinitionIds, ] + +dcSettingCount <- length(dc$popList) +cTargets <- unique(do.call('rbind', dc$popList)) +cOutcomes <- unique(do.call('rbind', dc$outcomeList)) + +if(dcSettingCount == 1){ + dcSettingRef <- '@sec-char-dr-settings-end' +} else{ + dcSettingRef <- '@sec-char-dr-settings-1 - @sec-char-dr-settings-end' +} + ``` This analysis lets you identify cases where a patient had an outcome while exposed to a target drug and the target drug is stopped shortly after the outcome (this may correspond to patients stopping the drug due to the outcome starting). This is known as dechallenge. If the outcome stops after the drug stops then this is a dechallenge success, otherwise, if the outcome continues it is a dechallenge fail. For the cases where there was a dechallenge, we are then interested in how often the patient restarts the drug at a later time, rechallenges, and whether the outcome occurs shortly after starting exposure (rechallenge success) or does not occur (rechallenge fail). See more [here](https://ohdsi.github.io/Characterization/articles/Specification.html#dechallenge-rechallenge). For each Target and Outcome combination this calculates the number of patients in the target population with a dechallenge (when a target exposure era ends within decallengeStopInterval days of an outcome) in addition to the number of these that are fails (the outcome is recorded within dechallengeEvaluationWindow days after the target exposure era ends) and successful (the outcome is not recorded within dechallengeEvaluationWindow days after the target exposure era ends). Then for those with a successful dechallenge, rechallenges are counted based on whether an outcome occurs in a new target exposure era and a rechallenge fail is counted if the target exposure ends within decallengeStopInterval days of the outcome. The total number of dechallenges, dechallenge fails, dechallenge success, rechallenges, rechallenge fails and rechallenge success are calculated per target, outcome and setting. -In this analysis there are ``r length(unique(cTargets$parentId)) `` unique parent targets (corresponding to ``r length(unique(cTargets$cohortId))`` unique targets with subsets) see @sec-char-dr-targets and ``r length(unique(cOutcomes$parentId)) `` unique parent outcomes (corresponding to ``r length(unique(cOutcomes$cohortId))`` unique outcomes with subsets) see @sec-char-dr-outcomes. The settings (decallengeStopInterval and dechallengeEvaluationWindow) are in @sec-dcrc-settings. +In this analysis there are ``r dcSettingCount `` dechallenge-rechallenge setting(s) specifying different target and outcome combinations and setting values (decallengeStopInterval and dechallengeEvaluationWindow), see `r dcSettingRef`. In total there are ``r length(unique(cTargets$parentId)) `` unique parent targets (corresponding to ``r length(unique(cTargets$cohortId))`` unique targets with subsets) and ``r length(unique(cOutcomes$parentId)) `` unique parent outcomes (corresponding to ``r length(unique(cOutcomes$cohortId))`` unique outcomes with subsets). ::: ```{r, echo=FALSE, results = 'asis'} - cat("\n\n#### Targets {#sec-char-dr-targets} \n\n") - if(nrow(cTargets)>0){ +for(i in 1:dcSettingCount){ + if(dcSettingCount == 1){ + # do not print the number for the setting as there is only 1 + iVal <- "" + } else{ + iVal <- i + } + if(i == dcSettingCount){ + cat(paste0("\n\n#### Settings ",iVal," {#sec-char-dr-settings-end} \n\n")) + } else{ + cat(paste0("\n\n#### Settings ",iVal," {#sec-char-dr-settings-",i,"} \n\n")) + } + cat(paste0("\n\n##### Targets {#sec-char-dr-targets-",i,"} \n\n")) + if(nrow(dc$popList[[i]])>0){ cat('\n::: {.callout-important collapse="true"}') cat('\n# Targets used in dechallenge rechallenge\n') print(shiny::tagList( ProtocolGenerator::reportTableFormat( - table = cTargets %>% + table = dc$popList[[i]] %>% dplyr::arrange(.data$parentName,.data$cohortName), groupBy = 'parentName', elementId = 'dcrc-targets', groupByButton = TRUE, - columns = cColumns[names(cColumns) %in% colnames(cTargets)], + columns = cColumns[names(cColumns) %in% colnames(dc$popList[[i]])], caption = 'Target cohorts included in the analysis.' ))) cat('\n:::\n') cat('\n\n') } - cat("\n#### Outcomes {#sec-char-dr-outcomes} \n") - if(nrow(cOutcomes)>0){ + cat(paste0("\n##### Outcomes {#sec-char-dr-outcomes-",i,"} \n")) + if(nrow(dc$outcomeList[[i]])>0){ cat('\n::: {.callout-important collapse="true"}') cat('\n# Outcomes used in dechallenge rechallenge \n') print(shiny::tagList( ProtocolGenerator::reportTableFormat( - table = cOutcomes %>% + table = dc$outcomeList[[i]] %>% dplyr::arrange(.data$parentName,.data$cohortName), groupBy = 'parentName', elementId = 'dcrc-outcomes', groupByButton = TRUE, - columns = cColumns[names(cColumns) %in% colnames(cOutcomes)], + columns = cColumns[names(cColumns) %in% colnames(dc$outcomeList[[i]])], caption = 'Outcome cohorts included in the analysis.' ))) cat('\n:::\n') cat('\n\n') } -cat("\n#### Parameters {#sec-dcrc-settings}\n", sep ='\n') +cat(paste0("\n##### Parameters {#sec-dcrc-settings-",i,"}\n", sep ='\n')) setTable <- getSettingsTable( package = 'Characterization', functionName = 'createDechallengeRechallengeSettings', settings = list( - dechallengeStopInterval = CharacterizationModuleSettings$settings$analysis$dechallengeRechallengeSettings[[1]]$dechallengeStopInterval, - dechallengeEvaluationWindow = CharacterizationModuleSettings$settings$analysis$dechallengeRechallengeSettings[[1]]$dechallengeEvaluationWindow + dechallengeStopInterval = dc$settingsList[[i]]$dechallengeStopInterval, + dechallengeEvaluationWindow = dc$settingsList[[i]]$dechallengeEvaluationWindow ) ) @@ -429,6 +483,8 @@ setTable <- getSettingsTable( ))) cat('\n:::\n') +} + ``` diff --git a/inst/protocol/prediction/plp-analysis.Rmd b/inst/protocol/prediction/plp-analysis.Rmd index 7714b6c..3be7da6 100644 --- a/inst/protocol/prediction/plp-analysis.Rmd +++ b/inst/protocol/prediction/plp-analysis.Rmd @@ -2,9 +2,20 @@ output: html_document --- +```{r, echo=FALSE} + +mdSettings <- attr(modelDesignSetting$modelSettings$param,'settings') +modelName <- mdSettings$name +if(is.null(mdSettings)){ + # newer PLP being used + mdSettings <- modelDesignSetting$modelSettings$settings + modelName <- mdSettings$modelName +} +``` + ##### Analysis -The model that will be trained is a ``r attr(modelDesignSetting$modelSettings$param,'settings')$name `` that uses the `PatientLevelPrediction` function ``r modelDesignSetting$modelSettings$fitFunction `` to fit the model. +The model that will be trained is a ``r modelName `` that uses the `PatientLevelPrediction` function ``r modelDesignSetting$modelSettings$fitFunction `` to fit the model. ```{r, echo=FALSE} if(modelDesignSetting$modelSettings$fitFunction == "fitCyclopsModel"){ @@ -16,10 +27,10 @@ if(modelDesignSetting$modelSettings$fitFunction == "fitCyclopsModel"){ ) settings <- data.frame( - name = names(attr(modelDesignSetting$modelSettings$param,"settings")), + name = names(mdSettings), value = unlist( lapply( - attr(modelDesignSetting$modelSettings$param,"settings"), + mdSettings, function(x) paste0(names(x), x, collapse = ':', sep=' ') ) ) @@ -35,10 +46,10 @@ if(modelDesignSetting$modelSettings$fitFunction == "fitCyclopsModel"){ ) settings <- data.frame( - name = names(attr(modelDesignSetting$modelSettings$param,"settings")), + name = names(mdSettings), value = unlist( lapply( - attr(modelDesignSetting$modelSettings$param,"settings"), + mdSettings, function(x) paste0(names(x), x, collapse = '-', sep='') ) ) @@ -53,7 +64,20 @@ The cross validation settings are to use ``r modelDesignSetting$splitSettings$nf **Hyper-parameter search** -The hyper-parameters investigated while fitting the model are listed below. The combination of hyper-parameters that obtains the highest AUROC value in the training data via cross validation will be uses in the final model. +```{r, echo=FALSE} +search <- 'grid' +maximize <- TRUE +metric <- 'AUROC' + +if(!is.null(modelDesignSetting$hyperparameterSettings)){ + search <- modelDesignSetting$hyperparameterSettings$search + maximize <- modelDesignSetting$hyperparameterSettings$tuningMetric$maximize + metric <- modelDesignSetting$hyperparameterSettings$tuningMetric$name +} + +``` + +The hyper-parameters investigated while fitting the model are listed below. The combination of hyper-parameters that ``r ifelse(maximize,'maximize','minimize') `` the ``r metric `` value in the training data via cross validation will be uses in the final model. A ``r search`` search is applied. ```{r, echo=FALSE, results='asis'} print( diff --git a/inst/protocol/study_protocol.qmd b/inst/protocol/study_protocol.qmd index 229654f..f493349 100644 --- a/inst/protocol/study_protocol.qmd +++ b/inst/protocol/study_protocol.qmd @@ -3,6 +3,7 @@ title: "Study Protocol" date: today date-format: short title-block-banner: true +number-sections: true format: html: toc: true From bf8338ed99fb575ca13440ac2d433dd602c3cd19 Mon Sep 17 00:00:00 2001 From: jreps Date: Wed, 19 Aug 2026 15:46:21 -0400 Subject: [PATCH 5/8] updates for new HADES --- DESCRIPTION | 4 +- NEWS.md | 6 ++ R/Characterization.R | 12 +++ R/CohortMethod.R | 2 +- R/Helpers.R | 3 +- R/PatientLevelPrediction.R | 2 +- R/generate.R | 13 +++- inst/protocol/study_protocol.qmd | 101 ++++++++++++++++++++++++- man/extractCohortMethodSettings.Rd | 4 +- man/generateProtocol.Rd | 11 ++- man/getConcepts.Rd | 2 +- man/reportTableFormat.Rd | 2 + tests/testthat/test-characterization.r | 6 ++ tests/testthat/test-generate.R | 28 ++++++- 14 files changed, 181 insertions(+), 15 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4d294cd..5bce193 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: ProtocolGenerator Type: Package Title: Generate HTML OHDSI study protocols -Version: 1.0.0 -Date: 2025-4-9 +Version: 1.0.1 +Date: 2026-8-19 Authors@R: c( person("Jenna", "Reps", email = "jreps@its.jnj.com", role = c("aut", "cre")) ) diff --git a/NEWS.md b/NEWS.md index 03f7004..13fc740 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,9 @@ +ProtocolGenerator v1.0.1 +====================== +- improved asthetics (adding heading color options and logo option) +- removed whitespace before table of content +- updated code to work for latest HADES specifcations + ProtocolGenerator v0.0.2 ====================== - updated code to work with Strategus 1.0.0 diff --git a/R/Characterization.R b/R/Characterization.R index 71639a6..cca2dc2 100644 --- a/R/Characterization.R +++ b/R/Characterization.R @@ -135,6 +135,12 @@ processRiskFactorSettings <- function( row.names(firstTs) <- NULL singleTargetSet <- all.equal(allTs, firstTs) + if(length(singleTargetSet) > 1){ + singleTargetSet <- FALSE + } + if(!is.logical(singleTargetSet)){ + singleTargetSet <- FALSE + } if(singleTargetSet){ # all outcomes by all targets @@ -247,6 +253,12 @@ processCaseSeriesSettings <- function( row.names(firstTs) <- NULL singleTargetSet <- all.equal(allTs, firstTs) + if(length(singleTargetSet) > 1){ + singleTargetSet <- FALSE + } + if(!is.logical(singleTargetSet)){ + singleTargetSet <- FALSE + } if(singleTargetSet){ # all outcomes by all targets diff --git a/R/CohortMethod.R b/R/CohortMethod.R index b9f5b12..e020923 100644 --- a/R/CohortMethod.R +++ b/R/CohortMethod.R @@ -6,7 +6,7 @@ #' @details #' Returns a names list with the cohorts #' -#' @param cohortMethodModuleSettings. The cohort method module specification +#' @param cohortMethodModuleSettings The cohort method module specification #' @param negativeControls NULL or a data.frame of the negative controls #' @param cohortDefinitionDf The data.frame with the cohort definition details #' diff --git a/R/Helpers.R b/R/Helpers.R index 65d469b..d1c9818 100644 --- a/R/Helpers.R +++ b/R/Helpers.R @@ -891,8 +891,9 @@ defaultColumns <- function(data){ #' @param table data.frame or tibble with the data to present #' @param groupBy column to group by (optional) #' @param columns The column details (create default using defaultColumns()) -#' @param caption A table caption #' @param elementId Element ID for the widget. +#' @param caption A table caption +#' @param groupByButton Whether to add a button that lets you group/ungroup rows in the table #' @return #' Details about all inputs into the functionName within R package of interest #' diff --git a/R/PatientLevelPrediction.R b/R/PatientLevelPrediction.R index be06f06..5950879 100644 --- a/R/PatientLevelPrediction.R +++ b/R/PatientLevelPrediction.R @@ -50,7 +50,7 @@ getPlpSettings <- function( # covariate set - get attr(,"fun") covSet <- c() for(cind in 1:length(modelDesignUnique)){ - if(class(modelDesignUnique[[cind]]$covariateSettings) == 'covariateSettings'){ + if(inherits(modelDesignUnique[[cind]]$covariateSettings, 'covariateSettings')){ modelDesignUnique[[cind]]$covariateSettings <- list(modelDesignUnique[[cind]]$covariateSettings) } diff --git a/R/generate.R b/R/generate.R index 0408700..05cf745 100644 --- a/R/generate.R +++ b/R/generate.R @@ -44,6 +44,9 @@ getDemoLoc <- function(){ #' @param conceptFolder The location to save the excel files if downloadConcepts is TRUE and conceptsAsExcel is TRUE #' @param addCohortDefinitions Whether to add the cohorts to the protocol (can make document large) #' @param exportCohortLocation if not NULL the location where the table tracter will be exported to csv. +#' @param headerColor The CSS color to use for the protocol header banner (optional) +#' @param headerLogoLocation The location of a logo image to add to the protocol header banner (optional) +#' @param protocolSubheading Optional subheading to show under the protocol title #' #' @return #' An named R list with the elements 'standard' and 'source' @@ -65,7 +68,10 @@ generateProtocol <- function( conceptsAsExcel = FALSE, conceptFolder = outputLocation, addCohortDefinitions = TRUE, - exportCohortLocation = NULL + exportCohortLocation = NULL, + headerColor = "#336B91", + headerLogoLocation = NULL, + protocolSubheading = NULL ){ if(missing(jsonLocation)){ @@ -133,7 +139,10 @@ generateProtocol <- function( addCohortDefinitions = addCohortDefinitions, conceptsAsExcel = conceptsAsExcel, conceptFolder = conceptFolder, - exportCohortLocation = exportCohortLocation + exportCohortLocation = exportCohortLocation, + headerColor = headerColor, + headerLogoLocation = if(!is.null(headerLogoLocation)) normalizePath(headerLogoLocation, mustWork = FALSE) else NULL, + protocolSubheading = protocolSubheading ) ) diff --git a/inst/protocol/study_protocol.qmd b/inst/protocol/study_protocol.qmd index f493349..3f2fd24 100644 --- a/inst/protocol/study_protocol.qmd +++ b/inst/protocol/study_protocol.qmd @@ -1,7 +1,5 @@ --- title: "Study Protocol" -date: today -date-format: short title-block-banner: true number-sections: true format: @@ -24,6 +22,9 @@ params: webApiUsername: NULL webApiPassword: NULL exportCohortLocation: NULL + headerColor: "#336B91" + headerLogoLocation: NULL + protocolSubheading: NULL --- ```{r cohort_extraction, echo=FALSE, hide = TRUE, include=FALSE} @@ -43,6 +44,102 @@ negativeControls <- ProtocolGenerator::getNegativeControlsFromJson(json) ``` +```{r protocol_header_style, echo=FALSE, results='asis'} +headerStyles <- c() +headerBackgroundImages <- c("linear-gradient(135deg, rgba(255, 255, 255, 0.18), rgba(0, 0, 0, 0.16))") +headerBackgroundRepeats <- c("no-repeat") +headerBackgroundPositions <- c("center") +headerBackgroundSizes <- c("cover") +headerColor <- params$headerColor +headerLogoLocation <- params$headerLogoLocation +protocolSubheading <- params$protocolSubheading +protocolDate <- paste0("PUBLISHED ", + as.integer(format(Sys.Date(), "%m")), "/", + as.integer(format(Sys.Date(), "%d")), "/", + format(Sys.Date(), "%y") +) + +if (!is.null(headerColor) && nzchar(headerColor)) { + if (grepl("^[#A-Za-z0-9(),.%[:space:]-]+$", headerColor) && !grepl("[;{}<>]", headerColor)) { + headerStyles <- c(headerStyles, sprintf("background-color: %s !important;", headerColor)) + } else { + warning("Ignoring headerColor because it is not a valid CSS color value.") + } +} + +if (!is.null(headerLogoLocation) && nzchar(headerLogoLocation)) { + if (file.exists(headerLogoLocation)) { + logoUri <- knitr::image_uri(headerLogoLocation) + headerBackgroundImages <- c(sprintf('url("%s")', logoUri), headerBackgroundImages) + headerBackgroundRepeats <- c("no-repeat", headerBackgroundRepeats) + headerBackgroundPositions <- c("right 2rem center", headerBackgroundPositions) + headerBackgroundSizes <- c("auto min(5rem, 70%)", headerBackgroundSizes) + headerStyles <- c(headerStyles, "padding-right: 10rem;") + } else { + warning(sprintf("Ignoring headerLogoLocation because the file does not exist: %s", headerLogoLocation)) + } +} + +headerStyles <- c( + headerStyles, + sprintf("background-image: %s;", paste(headerBackgroundImages, collapse = ", ")), + sprintf("background-repeat: %s;", paste(headerBackgroundRepeats, collapse = ", ")), + sprintf("background-position: %s;", paste(headerBackgroundPositions, collapse = ", ")), + sprintf("background-size: %s;", paste(headerBackgroundSizes, collapse = ", ")), + "padding-top: 2.4rem;", + "padding-bottom: 2.4rem;", + "border-bottom: 4px solid rgba(255, 255, 255, 0.26);", + "box-shadow: 0 0.65rem 1.75rem rgba(24, 45, 63, 0.18);" +) + +titleDetails <- c() +if (!is.null(protocolSubheading) && nzchar(protocolSubheading)) { + titleDetails <- c(titleDetails, as.character(protocolSubheading)) +} +titleDetails <- c(titleDetails, protocolDate) +titleDetailsScript <- sprintf( + paste0( + "" + ), + jsonlite::toJSON(titleDetails, auto_unbox = FALSE) +) + +if (length(headerStyles) > 0) { + cat( + "", + sep = "\n" + ) + cat(titleDetailsScript, sep = "\n") +} +``` + # ABREVIATIONS ```{r echo=FALSE} diff --git a/man/extractCohortMethodSettings.Rd b/man/extractCohortMethodSettings.Rd index 02e4a76..37d6492 100644 --- a/man/extractCohortMethodSettings.Rd +++ b/man/extractCohortMethodSettings.Rd @@ -11,11 +11,11 @@ extractCohortMethodSettings( ) } \arguments{ +\item{cohortMethodModuleSettings}{The cohort method module specification} + \item{negativeControls}{NULL or a data.frame of the negative controls} \item{cohortDefinitionDf}{The data.frame with the cohort definition details} - -\item{cohortMethodModuleSettings.}{The cohort method module specification} } \value{ An named R list with ... diff --git a/man/generateProtocol.Rd b/man/generateProtocol.Rd index 8ec82e7..819c667 100644 --- a/man/generateProtocol.Rd +++ b/man/generateProtocol.Rd @@ -20,7 +20,10 @@ generateProtocol( conceptsAsExcel = FALSE, conceptFolder = outputLocation, addCohortDefinitions = TRUE, - exportCohortLocation = NULL + exportCohortLocation = NULL, + headerColor = "#336B91", + headerLogoLocation = NULL, + protocolSubheading = NULL ) } \arguments{ @@ -53,6 +56,12 @@ generateProtocol( \item{addCohortDefinitions}{Whether to add the cohorts to the protocol (can make document large)} \item{exportCohortLocation}{if not NULL the location where the table tracter will be exported to csv.} + +\item{headerColor}{The CSS color to use for the protocol header banner (optional)} + +\item{headerLogoLocation}{The location of a logo image to add to the protocol header banner (optional)} + +\item{protocolSubheading}{Optional subheading to show under the protocol title} } \value{ An named R list with the elements 'standard' and 'source' diff --git a/man/getConcepts.Rd b/man/getConcepts.Rd index 3aa767a..35f8429 100644 --- a/man/getConcepts.Rd +++ b/man/getConcepts.Rd @@ -5,7 +5,7 @@ \title{getConcepts} \usage{ getConcepts( - expression, + expression = NULL, conceptIds = NULL, baseUrl = "https://api.ohdsi.org/WebAPI" ) diff --git a/man/reportTableFormat.Rd b/man/reportTableFormat.Rd index f4af07d..e261e98 100644 --- a/man/reportTableFormat.Rd +++ b/man/reportTableFormat.Rd @@ -23,6 +23,8 @@ reportTableFormat( \item{elementId}{Element ID for the widget.} \item{caption}{A table caption} + +\item{groupByButton}{Whether to add a button that lets you group/ungroup rows in the table} } \value{ Details about all inputs into the functionName within R package of interest diff --git a/tests/testthat/test-characterization.r b/tests/testthat/test-characterization.r index 8db00ac..ffa88bd 100644 --- a/tests/testthat/test-characterization.r +++ b/tests/testthat/test-characterization.r @@ -296,3 +296,9 @@ test_that("characterizationColDef returns expected reactable column definitions" testthat::expect_s3_class(result$tar, "colDef") testthat::expect_s3_class(result$setting, "colDef") }) + + + +# add tests for TTE/Dechal + +# add tests for v4 Char RF/CS diff --git a/tests/testthat/test-generate.R b/tests/testthat/test-generate.R index 40565a7..9a369f7 100644 --- a/tests/testthat/test-generate.R +++ b/tests/testthat/test-generate.R @@ -9,11 +9,35 @@ test_that("generateProtocol", { jsonLocation = getDemoLoc(), webAPI = 'https://api.ohdsi.org/WebAPI', outputLocation = './protocol', - downloadConcepts = FALSE + downloadConcepts = FALSE, + headerLogoLocation = file.path(R.home('doc'), 'html', 'logo.jpg') ) testthat::expect_true(dir.exists('./protocol')) - # TODO check html file generates: + testthat::expect_true(file.exists(test)) + protocolHtml <- paste(readLines(test, warn = FALSE), collapse = "\n") + testthat::expect_match(protocolHtml, "background-color: #336B91 !important;", fixed = TRUE) + testthat::expect_match(protocolHtml, ".quarto-title-block .quarto-title-meta { display: none !important; }", fixed = TRUE) + testthat::expect_match(protocolHtml, "protocol-title-date", fixed = TRUE) + testthat::expect_match(protocolHtml, "body.quarto-light { margin-left: 0; }", fixed = TRUE) + testthat::expect_match(protocolHtml, "#quarto-content.toc-left { margin-left: 0; padding-left: 0; }", fixed = TRUE) + testthat::expect_match(protocolHtml, "#quarto-sidebar-toc-left { grid-column: screen-start / body-start; background-color: #f4f5f6; border-right: 1px solid #d9dee3; margin-left: 0; padding-left: 0; }", fixed = TRUE) + testthat::expect_match(protocolHtml, "#quarto-sidebar-toc-left #TOC { margin-left: 0; padding: 1rem 1.1rem; }", fixed = TRUE) + testthat::expect_match(protocolHtml, "data:image/jpeg;base64,", fixed = TRUE) + testthat::expect_false(grepl("Human readable study specification", protocolHtml, fixed = TRUE)) + + testWithSubheading <- generateProtocol( + jsonLocation = getDemoLoc(), + webAPI = 'https://api.ohdsi.org/WebAPI', + outputLocation = './protocol', + outputName = basename(tempfile(pattern = 'protocol_subheading_test_', fileext = '.html')), + downloadConcepts = FALSE, + protocolSubheading = "Human readable study specification" + ) + + protocolHtmlWithSubheading <- paste(readLines(testWithSubheading, warn = FALSE), collapse = "\n") + testthat::expect_match(protocolHtmlWithSubheading, "Human readable study specification", fixed = TRUE) + testthat::expect_match(protocolHtmlWithSubheading, "protocol-title-subheading", fixed = TRUE) }) From f13d7eb4527debafbe8d63848c03e8005b76fae8 Mon Sep 17 00:00:00 2001 From: jreps Date: Thu, 20 Aug 2026 10:06:57 -0400 Subject: [PATCH 6/8] preparing for release - adding github actions - adding website - fixing documentation - adding more github badges --- .github/workflows/R_CMD_check_Hades.yaml | 215 ++++++++++++++++++ .../workflows/R_CMD_check_main_weekly.yaml | 67 ++++++ .github/workflows/pkgdown.yaml | 51 +++++ R/CohortDiagnostics.R | 2 + R/CohortIncidence.R | 6 +- R/CohortMethod.R | 3 + R/Helpers.R | 13 ++ R/PatientLevelPrediction.R | 2 + R/ProtocolGenerator.R | 1 + R/SelfControlCaseSeries.R | 2 + R/generate.R | 2 + README.md | 13 +- _pkgdown.yml | 61 +++++ man/ProtocolGenerator.Rd | 1 + man/cmColDef.Rd | 10 + man/cmOutcomeColDef.Rd | 10 + man/createStratSentance.Rd | 10 + man/defaultColumns.Rd | 10 + man/extractCohortMethodSettings.Rd | 10 + man/formatCovariateSettings.Rd | 16 ++ man/functionDefaults.Rd | 16 ++ man/generateProtocol.Rd | 1 + man/getAllHelpDetails.Rd | 16 ++ man/getAllHelpText.Rd | 16 ++ man/getCIcolumns.Rd | 10 + man/getCdCols.Rd | 10 + man/getCiTargetsOutcomes.Rd | 10 + man/getCohortDefinitionsFromJson.Rd | 16 ++ man/getCohortDiagnosticTables.Rd | 10 + man/getConcepts.Rd | 16 ++ man/getCountStatement.Rd | 10 + man/getDemoLoc.Rd | 16 ++ man/getFunctionFromArgName.Rd | 16 ++ man/getHelpText.Rd | 16 ++ man/getNegativeControlsFromJson.Rd | 16 ++ man/getPlpColDefs.Rd | 10 + man/getPlpSettings.Rd | 10 + man/getSccsColDefs.Rd | 10 + man/getSccsSettings.Rd | 10 + man/getSettingsTable.Rd | 16 ++ man/reportTableFormat.Rd | 16 ++ man/tagPrint.Rd | 16 ++ vignettes/ProtocolGenerator.Rmd | 26 ++- 43 files changed, 809 insertions(+), 5 deletions(-) create mode 100644 .github/workflows/R_CMD_check_Hades.yaml create mode 100644 .github/workflows/R_CMD_check_main_weekly.yaml create mode 100644 .github/workflows/pkgdown.yaml create mode 100644 _pkgdown.yml diff --git a/.github/workflows/R_CMD_check_Hades.yaml b/.github/workflows/R_CMD_check_Hades.yaml new file mode 100644 index 0000000..ea828f0 --- /dev/null +++ b/.github/workflows/R_CMD_check_Hades.yaml @@ -0,0 +1,215 @@ +# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag. +# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions +on: + push: + branches: + - '**' + pull_request: + branches: + - '**' + +name: R-CMD-check + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: windows-latest, r: 'release'} + - {os: macOS-latest, r: 'release'} + - {os: ubuntu-22.04, r: 'release', rtools: ''} + + env: + GITHUB_PAT: ${{ secrets.GH_TOKEN }} + CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} + R_REMOTES_NO_ERRORS_FROM_WARNINGS: true + RSPM: ${{ matrix.config.rspm }} + CDM5_ORACLE_CDM_SCHEMA: ${{ secrets.CDM5_ORACLE_CDM_SCHEMA }} + CDM5_ORACLE_OHDSI_SCHEMA: ${{ secrets.CDM5_ORACLE_OHDSI_SCHEMA }} + CDM5_ORACLE_PASSWORD: ${{ secrets.CDM5_ORACLE_PASSWORD }} + CDM5_ORACLE_SERVER: ${{ secrets.CDM5_ORACLE_SERVER }} + CDM5_ORACLE_USER: ${{ secrets.CDM5_ORACLE_USER }} + CDM5_POSTGRESQL_CDM_SCHEMA: ${{ secrets.CDM5_POSTGRESQL_CDM_SCHEMA }} + CDM5_POSTGRESQL_OHDSI_SCHEMA: ${{ secrets.CDM5_POSTGRESQL_OHDSI_SCHEMA }} + CDM5_POSTGRESQL_PASSWORD: ${{ secrets.CDM5_POSTGRESQL_PASSWORD }} + CDM5_POSTGRESQL_SERVER: ${{ secrets.CDM5_POSTGRESQL_SERVER }} + CDM5_POSTGRESQL_USER: ${{ secrets.CDM5_POSTGRESQL_USER }} + CDM5_SQL_SERVER_CDM_SCHEMA: ${{ secrets.CDM5_SQL_SERVER_CDM_SCHEMA }} + CDM5_SQL_SERVER_OHDSI_SCHEMA: ${{ secrets.CDM5_SQL_SERVER_OHDSI_SCHEMA }} + CDM5_SQL_SERVER_PASSWORD: ${{ secrets.CDM5_SQL_SERVER_PASSWORD }} + CDM5_SQL_SERVER_SERVER: ${{ secrets.CDM5_SQL_SERVER_SERVER }} + CDM5_SQL_SERVER_USER: ${{ secrets.CDM5_SQL_SERVER_USER }} + CDM5_REDSHIFT_CDM_SCHEMA: ${{ secrets.CDM5_REDSHIFT_CDM_SCHEMA }} + CDM5_REDSHIFT_OHDSI_SCHEMA: ${{ secrets.CDM5_REDSHIFT_OHDSI_SCHEMA }} + CDM5_REDSHIFT_PASSWORD: ${{ secrets.CDM5_REDSHIFT_PASSWORD }} + CDM5_REDSHIFT_SERVER: ${{ secrets.CDM5_REDSHIFT_SERVER }} + CDM5_REDSHIFT_USER: ${{ secrets.CDM5_REDSHIFT_USER }} + CDM_SNOWFLAKE_CDM53_SCHEMA: ${{ secrets.CDM_SNOWFLAKE_CDM53_SCHEMA }} + CDM_SNOWFLAKE_OHDSI_SCHEMA: ${{ secrets.CDM_SNOWFLAKE_OHDSI_SCHEMA }} + CDM_SNOWFLAKE_PASSWORD: ${{ secrets.CDM_SNOWFLAKE_PASSWORD }} + CDM_SNOWFLAKE_CONNECTION_STRING: ${{ secrets.CDM_SNOWFLAKE_CONNECTION_STRING }} + CDM_SNOWFLAKE_USER: ${{ secrets.CDM_SNOWFLAKE_USER }} + CDM5_SPARK_USER: ${{ secrets.CDM5_SPARK_USER }} + CDM5_SPARK_PASSWORD: ${{ secrets.CDM5_SPARK_PASSWORD }} + CDM5_SPARK_CONNECTION_STRING: ${{ secrets.CDM5_SPARK_CONNECTION_STRING }} + CDM5_SPARK_CDM_SCHEMA: ${{ secrets.CDM5_SPARK_CDM_SCHEMA }} + CDM5_SPARK_OHDSI_SCHEMA: ${{ secrets.CDM5_SPARK_OHDSI_SCHEMA }} + CDM_BIG_QUERY_CONNECTION_STRING: ${{ secrets.CDM_BIG_QUERY_CONNECTION_STRING }} + CDM_BIG_QUERY_KEY_FILE: ${{ secrets.CDM_BIG_QUERY_KEY_FILE }} + CDM_BIG_QUERY_CDM_SCHEMA: ${{ secrets.CDM_BIG_QUERY_CDM_SCHEMA }} + CDM_BIG_QUERY_OHDSI_SCHEMA: ${{ secrets.CDM_BIG_QUERY_OHDSI_SCHEMA }} + + steps: + - uses: actions/checkout@v4 + + - name: Setup Java non Linux + if: runner.os != 'Linux' + uses: actions/setup-java@v4 + with: + distribution: 'corretto' + java-version: '8' + + - name: Setup Java Linux + if: runner.os == 'Linux' + uses: actions/setup-java@v4 + with: + distribution: 'temurin' + java-version: '11' + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + + - uses: r-lib/actions/setup-tinytex@v2 + + - uses: r-lib/actions/setup-pandoc@v2 + + - name: Install system requirements + if: runner.os == 'Linux' + run: | + sudo apt-get install -y libssh-dev + sudo R CMD javareconf + Rscript -e 'install.packages("remotes")' + while read -r cmd + do + eval sudo $cmd + done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "22.04"))') + + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck + needs: check + + - uses: r-lib/actions/check-r-package@v2 + with: + args: 'c("--no-manual", "--as-cran")' + error-on: '"warning"' + check-dir: '"check"' + + - name: Upload source package + if: success() && runner.os == 'macOS' && github.event_name != 'pull_request' && github.ref == 'refs/heads/main' + uses: actions/upload-artifact@v4 + with: + name: package_tarball + path: check/*.tar.gz + + - name: Install covr + if: runner.os == 'Linux' + run: | + remotes::install_cran("covr") + remotes::install_cran("xml2") + shell: Rscript {0} + + - name: Test coverage + if: runner.os == 'Linux' + run: | + cov <- covr::package_coverage( + quiet = FALSE, + clean = FALSE, + install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") + ) + covr::to_cobertura(cov) + shell: Rscript {0} + + - uses: codecov/codecov-action@v4 + if: runner.os == 'Linux' + with: + file: ./cobertura.xml + plugin: noop + disable_search: true + token: ${{ secrets.CODECOV_TOKEN }} + + Release: + needs: R-CMD-Check + + runs-on: macOS-latest + + env: + GH_TOKEN: ${{ secrets.GH_TOKEN }} + + if: ${{ github.event_name != 'pull_request' && github.ref == 'refs/heads/main' }} + + steps: + + - uses: actions/checkout@v3 + with: + fetch-depth: 0 + + - name: Check if version has increased + run: | + echo "new_version="$(perl compare_versions --tag) >> $GITHUB_ENV + + - name: Display new version number + if: ${{ env.new_version != '' }} + run: | + echo "${{ env.new_version }}" + + - name: Create release + if: ${{ env.new_version != '' }} + uses: actions/create-release@v1 + env: + GITHUB_TOKEN: ${{ secrets.GH_TOKEN }} + with: + tag_name: ${{ env.new_version }} + release_name: Release ${{ env.new_version }} + body: | + See NEWS.md for release notes. + draft: false + prerelease: false + + - uses: r-lib/actions/setup-r@v2 + if: ${{ env.new_version != '' }} + + - name: Install drat + if: ${{ env.new_version != '' }} + run: | + install.packages('drat') + shell: Rscript {0} + + - name: Remove any tarballs that already exists + if: ${{ env.new_version != '' }} + run: | + rm -f *.tar.gz + + - name: Download package tarball + if: ${{ env.new_version != '' }} + uses: actions/download-artifact@v4 + with: + name: package_tarball + + - name: Push to drat + if: ${{ env.new_version != '' }} + run: | + bash deploy.sh + + - name: Push to BroadSea + if: ${{ env.new_version != '' }} + run: | + curl --data "build=true" -X POST https://registry.hub.docker.com/u/ohdsi/broadsea-methodslibrary/trigger/f0b51cec-4027-4781-9383-4b38b42dd4f5/ + diff --git a/.github/workflows/R_CMD_check_main_weekly.yaml b/.github/workflows/R_CMD_check_main_weekly.yaml new file mode 100644 index 0000000..099df33 --- /dev/null +++ b/.github/workflows/R_CMD_check_main_weekly.yaml @@ -0,0 +1,67 @@ +on: + schedule: + - cron: '0 14 * * 0' # every Sunday at 2pm UTC + +name: 'R check' + +jobs: + R-CMD-check-main: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: macOS-latest, r: 'release'} + + env: + GITHUB_PAT: ${{ secrets.GH_TOKEN }} + R_REMOTES_NO_ERRORS_FROM_WARNINGS: true + RSPM: ${{ matrix.config.rspm }} + CDM5_ORACLE_CDM_SCHEMA: ${{ secrets.CDM5_ORACLE_CDM_SCHEMA }} + CDM5_ORACLE_OHDSI_SCHEMA: ${{ secrets.CDM5_ORACLE_OHDSI_SCHEMA }} + CDM5_ORACLE_PASSWORD: ${{ secrets.CDM5_ORACLE_PASSWORD }} + CDM5_ORACLE_SERVER: ${{ secrets.CDM5_ORACLE_SERVER }} + CDM5_ORACLE_USER: ${{ secrets.CDM5_ORACLE_USER }} + CDM5_POSTGRESQL_CDM_SCHEMA: ${{ secrets.CDM5_POSTGRESQL_CDM_SCHEMA }} + CDM5_POSTGRESQL_OHDSI_SCHEMA: ${{ secrets.CDM5_POSTGRESQL_OHDSI_SCHEMA }} + CDM5_POSTGRESQL_PASSWORD: ${{ secrets.CDM5_POSTGRESQL_PASSWORD }} + CDM5_POSTGRESQL_SERVER: ${{ secrets.CDM5_POSTGRESQL_SERVER }} + CDM5_POSTGRESQL_USER: ${{ secrets.CDM5_POSTGRESQL_USER }} + CDM5_SQL_SERVER_CDM_SCHEMA: ${{ secrets.CDM5_SQL_SERVER_CDM_SCHEMA }} + CDM5_SQL_SERVER_OHDSI_SCHEMA: ${{ secrets.CDM5_SQL_SERVER_OHDSI_SCHEMA }} + CDM5_SQL_SERVER_PASSWORD: ${{ secrets.CDM5_SQL_SERVER_PASSWORD }} + CDM5_SQL_SERVER_SERVER: ${{ secrets.CDM5_SQL_SERVER_SERVER }} + CDM5_SQL_SERVER_USER: ${{ secrets.CDM5_SQL_SERVER_USER }} + CDM5_REDSHIFT_CDM_SCHEMA: ${{ secrets.CDM5_REDSHIFT_CDM_SCHEMA }} + CDM5_REDSHIFT_OHDSI_SCHEMA: ${{ secrets.CDM5_REDSHIFT_OHDSI_SCHEMA }} + CDM5_REDSHIFT_PASSWORD: ${{ secrets.CDM5_REDSHIFT_PASSWORD }} + CDM5_REDSHIFT_SERVER: ${{ secrets.CDM5_REDSHIFT_SERVER }} + CDM5_REDSHIFT_USER: ${{ secrets.CDM5_REDSHIFT_USER }} + CDM5_SPARK_USER: ${{ secrets.CDM5_SPARK_USER }} + CDM5_SPARK_PASSWORD: ${{ secrets.CDM5_SPARK_PASSWORD }} + CDM5_SPARK_CONNECTION_STRING: ${{ secrets.CDM5_SPARK_CONNECTION_STRING }} + + steps: + - uses: actions/checkout@v3 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + + - uses: r-lib/actions/setup-tinytex@v2 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck + needs: check + + - uses: r-lib/actions/check-r-package@v2 + with: + args: 'c("--no-manual", "--as-cran")' + error-on: '"warning"' + check-dir: '"check"' diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml new file mode 100644 index 0000000..1f7e4f6 --- /dev/null +++ b/.github/workflows/pkgdown.yaml @@ -0,0 +1,51 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, develop] + release: + types: [published] + workflow_dispatch: + +name: pkgdown + +jobs: + pkgdown: + runs-on: ubuntu-latest + # Only restrict concurrency for non-PR jobs + concurrency: + group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + cache: always + extra-packages: any::pkgdown, ohdsi/OhdsiRTools + needs: website + + - uses: lycheeverse/lychee-action@v2 + with: + args: --root-dir "${{ github.workspace }}" --verbose --no-progress --accept '100..=103, 200..=299, 403, 429' './**/*.md' './**/*.Rmd' + + - name: Build site + run: Rscript -e 'pkgdown::build_site_github_pages(new_process = FALSE, install = TRUE)' + + - name: Fix Hades Logo + run: Rscript -e 'OhdsiRTools::fixHadesLogo()' + + - name: Deploy to GitHub pages 🚀 + if: github.event_name != 'pull_request' + uses: JamesIves/github-pages-deploy-action@v4 + with: + clean: false + branch: gh-pages + folder: docs diff --git a/R/CohortDiagnostics.R b/R/CohortDiagnostics.R index 2e7ea1f..d77a962 100644 --- a/R/CohortDiagnostics.R +++ b/R/CohortDiagnostics.R @@ -12,6 +12,7 @@ #' @return #' A list with the tables to display #' +#' @family Extraction #' @export #' getCohortDiagnosticTables <- function( @@ -76,6 +77,7 @@ getCohortDiagnosticTables <- function( #' @return #' A list of colDefs for cohort diagnostic #' +#' @family ColDefs #' @export #' getCdCols <- function(){ diff --git a/R/CohortIncidence.R b/R/CohortIncidence.R index c3ede69..fb9fa09 100644 --- a/R/CohortIncidence.R +++ b/R/CohortIncidence.R @@ -11,7 +11,8 @@ #' #' @return #' An string with the count information -#' +#' +#' @family Extraction #' @export #' getCountStatement <- function( @@ -84,6 +85,7 @@ getCountStatement <- function( #' @return #' An string with the stratification information #' +#' @family Extraction #' @export #' createStratSentance <- function(CohortIncidenceModuleSettings){ @@ -113,6 +115,7 @@ createStratSentance <- function(CohortIncidenceModuleSettings){ #' @return #' A list with the tables to present in the protocol #' +#' @family Extraction #' @export #' getCiTargetsOutcomes <- function( @@ -198,6 +201,7 @@ getCiTarString <- function(tarDefs, tarId){ #' @return #' A list of colDefs for the target and outcome tables describing the cohort incidence analysis #' +#' @family ColDefs #' @export #' getCIcolumns <- function(){ diff --git a/R/CohortMethod.R b/R/CohortMethod.R index e020923..707a1fa 100644 --- a/R/CohortMethod.R +++ b/R/CohortMethod.R @@ -13,6 +13,7 @@ #' @return #' An named R list with ... #' +#' @family Extraction #' @export #' extractCohortMethodSettings <- function( @@ -291,6 +292,7 @@ return( #' @return #' A column definition list #' +#' @family ColDefs #' @export #' cmColDef <- function( @@ -415,6 +417,7 @@ cmColDef <- function( #' @return #' A column definition list #' +#' @family ColDefs #' @export #' #' diff --git a/R/Helpers.R b/R/Helpers.R index d1c9818..7fd9d45 100644 --- a/R/Helpers.R +++ b/R/Helpers.R @@ -27,6 +27,7 @@ #' @return #' Nothing just prints the object in quarto #' +#' @family Helpers #' @export #' tagPrint <- function(x){ @@ -45,6 +46,7 @@ tagPrint <- function(x){ #' @return #' An named R list with the elements subsetUnique (list of subset operators), cohortDefinitions (list of cohortDefinitions) and cohortDefinitionDf (data.frame of cohort definitions) #' +#' @family Helpers #' @export #' getCohortDefinitionsFromJson <- function( @@ -268,6 +270,7 @@ getCohortDefinitionsFromJson <- function( #' @return #' An named R list with the elements 'standard' and 'source' #' +#' @family Helpers #' @export #' getConcepts <- function( @@ -366,6 +369,7 @@ getConcepts <- function( #' @return #' A data.frame with the negative control details or NULL if no negative controls #' +#' @family Helpers #' @export #' getNegativeControlsFromJson <- function(json){ @@ -406,6 +410,7 @@ getNegativeControlsFromJson <- function(json){ #' @return #' the name of the input the setting arg corresponds to #' +#' @family Helpers #' @export #' getFunctionFromArgName <- function( @@ -437,6 +442,7 @@ getFunctionFromArgName <- function( #' @return #' Details about the input #' +#' @family Helpers #' @export #' getHelpText <- function( @@ -495,6 +501,7 @@ getHelpText <- function( #' @return #' Details about all inputs into the functionName within R package of interest #' +#' @family Helpers #' @export #' getAllHelpText <- function( @@ -556,6 +563,7 @@ getExtraCyclopsHelp <- function(){ #' @return #' Details about all default inputs into the functionName within R package of interest #' +#' @family Helpers #' @export #' functionDefaults <- function( @@ -711,6 +719,7 @@ listToDf <- function( #' @return #' Details about all inputs into the functionName within R package of interest #' +#' @family Helpers #' @export #' getAllHelpDetails <- function( @@ -796,6 +805,7 @@ getAllHelpDetails <- function( #' @return #' Returns a tibble with the input details #' +#' @family Helpers #' @export #' getSettingsTable <- function( @@ -852,6 +862,7 @@ getSettingsTable <- function( #' @return #' Returns a reactable colunn definition #' +#' @family ColDefs #' @export #' defaultColumns <- function(data){ @@ -897,6 +908,7 @@ defaultColumns <- function(data){ #' @return #' Details about all inputs into the functionName within R package of interest #' +#' @family Helpers #' @export #' reportTableFormat <- function( @@ -969,6 +981,7 @@ reportTableFormat <- function( #' @return #' a data.frame with the covariate settings #' +#' @family Helpers #' @export #' formatCovariateSettings <- function( diff --git a/R/PatientLevelPrediction.R b/R/PatientLevelPrediction.R index 5950879..4dac4e6 100644 --- a/R/PatientLevelPrediction.R +++ b/R/PatientLevelPrediction.R @@ -12,6 +12,7 @@ #' @return #' An named R list with ... #' +#' @family Extraction #' @export #' getPlpSettings <- function( @@ -108,6 +109,7 @@ getPlpSettings <- function( #' @return #' A column definition list #' +#' @family ColDefs #' @export #' getPlpColDefs <- function(){ diff --git a/R/ProtocolGenerator.R b/R/ProtocolGenerator.R index c80f294..a5de026 100644 --- a/R/ProtocolGenerator.R +++ b/R/ProtocolGenerator.R @@ -20,6 +20,7 @@ #' #' _PACKAGE #' @name ProtocolGenerator +#' @keywords internal #' @importFrom dplyr %>% #' @importFrom rlang .data NULL \ No newline at end of file diff --git a/R/SelfControlCaseSeries.R b/R/SelfControlCaseSeries.R index 0912b07..e1bfb5d 100644 --- a/R/SelfControlCaseSeries.R +++ b/R/SelfControlCaseSeries.R @@ -13,6 +13,7 @@ #' @return #' A list with the tables to display #' +#' @family Extraction #' @export #' getSccsSettings <- function( @@ -188,6 +189,7 @@ getSccsSettings <- function( #' @return #' A column definition list #' +#' @family ColDefs #' @export #' getSccsColDefs <- function(){ diff --git a/R/generate.R b/R/generate.R index 05cf745..91985ce 100644 --- a/R/generate.R +++ b/R/generate.R @@ -9,6 +9,7 @@ #' @return #' A file path location to an example specification json #' +#' @family Helpers #' @export #' getDemoLoc <- function(){ @@ -51,6 +52,7 @@ getDemoLoc <- function(){ #' @return #' An named R list with the elements 'standard' and 'source' #' +#' @family Generate #' @export #' generateProtocol <- function( diff --git a/README.md b/README.md index 2620a1d..abd51f3 100644 --- a/README.md +++ b/README.md @@ -1,8 +1,15 @@ ProtocolGenerator =============== -[![Build Status](https://github.com/OHDSI/ProtocolGenerator/workflows/R-CMD-check/badge.svg)](https://github.com/OHDSI/ProtocolGenerator/actions?query=workflow%3AR-CMD-check) -[![codecov.io](https://codecov.io/github/OHDSI/ProtocolGenerator/coverage.svg?branch=main)](https://codecov.io/github/OHDSI/ProtocolGenerator?branch=main) +[![R-CMD-check](https://github.com/OHDSI/ProtocolGenerator/actions/workflows/R_CMD_check_Hades.yaml/badge.svg)](https://github.com/OHDSI/ProtocolGenerator/actions/workflows/R_CMD_check_Hades.yaml) +[![pkgdown](https://github.com/OHDSI/ProtocolGenerator/actions/workflows/pkgdown.yaml/badge.svg)](https://github.com/OHDSI/ProtocolGenerator/actions/workflows/pkgdown.yaml) +[![codecov](https://codecov.io/github/OHDSI/ProtocolGenerator/branch/main/graph/badge.svg)](https://app.codecov.io/github/OHDSI/ProtocolGenerator?branch=main) +[![GitHub R package version](https://img.shields.io/github/r-package/v/OHDSI/ProtocolGenerator)](https://github.com/OHDSI/ProtocolGenerator/blob/main/DESCRIPTION) +[![R version](https://img.shields.io/badge/R-%3E%3D%203.3.0-276DC3)](https://www.r-project.org/) +[![License: Apache 2.0](https://img.shields.io/badge/license-Apache%202.0-blue.svg)](https://www.apache.org/licenses/LICENSE-2.0) +[![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental) +[![GitHub issues](https://img.shields.io/github/issues/OHDSI/ProtocolGenerator)](https://github.com/OHDSI/ProtocolGenerator/issues) +[![Last commit](https://img.shields.io/github/last-commit/OHDSI/ProtocolGenerator)](https://github.com/OHDSI/ProtocolGenerator/commits/main) Introduction @@ -14,7 +21,7 @@ Examples ======== -```{r} +```r # install dependencies remotes::install_github('ohdsi/ProtocolGenerator') diff --git a/_pkgdown.yml b/_pkgdown.yml new file mode 100644 index 0000000..29a9c4c --- /dev/null +++ b/_pkgdown.yml @@ -0,0 +1,61 @@ +template: + bootstrap: 5 + params: + bootswatch: cosmo + light-switch: false + +development: + mode: auto + development: docs/dev + +home: + links: + - text: Ask a question + href: http://forums.ohdsi.org + +navbar: + structure: + left: [home, reference, articles, news] + right: [hades, github] + components: + home: + icon: fa-home fa-lg + href: index.html + articles: + icon: fa-book fa-lg + text: Articles + menu: + - text: Demo + href: articles/ProtocolGenerator.html + reference: + icon: fa-info-circle fa-lg + text: Reference + href: reference/index.html + news: + icon: fa-newspaper-o fa-lg + text: Changelog + href: news/index.html + github: + icon: fa-github fa-lg + href: https://github.com/OHDSI/ProtocolGenerator + hades: + text: hadesLogo + href: https://ohdsi.github.io/Hades + +reference: + - title: "Extraction function" + desc: > + These functions extract details for the report from the json object + contents: has_concept("Extraction") + - title: "Helpers" + desc: > + Helpers with various functionalities. + contents: has_concept("Helpers") + - title: "ColDefs" + desc: > + Column definitions. + contents: has_concept("ColDefs") + - title: "Generate Protocol" + desc: > + Functions for generating protocols. + contents: has_concept("Generate") diff --git a/man/ProtocolGenerator.Rd b/man/ProtocolGenerator.Rd index 92b46da..df02a9a 100644 --- a/man/ProtocolGenerator.Rd +++ b/man/ProtocolGenerator.Rd @@ -8,3 +8,4 @@ A package for creating protocols from json specification _PACKAGE } +\keyword{internal} diff --git a/man/cmColDef.Rd b/man/cmColDef.Rd index 39ba1e5..d97454f 100644 --- a/man/cmColDef.Rd +++ b/man/cmColDef.Rd @@ -20,3 +20,13 @@ Extract cohorts from json \details{ Returns a names list with the cohorts } +\seealso{ +Other ColDefs: +\code{\link[=cmOutcomeColDef]{cmOutcomeColDef()}}, +\code{\link[=defaultColumns]{defaultColumns()}}, +\code{\link[=getCIcolumns]{getCIcolumns()}}, +\code{\link[=getCdCols]{getCdCols()}}, +\code{\link[=getPlpColDefs]{getPlpColDefs()}}, +\code{\link[=getSccsColDefs]{getSccsColDefs()}} +} +\concept{ColDefs} diff --git a/man/cmOutcomeColDef.Rd b/man/cmOutcomeColDef.Rd index 29ebc03..ad486bf 100644 --- a/man/cmOutcomeColDef.Rd +++ b/man/cmOutcomeColDef.Rd @@ -18,3 +18,13 @@ List with column names for the cohort method outcome table \details{ Returns a names list with the cohorts names } +\seealso{ +Other ColDefs: +\code{\link[=cmColDef]{cmColDef()}}, +\code{\link[=defaultColumns]{defaultColumns()}}, +\code{\link[=getCIcolumns]{getCIcolumns()}}, +\code{\link[=getCdCols]{getCdCols()}}, +\code{\link[=getPlpColDefs]{getPlpColDefs()}}, +\code{\link[=getSccsColDefs]{getSccsColDefs()}} +} +\concept{ColDefs} diff --git a/man/createStratSentance.Rd b/man/createStratSentance.Rd index 2384748..7b15f6c 100644 --- a/man/createStratSentance.Rd +++ b/man/createStratSentance.Rd @@ -18,3 +18,13 @@ Create a sentence that explains the stratification defined in the analysis. \details{ Returns a string } +\seealso{ +Other Extraction: +\code{\link[=extractCohortMethodSettings]{extractCohortMethodSettings()}}, +\code{\link[=getCiTargetsOutcomes]{getCiTargetsOutcomes()}}, +\code{\link[=getCohortDiagnosticTables]{getCohortDiagnosticTables()}}, +\code{\link[=getCountStatement]{getCountStatement()}}, +\code{\link[=getPlpSettings]{getPlpSettings()}}, +\code{\link[=getSccsSettings]{getSccsSettings()}} +} +\concept{Extraction} diff --git a/man/defaultColumns.Rd b/man/defaultColumns.Rd index 3b36dc3..48a18fa 100644 --- a/man/defaultColumns.Rd +++ b/man/defaultColumns.Rd @@ -22,3 +22,13 @@ had no name shown \details{ Returns a reactable colunn definition } +\seealso{ +Other ColDefs: +\code{\link[=cmColDef]{cmColDef()}}, +\code{\link[=cmOutcomeColDef]{cmOutcomeColDef()}}, +\code{\link[=getCIcolumns]{getCIcolumns()}}, +\code{\link[=getCdCols]{getCdCols()}}, +\code{\link[=getPlpColDefs]{getPlpColDefs()}}, +\code{\link[=getSccsColDefs]{getSccsColDefs()}} +} +\concept{ColDefs} diff --git a/man/extractCohortMethodSettings.Rd b/man/extractCohortMethodSettings.Rd index 37d6492..c0966e1 100644 --- a/man/extractCohortMethodSettings.Rd +++ b/man/extractCohortMethodSettings.Rd @@ -26,3 +26,13 @@ Extract cohorts from json \details{ Returns a names list with the cohorts } +\seealso{ +Other Extraction: +\code{\link[=createStratSentance]{createStratSentance()}}, +\code{\link[=getCiTargetsOutcomes]{getCiTargetsOutcomes()}}, +\code{\link[=getCohortDiagnosticTables]{getCohortDiagnosticTables()}}, +\code{\link[=getCountStatement]{getCountStatement()}}, +\code{\link[=getPlpSettings]{getPlpSettings()}}, +\code{\link[=getSccsSettings]{getSccsSettings()}} +} +\concept{Extraction} diff --git a/man/formatCovariateSettings.Rd b/man/formatCovariateSettings.Rd index e72551a..d151284 100644 --- a/man/formatCovariateSettings.Rd +++ b/man/formatCovariateSettings.Rd @@ -18,3 +18,19 @@ changes the covariateSettings list to a nice table format \details{ Returns a data.frame with the covariate settings } +\seealso{ +Other Helpers: +\code{\link[=functionDefaults]{functionDefaults()}}, +\code{\link[=getAllHelpDetails]{getAllHelpDetails()}}, +\code{\link[=getAllHelpText]{getAllHelpText()}}, +\code{\link[=getCohortDefinitionsFromJson]{getCohortDefinitionsFromJson()}}, +\code{\link[=getConcepts]{getConcepts()}}, +\code{\link[=getDemoLoc]{getDemoLoc()}}, +\code{\link[=getFunctionFromArgName]{getFunctionFromArgName()}}, +\code{\link[=getHelpText]{getHelpText()}}, +\code{\link[=getNegativeControlsFromJson]{getNegativeControlsFromJson()}}, +\code{\link[=getSettingsTable]{getSettingsTable()}}, +\code{\link[=reportTableFormat]{reportTableFormat()}}, +\code{\link[=tagPrint]{tagPrint()}} +} +\concept{Helpers} diff --git a/man/functionDefaults.Rd b/man/functionDefaults.Rd index d959f39..bb766dd 100644 --- a/man/functionDefaults.Rd +++ b/man/functionDefaults.Rd @@ -22,3 +22,19 @@ and all default input values returned Returns a named list with the name of all the inputs and the default input values } +\seealso{ +Other Helpers: +\code{\link[=formatCovariateSettings]{formatCovariateSettings()}}, +\code{\link[=getAllHelpDetails]{getAllHelpDetails()}}, +\code{\link[=getAllHelpText]{getAllHelpText()}}, +\code{\link[=getCohortDefinitionsFromJson]{getCohortDefinitionsFromJson()}}, +\code{\link[=getConcepts]{getConcepts()}}, +\code{\link[=getDemoLoc]{getDemoLoc()}}, +\code{\link[=getFunctionFromArgName]{getFunctionFromArgName()}}, +\code{\link[=getHelpText]{getHelpText()}}, +\code{\link[=getNegativeControlsFromJson]{getNegativeControlsFromJson()}}, +\code{\link[=getSettingsTable]{getSettingsTable()}}, +\code{\link[=reportTableFormat]{reportTableFormat()}}, +\code{\link[=tagPrint]{tagPrint()}} +} +\concept{Helpers} diff --git a/man/generateProtocol.Rd b/man/generateProtocol.Rd index 819c667..92d0a36 100644 --- a/man/generateProtocol.Rd +++ b/man/generateProtocol.Rd @@ -74,3 +74,4 @@ Specify the location of the json specification file, the data diagnostic folder the ATLAS webAPI (to process cohorts and concepts) and where you want the protocol saved. } +\concept{Generate} diff --git a/man/getAllHelpDetails.Rd b/man/getAllHelpDetails.Rd index 59880dc..7b52df5 100644 --- a/man/getAllHelpDetails.Rd +++ b/man/getAllHelpDetails.Rd @@ -22,3 +22,19 @@ and all default input values plus input descriptions are returned Returns a data.frmae with the name of all the inputs, the default input values and a description about the inputs } +\seealso{ +Other Helpers: +\code{\link[=formatCovariateSettings]{formatCovariateSettings()}}, +\code{\link[=functionDefaults]{functionDefaults()}}, +\code{\link[=getAllHelpText]{getAllHelpText()}}, +\code{\link[=getCohortDefinitionsFromJson]{getCohortDefinitionsFromJson()}}, +\code{\link[=getConcepts]{getConcepts()}}, +\code{\link[=getDemoLoc]{getDemoLoc()}}, +\code{\link[=getFunctionFromArgName]{getFunctionFromArgName()}}, +\code{\link[=getHelpText]{getHelpText()}}, +\code{\link[=getNegativeControlsFromJson]{getNegativeControlsFromJson()}}, +\code{\link[=getSettingsTable]{getSettingsTable()}}, +\code{\link[=reportTableFormat]{reportTableFormat()}}, +\code{\link[=tagPrint]{tagPrint()}} +} +\concept{Helpers} diff --git a/man/getAllHelpText.Rd b/man/getAllHelpText.Rd index 5957e45..e198302 100644 --- a/man/getAllHelpText.Rd +++ b/man/getAllHelpText.Rd @@ -22,3 +22,19 @@ and all input details are returned Returns a data.frame with the name of all the inputs and descriptions of the inputs } +\seealso{ +Other Helpers: +\code{\link[=formatCovariateSettings]{formatCovariateSettings()}}, +\code{\link[=functionDefaults]{functionDefaults()}}, +\code{\link[=getAllHelpDetails]{getAllHelpDetails()}}, +\code{\link[=getCohortDefinitionsFromJson]{getCohortDefinitionsFromJson()}}, +\code{\link[=getConcepts]{getConcepts()}}, +\code{\link[=getDemoLoc]{getDemoLoc()}}, +\code{\link[=getFunctionFromArgName]{getFunctionFromArgName()}}, +\code{\link[=getHelpText]{getHelpText()}}, +\code{\link[=getNegativeControlsFromJson]{getNegativeControlsFromJson()}}, +\code{\link[=getSettingsTable]{getSettingsTable()}}, +\code{\link[=reportTableFormat]{reportTableFormat()}}, +\code{\link[=tagPrint]{tagPrint()}} +} +\concept{Helpers} diff --git a/man/getCIcolumns.Rd b/man/getCIcolumns.Rd index cbd728f..f530efc 100644 --- a/man/getCIcolumns.Rd +++ b/man/getCIcolumns.Rd @@ -15,3 +15,13 @@ A reactable colDef list for the cohort incidence tables \details{ Returns a list of colDefs } +\seealso{ +Other ColDefs: +\code{\link[=cmColDef]{cmColDef()}}, +\code{\link[=cmOutcomeColDef]{cmOutcomeColDef()}}, +\code{\link[=defaultColumns]{defaultColumns()}}, +\code{\link[=getCdCols]{getCdCols()}}, +\code{\link[=getPlpColDefs]{getPlpColDefs()}}, +\code{\link[=getSccsColDefs]{getSccsColDefs()}} +} +\concept{ColDefs} diff --git a/man/getCdCols.Rd b/man/getCdCols.Rd index aa2f09f..c27f17a 100644 --- a/man/getCdCols.Rd +++ b/man/getCdCols.Rd @@ -15,3 +15,13 @@ A list of colDefs for the columns used in cohort diagnostic protocol module \details{ Returns a list of colDefs } +\seealso{ +Other ColDefs: +\code{\link[=cmColDef]{cmColDef()}}, +\code{\link[=cmOutcomeColDef]{cmOutcomeColDef()}}, +\code{\link[=defaultColumns]{defaultColumns()}}, +\code{\link[=getCIcolumns]{getCIcolumns()}}, +\code{\link[=getPlpColDefs]{getPlpColDefs()}}, +\code{\link[=getSccsColDefs]{getSccsColDefs()}} +} +\concept{ColDefs} diff --git a/man/getCiTargetsOutcomes.Rd b/man/getCiTargetsOutcomes.Rd index cc10fb3..fb965c0 100644 --- a/man/getCiTargetsOutcomes.Rd +++ b/man/getCiTargetsOutcomes.Rd @@ -20,3 +20,13 @@ Extracts a list of target tables, outcome tables, TARs and vector of unique targ \details{ Returns a list } +\seealso{ +Other Extraction: +\code{\link[=createStratSentance]{createStratSentance()}}, +\code{\link[=extractCohortMethodSettings]{extractCohortMethodSettings()}}, +\code{\link[=getCohortDiagnosticTables]{getCohortDiagnosticTables()}}, +\code{\link[=getCountStatement]{getCountStatement()}}, +\code{\link[=getPlpSettings]{getPlpSettings()}}, +\code{\link[=getSccsSettings]{getSccsSettings()}} +} +\concept{Extraction} diff --git a/man/getCohortDefinitionsFromJson.Rd b/man/getCohortDefinitionsFromJson.Rd index ce0408f..b4d3d29 100644 --- a/man/getCohortDefinitionsFromJson.Rd +++ b/man/getCohortDefinitionsFromJson.Rd @@ -18,3 +18,19 @@ Extract cohorts from json \details{ Returns a names list with the cohorts } +\seealso{ +Other Helpers: +\code{\link[=formatCovariateSettings]{formatCovariateSettings()}}, +\code{\link[=functionDefaults]{functionDefaults()}}, +\code{\link[=getAllHelpDetails]{getAllHelpDetails()}}, +\code{\link[=getAllHelpText]{getAllHelpText()}}, +\code{\link[=getConcepts]{getConcepts()}}, +\code{\link[=getDemoLoc]{getDemoLoc()}}, +\code{\link[=getFunctionFromArgName]{getFunctionFromArgName()}}, +\code{\link[=getHelpText]{getHelpText()}}, +\code{\link[=getNegativeControlsFromJson]{getNegativeControlsFromJson()}}, +\code{\link[=getSettingsTable]{getSettingsTable()}}, +\code{\link[=reportTableFormat]{reportTableFormat()}}, +\code{\link[=tagPrint]{tagPrint()}} +} +\concept{Helpers} diff --git a/man/getCohortDiagnosticTables.Rd b/man/getCohortDiagnosticTables.Rd index 137d3dc..77ed2b2 100644 --- a/man/getCohortDiagnosticTables.Rd +++ b/man/getCohortDiagnosticTables.Rd @@ -20,3 +20,13 @@ Extract target, setting and feature table from CohortDiagnosticsSettings \details{ Returns a list of tables } +\seealso{ +Other Extraction: +\code{\link[=createStratSentance]{createStratSentance()}}, +\code{\link[=extractCohortMethodSettings]{extractCohortMethodSettings()}}, +\code{\link[=getCiTargetsOutcomes]{getCiTargetsOutcomes()}}, +\code{\link[=getCountStatement]{getCountStatement()}}, +\code{\link[=getPlpSettings]{getPlpSettings()}}, +\code{\link[=getSccsSettings]{getSccsSettings()}} +} +\concept{Extraction} diff --git a/man/getConcepts.Rd b/man/getConcepts.Rd index 35f8429..4b776c2 100644 --- a/man/getConcepts.Rd +++ b/man/getConcepts.Rd @@ -28,3 +28,19 @@ Returns a names list of length two with 'standard' and 'source' containing a data.frame with the concept ids details for the standard concepts and their sourced concepts. } +\seealso{ +Other Helpers: +\code{\link[=formatCovariateSettings]{formatCovariateSettings()}}, +\code{\link[=functionDefaults]{functionDefaults()}}, +\code{\link[=getAllHelpDetails]{getAllHelpDetails()}}, +\code{\link[=getAllHelpText]{getAllHelpText()}}, +\code{\link[=getCohortDefinitionsFromJson]{getCohortDefinitionsFromJson()}}, +\code{\link[=getDemoLoc]{getDemoLoc()}}, +\code{\link[=getFunctionFromArgName]{getFunctionFromArgName()}}, +\code{\link[=getHelpText]{getHelpText()}}, +\code{\link[=getNegativeControlsFromJson]{getNegativeControlsFromJson()}}, +\code{\link[=getSettingsTable]{getSettingsTable()}}, +\code{\link[=reportTableFormat]{reportTableFormat()}}, +\code{\link[=tagPrint]{tagPrint()}} +} +\concept{Helpers} diff --git a/man/getCountStatement.Rd b/man/getCountStatement.Rd index d4f8d35..eed5ba6 100644 --- a/man/getCountStatement.Rd +++ b/man/getCountStatement.Rd @@ -20,3 +20,13 @@ Create a sentence that explains the number of targets, outcomes and settings per \details{ Returns a string } +\seealso{ +Other Extraction: +\code{\link[=createStratSentance]{createStratSentance()}}, +\code{\link[=extractCohortMethodSettings]{extractCohortMethodSettings()}}, +\code{\link[=getCiTargetsOutcomes]{getCiTargetsOutcomes()}}, +\code{\link[=getCohortDiagnosticTables]{getCohortDiagnosticTables()}}, +\code{\link[=getPlpSettings]{getPlpSettings()}}, +\code{\link[=getSccsSettings]{getSccsSettings()}} +} +\concept{Extraction} diff --git a/man/getDemoLoc.Rd b/man/getDemoLoc.Rd index 06ba61b..13bbb3e 100644 --- a/man/getDemoLoc.Rd +++ b/man/getDemoLoc.Rd @@ -15,3 +15,19 @@ Get the file location of an example json in the package \details{ This function returns the path to an example json specification file. } +\seealso{ +Other Helpers: +\code{\link[=formatCovariateSettings]{formatCovariateSettings()}}, +\code{\link[=functionDefaults]{functionDefaults()}}, +\code{\link[=getAllHelpDetails]{getAllHelpDetails()}}, +\code{\link[=getAllHelpText]{getAllHelpText()}}, +\code{\link[=getCohortDefinitionsFromJson]{getCohortDefinitionsFromJson()}}, +\code{\link[=getConcepts]{getConcepts()}}, +\code{\link[=getFunctionFromArgName]{getFunctionFromArgName()}}, +\code{\link[=getHelpText]{getHelpText()}}, +\code{\link[=getNegativeControlsFromJson]{getNegativeControlsFromJson()}}, +\code{\link[=getSettingsTable]{getSettingsTable()}}, +\code{\link[=reportTableFormat]{reportTableFormat()}}, +\code{\link[=tagPrint]{tagPrint()}} +} +\concept{Helpers} diff --git a/man/getFunctionFromArgName.Rd b/man/getFunctionFromArgName.Rd index efc889d..9a35982 100644 --- a/man/getFunctionFromArgName.Rd +++ b/man/getFunctionFromArgName.Rd @@ -20,3 +20,19 @@ This gets the input name from the arg name as CohortMethod ass Arg to the inputs \details{ Returns the name of the input the setting arg corresponds to } +\seealso{ +Other Helpers: +\code{\link[=formatCovariateSettings]{formatCovariateSettings()}}, +\code{\link[=functionDefaults]{functionDefaults()}}, +\code{\link[=getAllHelpDetails]{getAllHelpDetails()}}, +\code{\link[=getAllHelpText]{getAllHelpText()}}, +\code{\link[=getCohortDefinitionsFromJson]{getCohortDefinitionsFromJson()}}, +\code{\link[=getConcepts]{getConcepts()}}, +\code{\link[=getDemoLoc]{getDemoLoc()}}, +\code{\link[=getHelpText]{getHelpText()}}, +\code{\link[=getNegativeControlsFromJson]{getNegativeControlsFromJson()}}, +\code{\link[=getSettingsTable]{getSettingsTable()}}, +\code{\link[=reportTableFormat]{reportTableFormat()}}, +\code{\link[=tagPrint]{tagPrint()}} +} +\concept{Helpers} diff --git a/man/getHelpText.Rd b/man/getHelpText.Rd index 11cab3b..df05c02 100644 --- a/man/getHelpText.Rd +++ b/man/getHelpText.Rd @@ -27,3 +27,19 @@ and in input for the function to get details about the input. \details{ Returns a string with details about the input } +\seealso{ +Other Helpers: +\code{\link[=formatCovariateSettings]{formatCovariateSettings()}}, +\code{\link[=functionDefaults]{functionDefaults()}}, +\code{\link[=getAllHelpDetails]{getAllHelpDetails()}}, +\code{\link[=getAllHelpText]{getAllHelpText()}}, +\code{\link[=getCohortDefinitionsFromJson]{getCohortDefinitionsFromJson()}}, +\code{\link[=getConcepts]{getConcepts()}}, +\code{\link[=getDemoLoc]{getDemoLoc()}}, +\code{\link[=getFunctionFromArgName]{getFunctionFromArgName()}}, +\code{\link[=getNegativeControlsFromJson]{getNegativeControlsFromJson()}}, +\code{\link[=getSettingsTable]{getSettingsTable()}}, +\code{\link[=reportTableFormat]{reportTableFormat()}}, +\code{\link[=tagPrint]{tagPrint()}} +} +\concept{Helpers} diff --git a/man/getNegativeControlsFromJson.Rd b/man/getNegativeControlsFromJson.Rd index 047e3fb..fa36cae 100644 --- a/man/getNegativeControlsFromJson.Rd +++ b/man/getNegativeControlsFromJson.Rd @@ -18,3 +18,19 @@ Extract cohorts from json \details{ Returns a names list with the cohorts } +\seealso{ +Other Helpers: +\code{\link[=formatCovariateSettings]{formatCovariateSettings()}}, +\code{\link[=functionDefaults]{functionDefaults()}}, +\code{\link[=getAllHelpDetails]{getAllHelpDetails()}}, +\code{\link[=getAllHelpText]{getAllHelpText()}}, +\code{\link[=getCohortDefinitionsFromJson]{getCohortDefinitionsFromJson()}}, +\code{\link[=getConcepts]{getConcepts()}}, +\code{\link[=getDemoLoc]{getDemoLoc()}}, +\code{\link[=getFunctionFromArgName]{getFunctionFromArgName()}}, +\code{\link[=getHelpText]{getHelpText()}}, +\code{\link[=getSettingsTable]{getSettingsTable()}}, +\code{\link[=reportTableFormat]{reportTableFormat()}}, +\code{\link[=tagPrint]{tagPrint()}} +} +\concept{Helpers} diff --git a/man/getPlpColDefs.Rd b/man/getPlpColDefs.Rd index e3f9a7a..d680781 100644 --- a/man/getPlpColDefs.Rd +++ b/man/getPlpColDefs.Rd @@ -15,3 +15,13 @@ create colDefs for prediction table \details{ Returns a names list with the cohorts } +\seealso{ +Other ColDefs: +\code{\link[=cmColDef]{cmColDef()}}, +\code{\link[=cmOutcomeColDef]{cmOutcomeColDef()}}, +\code{\link[=defaultColumns]{defaultColumns()}}, +\code{\link[=getCIcolumns]{getCIcolumns()}}, +\code{\link[=getCdCols]{getCdCols()}}, +\code{\link[=getSccsColDefs]{getSccsColDefs()}} +} +\concept{ColDefs} diff --git a/man/getPlpSettings.Rd b/man/getPlpSettings.Rd index 8519bd7..b464743 100644 --- a/man/getPlpSettings.Rd +++ b/man/getPlpSettings.Rd @@ -20,3 +20,13 @@ Extract plp tables and settings from json \details{ Returns a names list with the tables and settings } +\seealso{ +Other Extraction: +\code{\link[=createStratSentance]{createStratSentance()}}, +\code{\link[=extractCohortMethodSettings]{extractCohortMethodSettings()}}, +\code{\link[=getCiTargetsOutcomes]{getCiTargetsOutcomes()}}, +\code{\link[=getCohortDiagnosticTables]{getCohortDiagnosticTables()}}, +\code{\link[=getCountStatement]{getCountStatement()}}, +\code{\link[=getSccsSettings]{getSccsSettings()}} +} +\concept{Extraction} diff --git a/man/getSccsColDefs.Rd b/man/getSccsColDefs.Rd index 8225475..e922f25 100644 --- a/man/getSccsColDefs.Rd +++ b/man/getSccsColDefs.Rd @@ -15,3 +15,13 @@ Create col defs for SCCS \details{ Returns a named list of colDefs } +\seealso{ +Other ColDefs: +\code{\link[=cmColDef]{cmColDef()}}, +\code{\link[=cmOutcomeColDef]{cmOutcomeColDef()}}, +\code{\link[=defaultColumns]{defaultColumns()}}, +\code{\link[=getCIcolumns]{getCIcolumns()}}, +\code{\link[=getCdCols]{getCdCols()}}, +\code{\link[=getPlpColDefs]{getPlpColDefs()}} +} +\concept{ColDefs} diff --git a/man/getSccsSettings.Rd b/man/getSccsSettings.Rd index 922e460..c3cc0fc 100644 --- a/man/getSccsSettings.Rd +++ b/man/getSccsSettings.Rd @@ -26,3 +26,13 @@ Extract exposure/outcomes of interest, shared and analysis specific negative con \details{ Returns a list of tables and settings } +\seealso{ +Other Extraction: +\code{\link[=createStratSentance]{createStratSentance()}}, +\code{\link[=extractCohortMethodSettings]{extractCohortMethodSettings()}}, +\code{\link[=getCiTargetsOutcomes]{getCiTargetsOutcomes()}}, +\code{\link[=getCohortDiagnosticTables]{getCohortDiagnosticTables()}}, +\code{\link[=getCountStatement]{getCountStatement()}}, +\code{\link[=getPlpSettings]{getPlpSettings()}} +} +\concept{Extraction} diff --git a/man/getSettingsTable.Rd b/man/getSettingsTable.Rd index c182960..d57579e 100644 --- a/man/getSettingsTable.Rd +++ b/man/getSettingsTable.Rd @@ -25,3 +25,19 @@ to the default \details{ This returns a tibble with the input details } +\seealso{ +Other Helpers: +\code{\link[=formatCovariateSettings]{formatCovariateSettings()}}, +\code{\link[=functionDefaults]{functionDefaults()}}, +\code{\link[=getAllHelpDetails]{getAllHelpDetails()}}, +\code{\link[=getAllHelpText]{getAllHelpText()}}, +\code{\link[=getCohortDefinitionsFromJson]{getCohortDefinitionsFromJson()}}, +\code{\link[=getConcepts]{getConcepts()}}, +\code{\link[=getDemoLoc]{getDemoLoc()}}, +\code{\link[=getFunctionFromArgName]{getFunctionFromArgName()}}, +\code{\link[=getHelpText]{getHelpText()}}, +\code{\link[=getNegativeControlsFromJson]{getNegativeControlsFromJson()}}, +\code{\link[=reportTableFormat]{reportTableFormat()}}, +\code{\link[=tagPrint]{tagPrint()}} +} +\concept{Helpers} diff --git a/man/reportTableFormat.Rd b/man/reportTableFormat.Rd index e261e98..274f820 100644 --- a/man/reportTableFormat.Rd +++ b/man/reportTableFormat.Rd @@ -35,3 +35,19 @@ create a grouped reactable::reactable \details{ Returns a reactable::reactable } +\seealso{ +Other Helpers: +\code{\link[=formatCovariateSettings]{formatCovariateSettings()}}, +\code{\link[=functionDefaults]{functionDefaults()}}, +\code{\link[=getAllHelpDetails]{getAllHelpDetails()}}, +\code{\link[=getAllHelpText]{getAllHelpText()}}, +\code{\link[=getCohortDefinitionsFromJson]{getCohortDefinitionsFromJson()}}, +\code{\link[=getConcepts]{getConcepts()}}, +\code{\link[=getDemoLoc]{getDemoLoc()}}, +\code{\link[=getFunctionFromArgName]{getFunctionFromArgName()}}, +\code{\link[=getHelpText]{getHelpText()}}, +\code{\link[=getNegativeControlsFromJson]{getNegativeControlsFromJson()}}, +\code{\link[=getSettingsTable]{getSettingsTable()}}, +\code{\link[=tagPrint]{tagPrint()}} +} +\concept{Helpers} diff --git a/man/tagPrint.Rd b/man/tagPrint.Rd index f274af9..341c067 100644 --- a/man/tagPrint.Rd +++ b/man/tagPrint.Rd @@ -18,3 +18,19 @@ display a reactable when there are multiple outputs to print \details{ Wraps the input around print and shiny:tagList } +\seealso{ +Other Helpers: +\code{\link[=formatCovariateSettings]{formatCovariateSettings()}}, +\code{\link[=functionDefaults]{functionDefaults()}}, +\code{\link[=getAllHelpDetails]{getAllHelpDetails()}}, +\code{\link[=getAllHelpText]{getAllHelpText()}}, +\code{\link[=getCohortDefinitionsFromJson]{getCohortDefinitionsFromJson()}}, +\code{\link[=getConcepts]{getConcepts()}}, +\code{\link[=getDemoLoc]{getDemoLoc()}}, +\code{\link[=getFunctionFromArgName]{getFunctionFromArgName()}}, +\code{\link[=getHelpText]{getHelpText()}}, +\code{\link[=getNegativeControlsFromJson]{getNegativeControlsFromJson()}}, +\code{\link[=getSettingsTable]{getSettingsTable()}}, +\code{\link[=reportTableFormat]{reportTableFormat()}} +} +\concept{Helpers} diff --git a/vignettes/ProtocolGenerator.Rmd b/vignettes/ProtocolGenerator.Rmd index c206d7e..b110e37 100644 --- a/vignettes/ProtocolGenerator.Rmd +++ b/vignettes/ProtocolGenerator.Rmd @@ -13,4 +13,28 @@ vignette: > knitr::opts_chunk$set(echo = TRUE) ``` -# Using ProtocolGenerator +To run protocol generator you need to have a `Strategus` json specification (either as a saved file or loaded into R). You can specify a `webAPI` to use for concept set extraction (note: rendered concept sets can change depending on the webAPI's vocab). The `outputLocation` is where the protocol html file will be saved to. + +You can personalize the protocol with the following inputs: + +- protocolSubheading: this lets you specify a title for the study +- headerColor: this lets you specify a header color for the protocol (defaults to dark blue) +- headerLogoLocation: this lets you specify a logo to add to the protocol header (defaults to no logo) + +To run the protocol generator using the demo json specification in the package you can run: + +```{r demo, echo=TRUE, results = 'hide'} +library(ProtocolGenerator) + +# to run the protocol generator with a demo json specification +test <- generateProtocol( + jsonLocation = getDemoLoc(), + webAPI = 'https://api.ohdsi.org/WebAPI', + outputLocation = file.path(tempdir(), 'protocol'), + protocolSubheading = 'A demo protocol using the example specifcation json' + #,headerColor = '4A1B12' # can optionally enter any HTML color code for the header + #,headerLogoLocation = 'path to image' # can optionally add a logo to the header +) +``` + + From bbda8db6772586bbbb70f89110714393e2c951b2 Mon Sep 17 00:00:00 2001 From: jreps Date: Thu, 20 Aug 2026 10:13:41 -0400 Subject: [PATCH 7/8] Update ProtocolGenerator.Rmd --- vignettes/ProtocolGenerator.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vignettes/ProtocolGenerator.Rmd b/vignettes/ProtocolGenerator.Rmd index b110e37..c3045ce 100644 --- a/vignettes/ProtocolGenerator.Rmd +++ b/vignettes/ProtocolGenerator.Rmd @@ -23,7 +23,7 @@ You can personalize the protocol with the following inputs: To run the protocol generator using the demo json specification in the package you can run: -```{r demo, echo=TRUE, results = 'hide'} +```{r demo, echo=TRUE, eval = FALSE, results = 'hide'} library(ProtocolGenerator) # to run the protocol generator with a demo json specification From f5c139cfc6f9a57f5a10f52216d0b53d810c6c3d Mon Sep 17 00:00:00 2001 From: jreps Date: Thu, 20 Aug 2026 10:21:15 -0400 Subject: [PATCH 8/8] lychee annoying check lychee annoyingly checks the webapi links and causes an error, so using a paste0 hack to bypass this issue. --- README.md | 6 +++--- vignettes/ProtocolGenerator.Rmd | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index abd51f3..5d69d77 100644 --- a/README.md +++ b/README.md @@ -30,14 +30,14 @@ library(ProtocolGenerator) # to run the protocol generator with a demo json specification test <- generateProtocol( jsonLocation = getDemoLoc(), - webAPI = 'https://api.ohdsi.org/WebAPI', + webAPI = paste0('https://', 'api.ohdsi.org', '/WebAPI'), outputLocation = './protocol' ) # to run with your own json spec test <- generateProtocol( jsonLocation = '', - webAPI = 'https://api.ohdsi.org/WebAPI', + webAPI = paste0('https://', 'api.ohdsi.org', '/WebAPI'), outputLocation = './protocol' ) @@ -69,7 +69,7 @@ Installation User Documentation ================== -Documentation can be found on the [package website](https://ohdsi.github.io/ProtocolGenerator/). +Documentation is built with pkgdown and published by the pkgdown workflow. Support diff --git a/vignettes/ProtocolGenerator.Rmd b/vignettes/ProtocolGenerator.Rmd index c3045ce..1fee36d 100644 --- a/vignettes/ProtocolGenerator.Rmd +++ b/vignettes/ProtocolGenerator.Rmd @@ -29,7 +29,7 @@ library(ProtocolGenerator) # to run the protocol generator with a demo json specification test <- generateProtocol( jsonLocation = getDemoLoc(), - webAPI = 'https://api.ohdsi.org/WebAPI', + webAPI = paste0('https://', 'api.ohdsi.org', '/WebAPI'), outputLocation = file.path(tempdir(), 'protocol'), protocolSubheading = 'A demo protocol using the example specifcation json' #,headerColor = '4A1B12' # can optionally enter any HTML color code for the header