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/DESCRIPTION b/DESCRIPTION
index 02254ac..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"))
)
@@ -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
-RoxygenNote: 7.3.2
+ ohdsi/CohortIncidence
Encoding: UTF-8
+Config/roxygen2/version: 8.0.0
diff --git a/NAMESPACE b/NAMESPACE
index b58feff..15a340f 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,16 +1,30 @@
# Generated by roxygen2: do not edit by hand
+export(cmColDef)
+export(cmOutcomeColDef)
+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/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
new file mode 100644
index 0000000..cca2dc2
--- /dev/null
+++ b/R/Characterization.R
@@ -0,0 +1,800 @@
+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.'
+ )
+
+ # 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)
+}
+
+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
+
+ # only non-NULL in v4 or higher
+ characterizationTargetLookup <- CharacterizationModuleSettings$settings$analysis$characterizationTargetLookup
+
+ if(is.null(tbSpec)){
+ return(NULL)
+ }
+
+
+ # helper at bottom of file
+ targetPop <- getTargetPop(
+ spec = tbSpec,
+ settingName = 'targetBaselineSettings',
+ characterizationTargetLookup = characterizationTargetLookup,
+ mapCovariates = TRUE,
+ mapOutcomes = FALSE
+ )
+
+ targetSettings <- targetPop$targetSettings
+ covariateJsonUnique <- targetPop$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
+ # only non-NULL in v4 or higher
+ characterizationTargetLookup <- CharacterizationModuleSettings$settings$analysis$characterizationTargetLookup
+
+
+ if(is.null(rfSpec)){
+ return(NULL)
+ }
+
+ # 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(length(singleTargetSet) > 1){
+ singleTargetSet <- FALSE
+ }
+ if(!is.logical(singleTargetSet)){
+ singleTargetSet <- FALSE
+ }
+
+ if(singleTargetSet){
+ # all outcomes by all targets
+ targetPop <- getTargetPop(
+ spec = rfSpec,
+ settingName = 'riskFactorSettings',
+ characterizationTargetLookup = characterizationTargetLookup,
+ mapCovariates = TRUE,
+ mapOutcomes = TRUE
+ )
+
+ 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
+ targetPop <- getTargetPop(
+ spec = rfSpec,
+ settingName = 'riskFactorSettings',
+ characterizationTargetLookup = characterizationTargetLookup,
+ mapCovariates = TRUE,
+ mapOutcomes = TRUE
+ )
+ rfTargetSettings <- targetPop$targetSettings
+ covariateJsonUnique <- targetPop$covariateJsonUnique
+ rfOutcomeList <- targetPop$outcomeList
+
+ }
+
+ # 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
+ characterizationTargetLookup <- CharacterizationModuleSettings$settings$analysis$characterizationTargetLookup
+
+ if(is.null(csSpec)){
+ return(NULL)
+ }
+
+ # 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(length(singleTargetSet) > 1){
+ singleTargetSet <- FALSE
+ }
+ if(!is.logical(singleTargetSet)){
+ singleTargetSet <- FALSE
+ }
+
+ if(singleTargetSet){
+ # all outcomes by all targets
+ targetPop <- getTargetPop(
+ spec = csSpec,
+ settingName = 'caseSeriesSettings',
+ characterizationTargetLookup = characterizationTargetLookup,
+ mapCovariates = FALSE,
+ mapOutcomes = TRUE,
+ mapCaseSeries = TRUE
+ )
+
+ 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
+ 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
+ # 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
+ )
+ )
+
+}
+
+
+
+# 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),
+ 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)
+}
+
+
+
+
+
+# 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/CohortDiagnostics.R b/R/CohortDiagnostics.R
new file mode 100644
index 0000000..d77a962
--- /dev/null
+++ b/R/CohortDiagnostics.R
@@ -0,0 +1,130 @@
+#' 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
+#'
+#' @family Extraction
+#' @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
+#'
+#' @family ColDefs
+#' @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..fb9fa09
--- /dev/null
+++ b/R/CohortIncidence.R
@@ -0,0 +1,267 @@
+#' 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
+#'
+#' @family Extraction
+#' @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
+#'
+#' @family Extraction
+#' @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
+#'
+#' @family Extraction
+#' @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
+#'
+#' @family ColDefs
+#' @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..707a1fa
--- /dev/null
+++ b/R/CohortMethod.R
@@ -0,0 +1,471 @@
+#' 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 ...
+#'
+#' @family Extraction
+#' @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
+ 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)),
+ 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){
+ if(commonExclude[1] != -1){
+ for(ind in 2:length(excludeConcepts)){
+ commonExclude <- intersect(excludeConcepts[[ind]],commonExclude)
+ }
+ } else{
+ commonExclude <- c()
+ }
+ }
+ 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'
+ )
+
+ if(!'subsetCohortsTarget' %in% colnames(tcCombos)){
+ tcCombos$subsetCohortsTarget <- ''
+ }
+ if(!'appliedSubsetsTarget' %in% colnames(tcCombos)){
+ tcCombos$appliedSubsetsTarget <- ''
+ }
+
+ 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
+#'
+#' @family ColDefs
+#' @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)
+}
+
+
+#' 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
+#'
+#' @family ColDefs
+#' @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 86218d2..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){
@@ -43,37 +44,39 @@ 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)
#'
+#' @family Helpers
#' @export
#'
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,23 +108,152 @@ 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))
+ 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
@@ -138,32 +270,83 @@ getCohortDefinitionsFromJson <- function(
#' @return
#' An named R list with the elements 'standard' and 'source'
#'
+#' @family Helpers
#' @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
}
- 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 +357,45 @@ 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
+#'
+#' @family Helpers
+#' @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)))
+
+ if(!nrow(negativeControls) == 0){
+ negativeControls$occurrenceType <- negativeControlsTemp$occurrenceType
+ negativeControls$detectOnDescendants <- negativeControlsTemp$detectOnDescendants
+ } else{
+ negativeControls <- NULL
+ }
+
+ }
+
+ return(negativeControls)
+}
+
+
+
#' getFunctionFromArgName
#'
@@ -188,6 +410,7 @@ getConcepts <- function(
#' @return
#' the name of the input the setting arg corresponds to
#'
+#' @family Helpers
#' @export
#'
getFunctionFromArgName <- function(
@@ -195,7 +418,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))]
@@ -217,6 +442,7 @@ getFunctionFromArgName <- function(
#' @return
#' Details about the input
#'
+#' @family Helpers
#' @export
#'
getHelpText <- function(
@@ -236,21 +462,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)
@@ -272,6 +501,7 @@ getHelpText <- function(
#' @return
#' Details about all inputs into the functionName within R package of interest
#'
+#' @family Helpers
#' @export
#'
getAllHelpText <- function(
@@ -333,6 +563,7 @@ getExtraCyclopsHelp <- function(){
#' @return
#' Details about all default inputs into the functionName within R package of interest
#'
+#' @family Helpers
#' @export
#'
functionDefaults <- function(
@@ -395,20 +626,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
)
@@ -433,6 +719,7 @@ listToDf <- function(
#' @return
#' Details about all inputs into the functionName within R package of interest
#'
+#' @family Helpers
#' @export
#'
getAllHelpDetails <- function(
@@ -518,6 +805,7 @@ getAllHelpDetails <- function(
#' @return
#' Returns a tibble with the input details
#'
+#' @family Helpers
#' @export
#'
getSettingsTable <- function(
@@ -531,16 +819,22 @@ getSettingsTable <- function(
functionName
)
- settingsDf <- listToDf(
- settings,
- valueName = 'value'
+ if(is.null(settings)){
+ settingsDf <- listToDf(list(isNUll = 'NULL'))
+ } else if(identical(settings, list())){
+ 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
@@ -568,6 +862,7 @@ getSettingsTable <- function(
#' @return
#' Returns a reactable colunn definition
#'
+#' @family ColDefs
#' @export
#'
defaultColumns <- function(data){
@@ -607,11 +902,13 @@ 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
#'
+#' @family Helpers
#' @export
#'
reportTableFormat <- function(
@@ -619,22 +916,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
+ )
+ }
}
@@ -650,6 +981,7 @@ reportTableFormat <- function(
#' @return
#' a data.frame with the covariate settings
#'
+#' @family Helpers
#' @export
#'
formatCovariateSettings <- function(
@@ -671,6 +1003,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 +1017,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..4dac4e6
--- /dev/null
+++ b/R/PatientLevelPrediction.R
@@ -0,0 +1,154 @@
+#' 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 ...
+#'
+#' @family Extraction
+#' @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(inherits(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
+#'
+#' @family ColDefs
+#' @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/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
new file mode 100644
index 0000000..e1bfb5d
--- /dev/null
+++ b/R/SelfControlCaseSeries.R
@@ -0,0 +1,266 @@
+#' 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
+#'
+#' @family Extraction
+#' @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
+#'
+#' @family ColDefs
+#' @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/R/generate.R b/R/generate.R
index 0408700..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(){
@@ -44,10 +45,14 @@ 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'
#'
+#' @family Generate
#' @export
#'
generateProtocol <- function(
@@ -65,7 +70,10 @@ generateProtocol <- function(
conceptsAsExcel = FALSE,
conceptFolder = outputLocation,
addCohortDefinitions = TRUE,
- exportCohortLocation = NULL
+ exportCohortLocation = NULL,
+ headerColor = "#336B91",
+ headerLogoLocation = NULL,
+ protocolSubheading = NULL
){
if(missing(jsonLocation)){
@@ -133,7 +141,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/README.md b/README.md
index 2620a1d..5d69d77 100644
--- a/README.md
+++ b/README.md
@@ -1,8 +1,15 @@
ProtocolGenerator
===============
-[](https://github.com/OHDSI/ProtocolGenerator/actions?query=workflow%3AR-CMD-check)
-[](https://codecov.io/github/OHDSI/ProtocolGenerator?branch=main)
+[](https://github.com/OHDSI/ProtocolGenerator/actions/workflows/R_CMD_check_Hades.yaml)
+[](https://github.com/OHDSI/ProtocolGenerator/actions/workflows/pkgdown.yaml)
+[](https://app.codecov.io/github/OHDSI/ProtocolGenerator?branch=main)
+[](https://github.com/OHDSI/ProtocolGenerator/blob/main/DESCRIPTION)
+[](https://www.r-project.org/)
+[](https://www.apache.org/licenses/LICENSE-2.0)
+[](https://lifecycle.r-lib.org/articles/stages.html#experimental)
+[](https://github.com/OHDSI/ProtocolGenerator/issues)
+[](https://github.com/OHDSI/ProtocolGenerator/commits/main)
Introduction
@@ -14,7 +21,7 @@ Examples
========
-```{r}
+```r
# install dependencies
remotes::install_github('ohdsi/ProtocolGenerator')
@@ -23,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'
)
@@ -62,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/_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/inst/protocol/characterization.qmd b/inst/protocol/characterization.qmd
index 6cefdd4..af0d991 100644
--- a/inst/protocol/characterization.qmd
+++ b/inst/protocol/characterization.qmd
@@ -4,420 +4,375 @@ 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')
-
-groupByOutcomes <- c('parentNameOutcome')
+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
+ )
-caAllDf <- caAllDf %>%
- dplyr::relocate("cohortNameOutcome") %>%
- dplyr::relocate("parentNameOutcome") %>%
- dplyr::relocate("outcomeWashoutDays", .after = "cohortNameOutcome") %>%
- dplyr::relocate("tar", .after = "outcomeWashoutDays")
+# add dechalRechal and timeToEvent functions
+tte <- ProtocolGenerator:::processTimeToEventSettings(
+ CharacterizationModuleSettings = CharacterizationModuleSettings,
+ cohortDefinitionDf = cohortDefinitionDf
+)
-} 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))
+dc <- ProtocolGenerator:::processDechalSettings(
+ CharacterizationModuleSettings = CharacterizationModuleSettings,
+ cohortDefinitionDf = cohortDefinitionDf
+)
-}
+# 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))
-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"
- )
- )
+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))))
+cColumns <- ProtocolGenerator:::characterizationColDef()
```
## Characterization
-### Aggregate Covariates
+::: {.callout-important collapse="false"}
+# Global settings
+```{r, echo=FALSE, results = 'asis'}
+cat('\n')
+cat(globalSetings)
+cat('\n')
+```
+:::
-Aggregate covariates analysis executes three different types of 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.
-**1. Target with and without outcome during TAR characterization**
+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.
+:::
-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).
+```{r, echo=FALSE, results = 'asis'}
-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.
+if(!is.null(targetBaseline)){
+
+cat("#### Targets {#sec-char-tb-targets}\n\n")
+ 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)
-**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')
+cat('\n#### Settings {#sec-char-tb-settings}\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)
+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)
-This can show how the patients with the outcome change over time.
+ 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')
+}
+```
-**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).
+### 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:
+
+- 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("#### 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(paste0('\n\n##### Settings ', cfInd, '{#sec-char-setting-',cfInd,'}'))
+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)){
+
+ cat(paste0('\n\n##### Settings ', settingInd, '{#sec-char-cs-setting-',settingInd,'}'))
cat('\n\n')
- # are these relevant?
+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, ]
+
+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'
+}
+
```
-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 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).
-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'}
+ 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')
- cat("\n\n#### Targets {#sec-char-tte-targets} \n")
-if(nrow(cTargets)>0){
print(shiny::tagList(
ProtocolGenerator::reportTableFormat(
- table = cTargets %>%
+ table = tte$popList[[i]] %>%
dplyr::arrange(.data$parentName,.data$cohortName),
groupBy = 'parentName',
- columns = cColumns[names(cColumns) %in% colnames(cTargets)],
+ elementId = 'tte-targets',
+ groupByButton = TRUE,
+ 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',
- columns = cColumns[names(cColumns) %in% colnames(cOutcomes)],
+ elementId = 'tte-outcomes',
+ groupByButton = TRUE,
+ 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)
@@ -426,57 +381,94 @@ 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, ]
+
+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',
- columns = cColumns[names(cColumns) %in% colnames(cTargets)],
+ elementId = 'dcrc-targets',
+ groupByButton = TRUE,
+ 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',
- columns = cColumns[names(cColumns) %in% colnames(cOutcomes)],
+ elementId = 'dcrc-outcomes',
+ groupByButton = TRUE,
+ 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
)
)
+ cat('\n::: {.callout-important collapse="true"}')
+ cat('\n# Parameters for dechallenge rechallange \n')
print(shiny::tagList(reportTableFormat(
table = setTable,
#groupBy = 'input',
@@ -489,6 +481,9 @@ setTable <- getSettingsTable(
)),
caption = 'Parameters for dechallenge rechallange'
)))
+ cat('\n:::\n')
+
+}
```
@@ -500,18 +495,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 +548,9 @@ cohortTracker <- rbind(
value = 1
)
)
+}
+if(length(unique(cTargets$cohortId)) > 0){
cohortTracker <- rbind(
cohortTracker,
data.frame(
@@ -535,5 +562,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..0762a5c 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,157 +72,44 @@ 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"),
- columns = list(
- priorOutcomeLookback = reactable::colDef(
- aggregate = "unique",
- show = TRUE,
- name = 'Prior Outcome Lookback (days)',
- filterable = TRUE
+ groupBy = "parentNameOutcome",
+ groupByButton = TRUE,
+ columns = ProtocolGenerator::cmOutcomeColDef(
+ colNames = colnames(cmOutUnique[[cmi]])
),
- 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)
- ),
elementId = paste0("cm-out-tab-",cmi)
)
)
)
-
+ 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 +124,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 +139,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 +172,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 +187,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 +232,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 +252,7 @@ if(length(concepts$standard) > 0){
),
negativeControlsCM,
by = 'cohortId',
- all.x = T
+ all.x = TRUE
),
groupBy = NULL,
columns = NULL
@@ -519,7 +260,7 @@ if(length(concepts$standard) > 0){
)
)
)
-
+ cat('\n:::\n')
}
}
@@ -530,26 +271,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 +291,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 +307,6 @@ for(i in 1:length(cohortMethodModuleSettings$settings$cmAnalysisList)){
extractSettings,
covariateDetails
),
- groupBy = 'input',
columns = append(defaultColumns(covariateDetails),
list(
desc = reactable::colDef(
@@ -581,13 +317,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 +344,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 +361,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 +388,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 +414,7 @@ settingDf <- getSettingsTable(
)
)
- if(!is.null(covariateFilter)){
+ if(is.data.frame(covariateFilter)){
cat("\n covariateFilter Settings: \n")
print(
shiny::tagList(
@@ -679,7 +425,10 @@ settingDf <- getSettingsTable(
)
}
+ cat('\n:::\n')
+
}
+ } # if "computeCovariateBalanceArgs" not NULL
} # if "computeCovariateBalanceArgs"
@@ -691,6 +440,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 +453,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 +506,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-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/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..3f2fd24 100644
--- a/inst/protocol/study_protocol.qmd
+++ b/inst/protocol/study_protocol.qmd
@@ -1,8 +1,7 @@
---
title: "Study Protocol"
-date: today
-date-format: short
title-block-banner: true
+number-sections: true
format:
html:
toc: true
@@ -23,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}
@@ -32,129 +34,109 @@ 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, ')')
+subsetUnique <- cohortDetails$subsetUnique
+cohortDefinitionDf <- cohortDetails$cohortDefinitionDf
-subsetIds <- unlist(lapply(cohortDefinitions, function(x){
- if(!is.null(x$subsetDefinition)){
- ParallelLogger::convertJsonToSettings(x$subsetDefinition)$definitionId
- } else{
- return(-1)
-}
-}))
+negativeControls <- ProtocolGenerator::getNegativeControlsFromJson(json)
-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
-})
+```{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")
+)
-# 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
- }
+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.")
}
- 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)
+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))
}
- )), 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 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
+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);"
+)
-} # end if subsetDefs is not null
+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)
+)
-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
-
+if (length(headerStyles) > 0) {
+ cat(
+ "",
+ sep = "\n"
+ )
+ cat(titleDetailsScript, sep = "\n")
}
```
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/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
new file mode 100644
index 0000000..d97454f
--- /dev/null
+++ b/man/cmColDef.Rd
@@ -0,0 +1,32 @@
+% 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
+}
+\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
new file mode 100644
index 0000000..ad486bf
--- /dev/null
+++ b/man/cmOutcomeColDef.Rd
@@ -0,0 +1,30 @@
+% 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
+}
+\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
new file mode 100644
index 0000000..7b15f6c
--- /dev/null
+++ b/man/createStratSentance.Rd
@@ -0,0 +1,30 @@
+% 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
+}
+\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
new file mode 100644
index 0000000..c0966e1
--- /dev/null
+++ b/man/extractCohortMethodSettings.Rd
@@ -0,0 +1,38 @@
+% 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{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}
+}
+\value{
+An named R list with ...
+}
+\description{
+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 8ec82e7..92d0a36 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'
@@ -65,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
new file mode 100644
index 0000000..f530efc
--- /dev/null
+++ b/man/getCIcolumns.Rd
@@ -0,0 +1,27 @@
+% 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
+}
+\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
new file mode 100644
index 0000000..c27f17a
--- /dev/null
+++ b/man/getCdCols.Rd
@@ -0,0 +1,27 @@
+% 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
+}
+\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
new file mode 100644
index 0000000..fb965c0
--- /dev/null
+++ b/man/getCiTargetsOutcomes.Rd
@@ -0,0 +1,32 @@
+% 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
+}
+\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 3fb8b2b..b4d3d29 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
@@ -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
new file mode 100644
index 0000000..77ed2b2
--- /dev/null
+++ b/man/getCohortDiagnosticTables.Rd
@@ -0,0 +1,32 @@
+% 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
+}
+\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 3aa767a..4b776c2 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"
)
@@ -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
new file mode 100644
index 0000000..eed5ba6
--- /dev/null
+++ b/man/getCountStatement.Rd
@@ -0,0 +1,32 @@
+% 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
+}
+\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
new file mode 100644
index 0000000..fa36cae
--- /dev/null
+++ b/man/getNegativeControlsFromJson.Rd
@@ -0,0 +1,36 @@
+% 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
+}
+\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
new file mode 100644
index 0000000..d680781
--- /dev/null
+++ b/man/getPlpColDefs.Rd
@@ -0,0 +1,27 @@
+% 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
+}
+\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
new file mode 100644
index 0000000..b464743
--- /dev/null
+++ b/man/getPlpSettings.Rd
@@ -0,0 +1,32 @@
+% 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
+}
+\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
new file mode 100644
index 0000000..e922f25
--- /dev/null
+++ b/man/getSccsColDefs.Rd
@@ -0,0 +1,27 @@
+% 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
+}
+\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
new file mode 100644
index 0000000..c3cc0fc
--- /dev/null
+++ b/man/getSccsSettings.Rd
@@ -0,0 +1,38 @@
+% 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
+}
+\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 942ca62..274f820 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{
@@ -22,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
@@ -32,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/tests/testthat/test-characterization.r b/tests/testthat/test-characterization.r
new file mode 100644
index 0000000..ffa88bd
--- /dev/null
+++ b/tests/testthat/test-characterization.r
@@ -0,0 +1,304 @@
+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")
+})
+
+
+
+# add tests for TTE/Dechal
+
+# add tests for v4 Char RF/CS
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-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)
})
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)
+})
diff --git a/vignettes/ProtocolGenerator.Rmd b/vignettes/ProtocolGenerator.Rmd
index c206d7e..1fee36d 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, eval = FALSE, results = 'hide'}
+library(ProtocolGenerator)
+
+# to run the protocol generator with a demo json specification
+test <- generateProtocol(
+ jsonLocation = getDemoLoc(),
+ 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
+ #,headerLogoLocation = 'path to image' # can optionally add a logo to the header
+)
+```
+
+