---
title: "MSI study report"
author: "Matt Smith"
date: "`r format(Sys.time(), '%d %B, %Y')`"
output: 
    html_document :
      code_folding: hide
      number_sections: false
      toc: true
      toc_float: 
        collapsed: false
        smooth_scroll: true

---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)

# Attach the analysis packages this report calls with unqualified names
# (%>% + dplyr verbs, ggplot2 geoms, viridis) so it renders
# self-contained -- both from runExample() (which renders inside the package
# namespace) and from runStudy.R (global env). All are quantMSImageR Imports,
# so they are guaranteed installed alongside the package. Other packages the
# report uses (DT, patchwork, openxlsx, grid, matter, Cardinal) are called
# pkg::-qualified and only need to be installed, not attached.
suppressPackageStartupMessages({
  library(dplyr)
  library(tidyr)
  library(ggplot2)
  library(viridis)
})

# Figure resolution. One value for every raster in the report -- knitr's
# figures and the heatmap PNG below -- since they used to disagree (120 with
# fig.retina = 3, so 360 effective, against a hardcoded 150 for the heatmap).
# 300 dpi is the usual floor for a figure that may end up in a manuscript.
#
# fig.retina is 1 deliberately: it renders at dpi x 3 to look crisp on a
# high-DPI screen, which at 300 dpi means 900 and a report several times
# larger for no visible gain.
.fig_dpi <- if (exists("fig_dpi")) suppressWarnings(as.numeric(fig_dpi)) else 300
if (length(.fig_dpi) != 1L || is.na(.fig_dpi) || .fig_dpi < 72) .fig_dpi <- 300

# set default options
knitr::opts_chunk$set(echo = FALSE,
               message = FALSE,
               warning = FALSE,
               fig.align="center",
               dpi = .fig_dpi,
               fig.retina = 1)

# Define a function to safely plot or show a blank plot
safe_plot <- function(p) {
  tryCatch({
    plot(p)
  }, error = function(e) {
    message("Plot failed: ", e$message)
    plot.new()
    title("Blank plot (error occurred)")
  })
}

make_sim_mat <- function(out, metric = "Dice") {
  mets <- sort(unique(c(out$metA, out$metB)))
  
  # wide upper-triangle -> matrix
  w <- out %>%
    select(metA, metB, value = all_of(metric)) %>%
    filter(metA != metB) %>%
    mutate(metA = factor(metA, levels = mets),
           metB = factor(metB, levels = mets)) %>%
    tidyr::complete(metA, metB) %>%   # ensure full square
    pivot_wider(names_from = metB, values_from = value)
  
  mat <- as.matrix(w[,-1])
  rownames(mat) <- as.character(w$metA)
  
  # symmetrize (upper/lower may be NA depending on how 'out' was built)
  mat_t <- t(mat)
  mat_sym <- ifelse(is.na(mat), mat_t, mat)
  mat_sym <- ifelse(is.na(mat_sym), mat, mat_sym)
  
  diag(mat_sym) <- 1
  mat_sym
}

cluster_from_sim <- function(sim_mat, method = "average") {
  # handle any remaining NA (choose one strategy)
  # option A: treat missing as 0 similarity
  sim_mat[is.na(sim_mat)] <- 0
  
  d <- as.dist(1 - sim_mat)
  hclust(d, method = method)
}

plot_tri_heatmap <- function(out, metric = "Dice", ord,
                              feature_groups = NULL, group_colors = NULL,
                              group_legend_name = "Met-1") {

  # Reorder features by Met-1 group (preserves the within-group ordering
  # supplied via `ord`). Without groups we leave `ord` untouched.
  if (!is.null(feature_groups)) {
    fg_ord <- as.character(feature_groups[ord])
    fg_ord[is.na(fg_ord) | !nzchar(fg_ord)] <- "Other"
    ord <- ord[order(match(fg_ord, unique(fg_ord)), seq_along(ord))]
  }

  n <- length(ord)

  # Use integer positions on a continuous scale so we can paint annotation
  # tiles outside the [1, n] data range (left strip at x = 0, bottom strip
  # at y = 0).
  tmp <- out %>%
    select(metA, metB, value = all_of(metric)) %>%
    filter(metA != metB) %>%
    mutate(
      i = match(as.character(metA), ord),
      j = match(as.character(metB), ord)
    ) %>%
    filter(!is.na(i), !is.na(j), j > i)

  has_groups <- !is.null(feature_groups)
  pad_lo     <- if (has_groups) -0.5 else 0.5

  p <- ggplot(tmp, aes(x = i, y = j, fill = value)) +
    geom_tile(color = "grey85", linewidth = 0.1) +
    scale_x_continuous(breaks = seq_len(n), labels = ord,
                        limits = c(pad_lo, n + 0.5), expand = c(0, 0)) +
    scale_y_continuous(breaks = seq_len(n), labels = ord,
                        limits = c(pad_lo, n + 0.5), expand = c(0, 0)) +
    scale_fill_gradientn(
      colours = c("#053061","#92C5DE","white","#F4A582","#67001F"),
      limits = c(min(tmp$value, na.rm = TRUE)-0.1, max(tmp$value, na.rm = TRUE)+0.1),
      na.value = "white"
    ) +
    labs(fill = "Colocalization") +
    coord_fixed() +
    theme_minimal(base_size = 10) +
    theme(
      axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5,
                                  colour = "black"),
      axis.text.y = element_text(colour = "black"),
      axis.title = element_blank(),
      panel.grid = element_blank(),
      legend.position = "right"
    )

  if (has_groups) {
    fg_per_ord <- as.character(feature_groups[ord])
    fg_per_ord[is.na(fg_per_ord) | !nzchar(fg_per_ord)] <- "Other"
    if (is.null(group_colors)) {
      lvls <- unique(fg_per_ord)
      group_colors <- setNames(
        grDevices::hcl.colors(max(length(lvls), 2), palette = "Set 2")[seq_along(lvls)],
        lvls
      )
    }

    strip_df <- data.frame(
      pos = seq_len(n),
      hex = unname(group_colors[fg_per_ord]),
      stringsAsFactors = FALSE
    )

    p <- p +
      # LEFT strip — vertical column of tiles at x = 0
      geom_tile(data = strip_df, aes(x = 0, y = pos),
                fill = strip_df$hex, color = "grey60", linewidth = 0.2,
                inherit.aes = FALSE) +
      # BOTTOM strip — horizontal row of tiles at y = 0
      geom_tile(data = strip_df, aes(x = pos, y = 0),
                fill = strip_df$hex, color = "grey60", linewidth = 0.2,
                inherit.aes = FALSE)

    # Phantom layer purely to render a Met-1 legend without clashing with
    # the heatmap's `fill` scale.
    legend_df <- data.frame(
      .group = factor(names(group_colors), levels = names(group_colors)),
      stringsAsFactors = FALSE
    )
    p <- p +
      geom_point(data = legend_df,
                 aes(x = NA_real_, y = NA_real_, colour = .group),
                 inherit.aes = FALSE, size = 4, na.rm = TRUE) +
      scale_colour_manual(values = group_colors, name = group_legend_name,
                           drop = FALSE) +
      guides(colour = guide_legend(override.aes = list(shape = 15, size = 5)))
  }

  p
}

