Merge pull request #148 from OHDSI/runCmAnalyses-tests

Run cm analyses tests

R/RunAnalyses.R

@@ -224,15 +224,16 @@ runCmAnalyses <- function(connectionDetails,
   checkmate::assertCharacter(outcomeTable, len = 1, add = errorMessages)
   checkmate::assertCharacter(cdmVersion, len = 1, add = errorMessages)
   checkmate::assertCharacter(outputFolder, len = 1, add = errorMessages)
-  checkmate::assertList(cmAnalysisList, min.len = 1, add = errorMessages)
-  for (i in 1:length(cmAnalysisList)) {
-    checkmate::assertClass(cmAnalysisList[[i]], "cmAnalysis", add = errorMessages)
-  }
-  checkmate::assertList(targetComparatorOutcomesList, min.len = 1, add = errorMessages)
-  for (i in 1:length(targetComparatorOutcomesList)) {
-    checkmate::assertClass(targetComparatorOutcomesList[[i]], "targetComparatorOutcomes", add = errorMessages)
-  }
+  checkmate::assertList(cmAnalysisList, min.len = 1, types = "cmAnalysis", add = errorMessages)
+  checkmate::assertList(targetComparatorOutcomesList, min.len = 1, types = "targetComparatorOutcomes", add = errorMessages)
   checkmate::assertDataFrame(analysesToExclude, null.ok = TRUE, add = errorMessages)
+
+  if (!is.null(analysesToExclude)) {
+    if (nrow(analysesToExclude) == 0) {
+      warning("Passed `data.frame` with 0 rows to parameter: `analysesToExclude`, no analyses excluded.")
+    }
+  }
+
   checkmate::assertLogical(refitPsForEveryOutcome, len = 1, add = errorMessages)
   checkmate::assertLogical(refitPsForEveryStudyPopulation, len = 1, add = errorMessages)
   checkmate::assertClass(multiThreadingSettings, "CmMultiThreadingSettings", add = errorMessages)

tests/testthat/setup-runCmAnalyses.R

@@ -0,0 +1,167 @@
+# Setup ----
+library(CohortMethod)
+
+outputFolder <- tempfile(pattern = "cmData")
+
+covarSettings <- createDefaultCovariateSettings(addDescendantsToExclude = TRUE)
+
+getDbCmDataArgs <- createGetDbCohortMethodDataArgs(
+  washoutPeriod = 183,
+  firstExposureOnly = TRUE,
+  removeDuplicateSubjects = "remove all",
+  covariateSettings = covarSettings
+)
+
+createPsArgs <- createCreatePsArgs(
+  prior = createPrior("laplace", variance = 0.01),
+  estimator = "att"
+)
+
+matchOnPsArgs <- createMatchOnPsArgs(maxRatio = 100)
+
+computeSharedCovBalArgs <- createComputeCovariateBalanceArgs()
+
+computeCovBalArgs <- createComputeCovariateBalanceArgs(
+  covariateFilter = FeatureExtraction::getDefaultTable1Specifications()
+)
+
+truncateIptwArgs <- createTruncateIptwArgs(maxWeight = 10)
+
+tcos1 <- createTargetComparatorOutcomes(
+  targetId = 1,
+  comparatorId = 2,
+  outcomes = list(
+    createOutcome(
+      outcomeId = 3,
+      priorOutcomeLookback = 30
+    ),
+    createOutcome(
+      outcomeId = 4,
+      outcomeOfInterest = FALSE,
+      trueEffectSize = 1
+    )
+  ),
+  excludedCovariateConceptIds = c(1118084, 1124300)
+)
+# Empty cohorts:
+tcos2 <- createTargetComparatorOutcomes(
+  targetId = 998,
+  comparatorId = 999,
+  outcomes = list(
+    createOutcome(
+      outcomeId = 3,
+      priorOutcomeLookback = 30
+    ),
+    createOutcome(
+      outcomeId = 4,
+      outcomeOfInterest = FALSE,
+      trueEffectSize = 1
+    )
+  )
+)
+
+targetComparatorOutcomesList <- list(tcos1, tcos2)
+
+analysesToExclude <- data.frame(
+  targetId = c(998, 998),
+  analysisId = c(3, 4)
+)
+
+createStudyPopArgs1 <- createCreateStudyPopulationArgs(
+  removeSubjectsWithPriorOutcome = TRUE,
+  firstExposureOnly = TRUE,
+  restrictToCommonPeriod = TRUE,
+  removeDuplicateSubjects = "remove all",
+  washoutPeriod = 183,
+  censorAtNewRiskWindow = TRUE,
+  minDaysAtRisk = 1,
+  riskWindowStart = 0,
+  startAnchor = "cohort start",
+  riskWindowEnd = 30,
+  endAnchor = "cohort end"
+)
+
+createStudyPopArgs2 <- createCreateStudyPopulationArgs(
+  removeSubjectsWithPriorOutcome = TRUE,
+  firstExposureOnly = TRUE,
+  restrictToCommonPeriod = TRUE,
+  removeDuplicateSubjects = "keep first",
+  washoutPeriod = 183,
+  censorAtNewRiskWindow = TRUE,
+  minDaysAtRisk = 1,
+  riskWindowStart = 0,
+  startAnchor = "cohort start",
+  riskWindowEnd = 30,
+  endAnchor = "cohort end"
+)
+
+## Analysis 1 ----
+fitOutcomeModelArgs1 <- createFitOutcomeModelArgs(
+  modelType = "cox"
+)
+
+cmAnalysis1 <- createCmAnalysis(
+  analysisId = 1,
+  description = "No matching, simple outcome model",
+  getDbCohortMethodDataArgs = getDbCmDataArgs,
+  createStudyPopArgs = createStudyPopArgs1,
+  fitOutcomeModelArgs = fitOutcomeModelArgs1
+)
+
+## Analysis 2 ----
+fitOutcomeModelArgs2 <- createFitOutcomeModelArgs(
+  modelType = "cox",
+  stratified = TRUE
+)
+
+cmAnalysis2 <- createCmAnalysis(
+  analysisId = 2,
+  description = "Matching",
+  getDbCohortMethodDataArgs = getDbCmDataArgs,
+  createStudyPopArgs = createStudyPopArgs2,
+  createPsArgs = createPsArgs,
+  matchOnPsArgs = matchOnPsArgs,
+  computeSharedCovariateBalanceArgs = computeSharedCovBalArgs,
+  computeCovariateBalanceArgs = computeCovBalArgs,
+  fitOutcomeModelArgs = fitOutcomeModelArgs2
+)
+
+## Analysis 3 ----
+fitOutcomeModelArgs3 <- createFitOutcomeModelArgs(
+  modelType = "cox",
+  inversePtWeighting = TRUE
+)
+cmAnalysis3 <- createCmAnalysis(
+  analysisId = 3,
+  description = "IPTW",
+  getDbCohortMethodDataArgs = getDbCmDataArgs,
+  createStudyPopArgs = createStudyPopArgs2,
+  createPsArgs = createPsArgs,
+  truncateIptwArgs = truncateIptwArgs,
+  computeSharedCovariateBalanceArgs = computeSharedCovBalArgs,
+  fitOutcomeModelArgs = fitOutcomeModelArgs3
+)
+
+## Analysis 4 ----
+fitOutcomeModelArgs4 <- createFitOutcomeModelArgs(
+  modelType = "cox",
+  stratified = TRUE,
+  interactionCovariateIds = 8532001
+)
+
+cmAnalysis4 <- createCmAnalysis(
+  analysisId = 4,
+  description = "Matching with gender interaction",
+  getDbCohortMethodDataArgs = getDbCmDataArgs,
+  createStudyPopArgs = createStudyPopArgs2,
+  createPsArgs = createPsArgs,
+  matchOnPsArgs = matchOnPsArgs,
+  fitOutcomeModelArgs = fitOutcomeModelArgs4
+)
+
+cmAnalysisList <- list(cmAnalysis1, cmAnalysis2, cmAnalysis3, cmAnalysis4)
+
+# Clean-up ----
+withr::defer({
+  unlink(outputFolder)
+})