R color palettes for medical studies

palette-explorer.R

library(shiny)
library(ggplot2)
library(ggsci)
library(RColorBrewer)
library(viridis)

# ---- Palette definitions ----
# Each entry: label shown to user, and a function that returns
# a discrete scale and a continuous/fill scale where relevant
palette_choices <- list(
  "NPG (Nature)"        = "npg",
  "AAAS (Science)"      = "aaas",
  "NEJM"                = "nejm",
  "Lancet"              = "lancet",
  "JAMA"                = "jama",
  "JCO (Clin. Oncology)"= "jco",
  "UCSC Genome Browser" = "ucscgb",
  "IGV"                 = "igv",
  "Brewer: Set1"        = "brewer_set1",
  "Brewer: Dark2"       = "brewer_dark2",
  "Brewer: RdBu (diverging)" = "brewer_rdbu",
  "Viridis"             = "viridis",
  "Magma"               = "magma"
)

get_discrete_scales <- function(pal) {
  switch(pal,
    npg    = list(color = scale_color_npg(),    fill = scale_fill_npg()),
    aaas   = list(color = scale_color_aaas(),   fill = scale_fill_aaas()),
    nejm   = list(color = scale_color_nejm(),   fill = scale_fill_nejm()),
    lancet = list(color = scale_color_lancet(), fill = scale_fill_lancet()),
    jama   = list(color = scale_color_jama(),   fill = scale_fill_jama()),
    jco    = list(color = scale_color_jco(),    fill = scale_fill_jco()),
    ucscgb = list(color = scale_color_ucscgb(), fill = scale_fill_ucscgb()),
    igv    = list(color = scale_color_igv(),    fill = scale_fill_igv()),
    brewer_set1  = list(color = scale_color_brewer(palette = "Set1"),
                         fill  = scale_fill_brewer(palette = "Set1")),
    brewer_dark2 = list(color = scale_color_brewer(palette = "Dark2"),
                         fill  = scale_fill_brewer(palette = "Dark2")),
    brewer_rdbu  = list(color = scale_color_brewer(palette = "RdBu"),
                         fill  = scale_fill_brewer(palette = "RdBu")),
    viridis = list(color = scale_color_viridis_d(), fill = scale_fill_viridis_d()),
    magma   = list(color = scale_color_viridis_d(option = "magma"),
                    fill  = scale_fill_viridis_d(option = "magma"))
  )
}

get_continuous_fill <- function(pal) {
  switch(pal,
    viridis = scale_fill_viridis_c(),
    magma   = scale_fill_viridis_c(option = "magma"),
    brewer_rdbu = scale_fill_distiller(palette = "RdBu"),
    # Journal palettes are discrete by design; fall back to viridis-like gradient
    # using the same hue family isn't native, so default to a neutral gradient
    scale_fill_gradientn(colors = get_discrete_scales(pal)$fill$palette(7))
  )
}

# ---- Simulated example datasets ----
set.seed(42)
scatter_data <- data.frame(
  biomarker_a = rnorm(180, 50, 12),
  biomarker_b = rnorm(180, 30, 8),
  group = sample(paste("Cohort", LETTERS[1:5]), 180, replace = TRUE)
)
scatter_data$biomarker_b <- scatter_data$biomarker_b +
  0.4 * scatter_data$biomarker_a * (as.numeric(factor(scatter_data$group)) / 5)

bar_data <- data.frame(
  treatment = rep(paste("Arm", LETTERS[1:5]), each = 3),
  timepoint = rep(c("Baseline", "Week 4", "Week 12"), times = 5),
  response  = c(20,35,55, 18,30,48, 25,40,60, 15,22,33, 30,45,62)
)
bar_data$timepoint <- factor(bar_data$timepoint, levels = c("Baseline","Week 4","Week 12"))

box_data <- data.frame(
  expression = c(rnorm(60, 5, 1), rnorm(60, 7, 1.3), rnorm(60, 4.2, 0.9),
                 rnorm(60, 8.1, 1.1), rnorm(60, 6, 1.5)),
  gene_group = rep(paste("Cluster", 1:5), each = 60)
)

heat_genes <- paste0("Gene", 1:15)
heat_samples <- paste0("Sample", 1:12)
heat_data <- expand.grid(gene = heat_genes, sample = heat_samples)
heat_data$expression <- rnorm(nrow(heat_data), 0, 1) +
  outer(1:15, 1:12, function(g, s) sin(g/2) + cos(s/3))[cbind(
    match(heat_data$gene, heat_genes), match(heat_data$sample, heat_samples))]

