Add unit tests for the plotting functions; fix scales >= 1.3.0 compatibility

DESCRIPTION

@@ -112,7 +112,7 @@ Suggests:
     png,
     pracma,
     rmarkdown,
-    scales,
+    scales (>= 1.4.0),
     testthat (>= 3.0.0),
     viridisLite
 biocViews: Software, Preprocessing, Visualization, Classification,

R/plot-GCIMSSample.R

@@ -69,7 +69,7 @@ mat_to_gplot <- function(intmat, dt_min = NULL, dt_max = NULL, rt_min = NULL, rt
     } else {
       cli_abort("unknown trans value")
     }
-  } else if (!inherits(trans, "trans")) {
+  } else if (!inherits(trans, "transform")) {
     cli_abort("unknown trans value")
   }
   intmat_trans <- trans$transform(intmat)

tests/testthat/test-plot-GCIMSChromatogram.R

@@ -0,0 +1,45 @@
+test_that("plot() on a GCIMSChromatogram returns a ggplot with data, title and labels from the object", {
+  ch <- GCIMSChromatogram(retention_time = 1:5, intensity = c(1, 2, 5, 2, 1), description = "Chrom1")
+
+  p <- plot(ch)
+
+  expect_s3_class(p, "ggplot")
+  expect_equal(p$data$x, rtime(ch))
+  expect_equal(p$data$y, intensity(ch), ignore_attr = TRUE)
+  expect_equal(p$labels$title, "Chrom1")
+  expect_equal(p$labels$x, "Retention time (s)")
+  expect_equal(p$labels$y, "Intensity (a.u.)")
+})
+
+test_that("plot() on a GCIMSChromatogram builds a single-value drift time subtitle", {
+  ch <- GCIMSChromatogram(
+    retention_time = 1:5, intensity = c(1, 2, 5, 2, 1),
+    drift_time_idx = 3L, drift_time_ms = 3.5
+  )
+
+  p <- plot(ch)
+
+  expect_equal(as.character(p$labels$subtitle), "Drift time 3.5 ms")
+})
+
+test_that("plot() on a GCIMSChromatogram builds a range drift time subtitle for multiple values", {
+  ch <- GCIMSChromatogram(
+    retention_time = 1:5, intensity = c(1, 2, 5, 2, 1),
+    drift_time_idx = c(3L, 4L), drift_time_ms = c(3, 4)
+  )
+
+  p <- plot(ch)
+
+  expect_equal(as.character(p$labels$subtitle), "Drift time 3 - 4 ms")
+})
+
+test_that("plot() on a GCIMSChromatogram has no subtitle when drift_time_ms is empty", {
+  ch <- GCIMSChromatogram(
+    retention_time = 1:5, intensity = c(1, 2, 5, 2, 1),
+    drift_time_idx = integer(0), drift_time_ms = numeric(0)
+  )
+
+  p <- plot(ch)
+
+  expect_null(p$labels$subtitle)
+})

tests/testthat/test-plot-GCIMSSample.R

