add tests

R/activate.R

@@ -16,6 +16,12 @@ deactivate <- function(x) UseMethod("deactivate")
 
 #' @export
 activate.ggheatmap <- function(x, what) {
+    if (is.null(what)) {
+        cli::cli_abort(paste(
+            "{.arg what} must be a string of ",
+            oxford_comma(GGHEAT_ELEMENTS, final = "or")
+        ))
+    }
     what <- match.arg(what, GGHEAT_ELEMENTS)
     set_context(x, what)
 }

R/ggheat.R

@@ -24,7 +24,6 @@
 #' @inheritParams patchwork::plot_layout
 #' @param filling A boolean value indicates whether filling the heatmap. If you
 #' want to custom the filling style, you can set to `FALSE`.
-#' @param environment Used by [ggplot_build][ggplot2::ggplot_build].
 #' @return A `ggheatmap` object.
 #' @importFrom ggplot2 aes
 #' @export
@@ -41,8 +40,7 @@ ggheat.matrix <- function(data, mapping = NULL,
                           ylabels_nudge = waiver(),
                           guides = "collect",
                           axes = NULL, axis_titles = axes,
-                          filling = TRUE, ...,
-                          environment = parent.frame()) {
+                          filling = TRUE, ...) {
     assert_bool(filling)
     xlabels <- set_labels(xlabels, "column", colnames(data), ncol(data))
     xlabels_nudge <- set_nudge(xlabels_nudge, ncol(data), xlabels, "column")
@@ -77,8 +75,7 @@ ggheat.matrix <- function(data, mapping = NULL,
             filling = filling
         ),
         heatmap = heatmap,
-        active = NULL,
-        plot_env = environment
+        active = NULL
     )
 }
 