```


```{r logo, echo=FALSE, results="asis"}
# Package logo, placed beside the report title. The title block is written by
# the template before any chunk runs, so an <img> emitted here would land next
# to section 1 instead. A style rule reaches #header wherever it appears, and
# the image rides along base64-encoded so the report stays one portable file.
#
# Installed packages carry the logo at help/figures; a source tree
# (devtools::load_all) still has it at man/figures, so both are tried. A
# missing logo is silently skipped -- a decoration must never stop a report.
.logo <- system.file("help", "figures", "logo.png", package = "quantMSImageR")
if (!nzchar(.logo))
  .logo <- system.file("man", "figures", "logo.png", package = "quantMSImageR")
if (nzchar(.logo))
  cat(sprintf('<style>
/* min-height guarantees the 80px logo, anchored to the bottom, clears the
   ~24px code button above it however short the title block is. */
#header { position: relative; min-height: 112px; }
#header .title, #header .author, #header .date { padding-right: 100px; }
#header::after {
  content: ""; position: absolute; bottom: 0; right: 0;
  width: 80px; height: 80px;
  background: url("%s") no-repeat right bottom;
  background-size: contain;
}
/* Anchored bottom-right, not top-right: the code-folding button floats in the
   top-right corner of the same block and the two would sit on top of one
   another. Hidden on narrow screens, where there is no room beside the title. */
@media (max-width: 700px) { #header::after { display: none; } }
</style>', knitr::image_uri(.logo)))
```

# 1. Study

DESI-MRM mass spectrometry imaging of tissue sections, processed with quantMSImageR.

## 1.1 Sample mapping

Acquisition filenames, run IDs used throughout this report, and group labels.
Where a group contains biological replicates, each section is assigned a unique
`_1`, `_2`, … suffix (shown individually in heatmaps and ion images; pooled by
group label in comparison plots).

```{r sample-map, echo = FALSE}
if (exists("sample_map")) {
  # Hide empty polarity columns for cleaner display
  sm_show <- sample_map
  if (all(sm_show$pos_files == "")) sm_show$pos_files <- NULL
  if (all(sm_show$neg_files == "")) sm_show$neg_files <- NULL
  DT::datatable(sm_show, rownames = FALSE,
                options = list(pageLength = 25, scrollX = TRUE))
} else {
  cat("*(sample_map not available — run via runStudy.R to populate)*")
}
```

## 1.2 Features / transitions

MRM transitions and analyte metadata from the ion library. `SNR_used` is the
signal-to-noise threshold applied to each feature in this report (the global
threshold, or a per-analyte override where set).

```{r import, echo = FALSE}

# m/z and SNR are reported to one decimal place: that is the precision an MRM
# ion library is quoted at, and the precision transitions are matched on.
# Intensities are left alone -- they are measured counts, not masses.
.round1 <- function(x) {
  if (is.numeric(x)) return(round(x, 1))
  chr <- as.character(x)
  num <- suppressWarnings(as.numeric(chr))
  # A column that is wholly numeric becomes numeric, so the table still sorts
  # by value rather than alphabetically.
  if (!any(is.na(num) & !is.na(chr))) return(round(num, 1))
  # Otherwise it holds " || "-joined tokens (a feature covering several
  # transitions); round each token and rejoin.
  vapply(strsplit(chr, " || ", fixed = TRUE), function(tok) {
    n <- suppressWarnings(as.numeric(tok))
    paste(ifelse(is.na(n), tok, format(round(n, 1), trim = TRUE)),
          collapse = " || ")
  }, character(1))
}

.fd <- data.frame(fData(combined), check.names = FALSE)

# Insert the effective SNR threshold used per feature immediately to the right
# of product_mz, if provided by the caller (append at the end if product_mz is
# absent).
if (exists("snr_used") && !is.null(snr_used)) {
  .fd$SNR_used <- unname(snr_used[as.character(.fd$name)])
  .nm  <- setdiff(colnames(.fd), "SNR_used")
  .pos <- match("product_mz", .nm)
  .ord <- if (is.na(.pos)) c(.nm, "SNR_used") else append(.nm, "SNR_used", after = .pos)
  .fd <- .fd[, .ord, drop = FALSE]
}

# Applied to .fd itself, so the xlsx Features tab below matches this table.
.dp1 <- c(grep("_mz$", colnames(.fd), value = TRUE),
          intersect("SNR_used", colnames(.fd)))
for (.c in .dp1) .fd[[.c]] <- .round1(.fd[[.c]])

# formatRound pins the display at exactly one decimal place (279 -> 279.0)
# while the column stays numeric, so the table still sorts by value. Columns
# left as character hold " || "-joined tokens and are already formatted.
.dp1_num <- .dp1[vapply(.fd[.dp1], is.numeric, logical(1))]
.dt <- DT::datatable(.fd, rownames = FALSE)
if (length(.dp1_num)) .dt <- DT::formatRound(.dt, columns = .dp1_num, digits = 1)
.dt

```

# 2. Heatmap {.tabset .tabset-fade}

Nth-percentile intensity per feature per sample, z-scored per feature across
samples. Rows are individual sections ordered by group; columns are features,
split by class. Cells are drawn square, so the panel grows with the study
rather than distorting to fill a fixed area.

```{r hm-style-note, echo=FALSE, results="asis"}
# Which of the two heatmaps to draw. "auto" decides from the study design;
# never both, since two readings of one matrix stacked together is more to
# compare rather than more information.
.style_cfg <- if (exists("heatmap_style") && !is.null(heatmap_style)) {
  heatmap_style
} else {
  "auto"
}
.hm_style <- quantMSImageR:::.heatmap_style(.style_cfg, heatmap_labs)

# Which heatmap this is, said in the report rather than left to the config.
#
# Braces are required on both arms: a bare `else` starting a new line at top
# level is a parse error, which is why the [palettes] chunk above brackets its
# if/else too.
.style_note <- if (identical(.hm_style, "contribution")) {
  paste0("Each cell carries two things: the **hue** is that sample's *group* ",
         "mean for the feature, and the **opacity** is how much that *sample* ",
         "contributed to it. A uniformly solid block is a real group effect; ",
         "one opaque tile among faded ones is a group mean resting on a ",
         "single sample. Features with no variance across samples are grey.")
} else {
  paste0("Each cell is that sample's own z-score, clipped to [-1, 1] -- every ",
         "sample shown directly, with no group summary in between.")
}
cat(.style_note, "\n\n")
```

```{r palettes, echo=FALSE, include=FALSE}
# Palettes come from the YAML `colours:` block via runStudy(); runExample()
# sets the same names. Fall back to the package defaults when absent so the
# report still renders if a config predates the block.
.pal_ion     <- if (exists("pal_ion"))     pal_ion     else "heatmap0"
.pal_heatmap <- if (exists("pal_heatmap")) pal_heatmap else "heatmap2"
.pal_group   <- if (exists("pal_group"))   pal_group   else "hat"
.pal_feature <- if (exists("pal_feature")) pal_feature else "reading"

# Hairline drawn between heatmap cells. "none" (or blank) means no border, in
# which case neighbouring cells of the same colour merge into one block.
.cell_border <- if (exists("hm_cell_border")) as.character(hm_cell_border) else "white"
if (length(.cell_border) != 1L || is.na(.cell_border) ||
    tolower(.cell_border) %in% c("none", "")) {
  .cell_border <- NA
}

# Cardinal's image() takes a colour vector rather than a palette name.
# Braces matter here: a bare `else` starting a new line at top level is a
# parse error.
.ion_cols <- if (identical(.pal_ion, "viridis")) {
  viridis::viridis(256)
} else {
  grDevices::colorRampPalette(quantMSImageR::quantPalettes(.pal_ion))(256)
}

# Named colour vector for a categorical variable. Mirrors the package-internal
# .anno_cols() that quantileHm() uses, so the group colours in the box/violin
# plots are the same ones as the heatmap's group bar.
.cat_cols <- function(levels, palette) {
  n <- max(length(levels), 2)
  cols <- if (palette %in% names(quantMSImageR::quantPalettes()))
            quantMSImageR::quantPalettes(palette, n = n)
          else
            grDevices::hcl.colors(n, palette = palette)
  stats::setNames(cols[seq_along(levels)], levels)
}

# Group levels in the order the heatmap uses them, so colours line up between
# section 2 and section 3.
.grp_levels <- if (exists("heatmap_labs")) {
  unique(as.character(heatmap_labs))
} else {
  character(0)
}
.grp_cols   <- .cat_cols(.grp_levels, .pal_group)

# run_id -> group label. Defined here (always run) so single-sample reports,
# which skip the comparison chunks, still have it for the ion-image ordering.
if (exists("heatmap_labs") && exists("heatmap_order"))
  run_to_lab <- stats::setNames(heatmap_labs, heatmap_order)
```

```{r hm-size, echo=FALSE, include=FALSE}
# Both heatmaps give the body an absolute size in millimetres, so the device
# must be sized to the heatmap rather than the other way round. Drawing once on
# a null device lets ComplexHeatmap report the total size it needs (body +
# annotations + labels + legends); anything left over would otherwise be
# emitted as white space around a small panel.
.hm_dev_size <- function(p, extra = NULL, fallback = c(12, 7)) {
  tryCatch({
    # ComplexHeatmap documents measuring a drawn heatmap this way but does not
    # export the two accessors, so they are fetched by name; the whole thing
    # falls back to a fixed size if that ever stops working.
    .w_fun <- utils::getFromNamespace("width",  "ComplexHeatmap")
    .h_fun <- utils::getFromNamespace("height", "ComplexHeatmap")
    grDevices::pdf(NULL)
    on.exit(grDevices::dev.off(), add = TRUE)
    # Measured with the same arguments the real render uses, including the
    # opacity key -- a legend left out here becomes white space there.
    ht <- ComplexHeatmap::draw(p, merge_legends = TRUE,
                               annotation_legend_list = extra)
    w  <- grid::convertWidth(.w_fun(ht),  "in", valueOnly = TRUE)
    h  <- grid::convertHeight(.h_fun(ht), "in", valueOnly = TRUE)
    if (!is.finite(w) || !is.finite(h) || w <= 0 || h <= 0) return(fallback)
    # A small margin, then clamp so a huge study cannot produce an unusable
    # file. The cap CROPS rather than scales -- ComplexHeatmap draws at its
    # measured size regardless -- so anything wider than this loses its
    # right-hand legends off the edge. 25 in was too tight once a study had
    # long feature-class names; the labels are wrapped at source now, and the
    # cap is raised so wrapping is the thing that keeps it narrow, not the
    # crop. A message rather than silence, because the failure is invisible in
    # the output.
    .wmax <- 36
    if (w + 0.4 > .wmax)
      message("heatmap is ", round(w + 0.4, 1), " in wide but the device is ",
              "capped at ", .wmax, " in -- the right-hand legends will be ",
              "cropped. Shorten the feature-class names or lower `fontsize`.")
    c(min(max(w + 0.4, 4), .wmax), min(max(h + 0.4, 2.5), 40))
  }, error = function(e) fallback)
}
```

```{r hm, results="asis", echo = FALSE, include=T, warning=FALSE}

# Build feature split vector from per-feature metadata (joined by m/z in runStudy.R)
.row_split <- NULL
if (exists("feature_meta") && !is.null(feature_meta) &&
    exists("heatmap_row_split") && !is.null(heatmap_row_split) &&
    heatmap_row_split %in% colnames(feature_meta)) {
  .row_split <- as.character(feature_meta[[heatmap_row_split]])
  # Unmatched / blank entries become a single "Other" group instead of NAs
  .row_split[is.na(.row_split) | !nzchar(trimws(.row_split))] <- "Other"
}

.split_name <- if (exists("heatmap_row_split") && !is.null(heatmap_row_split) &&
                   nzchar(heatmap_row_split)) heatmap_row_split else "Pathway"

# A z-score needs something to compare against. With one acquisition the
# per-feature sd is undefined, so every cell would be missing -- and the old
# implementation drew them all at the ramp midpoint, which reads as a real
# result rather than an absent one. Say so instead of drawing either.
if (length(heatmap_order) < 2) {
  cat("## Heatmap\n\n",
      "*Not drawn: a single acquisition has nothing to be scored against. ",
      "Per-feature intensities are in section 1.2, and the ion images below ",
      "show their distribution.*\n\n", sep = "")
} else {

for (quant_value in c(0.25, 0.5, 0.75, 0.95, 0.98)) {

  cat(paste('## ', as.character(quant_value * 100), "th quantile heatmap",
            '\n\n'))

  .args <- list(MSIobject = combined, quant_val = quant_value,
                heatmap_order = heatmap_order, heatmap_labs = heatmap_labs,
                feature_split = .row_split,
                feature_split_name = .split_name,
                group_split_name = "Group",
                palette          = .pal_heatmap,
                group_palette    = .pal_group,
                feature_palette  = .pal_feature,
                cell_border      = .cell_border)

  p <- if (identical(.hm_style, "contribution")) {
    do.call(quantMSImageR::contributionHm, .args)
  } else {
    do.call(quantMSImageR::quantileHm, .args)
  }

  # The opacity channel has no colour mapping, so contributionHm() attaches
  # its key for draw() to place alongside the others.
  .extra <- attr(p, "contribution_legend")

  # ComplexHeatmap's draw() targets the active grid device. Inside a
  # results="asis" chunk that device is the screen, not the chunk's PNG
  # capture, so print(p) would spill the plot to the R session window
  # instead of into the HTML. Render to a temp PNG and embed via base64.
  .tmp <- tempfile(fileext = ".png")
  .sz  <- .hm_dev_size(p, extra = .extra)
  grDevices::png(.tmp, width = .sz[1], height = .sz[2], units = "in",
                 res = .fig_dpi)
  # Draw with merge_legends = TRUE so the value, Group and feature-class keys
  # pack into one legend column -- this also avoids a ComplexHeatmap viewport
  # bug ("depth applied to NULL") that some versions hit when several
  # annotation legends are drawn separately. Fall back to a plain draw if
  # merging fails.
  .ok <- tryCatch({
      ComplexHeatmap::draw(p, merge_legends = TRUE,
                           annotation_legend_list = .extra); TRUE
    }, error = function(e)
      tryCatch({ ComplexHeatmap::draw(p); TRUE },
               error = function(e2) FALSE))
  grDevices::dev.off()
  if (.ok) {
    # Display at the physical size it was drawn at (96 CSS px per inch), so the
    # render stays crisp without the browser blowing it up or shrinking it;
    # max-width keeps a wide study inside the page.
    # Built with paste0, NOT sprintf, and deliberately so.
    #
    # rmarkdown's resource discovery renders this document WITHOUT evaluating
    # its chunks, then scans the result for image tags and feeds each source
    # attribute to utils::URLdecode(). An unevaluated sprintf placeholder in
    # the source therefore reaches it as a literal, and URLdecode reads the
    # letter after the percent sign as a hex escape, finds it is not one, and
    # warns "out-of-range values treated as 0 in coercion to raw" -- twice,
    # once per discovery pass. That warning was reported in Bioconductor
    # review and traced here.
    #
    # With paste0 the character after the opening attribute quote is itself a
    # quote, which the scanner's character class cannot match, so no
    # placeholder is ever seen. Do not convert this back to sprintf.
    #
    # NOTE the same applies to this comment: keep example markup out of it,
    # or the scanner finds the placeholder here instead.
    cat(paste0('<p><img src="', knitr::image_uri(.tmp),
               '" alt="quantile ', format(quant_value),
               ' heatmap" style="width:', round(.sz[1] * 96),
               'px;max-width:100%;height:auto;"/></p>\n'))
  } else {
    cat("*(heatmap could not be drawn on this ComplexHeatmap version)*\n\n")
  }
  unlink(.tmp)

  cat('\n \n')

}

}

```

```{r cmp-heading, results="asis", echo=FALSE}
if (length(heatmap_order) > 1)
  cat("# 3. Comparison plots {.tabset .tabset-fade}\n\n## Box + violin (side-by-side)\n\n")
```

```{r box_violin_dropdown, results="asis", echo=FALSE, include=TRUE, warning=FALSE, message=FALSE, fig.width=11, fig.height=5.5, eval=length(heatmap_order) > 1}

val_slot <- "intensity"

stopifnot(length(heatmap_order) == length(heatmap_labs))

# Map run_id -> group label (group label can repeat across replicates)
run_to_lab <- setNames(heatmap_labs, heatmap_order)

`%||%` <- function(a, b) if (is.null(a)) b else a

# Baseline label from calling script if present; else default to first label
if (!exists("baseline_label") || is.null(baseline_label) || !nzchar(baseline_label)) {
  baseline_label <- heatmap_labs[1]
}
if (!(baseline_label %in% heatmap_labs)) {
  stop(sprintf(
    "baseline_label '%s' not found in heatmap_labs.\nAvailable labels: %s",
    baseline_label, paste(unique(heatmap_labs), collapse = ", ")
  ))
}

# feature names for titles
met_names <- tryCatch(featureNames(combined), error = function(e) NULL)
if (is.null(met_names)) met_names <- as.character(mz(combined))

# safe ids for dropdown blocks
make_safe_id <- function(x) gsub("[^A-Za-z0-9_\\-]", "_", x)
safe_ids <- vapply(met_names, make_safe_id, character(1))

# ---- Detect features with any signal in selected runs ----
is_detected <- vapply(seq_along(met_names), function(mz_ind) {
  any(vapply(heatmap_order, function(fn) {
    p <- combined$run == fn
    v <- spectraData(combined)[[val_slot]][mz_ind, p]
    any(is.finite(v)) && any(v[is.finite(v)] != 0)
  }, logical(1)))
}, logical(1))

not_detected  <- met_names[!is_detected]
detected_mets <- met_names[is_detected]
detected_inds <- which(is_detected)
detected_ids  <- safe_ids[is_detected]

# Alphabetical dropdown
ord <- order(tolower(detected_mets))
detected_mets <- detected_mets[ord]
detected_inds <- detected_inds[ord]
detected_ids  <- detected_ids[ord]

# ---- Dropdown + JS ----
cat('
<label for="cmp_select" style="font-weight:600;">Select metabolite:</label>
<select id="cmp_select" style="margin: 0 0 12px 8px; padding: 4px 6px;"
        onchange="showCmp(this.value)">
')

if (length(detected_mets) == 0) {
  cat('<option value="">No detected metabolites</option>')
} else {
  for (i in seq_along(detected_mets)) {
    sel <- if (i == 1) " selected" else ""
    cat(sprintf('<option value="%s"%s>%s</option>\n', detected_ids[i], sel, detected_mets[i]))
  }
}

cat('</select>

<script>
function showCmp(id){
  var blocks = document.querySelectorAll(".cmp_block");
  for (var i=0; i<blocks.length; i++) { blocks[i].style.display = "none"; }
  var el = document.getElementById("cmp_" + id);
  if (el) el.style.display = "block";
}
</script>
')

# ============================
# Collect FC rows during plotting
# FC computed by GROUP label ("Ctrl", "HDM"), pooling runs per group
# ============================
fc_rows <- list()

if (length(detected_mets) > 0) {
  
  for (i in seq_along(detected_mets)) {
    
    mz_ind <- detected_inds[i]
    met    <- detected_mets[i]
    mid    <- detected_ids[i]
    
    # Build long df: one row per pixel, tagged with run_id and group label.
    df <- bind_rows(lapply(heatmap_order, function(fn) {
      p <- combined$run == fn
      v <- spectraData(combined)[[val_slot]][mz_ind, p]
      v <- v[is.finite(v)]
      tibble(
        run = fn,
        group_label = run_to_lab[[fn]],
        intensity = v
      )
    }))

    if (nrow(df) == 0) next

    # x-axis: one slot per run (ordered by group); fill: pooled group label
    df$run         <- factor(df$run, levels = heatmap_order)
    df$group_label <- factor(df$group_label, levels = unique(heatmap_labs))
    
    # ---- FC computation: quantiles per GROUP label ----
    q_tbl <- df %>%
      group_by(group_label) %>%
      summarise(
        q25 = unname(quantile(intensity, 0.25, na.rm = TRUE)),
        q50 = unname(quantile(intensity, 0.50, na.rm = TRUE)),
        q75 = unname(quantile(intensity, 0.75, na.rm = TRUE)),
        q90 = unname(quantile(intensity, 0.90, na.rm = TRUE)),
        .groups = "drop"
      )
    
    base_row <- q_tbl %>% filter(group_label == baseline_label)
    
    if (nrow(base_row) == 1) {
      
      base_q25 <- base_row$q25
      base_q50 <- base_row$q50
      base_q75 <- base_row$q75
      base_q90 <- base_row$q90
      
      if (all(is.finite(c(base_q25, base_q50, base_q75, base_q90))) &&
          all(c(base_q25, base_q50, base_q75, base_q90) != 0)) {
        
        fc_one <- q_tbl %>%
          filter(group_label != baseline_label) %>%
          transmute(
            metabolite = met,
            
            # FC (requested order)
            FC_q50 = q50 / base_q50,
            FC_q90 = q90 / base_q90,
            FC_q75 = q75 / base_q75,
            FC_q25 = q25 / base_q25,
            
            # log2FC (same order)
            log2FC_q50 = log2(q50 / base_q50),
            log2FC_q90 = log2(q90 / base_q90),
            log2FC_q75 = log2(q75 / base_q75),
            log2FC_q25 = log2(q25 / base_q25),
            
            baseline = baseline_label,
            compare  = as.character(group_label),
            
            # the rest (QC/debugging)
            baseline_q25 = base_q25,
            baseline_q50 = base_q50,
            baseline_q75 = base_q75,
            baseline_q90 = base_q90,
            
            compare_q25 = q25,
            compare_q50 = q50,
            compare_q75 = q75,
            compare_q90 = q90
          )
        
        fc_rows[[length(fc_rows) + 1]] <- fc_one
      }
    }
    
    # ---- Visualization clipping (global p90 across pixels shown) ----
    p90_vis  <- quantile(df$intensity, 0.90, na.rm = TRUE)
    pmin_vis <- min(df$intensity, na.rm = TRUE)
    
    # Same group colours as the heatmap's group bar (from the YAML `colours:`
    # block), so a group keeps one colour across the whole report.
    .grp_scale <- scale_fill_manual(values = .grp_cols, name = "Group",
                                    drop = FALSE)

    p_box <- ggplot(df, aes(x = run, y = intensity, fill = group_label)) +
      theme_classic() +
      geom_boxplot(outlier.shape = NA, width = 0.6, alpha = 0.7) +
      .grp_scale +
      coord_cartesian(ylim = c(pmin_vis, p90_vis)) +
      labs(x = NULL, y = "Intensity (≤ p90)", fill = "Group") +
      theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1),
            legend.position = "right")

    p_violin <- ggplot(df, aes(x = run, y = intensity, fill = group_label)) +
      theme_classic() +
      geom_violin(trim = TRUE, alpha = 0.6) +
      geom_boxplot(width = 0.15, outlier.shape = NA, alpha = 0.8) +
      .grp_scale +
      coord_cartesian(ylim = c(pmin_vis, p90_vis)) +
      labs(x = NULL, y = "Intensity (≤ p90)", fill = "Group") +
      theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1),
            legend.position = "right")
    
    p_both <- (p_box + ggtitle("Boxplot")) | (p_violin + ggtitle("Violin + box")) +
      patchwork::plot_annotation(title = met)
    
    display_style <- if (i == 1) "block" else "none"
    cat(sprintf('\n<div class="cmp_block" id="cmp_%s" style="display:%s;">\n\n', mid, display_style))
    tryCatch(print(p_both), error = function(e)
      cat("<p><em>plot failed: ", conditionMessage(e), "</em></p>\n"))
    cat("\n\n</div>\n\n")
  }
}