@@ -0,0 +1,219 @@
+gauss <- function(x, center, height, sd) height * exp(-(x - center)^2 / (2 * sd^2))
+
+make_sample <- function() {
+  dt <- seq(0, 4, by = 0.02) # 201 pts
+  rt <- seq(0, 50, by = 0.5) # 101 pts
+  int_mat <- matrix(50, nrow = length(dt), ncol = length(rt)) +
+    outer(gauss(dt, 2, 500, 0.1), gauss(rt, 25, 1, 3))
+  GCIMSSample(drift_time = dt, retention_time = rt, data = int_mat)
+}
+
+test_that("cubic_root_trans() transforms/inverts values symmetrically, including negatives", {
+  tr <- cubic_root_trans()
+
+  expect_equal(tr$name, "cubic_root")
+  expect_equal(tr$transform(8), 2)
+  expect_equal(tr$transform(-8), -2)
+  expect_equal(tr$inverse(tr$transform(c(-27, -8, 0, 8, 27))), c(-27, -8, 0, 8, 27))
+})
+
+test_that("cubic_root_trans()'s breaks() handles a normal range and all-non-finite input", {
+  tr <- cubic_root_trans()
+
+  b <- tr$breaks(c(-8, 8))
+  expect_true(length(b) > 0)
+  expect_true(all(is.finite(b)))
+
+  expect_equal(tr$breaks(c(NA, NaN, Inf)), numeric(0))
+})
+
+test_that("as.data.frame() on a GCIMSSample melts the intensity matrix into long format", {
+  s <- GCIMSSample(drift_time = 1:2, retention_time = 1:3, data = matrix(1:6, nrow = 2, ncol = 3))
+
+  df <- as.data.frame(s)
+
+  expect_named(df, c("dt_ms", "rt_s", "Intensity"))
+  expect_equal(nrow(df), 6L)
+  expect_equal(df$Intensity, 1:6)
+})
+
+test_that("as.data.frame() on a GCIMSSample respects dt_range/rt_range and row.names", {
+  s <- GCIMSSample(drift_time = 1:2, retention_time = 1:3, data = matrix(1:6, nrow = 2, ncol = 3))
+
+  df <- as.data.frame(s, dt_range = c(1, 1))
+  expect_equal(nrow(df), 3L)
+
+  df_rn <- as.data.frame(s, row.names = paste0("r", 1:6))
+  expect_equal(rownames(df_rn), paste0("r", 1:6))
+})
+
+test_that("plot() on a GCIMSSample returns a ggplot with the expected labels and axis limits", {
+  s <- make_sample()
+
+  p <- plot(s)
+
+  expect_s3_class(p, "ggplot")
+  expect_equal(p$labels$x, "Drift time (ms)")
+  expect_equal(p$labels$y, "Retention time (s)")
+  expect_equal(p$labels$fill, "Intensity (a.u.)")
+})
+
+test_that("plot() on a GCIMSSample restricts the plotted range to dt_range/rt_range", {
+  s <- make_sample()
+
+  p_full <- plot(s)
+  p_sub <- plot(s, dt_range = c(1, 2), rt_range = c(10, 20))
+
+  b_full <- ggplot2::ggplot_build(p_full)
+  b_sub <- ggplot2::ggplot_build(p_sub)
+
+  full_x_range <- diff(b_full$layout$panel_params[[1]]$x.range)
+  sub_x_range <- diff(b_sub$layout$panel_params[[1]]$x.range)
+  expect_lt(sub_x_range, full_x_range)
+})
+
+test_that("plot(remove_baseline = TRUE) on a GCIMSSample does not error once a baseline is estimated", {
+  s <- make_sample()
+  s_b <- estimateBaseline(s, dt_peak_fwhm_ms = 0.3, dt_region_multiplier = 6, rt_length_s = 10, remove = FALSE)
+
+  p <- plot(s_b, remove_baseline = TRUE)
+
+  expect_s3_class(p, "ggplot")
+})
+
+test_that("plot() on a GCIMSSample accepts trans as a string, or as a transform object directly", {
+  s <- make_sample()
+
+  # Regression test: mat_to_gplot() checked inherits(trans, "trans"), the
+  # legacy S3 class name for scales transform objects. scales >= 1.3.0
+  # renamed it to "transform", which made any non-string trans (including
+  # this package's own cubic_root_trans()) always fail with "unknown trans
+  # value".
+  expect_s3_class(plot(s, trans = "cubic_root"), "ggplot")
+  expect_s3_class(plot(s, trans = "log10"), "ggplot")
+  expect_s3_class(plot(s, trans = cubic_root_trans()), "ggplot")
+  expect_s3_class(plot(s, trans = scales::identity_trans()), "ggplot")
+})
+
+test_that("plot() on a GCIMSSample errors clearly for an invalid trans value", {
+  s <- make_sample()
+
+  expect_error(plot(s, trans = "not_a_real_transform"), "unknown trans value")
+  expect_error(plot(s, trans = 123), "unknown trans value")
+})
+
+test_that("overlay_peaklist() with a single color returns a rect layer, plus a point or blank layer for the apex", {
+  peaklist <- data.frame(
+    SampleID = c("s1", "s1", "s2"),
+    dt_min_ms = c(1, 3, 2), dt_max_ms = c(2, 4, 3),
+    rt_min_s = c(1, 3, 2), rt_max_s = c(2, 4, 3)
+  )
+
+  out_no_apex <- overlay_peaklist(peaklist)
+  expect_length(out_no_apex, 2)
+  expect_s3_class(out_no_apex[[1]]$geom, "GeomRect")
+  expect_s3_class(out_no_apex[[2]]$geom, "GeomBlank")
+
+  peaklist$dt_apex_ms <- c(1.5, 3.5, 2.5)
+  peaklist$rt_apex_s <- c(1.5, 3.5, 2.5)
+  out_apex <- overlay_peaklist(peaklist)
+  expect_length(out_apex, 2)
+  expect_s3_class(out_apex[[1]]$geom, "GeomRect")
+  expect_s3_class(out_apex[[2]]$geom, "GeomPoint")
+})
+
+test_that("overlay_peaklist() accepts a literal color name for color_by", {
+  peaklist <- data.frame(
+    SampleID = "s1", dt_min_ms = 1, dt_max_ms = 2, rt_min_s = 1, rt_max_s = 2
+  )
+
+  out <- overlay_peaklist(peaklist, color_by = "blue")
+
+  expect_length(out, 2)
+})
+
+test_that("overlay_peaklist() with color_by as a column adds a color scale and, past 10 groups, hides the legend", {
+  peaklist <- data.frame(
+    SampleID = c("s1", "s2"),
+    dt_min_ms = c(1, 2), dt_max_ms = c(2, 3), rt_min_s = c(1, 2), rt_max_s = c(2, 3)
+  )
+
+  out <- overlay_peaklist(peaklist, color_by = "SampleID")
+  geom_classes <- purrr::map_chr(out, function(l) if (inherits(l, "Layer")) class(l$geom)[1] else class(l)[1])
+  expect_equal(geom_classes, c("GeomRect", "GeomBlank", "GeomBlank", "ScaleDiscrete"))
+
+  many <- data.frame(
+    SampleID = paste0("s", 1:12),
+    dt_min_ms = 1:12, dt_max_ms = 2:13, rt_min_s = 1:12, rt_max_s = 2:13
+  )
+  out_many <- overlay_peaklist(many, color_by = "SampleID")
+  geom_classes_many <- purrr::map_chr(out_many, function(l) if (inherits(l, "Layer")) class(l$geom)[1] else class(l)[1])
+  expect_equal(geom_classes_many, c("GeomRect", "GeomBlank", "GeomBlank", "ScaleDiscrete", "Guides"))
+})
+
+test_that("overlay_peaklist() with color_by as a column AND apex columns adds a point layer too", {
+  peaklist <- data.frame(
+    SampleID = c("s1", "s2"),
+    dt_min_ms = c(1, 2), dt_max_ms = c(2, 3), rt_min_s = c(1, 2), rt_max_s = c(2, 3),
+    dt_apex_ms = c(1.5, 2.5), rt_apex_s = c(1.5, 2.5)
+  )
+
+  out <- overlay_peaklist(peaklist, color_by = "SampleID")
+  geom_classes <- purrr::map_chr(out, function(l) if (inherits(l, "Layer")) class(l$geom)[1] else class(l)[1])
+
+  expect_equal(geom_classes, c("GeomRect", "GeomBlank", "GeomPoint", "ScaleDiscrete"))
+})
+
+test_that("overlay_peaklist() recycles a palette smaller than the number of groups", {
+  many <- data.frame(
+    SampleID = paste0("s", 1:5),
+    dt_min_ms = 1:5, dt_max_ms = 2:6, rt_min_s = 1:5, rt_max_s = 2:6
+  )
+
+  expect_no_error(
+    overlay_peaklist(many, color_by = "SampleID", palette = c("red", "blue"))
+  )
+})
+
+test_that("overlay_peaklist() coerces a non-data.frame peaklist (e.g. S4Vectors::DataFrame)", {
+  peaklist_df <- S4Vectors::DataFrame(SampleID = "s1", dt_min_ms = 1, dt_max_ms = 2, rt_min_s = 1, rt_max_s = 2)
+
+  out <- overlay_peaklist(peaklist_df)
+
+  expect_length(out, 2)
+})
+
+test_that("overlay_peaklist() merges in pdata by SampleID when given", {
+  peaklist <- data.frame(
+    SampleID = c("s1", "s2"),
+    dt_min_ms = c(1, 2), dt_max_ms = c(2, 3), rt_min_s = c(1, 2), rt_max_s = c(2, 3)
+  )
+  pdata <- data.frame(SampleID = c("s1", "s2"), Group = c("A", "B"))
+
+  out <- overlay_peaklist(peaklist, pdata = pdata, color_by = "Group")
+
+  expect_length(out, 4)
+})
+
+test_that("mat_to_gplot() derives dt/rt limits from the matrix dimnames when not given explicitly", {
+  m <- matrix(1:6, nrow = 2, ncol = 3, dimnames = list(c("1", "2"), c("10", "20", "30")))
+
+  p <- mat_to_gplot(m)
+
+  b <- ggplot2::ggplot_build(p)
+  expect_equal(b$layout$panel_params[[1]]$x.range, c(0.95, 2.05))
+  expect_equal(b$layout$panel_params[[1]]$y.range, c(9, 31))
+})
+
+test_that("overlay_peaklist() validates color_by and mapping_roi", {
+  peaklist <- data.frame(
+    SampleID = "s1", dt_min_ms = 1, dt_max_ms = 2, rt_min_s = 1, rt_max_s = 2
+  )
+
+  expect_error(overlay_peaklist(peaklist, color_by = "not_a_col_or_color"), "neither a valid color name")
+  expect_error(overlay_peaklist(peaklist, color_by = 5), "should be .* a string")
+  expect_error(
+    overlay_peaklist(peaklist, mapping_roi = c(a = "a", b = "b", c = "c", d = "d")),
+    "mapping_roi should be a named vector"
+  )
+})

