diff --git a/OhdsiStudies/ui.R b/OhdsiStudies/ui.R index dd516d0a..877ea2c5 100644 --- a/OhdsiStudies/ui.R +++ b/OhdsiStudies/ui.R @@ -2,12 +2,14 @@ library(shiny) library(DT) ui <- fluidPage( - - titlePanel("OHDSI Studies"), + titlePanel( + title = div(img(src = "logo.png", height = 50, width = 50), "OHDSI Studies"), + windowTitle = "OHDSI Studies" + ), style = "width:1500px;", dataTableOutput("mainTable"), uiOutput("detailsUi"), uiOutput("lastUpdated") - + ) diff --git a/OhdsiStudies/www/favicon.ico b/OhdsiStudies/www/favicon.ico new file mode 100644 index 00000000..849a1fa4 Binary files /dev/null and b/OhdsiStudies/www/favicon.ico differ diff --git a/OhdsiStudies/www/logo.png b/OhdsiStudies/www/logo.png new file mode 100644 index 00000000..c6307af6 Binary files /dev/null and b/OhdsiStudies/www/logo.png differ diff --git a/SmallCountMetaAnalysisEvaluation/ResultsExplorer.Rproj b/SmallCountMetaAnalysisEvaluation/ResultsExplorer.Rproj new file mode 100644 index 00000000..8e3c2ebc --- /dev/null +++ b/SmallCountMetaAnalysisEvaluation/ResultsExplorer.Rproj @@ -0,0 +1,13 @@ +Version: 1.0 + +RestoreWorkspace: Default +SaveWorkspace: Default +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: Sweave +LaTeX: pdfLaTeX diff --git a/SmallCountMetaAnalysisEvaluation/data/fixedFx.rds b/SmallCountMetaAnalysisEvaluation/data/fixedFx.rds new file mode 100644 index 00000000..ab9987c5 Binary files /dev/null and b/SmallCountMetaAnalysisEvaluation/data/fixedFx.rds differ diff --git a/SmallCountMetaAnalysisEvaluation/data/randomFx.rds b/SmallCountMetaAnalysisEvaluation/data/randomFx.rds new file mode 100644 index 00000000..0a2d788f Binary files /dev/null and b/SmallCountMetaAnalysisEvaluation/data/randomFx.rds differ diff --git a/SmallCountMetaAnalysisEvaluation/global.R b/SmallCountMetaAnalysisEvaluation/global.R new file mode 100644 index 00000000..8cf45701 --- /dev/null +++ b/SmallCountMetaAnalysisEvaluation/global.R @@ -0,0 +1,10 @@ + +resultsFixed <- readRDS("data/fixedFx.rds") +typesFixed <- unique(resultsFixed$type) +metricsFixed <- unique(resultsFixed$metric) +simParamsFixed <- colnames(resultsFixed)[!(colnames(resultsFixed) %in% c("type", "metric", "value"))] + +resultsRandom <- readRDS("data/randomFx.rds") +typesRandom <- unique(resultsRandom$type) +metricsRandom <- unique(resultsRandom$metric) +simParamsRandom <- colnames(resultsRandom)[!(colnames(resultsRandom) %in% c("type", "metric", "value"))] diff --git a/SmallCountMetaAnalysisEvaluation/server.R b/SmallCountMetaAnalysisEvaluation/server.R new file mode 100644 index 00000000..e246cfc7 --- /dev/null +++ b/SmallCountMetaAnalysisEvaluation/server.R @@ -0,0 +1,315 @@ +library(shiny) +library(ggplot2) + +shinyServer(function(input, output, session) { + + # Fixed effects --------------------------------------------------- + + pivotDataFixed <- function(simParam, subset) { + if (length(unique(subset[, simParam])) == 1) { + return(NULL) + } else { + temp <- subset + maxValue <- max(subset[simParam]) + temp$parameterValue <- subset[, simParam] + temp$jitter <- temp$parameterValue + runif(nrow(subset), -0.02 * maxValue, 0.02 * maxValue) + temp$simParam <- simParam + temp[simParamsFixed] <- NULL + return(temp) + } + } + + filteredResultsFixed <- reactive({ + subset <- resultsFixed + subset <- subset[subset$metric %in% input$metricFixed, ] + subset <- subset[subset$type %in% input$typeFixed, ] + for (simParam in simParamsFixed) { + subset <- subset[subset[, simParam] %in% as.numeric(input[[paste0(simParam, "Fixed")]]), ] + } + return(subset) + }) + + filteredPivotedResultsFixed <- reactive({ + subset <- filteredResultsFixed() + vizData <- lapply(simParamsFixed, pivotDataFixed, subset = subset) + vizData <- do.call(rbind, vizData) + return(vizData) + }) + + output$mainPlotFixed <- renderPlot({ + subset <- filteredPivotedResultsFixed() + if (nrow(subset) == 0) { + return(NULL) + } else { + subset$type <- gsub(" ", "\n", subset$type) + plot <- ggplot2::ggplot(subset, ggplot2::aes(x = jitter, y = value, group = type, color = type)) + + ggplot2::geom_point(alpha = 0.4) + + ggplot2::facet_grid(metric~simParam, scales = "free", switch = "both") + + ggplot2::theme(legend.position = "top", + legend.title = ggplot2::element_blank(), + axis.title = ggplot2::element_blank(), + strip.placement = "outside", + strip.background = ggplot2::element_blank()) + return(plot) + } + }, + res = 125, + height = 800) + + output$hoverInfoPlotFixed <- renderUI({ + subset <- filteredPivotedResultsFixed() + if (nrow(subset) == 0) { + return(NULL) + } + hover <- input$plotHoverMainPlotFixed + point <- nearPoints(subset, hover, threshold = 5, maxpoints = 1, addDist = TRUE) + if (nrow(point) == 0) return(NULL) + + left_pct <- (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left) + top_pct <- (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom) + left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left) + top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top) + style <- paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); ", + "left:", left_px - 361, "px; top:", top_px - 150, "px; width:250px;") + + # Unpivot: + unpivotedRow <- resultsFixed[resultsFixed[, point$simParam] == point$parameterValue & + resultsFixed$type == point$type & + resultsFixed$metric == point$metric & + resultsFixed$value == point$value, ] + unpivotedRow <- unpivotedRow[1, ] + allMetrics <- merge(resultsFixed, unpivotedRow[, c(simParamsFixed, "type")]) + + lines <- sprintf(" Type: %s", point$type) + lines <- c(lines, "") + lines <- c(lines, sprintf(" %s: %s", simParamsFixed, unpivotedRow[, simParamsFixed])) + lines <- c(lines, "") + lines <- c(lines, sprintf(" %s: %.2f", allMetrics$metric, allMetrics$value)) + + div( + style = "position: relative; width: 0; height: 0", + wellPanel( + style = style, + p(HTML(paste(lines, collapse = "
"))))) + }) + + output$mainCaptionFixed <- renderUI({ + subset <- filteredPivotedResultsFixed() + if (nrow(subset) == 0) { + return(NULL) + } + count <- sum(subset$type == subset$type[1] & subset$metric == subset$metric[1]) + HTML(sprintf("Figure S1.1. Each dot represents one of the %s selected simulation scenarios. The y-axes represent the various metrics + as estimated over 1,000 iterations per scenario, and the x-axes represent the various simulation parameters. Color indicates the various tested + meta-analysis algorithms.", count)) + }) + + output$rankPlotFixed <- renderPlot({ + subset <- filteredResultsFixed() + subset <- subset[!grepl("bias", subset$metric), ] + + rankMethods <- function(subgroup, descending = TRUE) { + if (descending) { + subgroup$rank <- order(-subgroup$value) + } else { + subgroup$rank <- order(subgroup$value) + } + return(subgroup) + } + + processMetric <- function(metricSubset) { + metric <- metricSubset$metric[1] + descending <- grepl("precision", metric) + if (grepl("coverage", metric)) { + metricSubset$value <- abs(0.95 - metricSubset$value) + } + subgroups <- split(metricSubset, apply(metricSubset[, c(simParamsFixed, "metric")],1,paste,collapse=" ")) + metricSubset <- lapply(subgroups, rankMethods, descending = descending) + metricSubset <- do.call(rbind, metricSubset) + return(metricSubset) + } + + rankedSubset <- lapply(split(subset, subset$metric), processMetric) + rankedSubset <- do.call(rbind, rankedSubset) + rankedSubset$type <- gsub(" ", "\n", rankedSubset$type) + plot <- ggplot2::ggplot(rankedSubset, ggplot2::aes(x = rank)) + + ggplot2::geom_histogram(binwidth = 1, color = rgb(0, 0, 0.8, alpha = 0), fill = rgb(0, 0, 0.8), alpha = 0.6) + + ggplot2::scale_x_continuous("Rank (lower is better)", breaks = min(rankedSubset$rank):max(rankedSubset$rank)) + + ggplot2::scale_y_continuous("Count") + + ggplot2::facet_grid(type~metric) + + ggplot2::theme(panel.grid.major.x = ggplot2::element_blank(), + panel.grid.minor.x = ggplot2::element_blank()) + + return(plot) + }, + res = 110, + height = 800) + + output$rankCaptionFixed <- renderUI({ + subset <- filteredPivotedResultsFixed() + if (nrow(subset) == 0) { + return(NULL) + } + text <- "Figure S1.2. Histograms of algorithm ranks. Each bar represents the number of simulation scenarios where the algorithm on the + right achieved that rank on the metric at the top, compared to the other selected algorithms." + if (any(grepl("coverage", subset$metric))) { + text <- paste(text, "For coverage, algorithms were ranked by absolute difference between the estimated coverage and 95 percent.") + } + HTML(text) + }) + + # Random Fx ------------------------------------------------------------------ + + pivotDataRandom <- function(simParam, subset) { + if (length(unique(subset[, simParam])) == 1) { + return(NULL) + } else { + temp <- subset + maxValue <- max(subset[simParam]) + temp$parameterValue <- subset[, simParam] + temp$jitter <- temp$parameterValue + runif(nrow(subset), -0.02 * maxValue, 0.02 * maxValue) + temp$simParam <- simParam + temp[simParamsRandom] <- NULL + return(temp) + } + } + + filteredResultsRandom <- reactive({ + subset <- resultsRandom + subset <- subset[subset$metric %in% input$metricRandom, ] + subset <- subset[subset$type %in% input$typeRandom, ] + for (simParam in simParamsRandom) { + subset <- subset[subset[, simParam] %in% as.numeric(input[[paste0(simParam, "Random")]]), ] + } + return(subset) + }) + + filteredPivotedResultsRandom <- reactive({ + subset <- filteredResultsRandom() + vizData <- lapply(simParamsRandom, pivotDataRandom, subset = subset) + vizData <- do.call(rbind, vizData) + return(vizData) + }) + + output$mainPlotRandom <- renderPlot({ + subset <- filteredPivotedResultsRandom() + if (nrow(subset) == 0) { + return(NULL) + } else { + subset$type <- gsub(" ", "\n", subset$type) + plot <- ggplot2::ggplot(subset, ggplot2::aes(x = jitter, y = value, group = type, color = type)) + + ggplot2::geom_point(alpha = 0.4) + + ggplot2::facet_grid(metric~simParam, scales = "free", switch = "both") + + ggplot2::theme(legend.position = "top", + legend.title = ggplot2::element_blank(), + axis.title = ggplot2::element_blank(), + strip.placement = "outside", + strip.background = ggplot2::element_blank()) + return(plot) + } + }, + res = 150, + height = 800) + + output$hoverInfoPlotRandom <- renderUI({ + subset <- filteredPivotedResultsRandom() + if (nrow(subset) == 0) { + return(NULL) + } + hover <- input$plotHoverMainPlotRandom + point <- nearPoints(subset, hover, threshold = 5, maxpoints = 1, addDist = TRUE) + if (nrow(point) == 0) return(NULL) + + left_pct <- (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left) + top_pct <- (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom) + left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left) + top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top) + style <- paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); ", + "left:", left_px - 361, "px; top:", top_px - 150, "px; width:250px;") + + # Unpivot: + unpivotedRow <- resultsRandom[resultsRandom[, point$simParam] == point$parameterValue & + resultsRandom$type == point$type & + resultsRandom$metric == point$metric & + resultsRandom$value == point$value, ] + unpivotedRow <- unpivotedRow[1, ] + allMetrics <- merge(resultsRandom, unpivotedRow[, c(simParamsRandom, "type")]) + + lines <- sprintf(" Type: %s", point$type) + lines <- c(lines, "") + lines <- c(lines, sprintf(" %s: %s", simParamsRandom, unpivotedRow[, simParamsRandom])) + lines <- c(lines, "") + lines <- c(lines, sprintf(" %s: %.2f", allMetrics$metric, allMetrics$value)) + + div( + style = "position: relative; width: 0; height: 0", + wellPanel( + style = style, + p(HTML(paste(lines, collapse = "
"))))) + }) + + output$mainCaptionRandom <- renderUI({ + subset <- filteredPivotedResultsRandom() + if (nrow(subset) == 0) { + return(NULL) + } + count <- sum(subset$type == subset$type[1] & subset$metric == subset$metric[1]) + HTML(sprintf("Figure S2.1. Each dot represents one of the %s selected simulation scenarios. The y-axes represent the various metrics + as estimated over 1,000 iterations per scenario, and the x-axes represent the various simulation parameters. Color indicates the various tested + meta-analysis algorithms.", count)) + }) + + output$rankPlotRandom <- renderPlot({ + subset <- filteredResultsRandom() + subset <- subset[!grepl("bias", subset$metric), ] + + rankMethods <- function(subgroup, descending = TRUE) { + if (descending) { + subgroup$rank <- order(-subgroup$value) + } else { + subgroup$rank <- order(subgroup$value) + } + return(subgroup) + } + + processMetric <- function(metricSubset) { + metric <- metricSubset$metric[1] + descending <- grepl("precision", metric) + if (grepl("coverage", metric)) { + metricSubset$value <- abs(0.95 - metricSubset$value) + } + subgroups <- split(metricSubset, apply(metricSubset[, c(simParamsRandom, "metric")],1,paste,collapse=" ")) + metricSubset <- lapply(subgroups, rankMethods, descending = descending) + metricSubset <- do.call(rbind, metricSubset) + return(metricSubset) + } + + rankedSubset <- lapply(split(subset, subset$metric), processMetric) + rankedSubset <- do.call(rbind, rankedSubset) + rankedSubset$type <- gsub(" ", "\n", rankedSubset$type) + plot <- ggplot2::ggplot(rankedSubset, ggplot2::aes(x = rank)) + + ggplot2::geom_histogram(binwidth = 1, color = rgb(0, 0, 0.8, alpha = 0), fill = rgb(0, 0, 0.8), alpha = 0.6) + + ggplot2::scale_x_continuous("Rank (lower is better)", breaks = min(rankedSubset$rank):max(rankedSubset$rank)) + + ggplot2::scale_y_continuous("Count") + + ggplot2::facet_grid(type~metric) + + ggplot2::theme(panel.grid.major.x = ggplot2::element_blank(), + panel.grid.minor.x = ggplot2::element_blank()) + + return(plot) + }, + res = 110, + height = 800) + + output$rankCaptionRandom <- renderUI({ + subset <- filteredPivotedResultsRandom() + if (nrow(subset) == 0) { + return(NULL) + } + text <- "Figure S2.2. Histograms of algorithm ranks. Each bar represents the number of simulation scenarios where the algorithm on the + right achieved that rank on the metric at the top, compared to the other selected algorithms." + if (any(grepl("coverage", subset$metric))) { + text <- paste(text, "For coverage, algorithms were ranked by absolute difference between the estimated coverage and 95 percent.") + } + HTML(text) + }) +}) diff --git a/SmallCountMetaAnalysisEvaluation/ui.R b/SmallCountMetaAnalysisEvaluation/ui.R new file mode 100644 index 00000000..81b051d5 --- /dev/null +++ b/SmallCountMetaAnalysisEvaluation/ui.R @@ -0,0 +1,61 @@ +library(shiny) +library(DT) +source("widgets.R") + +shinyUI( + fluidPage(style = "width:1500px;", + titlePanel("Small-Sample Evidence Synthesis Results"), + tabsetPanel(id = "mainTabsetPanel", + tabPanel("About", + HTML("

This app is under development. All results are preliminary and may change without notice.

"), + HTML("

Do not use.

") + ), + tabPanel("Fixed-effects simulations", + fluidRow( + column(3, + checkboxGroupInput("typeFixed", "Meta-analysis algorithm", choices = typesFixed, selected = typesFixed), + lapply(simParamsFixed, createSimParamWidget, results = resultsFixed, suffix = "Fixed"), + checkboxGroupInput("metricFixed", "Metric", choices = metricsFixed, selected = metricsFixed), + ), + column(9, + tabsetPanel(id = "fixedEffectsTabsetPanel", + type = "pills", + tabPanel("Scatter plots", + uiOutput("hoverInfoPlotFixed"), + plotOutput("mainPlotFixed", height = 800, hover = hoverOpts("plotHoverMainPlotFixed", delay = 100, delayType = "debounce")), + uiOutput("mainCaptionFixed") + ), + tabPanel("Rankings", + plotOutput("rankPlotFixed", height = 800), + uiOutput("rankCaptionFixed") + ) + ) + ) + ) + ), + tabPanel("Random-effects simulations", + fluidRow( + column(3, + checkboxGroupInput("typeRandom", "Meta-analysis algorithm", choices = typesRandom, selected = typesRandom[grepl("random", typesRandom)]), + lapply(simParamsRandom, createSimParamWidget, results = resultsRandom, suffix = "Random"), + checkboxGroupInput("metricRandom", "Metric", choices = metricsRandom, selected = metricsRandom[!grepl("Tau", metricsRandom)]), + ), + column(9, + tabsetPanel(id = "fixedEffectsTabsetPanel", + type = "pills", + tabPanel("Scatter plots", + uiOutput("hoverInfoPlotRandom"), + plotOutput("mainPlotRandom", height = 800, hover = hoverOpts("plotHoverMainPlotRandom", delay = 100, delayType = "debounce")), + uiOutput("mainCaptionRandom") + ), + tabPanel("Rankings", + plotOutput("rankPlotRandom", height = 800), + uiOutput("rankCaptionRandom") + ) + ) + ) + ) + ) + ) + ) +) diff --git a/SmallCountMetaAnalysisEvaluation/widgets.R b/SmallCountMetaAnalysisEvaluation/widgets.R new file mode 100644 index 00000000..4ea974f9 --- /dev/null +++ b/SmallCountMetaAnalysisEvaluation/widgets.R @@ -0,0 +1,5 @@ +createSimParamWidget <- function(simParam, results, suffix) { + values <- unique(results[, simParam]) + values <- values[order(values)] + checkboxGroupInput(paste0(simParam, suffix), simParam, choices = values, selected = values, inline = TRUE) +}