# ---- Not-detected list (QC) ----
if (length(not_detected) > 0) {
  cat("<details style='margin-top:12px;'><summary><b>Not detected metabolites</b></summary><ul>")
  for (x in not_detected) cat(sprintf("<li>%s</li>", x))
  cat("</ul></details>")
}

# ---- FC table (built during plotting) ----
fc_tbl <- dplyr::bind_rows(fc_rows)

if (nrow(fc_tbl) > 0) {
  wanted <- c(
    "metabolite",
    "FC_q50", "FC_q90", "FC_q75", "FC_q25",
    "log2FC_q50", "log2FC_q90", "log2FC_q75", "log2FC_q25",
    "baseline", "compare"
  )
  keep_first <- intersect(wanted, colnames(fc_tbl))
  fc_tbl <- fc_tbl %>% dplyr::select(dplyr::all_of(keep_first), dplyr::everything())
}

cat("<hr>")
if (nrow(fc_tbl) == 0) {
  cat("<p><b>No fold-changes computed.</b> Likely baseline quantiles were 0/NA for many metabolites, or one group had no pixels.</p>")
} else {
  .xlsx_name <- paste0(if (exists("report_fn")) report_fn else "tables", "_tables.xlsx")
  cat(sprintf(
    "<p>Baseline: <b>%s</b>. FC (Q25/Q50/Q75/Q90) written to <code>%s</code> — sheet <em>Fold_Change</em>.</p>",
    baseline_label, .xlsx_name
  ))
}