@@ -178,8 +175,7 @@ methods::setClass(
         heatmap = "ANY", active = "ANY",
         facetted_pos_scales = "ANY",
         top = "ANY", left = "ANY",
-        bottom = "ANY", right = "ANY",
-        plot_env = "environment"
+        bottom = "ANY", right = "ANY"
     ),
     prototype = list(
         row_index = NULL,
@@ -203,7 +199,7 @@ methods::setMethod("$", "ggheatmap", function(x, name) {
     if (name == "theme") {
         slot(x, "heatmap")$theme
     } else if (name == "plot_env") {
-        slot(x, "plot_env")
+        slot(x, "heatmap")$plot_env
     } else {
         cli::cli_abort(c(
             "`$` is just for internal usage for ggplot2 methods",

R/htanno-dendrogram.R

@@ -156,19 +156,24 @@ HtannoDendro <- ggplot2::ggproto("HtannoDendro", HtannoProto,
             if (nlevels(panels) == 1L) { # only one parent
                 self$statistics <- .subset2(self$statistics, 1L)
             } else if (reorder_group) {
-                parent_data <- t(sapply(levels(panels), function(g) {
+                parent_levels <- levels(panels)
+                parent_data <- t(sapply(parent_levels, function(g) {
                     colMeans(data[panels == g, , drop = FALSE])
                 }))
-                rownames(parent_data) <- levels(panels)
+                rownames(parent_data) <- parent_levels
                 parent <- stats::as.dendrogram(self$compute(
                     data = parent_data,
                     panels = NULL,
                     distance = distance,
                     method = method,
                     use_missing = use_missing
                 ))
-                panels <- factor(panels, stats::order.dendrogram(parent))
+                # reorder parent based on the parent tree
+                panels <- factor(
+                    panels, parent_levels[stats::order.dendrogram(parent)]
+                )
                 self$statistics <- merge_dendrogram(parent, self$statistics)
+                # we don't cutree
                 # self$draw_params$height <- attr(ans, "cutoff_height")
             } else {
                 self$statistics <- Reduce(merge, self$statistics)

R/htanno-group.R

@@ -18,7 +18,7 @@ htanno_group <- function(group, position = NULL,
 }
 
 HtannoGroup <- ggplot2::ggproto("HtannoGroup", HtannoProto,
-    setup_params = function(self, data, position, params) {
+    setup_params = function(self, data, params, position) {
         if (nrow(data) != length(group <- .subset2(params, "group"))) {
             cli::cli_abort(paste(
                 "{.arg group} of {.fn {snake_class(self)}} must be ",

R/utils.R

@@ -5,6 +5,14 @@
 #' @importFrom utils packageName
 pkg_nm <- function() packageName(topenv(environment()))
 
+save_png <- function(code, width = 400L, height = 400L) {
+    path <- tempfile(fileext = ".png")
+    grDevices::png(path, width = width, height = height)
+    on.exit(grDevices::dev.off())
+    print(code)
+    path
+}
+
 allow_lambda <- function(x) {
     if (rlang::is_formula(x)) {
         rlang::as_function(x)

tests/testthat.R

@@ -0,0 +1,12 @@
+# This file is part of the standard setup for testthat.
+# It is recommended that you do not modify it.
+#
+# Where should you do additional test configuration?
+# Learn more about the roles of various files in:
+# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview
+# * https://testthat.r-lib.org/articles/special-files.html
+
+library(testthat)
+library(ggheat)
+
+test_check("ggheat")

tests/testthat/test-activate.R

@@ -0,0 +1,19 @@
+testthat::test_that("`activate and deactivate work well`", {
+    p <- ggheat(1:10)
+    expect_identical(get_context(p), NULL)
+    for (position in GGHEAT_ELEMENTS) {
+        expect_no_error(p2 <- activate(p, position))
+        expect_identical(get_context(p2), position)
+    }
+    expect_error(activate(p, NULL))
+    expect_identical(deactivate(p2), p)
+})
+
+testthat::test_that("`active` adding works well", {
+    p <- ggheat(1:10)
+    for (position in GGHEAT_ELEMENTS) {
+        expect_no_error(p2 <- p + active(position))
+        expect_identical(unclass(get_context(p2)), position)
+    }
+    expect_identical(p2 + active(), p)
+})

tests/testthat/test-ggheat.R

@@ -0,0 +1,20 @@
+testthat::test_that("`ggheat` works well", {
+    expect_snapshot_file(save_png(ggheat(1:10)), "numeric.png")
+    expect_identical(ncol(ggheat(1:10)@matrix), 1L)
+    expect_snapshot_file(save_png(ggheat(letters)), "character.png")
+    expect_identical(ncol(ggheat(letters)@matrix), 1L)
+    expect_snapshot_file(save_png(ggheat(matrix(1:9, nrow = 3L))), "matrix.png")
+    expect_snapshot_file(save_png(ggheat(data.frame(1:10))), "data_rame.png")
+    expect_error(ggheat(NULL))
+})
+
+testthat::test_that("`ggheat_build` works well", {
+    p <- ggheat(1:10)
+    expect_s3_class(ggheat_build(p), "patchwork")
+})
+
+testthat::test_that("`ggplot` method works well", {
+    p <- ggheat(1:10)
+    expect_no_error(ggplot2::ggplot_build(p))
+    expect_no_error(ggplot2::ggsave(tempfile(fileext = ".png"), plot = p))
+})

tests/testthat/test-htanno.R

@@ -0,0 +1,102 @@
+testthat::test_that("`htanno_group` works well", {
+    set.seed(1L)
+    p <- ggheat(matrix(stats::rnorm(72L), nrow = 9L))
+    row_group <- sample(letters[1:3], 9, replace = TRUE)
+    column_group <- sample(letters[1:3], 8, replace = TRUE)
+    expect_error(p + htanno_group(column_group))
+    expect_error(p + htanno_group(1:4, "t"))
+    expect_error(p + htanno_group(row_group, "t"))
+
+    expect_snapshot_file(
+        save_png(p + htanno_group(column_group, "t")), "group_top.png"
+    )
+    expect_snapshot_file(
+        save_png(p + htanno_group(column_group, "b")), "group_bottom.png"
+    )
+    expect_snapshot_file(
+        save_png(p + htanno_group(row_group, "l")), "group_left.png"
+    )
+    expect_snapshot_file(
+        save_png(p + htanno_group(row_group, "r")), "group_right.png"
+    )
+    # cannot do sub-group
+    expect_error(p + htanno_group(row_group, "t") + htanno_group(row_group))
+})
+
+testthat::test_that("`htanno_reorder` works well", {
+    set.seed(1L)
+    p <- ggheat(matrix(stats::rnorm(72L), nrow = 9L))
+    row_group <- sample(letters[1:3], 9, replace = TRUE)
+    column_group <- sample(letters[1:3], 8, replace = TRUE)
+    expect_snapshot_file(
+        save_png(p + htanno_reorder(position = "t")), "reorder_top.png"
+    )
+    expect_snapshot_file(
+        save_png(p + htanno_reorder(position = "b")), "reorder_bottom.png"
+    )
+    expect_snapshot_file(
+        save_png(p + htanno_reorder(position = "l")), "reorder_left.png"
+    )
+    expect_snapshot_file(
+        save_png(p + htanno_reorder(position = "r")), "reorder_right.png"
+    )
+    expect_error(p + htanno_group(column_group, "t") + htanno_reorder())
+    expect_snapshot_file(
+        save_png(p + htanno_group(column_group, "t") +
+            htanno_reorder(strict = FALSE)),
+        "reorder_top_within_group.png"
+    )
+    expect_snapshot_file(
+        save_png(p + htanno_reorder(position = "t", decreasing = TRUE)),
+        "reorder_top_decreasing.png"
+    )
+    expect_snapshot_file(
+        save_png(p + htanno_reorder(position = "l", decreasing = TRUE)),
+        "reorder_left_decreasing.png"
+    )
+})
+
+testthat::test_that("`htanno_kmeans` works well", {
+    set.seed(1L)
+    p <- ggheat(matrix(stats::rnorm(72L), nrow = 9L))
+    row_group <- sample(letters[1:3], 9, replace = TRUE)
+    column_group <- sample(letters[1:3], 8, replace = TRUE)
+    expect_snapshot_file(
+        save_png(p + htanno_kmeans(3L, position = "t")), "kmeans_top.png"
+    )
+    expect_snapshot_file(
+        save_png(p + htanno_kmeans(5L, position = "b")), "kmeans_bottom.png"
+    )
+    expect_snapshot_file(
+        save_png(p + htanno_kmeans(4L, position = "l")), "kmeans_left.png"
+    )
+    expect_snapshot_file(
+        save_png(p + htanno_kmeans(2L, position = "r")), "kmeans_right.png"
+    )
+    expect_error(p + htanno_group(column_group, "t") + htanno_kmeans(3L))
+    expect_error(p + htanno_group(row_group, "l") + htanno_kmeans(3L))
+})
+
+testthat::test_that("`htanno_dendro` works well", {
+    set.seed(1L)
+    p <- ggheat(matrix(stats::rnorm(72L), nrow = 9L))
+    row_group <- sample(letters[1:3], 9, replace = TRUE)
+    column_group <- sample(letters[1:3], 8, replace = TRUE)
+    expect_snapshot_file(
+        save_png(p + htanno_dendro(position = "t")), "dendro.png"
+    )
+    expect_snapshot_file(
+        save_png(p + htanno_dendro(k = 3L, position = "t")), "dendro_cutree.png"
+    )
+    expect_error(p + htanno_group(column_group, "t") + htanno_dendro(k = 3L))
+    expect_error(p + htanno_group(column_group, "t") + htanno_dendro(h = 3L))
+    expect_snapshot_file(
+        save_png(p + htanno_group(column_group, "t") + htanno_dendro()),
+        "dendro_top_between_group.png"
+    )
+    expect_snapshot_file(
+        save_png(p + htanno_group(row_group, "l") +
+            htanno_dendro(reorder_group = TRUE)),
+        "dendro_left_between_group_reorder.png"
+    )
+})