Skip to content

Commit

Permalink
Adding plots across methods to Eumaeus
Browse files Browse the repository at this point in the history
  • Loading branch information
@schuemie
schuemie committed Apr 1, 2021
1 parent d265511 commit ec0df0a
Show file tree
Hide file tree
Showing 4 changed files with 275 additions and 74 deletions.
2 changes: 1 addition & 1 deletion Eumaeus/global.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -31,7 +31,7 @@ vaccinations <- getVaccinations(connectionPool, schema)

# subset <- getEstimates(connection = connectionPool,
# schema = schema,
# databaseId = "IBM_MDCD",
# databaseId = "IBM_MDCR",
# exposureId = 21184,
# timeAtRisk = "1-28")

Expand Down
148 changes: 146 additions & 2 deletions Eumaeus/plotsAndTables.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -286,8 +286,6 @@ computeMaxSprtMetrics <- function(estimates, trueRr = "Overall") {

if (trueRr == "Overall") {
forEval <- estimates
} else if (trueRr == ">1") {
forEval <- estimates[estimates$effectSize > 1, ]
} else {
forEval <- estimates[estimates$effectSize == 1 | estimates$effectSize == as.numeric(trueRr), ]
}
Expand Down Expand Up @@ -315,6 +313,152 @@ computeMaxSprtMetrics <- function(estimates, trueRr = "Overall") {
return(result)
}

plotMaxSprtSensSpecAcrossMethods <- function(estimates, trueRr = "Overall") {
if (!"effectSize" %in% colnames(estimates))
stop("Must add column 'effectSize' to estimates (e.g. using addTrueEffectSize())")

if (trueRr != "Overall") {
estimates <- estimates[estimates$effectSize == 1 | estimates$effectSize == as.numeric(trueRr), ]
}
computeSensSpec <- function(subset) {
result <- computeMaxSprtMetricsPerPeriod(subset) %>%
mutate(method = subset$method[1],
analysisId = subset$analysisId[1])
return(result)
}

effectSizes <- unique(estimates$effectSize)
effectSizes <- effectSizes[effectSizes > 1]
effectSizes <- effectSizes[order(effectSizes)]
data <- tibble()
for (effectSize in effectSizes) {
subset <- estimates[estimates$effectSize == 1 | estimates$effectSize == effectSize, ]
data <- lapply(split(subset, paste(subset$method, subset$analysisId)), computeSensSpec) %>%
bind_rows() %>%
mutate(group = sprintf("Sensitivity when\ntrue effect = %s", effectSize)) %>%
bind_rows(data)
}
data <- data %>%
filter(.data$group == data$group[1]) %>%
mutate(value = .data$specificity,
group = "Specificity") %>%
select(-.data$sensitivity, -.data$specificity) %>%
bind_rows(data %>%
mutate(value = .data$sensitivity) %>%
select(-.data$sensitivity, -.data$specificity))

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)
yBreaks <- c(0, 0.2, 0.4, 0.6, 0.8, 0.9, 1)
f <- function(x) {
-log(1.1 - x)
}
cutoff <- expand.grid(group = sprintf("Sensitivity when\ntrue effect = %s", effectSizes), method = unique(data$method)) %>%
mutate(value = 0.8,
analysisId = 1)


data$analysisId <- as.factor(data$analysisId)
data$group <- factor(data$group, levels = rev(c("Specificity", sprintf("Sensitivity when\ntrue effect = %s", effectSizes))))
plot <- ggplot(data, aes(x = .data$periodId, y = f(.data$value), group = .data$analysisId, color = .data$analysisId)) +
geom_hline(aes(yintercept = f(.data$value)), size = 1, color = rgb(0, 0, 0), linetype = "dashed", data = cutoff) +
geom_line(size = 1, alpha = 0.5) +
geom_point(size = 2, alpha = 0.7) +
scale_x_continuous("Time (Months)", breaks = 1:max(data$periodId), limits = c(1, max(data$periodId))) +
scale_y_continuous("Sensitivity / Specificity", limits = f(c(0, 1)), breaks = f(yBreaks), labels = yBreaks) +
labs(color = "Analysis ID") +
facet_grid(group ~ method) +
theme(axis.text.y = theme,
axis.text.x = theme,
axis.title.x = theme,
axis.title.y = element_blank(),
strip.text.x = theme,
strip.text.y = theme,
strip.background = element_blank(),
legend.text = themeLA,
legend.title = themeLA,
legend.position = "right")
# plot
return(plot)
}

