Refactor tests

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: mascarade
 Type: Package
 Title: Generating Cluster Masks for Single-Cell Dimensional Reduction Plots
-Version: 0.4.1
+Version: 0.4.2
 Authors@R: person("Alexey", "Sergushichev", email = "alsergbox@gmail.com", role = c("aut", "cre"))
 Description: Implements a procedure to automatically generate 2D masks
     for clusters on dimensional reduction plots from methods like 
@@ -20,7 +20,7 @@ Imports:
     vctrs,
     rlang,
     cli,
-    systemfonts,
+    systemfonts (>= 1.3.0),
     Rcpp
 LinkingTo:
     Rcpp,
@@ -45,4 +45,4 @@ VignetteBuilder: knitr
 URL: https://alserglab.github.io/mascarade/
 BugReports: https://github.com/alserglab/mascarade/issues
 Roxygen: list(markdown=TRUE)
-RoxygenNote: 7.3.3
+Config/roxygen2/version: 8.0.0

NAMESPACE

@@ -1,6 +1,8 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(ggplot_add,fancyMask)
+S3method(grid::heightDetails,mascarade_mark_label)
+S3method(grid::widthDetails,mascarade_mark_label)
 S3method(makeContent,shape_enc)
 export(fancyMask)
 export(generateMask)
@@ -32,7 +34,6 @@ importFrom(grid,grid.layout)
 importFrom(grid,grobDescent)
 importFrom(grid,grobHeight)
 importFrom(grid,grobWidth)
-importFrom(grid,heightDetails)
 importFrom(grid,is.unit)
 importFrom(grid,makeContent)
 importFrom(grid,nullGrob)
@@ -43,7 +44,6 @@ importFrom(grid,textGrob)
 importFrom(grid,unit)
 importFrom(grid,valid.just)
 importFrom(grid,viewport)
-importFrom(grid,widthDetails)
 importFrom(polyclip,polyoffset)
 importFrom(polylabelr,poi)
 importFrom(rlang,.data)

R/ggforce_mark_label.R