tests/testthat/test-plot-GCIMSSpectrum.R

@@ -0,0 +1,45 @@
+test_that("plot() on a GCIMSSpectrum returns a ggplot with data, title and labels from the object", {
+  sp <- GCIMSSpectrum(drift_time = 1:5, intensity = c(1, 2, 5, 2, 1), description = "Spec1")
+
+  p <- plot(sp)
+
+  expect_s3_class(p, "ggplot")
+  expect_equal(p$data$x, dtime(sp))
+  expect_equal(p$data$y, intensity(sp), ignore_attr = TRUE)
+  expect_equal(p$labels$title, "Spec1")
+  expect_equal(p$labels$x, "Drift time (ms)")
+  expect_equal(p$labels$y, "Intensity (a.u.)")
+})
+
+test_that("plot() on a GCIMSSpectrum builds a single-value retention time subtitle", {
+  sp <- GCIMSSpectrum(
+    drift_time = 1:5, intensity = c(1, 2, 5, 2, 1),
+    retention_time_idx = 3L, retention_time_s = 3.5
+  )
+
+  p <- plot(sp)
+
+  expect_equal(as.character(p$labels$subtitle), "Retention time 3.5 s")
+})
+
+test_that("plot() on a GCIMSSpectrum builds a range retention time subtitle for multiple values", {
+  sp <- GCIMSSpectrum(
+    drift_time = 1:5, intensity = c(1, 2, 5, 2, 1),
+    retention_time_idx = c(3L, 4L), retention_time_s = c(3, 4)
+  )
+
+  p <- plot(sp)
+
+  expect_equal(as.character(p$labels$subtitle), "Retention time 3 - 4 s")
+})
+
+test_that("plot() on a GCIMSSpectrum has no subtitle when retention_time_s is empty", {
+  sp <- GCIMSSpectrum(
+    drift_time = 1:5, intensity = c(1, 2, 5, 2, 1),
+    retention_time_idx = integer(0), retention_time_s = numeric(0)
+  )
+
+  p <- plot(sp)
+
+  expect_null(p$labels$subtitle)
+})