# estimates <- addTrueEffectSize(estimates, negativeControlOutcome, positiveControlOutcome)
plotSensSpecAcrossMethods <- function(estimates, trueRr = "Overall") {
if (!"effectSize" %in% colnames(estimates))
stop("Must add column 'effectSize' to estimates (e.g. using addTrueEffectSize())")

if (trueRr != "Overall") {
estimates <- estimates[estimates$effectSize == 1 | estimates$effectSize == as.numeric(trueRr), ]
}
computeSensSpec <- function(subset) {
if (subset$effectSize[1] == 1) {
subset %>%
group_by(.data$periodId) %>%
summarize(value = 1 - mean(!is.na(.data$p) & .data$p < 0.05)) %>%
mutate(group = "Specificity",
method = subset$method[1],
analysisId = subset$analysisId[1]) %>%
return()
} else {
subset %>%
group_by(.data$periodId) %>%
summarize(value = mean(!is.na(.data$p) & .data$p < 0.05)) %>%
mutate(group = sprintf("Sensitivity when\ntrue effect = %s", subset$effectSize[1]),
method = subset$method[1],
analysisId = subset$analysisId[1]) %>%
return()
}
}

effectSizes <- unique(estimates$effectSize)
effectSizes <- effectSizes[order(effectSizes)]
data <- tibble()
for (effectSize in effectSizes) {
subset <- estimates %>%
filter(.data$effectSize == !!effectSize)
data <- lapply(split(subset, paste(subset$method, subset$analysisId)), computeSensSpec) %>%
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)
yBreaks <- c(0, 0.2, 0.4, 0.6, 0.8, 0.9, 1)
f <- function(x) {
-log(1.1 - x)
}
pcEffectSizes <- effectSizes[effectSizes > 1]
cutoff <- expand.grid(group = sprintf("Sensitivity when\ntrue effect = %s", pcEffectSizes), method = unique(data$method)) %>%
mutate(value = 0.8,
analysisId = 1)


data$analysisId <- as.factor(data$analysisId)
data$group <- factor(data$group, levels = rev(c("Specificity", sprintf("Sensitivity when\ntrue effect = %s", pcEffectSizes))))
plot <- ggplot(data, aes(x = .data$periodId, y = f(.data$value), group = .data$analysisId, color = .data$analysisId)) +
geom_hline(aes(yintercept = f(.data$value)), size = 1, color = rgb(0, 0, 0), linetype = "dashed", data = cutoff) +
geom_line(size = 1, alpha = 0.5) +
geom_point(size = 2, alpha = 0.7) +
scale_x_continuous("Time (Months)", breaks = 1:max(data$periodId), limits = c(1, max(data$periodId))) +
scale_y_continuous("Sensitivity / Specificity", limits = f(c(0, 1)), breaks = f(yBreaks), labels = yBreaks) +
labs(color = "Analysis ID") +
facet_grid(group ~ method) +
theme(axis.text.y = theme,
axis.text.x = theme,
axis.title.x = theme,
axis.title.y = element_blank(),
strip.text.x = theme,
strip.text.y = theme,
strip.background = element_blank(),
legend.text = themeLA,
legend.title = themeLA,
legend.position = "right")
plot
return(plot)
}

