diff --git a/Eumaeus/dataPulls.R b/Eumaeus/dataPulls.R index 7b370eb7..476a5bb5 100644 --- a/Eumaeus/dataPulls.R +++ b/Eumaeus/dataPulls.R @@ -56,3 +56,20 @@ getEstimates <- function(connection, schema, databaseId, exposureId, timeAtRisk) return(subset) } + +getMontlyRates <- function(connection, schema, databaseId, startDate, endDate) { + sql <- sprintf("SELECT * + FROM %s.monthly_rate + WHERE database_id = '%s' + AND start_date >= '%s' + AND end_date <= '%s';", + schema, + databaseId, + format(startDate, "%Y-%m-%d"), + format(endDate, "%Y-%m-%d")) + rates <- DatabaseConnector::dbGetQuery(connection, sql) + colnames(rates) <- SqlRender::snakeCaseToCamelCase(colnames(rates)) + rates <- rates %>% + mutate(ir = abs(1000 * .data$outcomes / (.data$days / 365.25))) + return(rates) +} \ No newline at end of file diff --git a/Eumaeus/plotsAndTables.R b/Eumaeus/plotsAndTables.R index 0262ea99..c88a2175 100644 --- a/Eumaeus/plotsAndTables.R +++ b/Eumaeus/plotsAndTables.R @@ -421,7 +421,7 @@ plotSensSpecAcrossMethods <- function(estimates, trueRr = "Overall") { bind_rows() %>% bind_rows(data) } - + theme <- element_text(colour = "#000000", size = 14) themeRA <- element_text(colour = "#000000", size = 14, hjust = 1) themeLA <- element_text(colour = "#000000", size = 14, hjust = 0) @@ -489,7 +489,7 @@ plotLlrs <- function(d, vaccinationsSubset, trueRr = "Overall") { themeRA <- element_text(colour = "#000000", size = 14, hjust = 1) themeLA <- element_text(colour = "#000000", size = 14, hjust = 0) yBreaks <- c(0, 1, 2, 3, 4, 5, 10, 20, 30, 40, 50, 100) - + f <- function(y) { log10(y + 1) } @@ -645,7 +645,7 @@ plotDbCharacteristics <- function(databaseCharacterization) { substr(x, 1, 1) <- toupper(substr(x, 1, 1)) return(paste0(" ", x)) } - + plot2 <- ggplot2::ggplot(observationDuration, ggplot2::aes(x = stratum, y = subjectCount)) + ggplot2::geom_bar(stat = "identity", color = rgb(0,0,0, alpha = 0), fill = "#547BD3", alpha = 0.8, width = 1) + ggplot2::geom_hline(yintercept = 0) + @@ -770,3 +770,40 @@ plotEstimatesAcrossPeriods <- function(d, trueRr = "Overall") { legend.position = "top") return(plot) } + +plotMonthlyRates <- function(monthlyRates, + historyStartDate, + historyEndDate, + startDate, + endDate, + negativeControlOutcome, + positiveControlOutcome) { + + minY <- min(monthlyRates$ir) + maxY <- max(monthlyRates$ir) + minX <- min(monthlyRates$endDate) + monthlyRates <- monthlyRates %>% + inner_join(bind_rows(select(negativeControlOutcome, .data$outcomeId, .data$outcomeName), + select(positiveControlOutcome, .data$outcomeId, .data$outcomeName)), + by = "outcomeId") + monthlyRates$outcomeId <- as.factor(monthlyRates$outcomeId) + f <- function(x) { + log(x) + } + if (maxY < 1) { + breaks <- seq(0, maxY, by = 0.1) + } else { + breaks <- seq(0, maxY, by = 1) + } + plot <- ggplot(monthlyRates) + + geom_line(aes(x = endDate, y = f(ir), group = outcomeName, color = outcomeName), size = 1, alpha = 0.8) + + geom_point(x = as.Date("2009-01-01"), y = 0.1) + + geom_rect(xmin = minX, xmax = historyStartDate, ymin = f(minY), ymax = f(maxY), fill = rgb(1, 1, 1, alpha = 0.05)) + + geom_rect(xmin = historyEndDate, xmax = startDate, ymin = f(minY), ymax = f(maxY), fill = rgb(1, 1, 1, alpha = 0.05)) + + geom_vline(xintercept = c(historyStartDate, historyEndDate, startDate)) + + geom_text(x = historyStartDate + 7, y = f(maxY - 0.05), label = "Historic period", hjust = 0) + + scale_y_continuous("Incidence rate (per 1,000 patient years)", breaks = f(breaks), labels = breaks) + + theme(legend.position = "top", + legend.title = element_blank()) + return(plot) +} diff --git a/Eumaeus/server.R b/Eumaeus/server.R index 31420e93..c8ccd848 100644 --- a/Eumaeus/server.R +++ b/Eumaeus/server.R @@ -216,6 +216,74 @@ shinyServer(function(input, output, session) { ) }) + observe({ + subset <- selectedEstimates() + if (is.null(subset)) { + return(NULL) + } + if (subset$method[1] == "HistoricalComparator") { + showTab(inputId = "perPeriodTabSetPanel", target = "Diagnostics") + } else { + hideTab(inputId = "perPeriodTabSetPanel", target = "Diagnostics") + } + }) + + monthlyRatesDateRanges <- reactive({ + endDate <- timePeriod %>% + filter(.data$exposureId == exposureId() & .data$label== input$period) %>% + pull(.data$endDate) + + dateRanges <- exposure %>% + filter(.data$exposureId == exposureId()) %>% + select(.data$historyStartDate, .data$historyEndDate, .data$startDate) %>% + mutate(endDate = !!endDate) + return(dateRanges) + }) + + monthlyRates <- reactive({ + dateRanges <- monthlyRatesDateRanges() + + monthlyRates <- getMontlyRates(connection = connectionPool, + schema = schema, + databaseId = input$database, + startDate = dateRanges$historyStartDate - 366, + endDate = dateRanges$endDate) + return(monthlyRates) + }) + + filteredMonthlyRates <- reactive({ + monthlyRates <- monthlyRates() + dateRanges <- monthlyRatesDateRanges() + threshold <- input$minRateChange / 100 + historicIr <- monthlyRates %>% + filter(.data$endDate > dateRanges$historyStartDate & .data$startDate < dateRanges$historyEndDate) %>% + group_by(.data$outcomeId) %>% + summarise(historicIr = sum(.data$outcomes) / sum(.data$days)) + currentIr <- monthlyRates %>% + filter(.data$endDate > dateRanges$startDate & .data$startDate < dateRanges$endDate) %>% + group_by(.data$outcomeId) %>% + summarise(currentIr = sum(.data$outcomes) / sum(.data$days)) + outcomeIds <- inner_join(historicIr, currentIr, by = "outcomeId") %>% + mutate(delta = abs((.data$currentIr - .data$historicIr) / .data$historicIr)) %>% + filter(.data$delta > threshold) %>% + pull(.data$outcomeId) + ratesSubset <- monthlyRates %>% + filter(.data$outcomeId %in% outcomeIds) + return(ratesSubset) + }) + + output$monthlyRates <- renderPlot({ + rates <- filteredMonthlyRates() + dateRanges <- monthlyRatesDateRanges() + plotMonthlyRates(monthlyRates = rates, + historyStartDate = dateRanges$historyStartDate, + historyEndDate = dateRanges$historyEndDate, + startDate = dateRanges$startDate, + endDate = dateRanges$endDate, + negativeControlOutcome, + positiveControlOutcome) + }) + # Across periods filterEstimatesAcrossPeriods <- reactive({ diff --git a/Eumaeus/ui.R b/Eumaeus/ui.R index 1278accc..8f99dbde 100644 --- a/Eumaeus/ui.R +++ b/Eumaeus/ui.R @@ -30,19 +30,25 @@ shinyUI( uiOutput("tableCaption"), conditionalPanel(condition = "output.details", div(style = "display:inline-block", h4(textOutput("details"))), - tabsetPanel( - tabPanel("Estimates", - uiOutput("hoverInfoEstimates"), - plotOutput("estimates", - height = "270px", - hover = hoverOpts("plotHoverInfoEstimates", - delay = 100, - delayType = "debounce")), - div(strong("Figure 1.1."),"Estimates with standard errors for the negative and positive controls, stratified by true effect size. Estimates that fall above the red dashed lines have a confidence interval that includes the truth. Hover mouse over point for more information.")), - tabPanel("ROC curves", - plotOutput("rocCurves", - height = "420px"), - div(strong("Figure 1.2."),"Receiver Operator Characteristics curves for distinguising positive controls from negative controls.")) + tabsetPanel(id = "perPeriodTabSetPanel", + tabPanel("Estimates", + uiOutput("hoverInfoEstimates"), + plotOutput("estimates", + height = "270px", + hover = hoverOpts("plotHoverInfoEstimates", + delay = 100, + delayType = "debounce")), + div(strong("Figure 1.1."),"Estimates with standard errors for the negative and positive controls, stratified by true effect size. Estimates that fall above the red dashed lines have a confidence interval that includes the truth. Hover mouse over point for more information.")), + tabPanel("ROC curves", + plotOutput("rocCurves", + height = "420px"), + div(strong("Figure 1.2."),"Receiver Operator Characteristics curves for distinguising positive controls from negative controls.")), + tabPanel("Diagnostics", + sliderInput("minRateChange", "Minimum relative rate change (%)", min = 0, max = 100, value = 50), + plotOutput("monthlyRates", + height = "420px"), + div(strong("Figure 1.3."),"Receiver Operator Characteristics curves for distinguising positive controls from negative controls.") + ) ) )), tabPanel("Across periods",