fixing tests

- fixing tests - updates for Characterization v1.1.0 - updating example app
OHDSI · Jul 31, 2024 · 9888845 · 9888845
1 parent a7b6685
commit 9888845
Show file tree

Hide file tree

Showing 19 changed files with 109 additions and 100 deletions.
diff --git a/R/characterization-caseSeries.R b/R/characterization-caseSeries.R
@@ -190,7 +190,7 @@ characterizationGetCaseSeriesOptions <- function(
           and s.database_id = cd.database_id
           and cd.target_cohort_id = @target_id
           and cd.outcome_cohort_id = @outcome_id
-          and cd.cohort_type = 'TnO'
+          and cd.cohort_type = 'Cases'
           
           inner join
           @schema.@cg_table_prefixcohort_definition ct1
@@ -256,9 +256,9 @@ characterizationGetCaseSeriesData <- function(
 
   sql <- "SELECT 
   case 
-  when cov.cohort_type = 'TnO' then 'Before'
-  when cov.cohort_type = 'TnObetween' then 'During'
-  when cov.cohort_type = 'OnT' then 'After'
+  when cov.cohort_type = 'CasesBefore' then 'Before'
+  when cov.cohort_type = 'CasesBetween' then 'During'
+  when cov.cohort_type = 'CaseAfter' then 'After'
   end as type, 
   cr.covariate_name, 
   s.min_prior_observation, s.outcome_washout_days,
@@ -277,7 +277,7 @@ characterizationGetCaseSeriesData <- function(
 
           where cov.target_cohort_id = @target_id
           and cov.outcome_cohort_id = @outcome_id
-          and cov.cohort_type in ('TnObetween','OnT','TnO')
+          and cov.cohort_type in ('CasesBetween','CasesAfter','CasesBefore')
           --and cov.setting_id = @setting_id
           and s.risk_window_start = @risk_window_start
           and s.risk_window_end = @risk_window_end
@@ -309,9 +309,9 @@ characterizationGetCaseSeriesData <- function(
 
   sql <- "SELECT
     case 
-  when cov.cohort_type = 'TnO' then 'Before'
-  when cov.cohort_type = 'TnObetween' then 'During'
-  when cov.cohort_type = 'OnT' then 'After'
+  when cov.cohort_type = 'CasesBefore' then 'Before'
+  when cov.cohort_type = 'CasesBetween' then 'During'
+  when cov.cohort_type = 'CasesAfter' then 'After'
   end as type, 
   cr.covariate_name, 
     s.min_prior_observation, s.outcome_washout_days, 
@@ -333,7 +333,7 @@ characterizationGetCaseSeriesData <- function(
           
           where cov.target_cohort_id = @target_id
           and cov.outcome_cohort_id = @outcome_id
-          and cov.cohort_type in ('TnObetween','OnT','TnO')
+          and cov.cohort_type in ('CasesBetween','CasesAfter','CasesBefore')
           and s.risk_window_start = @risk_window_start
           and s.risk_window_end = @risk_window_end
           and s.start_anchor = '@start_anchor'

diff --git a/R/characterization-cohorts.R b/R/characterization-cohorts.R
@@ -968,7 +968,7 @@ characterizatonGetCohortComparisonDataContinuous <- function(
       res <- res %>% dplyr::select(-"cohortDefinitionId", -"databaseId", -"type",
                                    -"settingId", -"targetCohortId", -"outcomeCohortId", 
                                    -"cohortType") %>%
-        dplyr::relocate(.data$databaseName, .after = .data$covariateName)
+        dplyr::relocate("databaseName", .after = "covariateName")
     }
 
     shiny::incProgress(4/4, detail = paste("Done"))

diff --git a/R/characterization-incidence.R b/R/characterization-incidence.R
@@ -1215,9 +1215,9 @@ characterizationIncidenceServer <- function(
                           outcomeLabel = paste(.data$outcomeIdShort, " = ", .data$outcomeName),
                           ageGroupName = factor(.data$ageGroupName, levels = custom_age_sort(.data$ageGroupName), ordered = TRUE)
             ) %>%
-            dplyr::rename("Target" = "targetIdShort",
-                          "Outcome" = "outcomeIdShort",
-                          "Age" = "ageGroupName")
+            dplyr::rename(Target = "targetIdShort",
+                          Outcome = "outcomeIdShort",
+                          Age = "ageGroupName")
 
           # Get unique target and outcome labels
           unique_target_labels <- strwrap(unique(plotData$targetLabel), width = 300)
@@ -1362,9 +1362,9 @@ renderIrPlotStandardAgeSex <- shiny::reactive(
                     outcomeLabel = paste(outcomeIdShort, " = ", outcomeName),
                     ageGroupName = factor(ageGroupName, levels = custom_age_sort(ageGroupName), ordered = TRUE)
                     ) %>%
-      dplyr::rename("Target" = targetIdShort,
-             "Outcome" = outcomeIdShort,
-             "Age" = ageGroupName)
+      dplyr::rename(Target = "targetIdShort",
+             Outcome = "outcomeIdShort",
+             Age = "ageGroupName")
 
     # plotHeightStandardAgeSex <- shiny::reactive({
     #   paste(sum(length(unique(plotData$targetLabel)), length(unique(plotData$Age)), -3)*100, "px", sep="")
@@ -1512,9 +1512,9 @@ renderIrPlotStandardYear <- shiny::reactive(
                     outcomeLabel = paste(outcomeIdShort, " = ", outcomeName),
                     ageGroupName = factor(ageGroupName, levels = custom_age_sort(ageGroupName), ordered = TRUE)
       ) %>%
-      dplyr::rename("Target" = targetIdShort,
-                    "Outcome" = outcomeIdShort,
-                    "Age" = ageGroupName)
+      dplyr::rename(Target = "targetIdShort",
+                    Outcome = "outcomeIdShort",
+                    Age = "ageGroupName")
 
     #get unique shorthand cohort name
     unique_target <- unique(plotData$Target)
@@ -1668,9 +1668,9 @@ renderIrPlotStandardAggregate <- shiny::reactive(
       dplyr::mutate(targetLabel = paste(targetIdShort, " = ", targetName),
                     outcomeLabel = paste(outcomeIdShort, " = ", outcomeName)
       ) %>%
-      dplyr::rename("Target" = targetIdShort,
-                    "Outcome" = outcomeIdShort,
-                    "Age" = ageGroupName)
+      dplyr::rename(Target = "targetIdShort",
+                    Outcome = "outcomeIdShort",
+                    Age = "ageGroupName")
 
     # Get unique target and outcome labels
     unique_target_labels <- strwrap(unique(plotData$targetLabel), width = 300)

diff --git a/R/characterization-main.R b/R/characterization-main.R
@@ -639,7 +639,7 @@ select distinct
 target_cohort_id,
 outcome_cohort_id
 from @schema.@c_table_prefixcohort_details
-where cohort_type = 'TnO'
+where cohort_type = 'Cases'
 
 {@include_incidence} ? {
 union

diff --git a/R/characterization-riskFactors.R b/R/characterization-riskFactors.R
@@ -222,7 +222,7 @@ characterizationGetRiskFactorData <- function(
           where 
           cov.target_cohort_id = @target_id
           and cov.outcome_cohort_id in (0,@outcome_id)
-          and cov.cohort_type in ('Target','TnO', 'TnOprior')
+          and cov.cohort_type in ('Target','Cases', 'Exclude')
           and cov.database_id = '@database_id'
           and cov.setting_id in (@setting_ids)
           and cr.analysis_id not in (109, 110, 217, 218, 305, 417, 418, 505, 605, 713, 805, 926, 927)
@@ -264,7 +264,7 @@ characterizationGetRiskFactorData <- function(
           
           where cov.target_cohort_id = @target_id
           and cov.outcome_cohort_id in (0,@outcome_id)
-          and cov.cohort_type in ('Target','TnO', 'TnOprior')
+          and cov.cohort_type in ('Target','Cases', 'Exclude')
           and cov.database_id = '@database_id'
           and cov.setting_id in (@setting_ids)
           and cr.analysis_id not in (109, 110, 217, 218, 305, 417, 418, 505, 605, 713, 805, 926, 927)
@@ -354,7 +354,7 @@ riskFactorTable <- function(
 
   caseData <- data %>% 
     dplyr::filter(
-      .data$cohortType == 'TnO' &
+      .data$cohortType == 'Cases' &
       .data$outcomeWashoutDays == !!outcomeWashoutDay
         ) %>%
     dplyr::select(-"cohortType")
@@ -367,7 +367,7 @@ riskFactorTable <- function(
 
   excludeData <- data %>% 
     dplyr::filter(
-      .data$cohortType == 'TnOprior' & 
+      .data$cohortType == 'Exclude' & 
         .data$outcomeWashoutDays == !!outcomeWashoutDay
       ) %>%
     dplyr::select(-"cohortType")
@@ -417,6 +417,13 @@ riskFactorTable <- function(
       })
     }
 
+  } else{
+    # if no excludes we need to add N for the target
+    allData <- allData %>% 
+      dplyr::inner_join( # add N per washout/min obs
+        allcounts, 
+        by = c('minPriorObservation')
+      ) 
     }
 
   if(nrow(caseData) > 0){
@@ -487,8 +494,8 @@ riskFactorTable <- function(
       dplyr::mutate(
         outcomeWashoutDays = !!outcomeWashoutDay
       ) %>%
-      dplyr::relocate(.data$outcomeWashoutDays, 
-                      .after = .data$minPriorObservation)
+      dplyr::relocate("outcomeWashoutDays", 
+                      .after = "minPriorObservation")
 
     completeData <- rbind(allData, completeData)
 
@@ -522,7 +529,7 @@ riskFactorContinuousTable <- function(
   data <- unique(data)
 
   caseData <- data %>% 
-    dplyr::filter(.data$cohortType == 'TnO') %>%
+    dplyr::filter(.data$cohortType == 'Cases') %>%
     dplyr::select(-"cohortType")
 
   allData <- data %>% 

diff --git a/R/cohort-diagnostics-characterization.R b/R/cohort-diagnostics-characterization.R
@@ -419,7 +419,7 @@ prepareTable1 <- function(covariates,
       "characteristic",
       "valueCount"
     ) %>%
-    dplyr::rename("count" = "valueCount") %>%
+    dplyr::rename(count = "valueCount") %>%
     dplyr::inner_join(cohort %>%
                         dplyr::select(
                           "cohortId",
@@ -739,7 +739,7 @@ cohortDiagCharacterizationModule <- function(
           "covariateName",
           "mean"
         ) %>%
-        dplyr::rename("sumValue" = "mean")
+        dplyr::rename(sumValue = "mean")
 
 
       table <- data %>%

diff --git a/R/estimation-cohort-method-covariateBalance.R b/R/estimation-cohort-method-covariateBalance.R
@@ -497,8 +497,8 @@ plotCohortMethodCovariateBalanceSummary <- function(balanceSummary,
                                                 upper = .data$upper,
                                                 ymax = .data$ymax,
                                                 group = .data$databaseId)) +
-    ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymin, ymax = .data$ymin), size = 1) +
-    ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymax, ymax = .data$ymax), size = 1) +
+    ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymin, ymax = .data$ymin), linewidth = 1) +
+    ggplot2::geom_errorbar(ggplot2::aes(ymin = .data$ymax, ymax = .data$ymax), linewidth = 1) +
     ggplot2::geom_boxplot(stat = "identity", fill = grDevices::rgb(0, 0, 0.8, alpha = 0.25), size = 1) +
     ggplot2::geom_hline(yintercept = 0) +
     ggplot2::scale_x_continuous(limits = c(0.5, max(vizData$x) + 1.75)) +

diff --git a/R/estimation-cohort-method-diagnostics.R b/R/estimation-cohort-method-diagnostics.R
@@ -127,7 +127,7 @@ estimationGetCmDiagnostics <- function(
 
   # add summaryValue after outcome
   result <- result %>% 
-    dplyr::relocate(.data$summaryValue, .after = .data$outcome)
+    dplyr::relocate("summaryValue", .after = "outcome")
 
   return(
     result

diff --git a/R/estimation-cohort-method-full-result.R b/R/estimation-cohort-method-full-result.R
@@ -76,11 +76,11 @@ estimationCmFullResultServer <- function(
             "cdmSourceAbbreviation"
           ) %>%
           dplyr::rename(
-            'Target' = .data$target,
-            'Comparator' = .data$comparator,
-            'Outcome' = .data$outcome,
-            'Analysis' = .data$description,
-            'Database' = .data$cdmSourceAbbreviation
+            Target = "target",
+            Comparator = "comparator",
+            Outcome = "outcome",
+            Analysis = "description",
+            Database = "cdmSourceAbbreviation"
           )
       })
 

diff --git a/R/estimation-sccs-results-full.R b/R/estimation-sccs-results-full.R
@@ -145,10 +145,10 @@ estimationSccsFullResultServer <- function(
             "databaseName"
           ) %>%
           dplyr::rename(
-            'Indication' = .data$indication,
-            'Outcome' = .data$outcome,
-            'Analysis' = .data$description,
-            'Database' = .data$databaseName
+            Indication = "indication",
+            Outcome = "outcome",
+            Analysis = "description",
+            Database = "databaseName"
           )
       })
 

diff --git a/R/helpers-sccsPlots.R b/R/helpers-sccsPlots.R
@@ -175,24 +175,21 @@ plotTimeToEventSccs <- function(timeToEvent) {
 
 drawAttritionDiagram <- function(attrition) {
 
-  formatNumber <- function(x) {
-    return(formatC(x, big.mark = ","))
-  }
-
+
   addStep <- function(data, attrition, row) {
     data$leftBoxText[length(data$leftBoxText) + 1] <- paste(attrition$description[row],
                                                             "\n",
                                                             "Cases: ",
-                                                            formatNumber(attrition$outcomeSubjects[row]),
+                                                            format(attrition$outcomeSubjects[row], scientific = FALSE),
                                                             "\n",
                                                             "Outcomes: ",
-                                                            formatNumber(attrition$outcomeEvents[row]),
+                                                            format(attrition$outcomeEvents[row], scientific = FALSE),
                                                             sep = "")
     data$rightBoxText[length(data$rightBoxText) + 1] <- paste("Cases: ",
-                                                              formatNumber(data$currentCases - attrition$outcomeSubjects[row]),
+                                                              format(data$currentCases - attrition$outcomeSubjects[row], scientific = FALSE),
                                                               "\n",
                                                               "Outcomes: ",
-                                                              formatNumber(data$currentOutcomes - attrition$outcomeEvents[row]),
+                                                              format(data$currentOutcomes - attrition$outcomeEvents[row], scientific = FALSE),
                                                               sep = "")
     data$currentCases <- attrition$outcomeSubjects[row]
     data$currentOutcomes <- attrition$outcomeEvents[row]
@@ -201,10 +198,10 @@ drawAttritionDiagram <- function(attrition) {
 
   data <- list(leftBoxText = c(paste("All outcomes occurrences:\n",
                                      "Cases: ",
-                                     formatNumber(attrition$outcomeSubjects[1]),
+                                     format(attrition$outcomeSubjects[1], scientific = FALSE),
                                      "\n",
                                      "Outcomes: ",
-                                     formatNumber(attrition$outcomeEvents[1]),
+                                     format(attrition$outcomeEvents[1], scientific = FALSE),
                                      sep = "")),
                rightBoxText = c(""),
                currentCases = attrition$outcomeSubjects[1],

diff --git a/R/report-main.R b/R/report-main.R
@@ -932,7 +932,7 @@ getTandOs <- function(
     by.y = 'cohortDefinitionId'
   ) %>%
     dplyr::rename(
-      targetName = 'cohortName'
+      targetName = "cohortName"
       )
 
   res <- merge(
@@ -942,7 +942,7 @@ getTandOs <- function(
     by.y = 'cohortDefinitionId'
   ) %>%
     dplyr::rename(
-      outcomeName = 'cohortName'
+      outcomeName = "cohortName"
       ) %>%
     dplyr::arrange(
       .data$targetName,
@@ -1021,7 +1021,7 @@ getTandOs <- function(
       by.x = 'comparatorId', 
       by.y = 'cohortDefinitionId'
     ) %>%
-      dplyr::rename(comparatorName = 'cohortName')
+      dplyr::rename(comparatorName = "cohortName")
 
     cs <- lapply(unique(comps$targetId), function(tid){
       data.frame(

diff --git a/extras/codeToCreateCharacterizationDatabase.R b/extras/codeToCreateCharacterizationDatabase.R
@@ -44,29 +44,44 @@ Characterization::runCharacterizationAnalyses(
   outcomeDatabaseSchema = "main", 
   outcomeTable = "cohort", 
   cdmDatabaseSchema = "main", 
-  characterizationSettings = charSet, 
-  saveDirectory = file.path(testDir,'charDatabase'), 
+  characterizationSettings = charSet, incremental = F,
+  executionPath = file.path(testDir,'charDatabase','execution'),
+  outputDirectory =  file.path(testDir,'charDatabase', 'results'), 
   databaseId = 'eunomia', 
-  tablePrefix = 'c_'
+  csvFilePrefix =  'c_'
   )
 
+#serverDesc <- file.path(getwd(),
+#                        'inst/extdata/results.sqlite')
 serverDesc <- "tests/resources/charDatabase/databaseFile.sqlite"
 connectionDetailsDesc <- DatabaseConnector::createConnectionDetails(
   dbms = 'sqlite',
   server = serverDesc
 )
 
+if(F){
+for(table in c('c_time_to_event', 'c_dechallenge_rechallenge',
+               'c_analysis_ref', 'c_covariate_ref', 'c_covariates',
+               'c_covariates_continuous', 'c_settings', 
+               'c_cohort_details', 'c_cohort_counts')){
+  sql <- "UPDATE main.@tbl SET database_id = '85642205.0';"
+  sql <- SqlRender::render(sql, tbl = table)
+  DatabaseConnector::executeSql(con, sql)
+}
+}
+
 Characterization::createCharacterizationTables(
   connectionDetails = connectionDetailsDesc, 
   resultSchema = 'main', 
-  createTables = T
+  createTables = T, 
+  deleteExistingTables = T
   )
 
 Characterization::insertResultsToDatabase(
   connectionDetails = connectionDetailsDesc, 
   schema = 'main', 
   resultsFolder = file.path(testDir,'charDatabase', 'results'), 
-  tablePrefix = 'c_'
+  csvTablePrefix =  'c_'
   )
 
 if(F){