computeTrueRr <- function(estimates, negativeControlOutcome, positiveControlOutcome) {
estimates <- addTrueEffectSize(estimates, negativeControlOutcome, positiveControlOutcome)

Expand Down
80 changes: 61 additions & 19 deletions Eumaeus/server.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -238,10 +238,6 @@ shinyServer(function(input, output, session) {
if (nrow(subset) == 0) {
return(data.frame())
}
# combis <- lapply(split(subset, paste(subset$method, subset$analysisId)),
# computeEffectEstimateMetrics,
# trueRr = input$trueRr)
# combis <- bind_rows(combis)
combis <- subset %>%
distinct(.data$method, .data$analysisId) %>%
arrange(.data$method, .data$analysisId)
Expand All @@ -266,18 +262,6 @@ shinyServer(function(input, output, session) {
return(data)
}
table <- DT::datatable(data, selection = selection, options = options, rownames = FALSE, escape = FALSE)

# colors <- c("#b7d3e6", "#b7d3e6", "#b7d3e6", "#f2b4a9", "#f2b4a9", "#f2b4a9", "#f2b4a9")
# mins <- c(0, 0, 0, 0, 0, 0, 0)
# maxs <- c(1, 1, max(data[, 5]), max(data[, 6]), 1, 1, 1)
# for (i in 1:length(colors)) {
# table <- DT::formatStyle(table = table,
# columns = i + 2,
# background = styleColorBar(c(mins[i], maxs[i]), colors[i]),
# backgroundSize = '98% 88%',
# backgroundRepeat = 'no-repeat',
# backgroundPosition = 'center')
# }
return(table)
})

Expand Down Expand Up @@ -334,6 +318,34 @@ shinyServer(function(input, output, session) {
}
})

# Across periods and methods

output$sensSpecAcrossMethods <- renderPlot({
subset <- filterEstimatesAcrossPeriods()
if (nrow(subset) == 0) {
return(data.frame())
}
# Drop negative controls that weren't powered to be used for positive control synthesis so all on equal power:
subset <- subset %>%
filter(.data$outcomeId %in% c(positiveControlOutcome$outcomeId, positiveControlOutcome$negativeControlId))
# x <<- subset
plot <- plotSensSpecAcrossMethods(subset, input$trueRr)
return(plot)
})

output$analysesDescriptions <- renderDataTable({
options = list(pageLength = 100,
searching = FALSE,
lengthChange = FALSE)
data <- analysis %>%
filter(.data$method %in% input$method & .data$timeAtRisk == input$timeAtRisk) %>%
select(.data$method, .data$analysisId, .data$description) %>%
arrange(.data$method, .data$analysisId)

table <- DT::datatable(data, options = options, colnames = c("Method", "AnalysisId", "Description"), rownames = FALSE, escape = FALSE)
return(table)
})

# MaxSPRT-based metrics --------------------------------------------------------------------------
exposureId2 <- reactive(
exposure %>%
Expand All @@ -359,6 +371,8 @@ shinyServer(function(input, output, session) {
return(subset)
})

# Per method

selectedEstimates2 <- reactive({
if (is.null(input$performanceMetrics2_rows_selected)) {
return(NULL)
Expand Down Expand Up @@ -531,6 +545,34 @@ shinyServer(function(input, output, session) {
}
})

# Across methods

output$sensSpecAcrossMethods2 <- renderPlot({
subset <- filterEstimates2()
if (nrow(subset) == 0) {
return(data.frame())
}
# Drop negative controls that weren't powered to be used for positive control synthesis so all on equal power:
subset <- subset %>%
filter(.data$outcomeId %in% c(positiveControlOutcome$outcomeId, positiveControlOutcome$negativeControlId))

plot <- plotMaxSprtSensSpecAcrossMethods(subset, input$trueRr2)
return(plot)
})

output$analysesDescriptions2 <- renderDataTable({
options = list(pageLength = 100,
searching = FALSE,
lengthChange = FALSE)
data <- analysis %>%
filter(.data$method %in% input$method2 & .data$timeAtRisk == input$timeAtRisk2) %>%
select(.data$method, .data$analysisId, .data$description) %>%
arrange(.data$method, .data$analysisId)

table <- DT::datatable(data, options = options, colnames = c("Method", "AnalysisId", "Description"), rownames = FALSE, escape = FALSE)
return(table)
})

# Database information -------------------------------------------------------
output$databaseInfoPlot <- renderPlot({
return(plotDbCharacteristics(databaseCharacterization))
Expand Down Expand Up @@ -598,8 +640,8 @@ shinyServer(function(input, output, session) {
HTML(periodInfoHtml)
))
})


observeEvent(input$databaseInfo, {
showModal(modalDialog(
title = "Databases",
Expand Down Expand Up @@ -629,7 +671,7 @@ shinyServer(function(input, output, session) {
HTML(methodsInfoHtml)
))
})

# MaxSPRT-based metrics tab
observeEvent(input$vaccineInfo2, {
showModal(modalDialog(
Expand Down
Loading

0 comments on commit ec0df0a

Please sign in to comment.