InteractiveComplexHeatmap teal Module with hermes Toy Data

This vignette reuses the teal module pattern from the proof-of-concept vignette with a toy SummarizedExperiment from hermes.

Prerequisites

library(shiny)
library(dplyr)
library(stringr)
library(tibble)

library(teal)
library(teal.data)
library(teal.widgets)

library(ComplexHeatmap)
library(InteractiveComplexHeatmap)
library(SummarizedExperiment) # 
BiocManager::install("SummarizedExperiment")

library(hermes) # devtools::install_github("insightsengineering/hermes")

Shared Helpers

as_heatmap_matrix <- function(x, id_col = c("ID", "id"), exclude_cols = "id_seq") {
  if (is.matrix(x)) {
    storage.mode(x) <- "numeric"
    return(x)
  }

  if (!is.data.frame(x)) {
    stop("Expected a matrix or data frame.", call. = FALSE)
  }

  id_col <- intersect(id_col, names(x))[1]
  if (!is.na(id_col)) {
    x <- tibble::column_to_rownames(x, id_col)
  }

  x <- x[, setdiff(names(x), exclude_cols), drop = FALSE]

  numeric_cols <- vapply(x, is.numeric, logical(1))
  if (!any(numeric_cols)) {
    stop("The selected data must contain at least one numeric column.", call. = FALSE)
  }

  as.matrix(x[, numeric_cols, drop = FALSE])
}

scale_heatmap_matrix <- function(m, scale_by = c("none", "row", "column")) {
  scale_by <- match.arg(scale_by)

  if (scale_by == "row") {
    return(t(scale(t(m))))
  }

  if (scale_by == "column") {
    return(scale(m))
  }

  m
}

make_heatmap <- function(
    x,
    scale_by = c("none", "row", "column"),
    cluster_rows = TRUE,
    cluster_columns = TRUE,
    palette = c("blue_white_red", "viridis"),
    name = "value") {
  scale_by <- match.arg(scale_by)
  palette <- match.arg(palette)

  m <- as_heatmap_matrix(x)
  m <- scale_heatmap_matrix(m, scale_by = scale_by)

  if (palette == "blue_white_red") {
    col_fun <- circlize::colorRamp2(
      c(min(m, na.rm = TRUE), 0, max(m, na.rm = TRUE)),
      c("#2B6CB0", "#F7FAFC", "#C53030")
    )
  } else {
    col_fun <- viridisLite::viridis(256)
  }

  ComplexHeatmap::Heatmap(
    m,
    name = name,
    col = col_fun,
    cluster_rows = cluster_rows,
    cluster_columns = cluster_columns,
    show_row_names = nrow(m) <= 50,
    show_column_names = TRUE
  )
}

teal Module

tm_interactive_heatmap_ui <- function(id) {
  ns <- shiny::NS(id)

  teal.widgets::standard_layout(
    encoding = shiny::tagList(
      shiny::selectInput(ns("dataset"), "Dataset", choices = NULL),
      shiny::selectInput(ns("scale_by"), "Scale", choices = c("none", "row", "column")),
      shiny::selectInput(ns("palette"), "Palette", choices = c("blue_white_red", "viridis")),
      shiny::checkboxInput(ns("cluster_rows"), "Cluster rows", value = TRUE),
      shiny::checkboxInput(ns("cluster_columns"), "Cluster columns", value = TRUE)
    ),
    output = InteractiveComplexHeatmap::InteractiveComplexHeatmapOutput(ns("heatmap"))
  )
}

tm_interactive_heatmap_server <- function(id, data) {
  shiny::moduleServer(id, function(input, output, session) {
    shiny::observe({
      shiny::updateSelectInput(
        session = session,
        inputId = "dataset",
        choices = names(data()),
        selected = "ADAE"
      )
    })

    selected_data <- shiny::reactive({
      shiny::req(input$dataset)
      data()[[input$dataset]]
    })

    heatmap <- shiny::reactive({
      make_heatmap(
        selected_data(),
        scale_by = input$scale_by,
        palette = input$palette,
        cluster_rows = input$cluster_rows,
        cluster_columns = input$cluster_columns
      )
    })

    shiny::observe({
      InteractiveComplexHeatmap::makeInteractiveComplexHeatmap(
        input = input,
        output = output,
        session = session,
        ht_list = heatmap(),
        heatmap_id = session$ns("heatmap")
      )
    })
  })
}