```

# 4. Correlation

Spatial co-localisation metrics computed pairwise across all features.

- **Pearson's r** — linear relationship between pixel intensities of two ions.
- **Manders Overlap Coefficient (MOC)** — degree of pixel-intensity overlap; M1 is the fraction of ion 1 intensity that overlaps with ion 2, M2 the reverse (asymmetric).
- **Dice score** — overlap of the binary segmentation masks derived from M1 and M2.

Metrics are reported for all samples pooled (**All**) and for each group separately.

Numeric tables (fold-change and pairwise correlation per group) are written to
`r paste0(if (exists("report_fn")) report_fn else "tables", "_tables.xlsx")`
in the report's output directory — see sheets `Fold_Change`, `Cor_All`, `Cor_<group>`.

```{r cor-compute, echo=FALSE, include=FALSE, warning=FALSE, message=FALSE}

# Metabolite names (use featureNames if available; fallback to mz labels)
met_names <- tryCatch(featureNames(combined), error = function(e) NULL)
if (is.null(met_names)) met_names <- as.character(mz(combined))
mz_vals   <- mz(combined)
name_to_idx <- setNames(seq_along(met_names), met_names)

# --- Helper: compute per-pair correlation long table for a given MSI object ---
compute_coloc_table <- function(obj) {
  if (ncol(obj) == 0) return(NULL)
  raw <- do.call(
    rbind,
    lapply(seq_along(mz_vals), function(j) {
      tryCatch({
        tmp <- data.frame(Cardinal::colocalized(obj, mz = mz_vals[j]),
                          check.names = FALSE)
        data.frame(
          metA = met_names[j],
          metB = rownames(tmp),
          cor  = tmp$cor,
          MOC  = tmp$MOC,
          M1   = tmp$M1,
          M2   = tmp$M2,
          Dice = tmp$Dice,
          stringsAsFactors = FALSE,
          check.names = FALSE
        )
      }, error = function(e) NULL)
    })
  )
  if (is.null(raw) || nrow(raw) == 0) return(NULL)
  raw <- raw |>
    dplyr::mutate(
      idxA = unname(name_to_idx[metA]),
      idxB = unname(name_to_idx[metB])
    ) |>
    dplyr::filter(!is.na(idxA), !is.na(idxB), idxA != idxB)
  pairs <- raw |>
    dplyr::mutate(
      idx1 = pmin(idxA, idxB),
      idx2 = pmax(idxA, idxB),
      met1 = met_names[idx1],
      met2 = met_names[idx2],
      pair_id = paste0(idx1, "__", idx2)
    ) |>
    dplyr::filter(idx1 < idx2) |>
    dplyr::distinct(pair_id, .keep_all = TRUE) |>
    dplyr::select(metA = met1, metB = met2, cor, MOC, M1, M2, Dice,
                  idxA = idx1, idxB = idx2, pair_id) |>
    dplyr::filter(is.finite(cor), is.finite(MOC),
                  is.finite(M1), is.finite(M2), is.finite(Dice))
  list(long = raw, pairs = pairs)
}

