Skip to content

Commit

Permalink
Updating Eumaeus Shiny app
Browse files Browse the repository at this point in the history
  • Loading branch information
@schuemie
schuemie committed Apr 6, 2021
1 parent ec0df0a commit 67079b1
Show file tree
Hide file tree
Showing 4 changed files with 144 additions and 16 deletions.
17 changes: 17 additions & 0 deletions Eumaeus/dataPulls.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
}
43 changes: 40 additions & 3 deletions Eumaeus/plotsAndTables.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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)
}
Expand Down Expand Up @@ -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) +
Expand Down Expand Up @@ -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)
}
68 changes: 68 additions & 0 deletions Eumaeus/server.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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({
Expand Down
32 changes: 19 additions & 13 deletions Eumaeus/ui.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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",
Expand Down

0 comments on commit 67079b1

Please sign in to comment.