diff --git a/DESCRIPTION b/DESCRIPTION index 0b94f12..a5878ee 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -112,7 +112,7 @@ Suggests: png, pracma, rmarkdown, - scales, + scales (>= 1.4.0), testthat (>= 3.0.0), viridisLite biocViews: Software, Preprocessing, Visualization, Classification, diff --git a/R/plot-GCIMSSample.R b/R/plot-GCIMSSample.R index 95d6c3f..a3c9e3e 100644 --- a/R/plot-GCIMSSample.R +++ b/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) diff --git a/tests/testthat/test-plot-GCIMSChromatogram.R b/tests/testthat/test-plot-GCIMSChromatogram.R new file mode 100644 index 0000000..5276e89 --- /dev/null +++ b/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) +}) diff --git a/tests/testthat/test-plot-GCIMSSample.R b/tests/testthat/test-plot-GCIMSSample.R new file mode 100644 index 0000000..4687f3f --- /dev/null +++ b/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" + ) +}) diff --git a/tests/testthat/test-plot-GCIMSSpectrum.R b/tests/testthat/test-plot-GCIMSSpectrum.R new file mode 100644 index 0000000..e778763 --- /dev/null +++ b/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) +}) diff --git a/tests/testthat/test-utils-plot.R b/tests/testthat/test-utils-plot.R new file mode 100644 index 0000000..2a3dc77 --- /dev/null +++ b/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") +})