# --- Build one correlation dataset per group + one for "All" ---
cor_datasets <- list()
cor_datasets[["All"]] <- compute_coloc_table(combined)

unique_groups <- unique(heatmap_labs)
if (length(unique_groups) > 1) {
  for (grp in unique_groups) {
    grp_runs <- heatmap_order[heatmap_labs == grp]
    grp_obj  <- combined[, pData(combined)$run %in% grp_runs]
    cor_datasets[[grp]] <- compute_coloc_table(grp_obj)
  }
}
# Drop failed groups
cor_datasets <- cor_datasets[!vapply(cor_datasets, is.null, logical(1))]

```

## Correlation heat map {.tabset .tabset-fade}

```{r cor-hm, results="asis", echo = FALSE, include=T, warning=FALSE, fig.width=10, fig.height=8}

# Per-feature -> Met-1 mapping for grouping/colouring the triangular heatmaps.
# Reuses feature_meta built in runStudy.R; falls back to no grouping if absent.
.feat_groups <- NULL
.met_palette <- NULL
if (exists("feature_meta") && !is.null(feature_meta) &&
    exists("heatmap_row_split") && !is.null(heatmap_row_split) &&
    nzchar(heatmap_row_split) &&
    heatmap_row_split %in% colnames(feature_meta)) {
  .fg <- as.character(feature_meta[[heatmap_row_split]])
  .fg[is.na(.fg) | !nzchar(trimws(.fg))] <- "Other"
  .feat_groups <- setNames(.fg, rownames(feature_meta))
  .lvls <- unique(.fg)
  # Feature-class colours from the YAML `colours:` block, matching the
  # heatmap's feature bar.
  .met_palette <- .cat_cols(.lvls, .pal_feature)
}