# ---- UI ----
ui <- fluidPage(
  tags$head(tags$style(HTML("
    body.light-mode { background-color: #ffffff; color: #111111; }
    body.dark-mode  { background-color: #1e1e1e; color: #f0f0f0; }
    body.dark-mode .well { background-color: #2a2a2a; border-color: #444; }
    body.dark-mode label, body.dark-mode h2, body.dark-mode .helpText,
    body.dark-mode .shiny-input-container { color: #f0f0f0; }
  "))),
  tags$script(HTML("
    Shiny.addCustomMessageHandler('toggleBodyClass', function(mode) {
      document.body.classList.remove('light-mode', 'dark-mode');
      document.body.classList.add(mode === 'dark' ? 'dark-mode' : 'light-mode');
    });
  ")),
  titlePanel("Biomedical Color Palette Explorer"),
  sidebarLayout(
    sidebarPanel(
      selectInput("palette", "Choose a palette:",
                  choices = palette_choices, selected = "npg"),
      radioButtons("plot_type", "Plot type:",
                   choices = c("Grouped bar (treatment arms)" = "bar",
                               "Scatter (cohorts)" = "scatter",
                               "Boxplot (gene clusters)" = "box",
                               "Heatmap (expression matrix)" = "heat"),
                   selected = "bar"),
      radioButtons("theme_mode", "Background theme:",
                   choices = c("Light" = "light", "Dark" = "dark"),
                   selected = "light"),
      hr(),
      helpText("Journal palettes (NPG, AAAS, NEJM, Lancet, JAMA, JCO) are ",
               "discrete color sets designed for figures in biomedical ",
               "publications. Viridis/Magma and Brewer palettes work well ",
               "for continuous data like heatmaps."),
      width = 3
    ),
    mainPanel(
      plotOutput("mainPlot", height = "520px"),
      width = 9
    )
  )
)

# ---- Server ----
server <- function(input, output, session) {

  observe({
    session$sendCustomMessage("toggleBodyClass", input$theme_mode)
  })

  plot_theme <- reactive({
    if (input$theme_mode == "dark") {
      theme_minimal(base_size = 14) +
        theme(
          plot.background  = element_rect(fill = "#1e1e1e", color = NA),
          panel.background = element_rect(fill = "#1e1e1e", color = NA),
          panel.grid = element_line(color = "#3a3a3a"),
          text = element_text(color = "#f0f0f0"),
          axis.text = element_text(color = "#f0f0f0"),
          legend.background = element_rect(fill = "#1e1e1e", color = NA),
          legend.key = element_rect(fill = "#1e1e1e", color = NA)
        )
    } else {
      theme_minimal(base_size = 14)
    }
  })

  output$mainPlot <- renderPlot({
    pal <- input$palette
    scales <- get_discrete_scales(pal)
    th <- plot_theme()

    if (input$plot_type == "scatter") {
      ggplot(scatter_data, aes(biomarker_a, biomarker_b, color = group)) +
        geom_point(size = 2.5, alpha = 0.85) +
        scales$color +
        labs(title = "Biomarker A vs Biomarker B by Cohort",
             x = "Biomarker A (units)", y = "Biomarker B (units)",
             color = "Cohort") +
        th

    } else if (input$plot_type == "bar") {
      ggplot(bar_data, aes(timepoint, response, fill = treatment)) +
        geom_col(position = position_dodge(width = 0.8), width = 0.7) +
        scales$fill +
        labs(title = "Treatment Response Over Time",
             x = NULL, y = "Response (%)", fill = "Treatment Arm") +
        th

    } else if (input$plot_type == "box") {
      ggplot(box_data, aes(gene_group, expression, fill = gene_group)) +
        geom_boxplot(alpha = 0.85, outlier.alpha = 0.5) +
        scales$fill +
        labs(title = "Gene Expression by Cluster",
             x = NULL, y = "Expression (log2)", fill = "Cluster") +
        th +
        theme(legend.position = "none")

    } else if (input$plot_type == "heat") {
      ggplot(heat_data, aes(sample, gene, fill = expression)) +
        geom_tile(color = if (input$theme_mode == "dark") "#1e1e1e" else "white",
                  linewidth = 0.3) +
        get_continuous_fill(pal) +
        labs(title = "Simulated Expression Heatmap",
             x = NULL, y = NULL, fill = "Expression") +
        th +
        theme(axis.text.x = element_text(angle = 45, hjust = 1))
    }
  }, bg = "transparent")
}

shinyApp(ui, server)