tests/testthat/test-utils-plot.R

@@ -0,0 +1,49 @@
+test_that("mat_to_nativeRaster() encodes a matrix into a nativeRaster with the right shape", {
+  colormap <- farver::encode_native(c("#000000", "#333333", "#666666", "#999999", "#CCCCCC", "#FFFFFF"))
+  m <- matrix(1:6, nrow = 2, ncol = 3)
+
+  nr <- mat_to_nativeRaster(m, colormap)
+
+  expect_s3_class(nr, "nativeRaster")
+  expect_equal(dim(nr), c(ncol(m), nrow(m)))
+  expect_equal(attr(nr, "channels"), 4L)
+  # more than one color of the map should show up for a varied matrix:
+  expect_gt(length(unique(as.vector(unclass(nr)))), 1L)
+  expect_true(all(unique(as.vector(unclass(nr))) %in% colormap))
+})
+
+test_that("mat_to_nativeRaster() is deterministic", {
+  colormap <- farver::encode_native(c("#000000", "#FFFFFF"))
+  m <- matrix(1:6, nrow = 2, ncol = 3)
+
+  expect_identical(mat_to_nativeRaster(m, colormap), mat_to_nativeRaster(m, colormap))
+})
+
+test_that("mat_to_nativeRaster() accepts a character colormap, giving the same result as pre-encoded colors", {
+  m <- matrix(1:6, nrow = 2, ncol = 3)
+  chr_colors <- c("#000000", "#333333", "#666666", "#999999", "#CCCCCC", "#FFFFFF")
+
+  nr_chr <- mat_to_nativeRaster(m, chr_colors)
+  nr_num <- mat_to_nativeRaster(m, farver::encode_native(chr_colors))
+
+  expect_identical(nr_chr, nr_num)
+})
+
+test_that("mat_to_nativeRaster() handles a zero-length matrix", {
+  colormap <- farver::encode_native(c("#000000", "#FFFFFF"))
+
+  nr <- mat_to_nativeRaster(matrix(numeric(0), nrow = 0, ncol = 0), colormap)
+
+  expect_s3_class(nr, "nativeRaster")
+  expect_equal(dim(nr), c(0L, 0L))
+  expect_equal(attr(nr, "channels"), 4L)
+})
+
+test_that("plot_interactive() wraps a ggplot into a plotly widget", {
+  d <- data.frame(x = c(1, 2), y = c(1, 2))
+  plt <- ggplot2::ggplot(d) + ggplot2::geom_point(ggplot2::aes(x = .data$x, y = .data$y))
+
+  out <- plot_interactive(plt)
+
+  expect_s3_class(out, "plotly")
+})