@@ -62,8 +62,7 @@ subset_gp <- function(gp, index, ignore = c('font')) {
 
 
 
-#' @importFrom grid valid.just textGrob nullGrob viewport grobWidth grobHeight
-#' rectGrob gpar grid.layout unit gTree gList grobDescent
+#' @importFrom grid valid.just textGrob nullGrob viewport grobWidth grobHeight rectGrob gpar grid.layout unit gTree gList grobDescent
 labelboxGrob <- function(label, x = unit(0.5, 'npc'), y = unit(0.5, 'npc'),
                          description = NULL, width = NULL, min.width = 50,
                          default.units = 'mm', hjust = 0,
@@ -133,14 +132,33 @@ labelboxGrob <- function(label, x = unit(0.5, 'npc'), y = unit(0.5, 'npc'),
   lab_grob$vp <- viewport(layout.pos.col = 2, layout.pos.row = 2)
   desc_grob$vp <- viewport(layout.pos.col = 2, layout.pos.row = 4)
   gTree(children = gList(bg_grob, lab_grob, desc_grob), vp = vp,
-        cl = 'mark_label')
+        cl = 'mascarade_mark_label')
 }
-#' @importFrom grid widthDetails
-widthDetails.mark_label <- function(x) {
+
+#' Report the label box's width to grid
+#'
+#' The grob's size is fixed by the viewport built in `labelboxGrob()`, so the
+#' natural width is simply that viewport's width.
+#'
+#' @param x A `mascarade_mark_label` grob.
+#' @return The grob's width as a [grid::unit].
+#' @keywords internal
+#' @noRd
+#' @exportS3Method grid::widthDetails
+widthDetails.mascarade_mark_label <- function(x) {
   x$vp$width
 }
-#' @importFrom grid heightDetails
-heightDetails.mark_label <- function(x) {
+
+#' Report the label box's height to grid
+#'
+#' Counterpart of `widthDetails.mascarade_mark_label()`; see there for details.
+#'
+#' @param x A `mascarade_mark_label` grob.
+#' @return The grob's height as a [grid::unit].
+#' @keywords internal
+#' @noRd
+#' @exportS3Method grid::heightDetails
+heightDetails.mascarade_mark_label <- function(x) {
   x$vp$height
 }
 #' Split text into wrap tokens

R/mascarade-package.R

@@ -9,6 +9,13 @@
 #' @name exampleMascarade
 NULL
 
+#' Example generated mask.
+#'
+#' Result of `generateMasks(dims=exampleMascarade$dims, clusters=exampleMascarade$clusters)`.
+#' @docType data
+#' @name exampleMaskTable
+NULL
+
 #' @useDynLib mascarade, .registration = TRUE
 #' @importFrom Rcpp sourceCpp
 NULL

data-raw/exampleMascarade.R

@@ -19,6 +19,11 @@ exampleMascarade <- list(
 usethis::use_data(exampleMascarade, overwrite = TRUE)
 
 
+exampleMaskTable <- generateMask(dims=exampleMascarade$dims,
+                                 clusters=exampleMascarade$clusters)
+
+usethis::use_data(exampleMaskTable, overwrite = TRUE)
+
 exampleSeurat <- DietSeurat(pbmc3k.final,
                             layers = c("data"),
                             features = featureList,

tests/testthat/fixtures/make-placement-fixtures.R

@@ -0,0 +1,38 @@
+# Regenerates the placement test fixtures. Not run during `devtools::test()` --
+# run it by hand from the package root when the placement geometry or the golden
+# layout scores need re-recording:
+#
+#   source("tests/testthat/fixtures/make-placement-fixtures.R")
+#
+# Writes, next to this script:
+#   placement_geom.rds  frozen placement geometry derived from `exampleMaskTable`
+#   golden_scores.rds   layout scores of `placeLabels()` on that geometry
+
+devtools::load_all(quiet = TRUE)
+
+fixtureDir <- "tests/testthat/fixtures"
+stopifnot(dir.exists(fixtureDir))
+
+# Helpers are not on the search path outside a test run; source them so the
+# fixture is built by the same code that loads it.
+source("tests/testthat/helper-score.R")
+source("tests/testthat/helper-fixtures.R")
+
+data("exampleMaskTable", package = "mascarade")
+
+firstCluster <- levels(exampleMaskTable$cluster)[1]
+placementGeom <- list(
+  example = buildPlacementGeom(exampleMaskTable),
+  singleCluster = buildPlacementGeom(
+    exampleMaskTable[exampleMaskTable$cluster == firstCluster, ]
+  )
+)
+saveRDS(placementGeom, file.path(fixtureDir, "placement_geom.rds"))
+
+scene <- restorePlacementGeom(placementGeom$example)
+placement <- placeLabels(scene$geom, scene$xlim, scene$ylim,
+                         scene$halfWidth, scene$halfHeight, scene$charHeight)
+goldenScores <- list(example_default = layoutScore(placement))
+saveRDS(goldenScores, file.path(fixtureDir, "golden_scores.rds"))
+
+print(goldenScores)

tests/testthat/helper-fixtures.R

@@ -0,0 +1,121 @@
+# Test-only fixture construction and loading (not shipped in the package).
+#
+# The placement geometry is frozen into `fixtures/placement_geom.rds` (by
+# `fixtures/make-placement-fixtures.R`) so the placement tests do not depend on
+# `generateMask()`, spatstat or polylabelr. The box-fit R-tree is an external
+# pointer that cannot be serialised, so the fixture stores plain data and
+# `restorePlacementGeom()` rebuilds the tree on load.
+
+#' Extract each cluster's largest (`#1`) part from a mask table
+#'
+#' @param maskTable A mask table as returned by `generateMask()`.
+#' @return A named list of `list(x =, y =)` rings, one per cluster.
+largestPartPolygons <- function(maskTable) {
+  maskTable <- as.data.frame(maskTable)
+  xColumn <- colnames(maskTable)[1]
+  yColumn <- colnames(maskTable)[2]
+
+  isLargestPart <- grepl("#1$", maskTable$part)
+  clusters <- if (is.factor(maskTable$cluster)) {
+    levels(maskTable$cluster)
+  } else {
+    unique(maskTable$cluster)
+  }
+  clusters <- clusters[vapply(clusters, function(cluster) {
+    any(maskTable$cluster == cluster & isLargestPart)
+  }, logical(1))]
+
+  polygons <- lapply(clusters, function(cluster) {
+    ring <- maskTable[maskTable$cluster == cluster & isLargestPart, ]
+    list(x = ring[[xColumn]], y = ring[[yColumn]])
+  })
+  names(polygons) <- clusters
+  polygons
+}
+
+#' Build a serialisable placement scene from a mask table
+#'
+#' Everything `placeLabels()` needs except the R-tree (see file header). Label
+#' boxes are sized from the character count, not real font metrics, keeping the
+#' fixture independent of the installed fonts.
+#'
+#' @param maskTable A mask table as returned by `generateMask()`.
+#' @param charFrac Label character height, as a fraction of the data y-range.
+#' @return A list of plain vectors and lists, safe to `saveRDS()`.
+buildPlacementGeom <- function(maskTable, charFrac = 0.045) {
+  polygons <- largestPartPolygons(maskTable)
+  labels <- names(polygons)
+
+  polysx <- lapply(polygons, `[[`, "x")
+  polysy <- lapply(polygons, `[[`, "y")
+
+  poles <- t(vapply(polygons, function(polygon) {
+    pole <- polylabelr::poi(polygon$x, polygon$y)
+    c(pole$x, pole$y)
+  }, numeric(2)))
+  dimnames(poles) <- NULL
+
+  xRange <- range(unlist(polysx))
+  yRange <- range(unlist(polysy))
+  charHeight <- charFrac * diff(yRange)
+
+  list(
+    labels = labels,
+    polysx = unname(polysx),
+    polysy = unname(polysy),
+    poi = poles,
+    charHeight = charHeight,
+    halfHeight = rep(charHeight / 2, length(labels)),
+    halfWidth = nchar(labels) * (0.55 * charHeight) / 2,
+    xlim = xRange + c(-1, 1) * 0.45 * diff(xRange),
+    ylim = yRange + c(-1, 1) * 0.10 * diff(yRange)
+  )
+}
+
+#' Rebuild the runtime placement scene from a frozen one
+#'
+#' Adds back the box-fit R-tree in the shape `placeLabels()` expects.
+#'
+#' @param frozen A scene from `buildPlacementGeom()`.
+#' @return `frozen` with a `geom` element added, ready for `placeLabels()`.
+restorePlacementGeom <- function(frozen) {
+  frozen$geom <- list(
+    poi = frozen$poi,
+    rtree = buildBoxFit(frozen$polysx, frozen$polysy),
+    polysx = frozen$polysx,
+    polysy = frozen$polysy
+  )
+  frozen
+}
+
+#' Load a frozen placement scene by name (`"example"` or `"singleCluster"`)
+#'
+#' @param name Scene name in `fixtures/placement_geom.rds`.
+#' @return A scene ready to pass to `placeLabels()`.
+loadPlacementScene <- function(name = "example") {
+  scenes <- readRDS(test_path("fixtures", "placement_geom.rds"))
+  restorePlacementGeom(scenes[[name]])
+}
+
+#' Load a recorded golden layout score by name
+#'
+#' @param name Entry name in `fixtures/golden_scores.rds`.
+#' @return A named score vector, as produced by `layoutScore()`.
+loadGoldenScore <- function(name = "example_default") {
+  readRDS(test_path("fixtures", "golden_scores.rds"))[[name]]
+}
+
+#' The shipped example mask table, optionally restricted to some clusters
+#'
+#' @param clusters Cluster names to keep; `NULL` (default) keeps all. Unused
+#'   factor levels are dropped.
+#' @return A mask table.
+exampleMask <- function(clusters = NULL) {
+  data("exampleMaskTable", package = "mascarade", envir = environment())
+  maskTable <- exampleMaskTable
+  if (!is.null(clusters)) {
+    maskTable <- maskTable[maskTable$cluster %in% clusters, ]
+    maskTable$cluster <- droplevels(maskTable$cluster)
+  }
+  maskTable
+}