for (grp_name in names(cor_datasets)) {

  cat("### ", grp_name, " {.tabset .tabset-fade}\n\n", sep = "")

  long_df <- cor_datasets[[grp_name]]$long

  for (cor_type in c("cor", "MOC", "M1", "M2", "Dice")) {

    cat("#### ", cor_type, "\n\n", sep = "")

    sim_mat <- tryCatch(make_sim_mat(long_df, cor_type), error = function(e) NULL)
    if (is.null(sim_mat) || nrow(sim_mat) < 2) {
      cat("*(insufficient data)*\n\n"); next
    }
    hc  <- cluster_from_sim(sim_mat)
    ord <- hc$labels[hc$order]

    p <- plot_tri_heatmap(long_df, cor_type, ord,
                           feature_groups = .feat_groups,
                           group_colors   = .met_palette,
                           group_legend_name = if (!is.null(heatmap_row_split) &&
                                                   nzchar(heatmap_row_split))
                                                 heatmap_row_split else "Met-1")
    print(p)
    cat("\n\n")
  }
}

```

```{r write-xlsx, echo=FALSE, include=FALSE, message=FALSE, warning=FALSE}
.out <- if (exists("out_path") && nzchar(out_path)) out_path else "."
.fn  <- if (exists("report_fn") && nzchar(report_fn)) report_fn else "tables"
dir.create(.out, recursive = TRUE, showWarnings = FALSE)
.xlsx_path <- normalizePath(file.path(.out, paste0(.fn, "_tables.xlsx")),
                             mustWork = FALSE, winslash = "/")

.sheets_added <- character()
wb <- openxlsx::createWorkbook()

# Feature / transition metadata (incl. SNR_used, positioned right of product_mz)
# as the first tab -- mirrors section 1.2 of the report.
if (exists(".fd") && is.data.frame(.fd) && nrow(.fd) > 0) {
  openxlsx::addWorksheet(wb, "Features")
  openxlsx::writeDataTable(wb, "Features", .fd,
                            startRow = 1, tableStyle = "TableStyleLight9")
  openxlsx::setColWidths(wb, "Features", cols = seq_len(ncol(.fd)),
                          widths = "auto")
  .sheets_added <- c(.sheets_added, "Features")
}

if (exists("fc_tbl") && is.data.frame(fc_tbl) && nrow(fc_tbl) > 0) {
  openxlsx::addWorksheet(wb, "Fold_Change")
  openxlsx::writeDataTable(wb, "Fold_Change", fc_tbl,
                            startRow = 1, tableStyle = "TableStyleLight9")
  openxlsx::setColWidths(wb, "Fold_Change", cols = seq_len(ncol(fc_tbl)),
                          widths = "auto")
  .sheets_added <- c(.sheets_added, "Fold_Change")
}

if (exists("cor_datasets") && length(cor_datasets) > 0) {
  for (.grp in names(cor_datasets)) {
    .tbl <- cor_datasets[[.grp]]$pairs
    if (is.null(.tbl) || !is.data.frame(.tbl) || nrow(.tbl) == 0) next
    .sname <- substr(paste0("Cor_", gsub("[^A-Za-z0-9_]", "_", .grp)), 1, 31)
    openxlsx::addWorksheet(wb, .sname)
    openxlsx::writeDataTable(wb, .sname, .tbl,
                              startRow = 1, tableStyle = "TableStyleLight9")
    openxlsx::setColWidths(wb, .sname, cols = seq_len(ncol(.tbl)),
                            widths = "auto")
    .sheets_added <- c(.sheets_added, .sname)
  }
}

