Updated plot for SCCS time trends (#200)

* Updated plot for SCCS time trends * updated figure text * fix test for old data and add new test
OHDSI · Sep 26, 2023 · 0f4c073 · 0f4c073
1 parent e7589b8
commit 0f4c073
Show file tree

Hide file tree

Showing 4 changed files with 71 additions and 5 deletions.
diff --git a/R/helpers-sccsDataPulls.R b/R/helpers-sccsDataPulls.R
@@ -205,7 +205,6 @@ getSccsTimeTrend <- function(connectionHandler,
     database_id = databaseId,
     analysis_id = analysisId,
     outcome_id = outcomeId,
-    #exposure_id = exposureId,
     snakeCaseToCamelCase = TRUE
   )
 }

diff --git a/R/helpers-sccsPlots.R b/R/helpers-sccsPlots.R
@@ -18,7 +18,7 @@ convertToEndDate <- function(year, month) {
   )) - 1)
 }
 
-plotTimeTrend <- function(timeTrend) {
+plotTimeTrendStability <- function(timeTrend) {
 
   timeTrend <- timeTrend %>%
     dplyr::mutate(
@@ -71,6 +71,54 @@ plotTimeTrend <- function(timeTrend) {
   return(plot)
 }
 
+plotTimeTrend <- function(timeTrend) {
+
+  timeTrend <- timeTrend %>%
+    dplyr::mutate(
+      monthStartDate = convertToStartDate(.data$calendarYear, .data$calendarMonth),
+      monthEndDate = convertToEndDate(.data$calendarYear, .data$calendarMonth),
+      ratio = pmax(0, .data$ratio),
+      adjustedRatio = pmax(0, .data$adjustedRatio))
+
+  plotData <- dplyr::bind_rows(
+    dplyr::select(timeTrend, "monthStartDate", "monthEndDate", value = "ratio") %>%
+      dplyr::mutate(type = "Assuming constant rate"),
+    dplyr::select(timeTrend, "monthStartDate", "monthEndDate", value = "adjustedRatio") %>%
+      dplyr::mutate(type = "Adj. For cal. time and season")
+  )
+
+  levels <- c("Assuming constant rate", "Adj. For cal. time and season")
+  plotData$type <- factor(plotData$type, levels = rev(levels))
+
+  theme <- ggplot2::element_text(colour = "#000000", size = 14)
+  themeRA <- ggplot2::element_text(colour = "#000000", size = 14, hjust = 1)
+  plot <- ggplot2::ggplot(plotData, ggplot2::aes(xmin = .data$monthStartDate, xmax = .data$monthEndDate + 1)) +
+    ggplot2::geom_rect(ggplot2::aes(ymax = .data$value),
+                       ymin = 0,
+                       fill = grDevices::rgb(0, 0, 0.8, alpha = 0.6),
+                       alpha = 0.6,
+                       linewidth = 0) +
+    ggplot2::scale_x_date("Calendar time") +
+    ggplot2::scale_y_continuous("Observed / expected", limits = c(0, NA)) +
+    ggplot2::facet_grid(.data$type ~ ., scales = "free_y") +
+    ggplot2::theme(
+      panel.grid.minor = ggplot2::element_blank(),
+      panel.background = ggplot2::element_rect(fill = "#FAFAFA", colour = NA),
+      panel.grid.major = ggplot2::element_line(colour = "#AAAAAA"),
+      axis.ticks = ggplot2::element_blank(),
+      axis.text.y = themeRA,
+      axis.text.x = theme,
+      axis.title = theme,
+      strip.text.y = theme,
+      strip.background = ggplot2::element_blank(),
+      legend.title = ggplot2::element_blank(),
+      legend.position = "top",
+      legend.text = theme
+    )
+  return(plot)
+}
+
+
 plotTimeToEventSccs <- function(timeToEvent) {
 
   events <- timeToEvent %>%

diff --git a/R/sccs-results-full.R b/R/sccs-results-full.R
@@ -65,7 +65,7 @@ sccsFullResultViewer <- function(id) {
           shiny::plotOutput(ns("timeTrendPlot"), height = 600),
           shiny::div(
             shiny::strong("Figure 4."),
-            "Per calendar month the number of people observed, the unadjusted rate of the outcome, and the rate of the outcome after adjusting for age, season, and calendar time, if specified in the model. Red indicates months where the adjusted rate was significantly different from the mean adjusted rate."
+            "The ratio of observed to expected outcomes per month. The expected count is computing either assuming a constant rate (bottom plot) or adjusting for calendar time, seasonality, and / or age, as specified in the model (top plot)."
           )
         ),
         shiny::tabPanel(
@@ -224,7 +224,12 @@ sccsFullResultServer <- function(
             databaseId = row$databaseId,
             analysisId = row$analysisId
           )
-          plotTimeTrend(timeTrend)
+
+          if (all(c(hasData(timeTrend$ratio), hasData(timeTrend$adjustedRatio)))) {
+            plotTimeTrend(timeTrend)
+          } else {
+            plotTimeTrendStability(timeTrend)
+          }
         }
       })
 

diff --git a/tests/testthat/test-helpers-sccsPlots.R b/tests/testthat/test-helpers-sccsPlots.R
@@ -6,7 +6,8 @@ test_that("convert to dates", {
   testthat::expect_equal(as.character(convertToEndDate(2020,12)), "2020-12-31")
 })
 
-test_that("plotTimeTrend", {
+# Note - this is the old plot
+test_that("plotTimeTrendStability", {
   df <- data.frame(
     calendarYear = c(2011,2012),
     calendarMonth = c(1,1),
@@ -15,11 +16,24 @@ test_that("plotTimeTrend", {
     adjustedRate = runif(2),
     stable = rep(1,2)
   )
+  res <- plotTimeTrendStability(df)
+  testthat::expect_is(res, "ggplot")
+})
+# New plot
+test_that("plotTimeTrend", {
+  df <- data.frame(
+    calendarYear = c(2011,2012),
+    calendarMonth = c(1,1),
+    ratio = runif(2),
+    observedSubjects = rep(100,2),
+    adjustedRatio = runif(2)
+  )
   res <- plotTimeTrend(df)
   testthat::expect_is(res, "ggplot")
 })
 
 
+
 test_that("plotTimeToEventSccs", {
 
   df <- data.frame(