tm_interactive_heatmap <- function(label = "Interactive Heatmap", datanames = "all") {
  teal::module(
    label = label,
    ui = tm_interactive_heatmap_ui,
    server = tm_interactive_heatmap_server,
    datanames = datanames
  )
}

toy Data 1

For the proof of concept, each dataset has an ID column and numeric assay-like columns. The module also accepts matrix objects directly.

set.seed(42)

make_demo_matrix <- function(n_rows = 20, n_cols = 8, prefix = "Gene") {
  matrix(
    rnorm(n_rows * n_cols),
    nrow = n_rows,
    dimnames = list(
      paste0(prefix, seq_len(n_rows)),
      paste0("Sample", seq_len(n_cols))
    )
  )
}

expression_matrix <- make_demo_matrix()

expression_df <- expression_matrix |>
  as.data.frame(check.names = FALSE) |>
  tibble::rownames_to_column("ID")

wide_clinical_df <- matrix(rnorm(12 * 6), nrow = 12) |>
  as.data.frame() |>
  dplyr::rename_with(~ stringr::str_replace(.x, "V", "Marker")) |>
  tibble::rownames_to_column("ID") |>
  dplyr::mutate(ID = paste0("Subject", ID))

teal App Assembly 1

The plain Shiny module handles matrix input directly, while the teal app keeps to two data-frame datasets with an ID column.

teal_data_obj <- teal.data::teal_data(
  expression_df = expression_df,
  wide_clinical_df = wide_clinical_df
)

teal_app <- teal::init(
  data = teal_data_obj,
  modules = teal::modules(
    tm_interactive_heatmap(
      label = "Interactive heatmap",
      datanames = c("expression_df", "wide_clinical_df")
    )
  )
)

# shiny::shinyApp(teal_app$ui, teal_app$server)

Toy Data 2

The hermes::summarized_experiment object is split into two teal datasets: subject-level column data and a wide expression table. The expression feature names are normalized so they are syntactic column names, and id_seq is retained as a row-level key for teal joins.

# df_SE <- hermes::summarized_experiment
nrows <- 20; ncols <- 6
counts <- matrix(runif(nrows * ncols, 1, 1e4), nrows)
rowRanges <- GRanges(rep(c("chr1", "chr2"), c(5, 15)),
                     IRanges(sample(1000L, 20), width=100),
                     strand=Rle(c("+", "-"), c(12, 8)),
                     seqlengths=c(chr1=1800, chr2=1300))
colData <- DataFrame(Treatment=rep(c("ChIP", "Input"), 3),
                     row.names=LETTERS[1:6])
rse <- SummarizedExperiment(assays=SimpleList(counts=counts),
                            rowRanges=rowRanges, colData=colData)



df_SE <- rse

df_se_ADSL <- df_SE |>
  SummarizedExperiment::colData() |>
  as.data.frame() |>
  tibble::rownames_to_column("id") |>
  tibble::as_tibble()

df_se_exprs_w <- df_SE |>
  SummarizedExperiment::assay() |>
  t() |>
  as.data.frame(check.names = FALSE) |>
  tibble::rownames_to_column("id") |>
  tibble::as_tibble() |>
  dplyr::rename_with(~ stringr::str_replace_all(.x, ":", "_"), -id) |>
  dplyr::group_by(id) |>
  dplyr::mutate(id_seq = dplyr::row_number(), .before = 2) |>
  dplyr::ungroup()

teal_data_obj_se <- teal.data::teal_data(
  ADSL = df_se_ADSL,
  ADAE = df_se_exprs_w
)

teal.data::join_keys(teal_data_obj_se) <- teal.data::join_keys(
  teal.data::join_key("ADSL", "ADSL", keys = "id"),
  teal.data::join_key("ADAE", "ADAE", keys = c("id", "id_seq")),
  teal.data::join_key("ADSL", "ADAE", keys = "id")
)

teal App Assembly 2

teal_app <- teal::init(
  data = teal_data_obj_se,
  modules = teal::modules(
    tm_interactive_heatmap(
      label = "Hermes expression heatmap",
      datanames = c("ADSL", "ADAE")
    )
  )
)

# shiny::shinyApp(teal_app$ui, teal_app$server)