minor updates

- fixed bug with control estimates plot not showing all results
- added ease value to control estimate plot
- added validation checks to print informative reason for missing plots

R/estimation-sccs-results-full.R

@@ -436,7 +436,10 @@ estimationSccsFullResultServer <- function(
             analysisId = row$analysisId,
             eraId = row$eraId
           )
-          plotControlEstimates(controlEstimates)
+          plotControlEstimates(
+            controlEstimates = controlEstimates$plotResult,
+            ease = controlEstimates$ease
+            )
         }
       })
 
@@ -582,8 +585,13 @@ estimationGetSccsTimeToEvent <- function(
     snakeCaseToCamelCase = TRUE
   )
 
+  # if NULL set to NA so code below works
+  if(is.null(p$preExposureP)){
+    p$preExposureP <- NA
+  }
+
   sql <- "
-  SELECT *, @p as p
+  SELECT * , @p as p
   FROM @schema.@sccs_table_prefixtime_to_event
 
   WHERE database_id = '@database_id'
@@ -600,10 +608,11 @@ estimationGetSccsTimeToEvent <- function(
     analysis_id = analysisId,
     exposures_outcome_set_id = exposuresOutcomeSetId,
     exposure_id = exposureId,
-    p = ifelse(is.null(p$preExposureP), -1, p$preExposureP),
+    p = ifelse(is.na(p$preExposureP), -1, p$preExposureP),
     snakeCaseToCamelCase = TRUE
   )
 
+
   return(timeToEvent)
 }
 
@@ -739,7 +748,7 @@ estimationGetSccsControlEstimates <- function(
   INNER JOIN
    @schema.@sccs_table_prefixexposure e
    on r.exposures_outcome_set_id = e.exposures_outcome_set_id
-   
+
    INNER JOIN 
    @schema.@sccs_table_prefixcovariate c
    on e.era_id = c.era_id 
@@ -748,13 +757,14 @@ estimationGetSccsControlEstimates <- function(
    and c.analysis_id = r.analysis_id
    and c.covariate_id = r.covariate_id
    
-   WHERE e.era_id = @era_id
-   AND r.database_id = '@database_id'
+   WHERE r.database_id = '@database_id'
    AND r.analysis_id = @analysis_id
    AND r.covariate_id = @covariate_id
    AND e.true_effect_size is not NULL
+   -- AND e.era_id = @era_id
   ;
   "
+
   res <- connectionHandler$queryDb(
     sql,
     schema = resultDatabaseSettings$schema,
@@ -766,7 +776,26 @@ estimationGetSccsControlEstimates <- function(
     snakeCaseToCamelCase = TRUE
   )
 
-  #allres <- merge(res, res2, by = 'exposuresOutcomeSetId')
+  # get ease for the plot
+  sql <- "SELECT top 1 ds.ease
+  FROM @schema.@sccs_table_prefixdiagnostics_summary ds
+  WHERE ds.database_id = '@database_id'
+  AND ds.analysis_id = @analysis_id
+  AND ds.covariate_id = @covariate_id;"
 
-  return(res)
+  ease <- connectionHandler$queryDb(
+    sql,
+    schema = resultDatabaseSettings$schema,
+    sccs_table_prefix = resultDatabaseSettings$sccsTablePrefix,
+    database_id = databaseId,
+    covariate_id = covariateId,
+    analysis_id = analysisId,
+    snakeCaseToCamelCase = TRUE
+  )
+
+  return(list(
+    plotResult = res,
+    ease = ease$ease
+    )
+  )
 }

R/helpers-sccsPlots.R

@@ -120,7 +120,9 @@ plotTimeTrend <- function(timeTrend) {
 
 
 plotTimeToEventSccs <- function(timeToEvent) {
-
+  if(nrow(timeToEvent) == 0){
+    shiny::validate('No Rows')
+  }
   events <- timeToEvent %>%
     dplyr::transmute(.data$week,
                      type = "Events",
@@ -300,12 +302,23 @@ drawAttritionDiagram <- function(attrition) {
 }
 
 plotEventDepObservation <- function(eventDepObservation, maxMonths = 12) {
+  if(nrow(eventDepObservation) == 0){
+    shiny::validate('No Rows')
+  }
+
   eventDepObservation <- eventDepObservation %>%
     dplyr::filter(.data$monthsToEnd <= maxMonths) %>%
     dplyr::mutate(
       outcomes = pmax(0, .data$outcomes),
       censoring = ifelse(.data$censored == 1, "Censored", "Uncensored")
     )
+  if(nrow(eventDepObservation) == 0){
+    shiny::validate('No Rows after filtering')
+  }
+  if(is.infinite(max(eventDepObservation$monthsToEnd))){
+    shiny::validate('Infinite max')
+  }
+
   timeBreaks <- 0:ceiling(max(eventDepObservation$monthsToEnd))
   timeLabels <- timeBreaks * 30.5
 
@@ -335,7 +348,20 @@ plotEventDepObservation <- function(eventDepObservation, maxMonths = 12) {
 }
 
 plotSpanning <- function(spanning, type = "age") {
+
+  if(nrow(spanning) == 0){
+    shiny::validate('No rows')
+  }
+
   if (type == "age") {
+
+    if(is.infinite(min(spanning$ageMonth))){
+      shiny::validate('infinte min age month')
+    }
+    if(is.infinite(max(spanning$ageMonth))){
+      shiny::validate('infinte max age month')
+    }
+
     spanning <- spanning %>%
       dplyr::mutate(x = .data$ageMonth)
     labels <- seq(ceiling(min(spanning$ageMonth) / 12), floor(max(spanning$ageMonth) / 12))
@@ -537,10 +563,16 @@ cyclicSplineDesign <- function(x, knots, ord = 4) {
   X1
 }
 
-plotControlEstimates <- function(controlEstimates) {
+plotControlEstimates <- function(
+    controlEstimates, 
+    ease = NULL
+    ) {
     if(nrow(controlEstimates) == 0){
       shiny::validate('No rows')
     } 
+
+  titleText <- paste('Ease: ', ease)
+
   size <- 2
   labelY <- 0.7
   d <- rbind(data.frame(yGroup = "Uncalibrated",
@@ -636,7 +668,8 @@ plotControlEstimates <- function(controlEstimates) {
                    strip.text.x = theme,
                    strip.text.y = theme,
                    strip.background = ggplot2::element_blank(),
-                   legend.position = "none")
+                   legend.position = "none") +
+    ggplot2::ggtitle(label = titleText)
   return(plot)
 }
 

R/sccs-results-full.R

@@ -412,7 +412,7 @@ sccsFullResultServer <- function(
             databaseId = row$databaseId,
             analysisId = row$analysisId
           )
-          plotControlEstimates(controlEstimates)
+          plotControlEstimates(controlEstimates = controlEstimates)
         }
       })
 

tests/testthat/test-helpers-sccsPlots.R

@@ -130,7 +130,7 @@ test_that("plotControlEstimates", {
     trueEffectSize = rep(1,100)
   )
 
-  res <- plotControlEstimates(df)
+  res <- plotControlEstimates(controlEstimates = df)
   testthat::expect_is(res, "ggplot")
 })