if (length(.sheets_added) > 0) {
  tryCatch(openxlsx::saveWorkbook(wb, .xlsx_path, overwrite = TRUE),
           error = function(e) message("Failed to write xlsx: ", conditionMessage(e)))
  message("Tables xlsx written to: ", .xlsx_path,
          " — sheets: ", paste(.sheets_added, collapse = ", "))
}
```

# 5. Ion images {.tabset .tabset-fade}

Ion images of all tissue sections. Three rendering modes per feature:

1. **Scaled to 95th quantile** — intensities capped at the p95 across all sections; balances spatial detail with cross-section intensity comparability.
2. **Histogram normalised** — contrast enhanced per section; best for visualising spatial distribution within a section.
3. **No scaling or normalisation** — raw intensities; dominated by hotspots but preserves absolute differences between sections.

```{r ion-img-dropdown, results="asis", echo=FALSE, include=TRUE, warning=FALSE, fig.width=7.5, fig.height=6}
# ---- Helper to make safe HTML ids ----
make_safe_id <- function(x) gsub("[^A-Za-z0-9_\\-]", "_", x)

# Reorder pixels (columns of `combined`) so panels appear grouped by label.
# combined has one column per PIXEL (not per sample), so we must compute the
# sort key per pixel — using its run -> group label — not per sample.
.pix_run <- as.character(pData(combined)$run)
.pix_grp <- run_to_lab[.pix_run]
.img_ord <- order(match(.pix_grp, unique(heatmap_labs)),
                  match(.pix_run, heatmap_order))
combined_img <- combined[, .img_ord]

features <- as.character(fData(combined)$name)
feature_ids <- vapply(features, make_safe_id, character(1))

ord <- order(tolower(features))

# sorted display vectors
features_sorted    <- features[ord]
feature_ids_sorted <- feature_ids[ord]

# ---- Dropdown + JS ----
cat('
<label for="ion_select" style="font-weight:600;">Select feature:</label>
<select id="ion_select" style="margin: 0 0 12px 8px; padding: 4px 6px;"
        onchange="showIonFeature(this.value)">
')

for (i in seq_along(features_sorted)) {
  sel <- if (i == 1) ' selected' else ''
  cat(sprintf('<option value="%s"%s>%s</option>\n',
              feature_ids_sorted[i], sel, features_sorted[i]))
}

cat('</select>

<script>
function showIonFeature(id){
  var blocks = document.querySelectorAll(".ion_feature_block");
  for (var i=0; i<blocks.length; i++) { blocks[i].style.display = "none"; }
  var el = document.getElementById("ion_" + id);
  if (el) el.style.display = "block";
}
</script>
')

# ---- Render each feature block (hidden except first) ----
for (i in seq_along(ord)) {

  idx <- ord[i]  # <-- original row index in combined/fData/spectraData

  feature <- features_sorted[i]
  fid     <- feature_ids_sorted[i]
  mz_val  <- fData(combined)$mz[idx]

  display_style <- if (i == 1) "block" else "none"
  cat(sprintf('\n<div class="ion_feature_block" id="ion_%s" style="display:%s;">\n\n',
              fid, display_style))
  # Use a styled <p> instead of <h3> so the feature name does not populate the TOC
  cat(sprintf("<p style='margin-top:10px;font-size:1.17em;font-weight:600;'>%s</p>\n", feature))

  # q95 from non-NA pixels only; as.numeric() forces out of matter-array to plain R vector
  all_ints <- tryCatch(
    as.numeric(spectraData(combined[idx, ])[["intensity"]]),
    error = function(e) numeric(0))   # empty -> has_signal FALSE, handled below
  q95      <- suppressWarnings(quantile(all_ints, 0.95, na.rm = TRUE))
  has_signal <- any(is.finite(all_ints))   # FALSE when feature absent in every sample

  # Helper: blank grid page with message (keeps device in grid mode after Cardinal's grid rendering)
  blank_grid <- function(msg) {
    grid::grid.newpage()
    grid::grid.text(msg, gp = grid::gpar(fontsize = 11, col = "grey40"))
  }

  # Plot 1: Scaled to 95th quantile (columns ordered by group)
  # Subset to single feature, convert matter-backed array to plain matrix, cap at q95,
  # replace entire slot (sub-slice assignment does not persist in matter backend).
  if (!has_signal) {
    blank_grid("Scaled to 95th quantile\n(No signal in any sample)")
  } else {
    tryCatch({
      combined_q95 <- combined_img[idx, ]
      ints_q95 <- as.matrix(spectraData(combined_q95)[["intensity"]])
      if (is.finite(q95)) ints_q95[!is.na(ints_q95) & ints_q95 > q95] <- q95
      spectraData(combined_q95)[["intensity"]] <- ints_q95
      p1 <- image(combined_q95, scale = FALSE, zlim = c(0, q95), mz = mz_val,
                  free = "xy", axes = FALSE, grid = FALSE, col = .ion_cols) |>
        matter::set_title("Scaled to 95th quantile")
      plot(p1)
    }, error = function(e) {
      blank_grid("Scaled to 95th quantile\n(No signal or error)")
    })
  }

  # Plot 2: Histogram normalization & scaled (columns ordered by group)
  if (!has_signal) {
    blank_grid("Histogram normalization & scaled\n(No signal in any sample)")
  } else {
    tryCatch({
      p2 <- image(combined_img, enhance = "histogram", scale = TRUE, mz = mz_val,
                  free = "xy", axes = FALSE, grid = FALSE, col = .ion_cols) |>
        matter::set_title("Histogram normalization & scaled")
      plot(p2)
    }, error = function(e) {
      blank_grid("Histogram normalization & scaled\n(No signal or error)")
    })
  }

  # Plot 3: No scaling or normalization (columns ordered by group)
  # Same pattern: subset → plain matrix → replace full slot → scale=FALSE + zlim.
  if (!has_signal) {
    blank_grid("No scaling or normalization\n(No signal in any sample)")
  } else {
    tryCatch({
      combined_p3 <- combined_img[idx, ]
      ints_p3 <- as.matrix(spectraData(combined_p3)[["intensity"]])
      glim <- max(ints_p3, na.rm = TRUE)
      spectraData(combined_p3)[["intensity"]] <- ints_p3
      p3 <- image(combined_p3, scale = FALSE, zlim = c(0, glim), mz = mz_val,
                  free = "xy", axes = FALSE, grid = FALSE, col = .ion_cols) |>
        matter::set_title("No scaling or normalization")
      plot(p3)
    }, error = function(e) {
      blank_grid("No scaling or normalization\n(No signal or error)")
    })
  }

  cat("\n\n</div>\n\n")
}
```

```{r cal-detect, echo=FALSE, include=FALSE}
# The calibration section only appears when the caller (runExample() or
# runStudy.R with `calibration: enabled: true`) put a calibrated object in the
# render environment. Everything below is gated on this flag.
.cal_obj <- if (exists("calibrated", inherits = TRUE)) get("calibrated") else NULL
.has_cal <- !is.null(.cal_obj) &&
  methods::is(.cal_obj, "quant_MSImagingExperiment") &&
  length(quantMSImageR::calibrationModels(.cal_obj)) > 0
```

```{r cal-heading, results="asis", echo=FALSE, eval=.has_cal}
# Headings are emitted from code, not written as markdown, so the whole section
# disappears cleanly when no calibration was run.
cat("# 6. Quantification\n\n",
    "Tissue intensities were converted to absolute amounts using the ",
    "calibration standards acquisition. Each analyte's response-versus-amount ",
    "curve was fitted with `createCalCurve()` and inverted by `int2conc()` ",
    "to give `pg_pixel` and `pg_mm2` layers. These are calibrated amount ",
    "estimates, not volumetric concentrations, and are conditional on the ",
    "calibration design, matrix matching and acquisition conditions.\n\n",
    "## 6.1 Calibration fits\n\n", sep = "")
```

```{r cal-r2, echo=FALSE, eval=.has_cal}
.r2 <- quantMSImageR::calibrationDiagnostics(.cal_obj)
.cl <- quantMSImageR::calibrationModels(.cal_obj)

.eqn <- data.frame(
  analyte   = names(.cl),
  slope     = vapply(.cl, function(m) unname(stats::coef(m)[2]), numeric(1)),
  intercept = vapply(.cl, function(m) unname(stats::coef(m)[1]), numeric(1)),
  row.names = NULL
)
.m <- match(.eqn$analyte, .r2$feature)
.eqn$r2 <- .r2$r2[.m]

# Proportion of pixels extrapolated beyond the calibrated range, added by
# int2conc(). Shown as a percentage so it reads alongside R-squared.
.cols <- c("slope", "intercept", "r2")
if ("out_of_range" %in% names(.r2)) {
  .eqn$`out of range (%)` <- 100 * .r2$out_of_range[.m]
  .cols <- c(.cols, "out of range (%)")
}

DT::datatable(.eqn, rownames = FALSE,
              options = list(dom = "t", pageLength = nrow(.eqn))) |>
  DT::formatSignif(.cols, digits = 4)
```

```{r cal-cov-heading, results="asis", echo=FALSE, eval=.has_cal}
cat("A low R-squared flags a standard that misbehaved, and a high ",
    "out-of-range percentage means those amounts were extrapolated beyond the ",
    "calibrated range rather than interpolated within it. Amounts from such an ",
    "analyte should not be treated as quantitative.\n\n",
    "## 6.2 Calibration coverage\n\n",
    "Converting intensities to concentrations is only valid where the ",
    "standards constrain the fit. The lower panel shows the standard spots and ",
    "the fitted model; the upper panel shows where this study's pixels ",
    "actually fall on the same axis, with the calibration levels marked. ",
    "Pixels inside the marked range are interpolated between real standards ",
    "rather than extrapolated.\n\n", sep = "")
```

```{r cal-coverage, echo=FALSE, eval=.has_cal, warning=FALSE, message=FALSE, fig.width=10, fig.height=6}
tryCatch(
  print(quantMSImageR::plotCalCoverage(.cal_obj, val_slot = "intensity")),
  error = function(e) {
    message("Calibration coverage plot failed: ", e$message)
    plot.new(); title("Calibration coverage unavailable")
  })
```

```{r cal-img-heading, results="asis", echo=FALSE, eval=.has_cal}
# Prefer areal amount (comparable between acquisitions of different pixel size)
# and fall back to per-pixel when the acquisition carried no pixelSize. The
# helper also accepts the pre-rename slot spellings.
.conc_slot <- quantMSImageR:::.pick_conc_slot(.cal_obj, prefer = "mm2")
.conc_unit <- quantMSImageR:::.conc_unit(.conc_slot)

cat("## 6.3 Calibrated amount ion images\n\n",
    "The same sections imaged after `int2conc()`. The colour scale is now an ",
    "estimated amount (", .conc_unit, ") rather than instrument response, ",
    "which is far more interpretable than raw response and transferable ",
    "between acquisitions where standards, matrix and acquisition conditions ",
    "are matched. Only analytes with a calibration curve appear here.\n\n",
    sep = "")
```

```{r cal-images, results="asis", echo=FALSE, eval=.has_cal, warning=FALSE, message=FALSE, fig.width=7.5, fig.height=6}
# Mirrors the section 5 dropdown, with its own element ids and JS handler so the
# two selectors on the same page do not collide. make_safe_id is defined in the
# section 5 chunk; redefine it here so this section does not depend on that
# chunk having run.
if (!exists("make_safe_id"))
  make_safe_id <- function(x) gsub("[^A-Za-z0-9_\\-]", "_", x)

.cal_feats <- as.character(fData(.cal_obj)$name)
.cal_ord   <- order(tolower(.cal_feats))
.cal_sorted <- .cal_feats[.cal_ord]
.cal_ids    <- vapply(.cal_sorted, make_safe_id, character(1))

cat('
<label for="conc_select" style="font-weight:600;">Select feature:</label>
<select id="conc_select" style="margin: 0 0 12px 8px; padding: 4px 6px;"
        onchange="showConcFeature(this.value)">
')

for (.i in seq_along(.cal_sorted)) {
  .sel <- if (.i == 1) ' selected' else ''
  cat(sprintf('<option value="%s"%s>%s</option>\n',
              .cal_ids[.i], .sel, .cal_sorted[.i]))
}

cat('</select>

<script>
function showConcFeature(id){
  var blocks = document.querySelectorAll(".conc_feature_block");
  for (var i=0; i<blocks.length; i++) { blocks[i].style.display = "none"; }
  var el = document.getElementById("conc_" + id);
  if (el) el.style.display = "block";
}
</script>
')

for (.i in seq_along(.cal_ord)) {

  .idx   <- .cal_ord[.i]                      # row index in .cal_obj
  .style <- if (.i == 1) "block" else "none"

  cat(sprintf('\n<div class="conc_feature_block" id="conc_%s" style="display:%s;">\n\n',
              .cal_ids[.i], .style))
  cat(sprintf("<p style='margin-top:10px;font-size:1.17em;font-weight:600;'>%s</p>\n",
              .cal_sorted[.i]))

  tryCatch({
    # imageR() returns a ggplot, so the panels can be laid out to match the
    # 3 x 2 grid used by the intensity images in section 5.
    print(
      quantMSImageR::imageR(.cal_obj, feat_ind = .idx, sample_lab = "run",
                            val_slot = .conc_slot, value = .conc_unit,
                            scale = "suppress", palette = .pal_ion) +
        ggplot2::facet_wrap(~ sample, ncol = 3) +
        ggplot2::theme(strip.text  = ggplot2::element_text(size = 8),
                       legend.text = ggplot2::element_text(size = 8))
    )
  }, error = function(e) {
    message("Concentration image failed for ", .cal_sorted[.i], ": ", e$message)
    grid::grid.newpage()
    grid::grid.text(paste0(.cal_sorted[.i], "\n(concentration image unavailable)"),
                    gp = grid::gpar(fontsize = 11, col = "grey40"))
  })

  cat("\n\n</div>\n\n")
}
```

```{r session-heading, results="asis", echo=FALSE}
# Numbered relative to whether the calibration section above was rendered.
cat("# ", if (.has_cal) 7 else 6, ". Session Information\n\n",
    "Packages used for the creation of this file\n", sep = "")
```

```{r session, echo = FALSE, warning=FALSE}

sessionInfo()

```


