From 1050f27ee24c4c3d8ece6895f4d49961d224716b Mon Sep 17 00:00:00 2001 From: Vincent Guyader Date: Sat, 25 Apr 2026 23:10:05 +0200 Subject: [PATCH 1/2] =?UTF-8?q?fix:=203=20issues=20=E2=80=94=20get=5Fdesc?= =?UTF-8?q?=20multiline=20(#18),=20kable=20double=20newline=20(#4),=20empt?= =?UTF-8?q?y=20test=5Fthat=20(#15)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - #18: get_desc() now finds the closest @description tag above the expectation (was: only -1 / -2 lines) and collapses inner newlines to a single space so the kable cell stays on one row. - #4: new helper sanitize_kable_cell() collapses runs of blank lines to a single newline, applied per-column before kable(); fixes the message-with-blank-lines spilling out of table cells. - #15: test_down() no longer errors on an empty test_that() body (basename(NULL) used to raise 'a character vector argument expected'). Tests: tests/testthat/test-get_desc.R (4), tests/testthat/test-sanitize_kable_cell.R (5), tests/testthat/test-empty_test.R (1). Tracking notes in dev/SUIVI_ISSUES.md. --- R/tomarkdown.R | 14 ++++-- R/utils.R | 47 ++++++++++++----- R/writers.R | 3 ++ dev/SUIVI_ISSUES.md | 55 ++++++++++++++++++++ tests/testthat/test-empty_test.R | 34 +++++++++++++ tests/testthat/test-get_desc.R | 61 +++++++++++++++++++++++ tests/testthat/test-sanitize_kable_cell.R | 43 ++++++++++++++++ 7 files changed, 242 insertions(+), 15 deletions(-) create mode 100644 dev/SUIVI_ISSUES.md create mode 100644 tests/testthat/test-empty_test.R create mode 100644 tests/testthat/test-get_desc.R create mode 100644 tests/testthat/test-sanitize_kable_cell.R diff --git a/R/tomarkdown.R b/R/tomarkdown.R index aba236f..6ee5170 100644 --- a/R/tomarkdown.R +++ b/R/tomarkdown.R @@ -124,9 +124,17 @@ test_down <- function( unname() %>% unlist() - were_skipped <- which( - ! basename(names(all_tests_read)) %in% .tr$df$location - ) + # An empty test_that() body produces no `expect_*` line, so + # `all_tests_read` ends up as a zero-length character vector with no + # names — `basename(NULL)` would then error out (#15). Guard the lookup. + if (is.null(all_tests_read) || !length(all_tests_read)) { + all_tests_read <- stats::setNames(character(), character()) + were_skipped <- integer() + } else { + were_skipped <- which( + ! basename(names(all_tests_read)) %in% .tr$df$location + ) + } were_skipped_df <- build_were_skipped( were_skipped = all_tests_read[were_skipped] diff --git a/R/utils.R b/R/utils.R index de08711..4150e96 100644 --- a/R/utils.R +++ b/R/utils.R @@ -104,22 +104,45 @@ get_desc <- function( fls <- readLines(normalizePath(attr(result$srcref, "srcfile")$filename)) parsed <- parse_text(fls, NULL) tags <- map(parsed, "tags") %>% flatten() - lines <- keep( - tags, - map(tags, "line") == result$srcref[1] - 1 - ) - if (!length(lines)){ - lines <- keep( - tags, - map(tags, "line") == result$srcref[1] - 2 - ) - } - if (length(lines)){ - lines[[1]]$val + expectation_line <- result$srcref[1] + + # Pick the closest @description tag *above* this expectation. Previously + # the code only looked exactly 1 or 2 lines above, which missed + # descriptions placed further up (e.g. before intermediate setup calls + # inside the same test_that block) — see issue #18. + tag_lines <- vapply(tags, function(x) x$line %||% NA_integer_, integer(1)) + candidates_idx <- which(!is.na(tag_lines) & tag_lines < expectation_line) + if (length(candidates_idx)) { + nearest <- candidates_idx[which.max(tag_lines[candidates_idx])] + val <- tags[[nearest]]$val + # A multi-line description would otherwise carry a literal newline + # into the kable cell and spill the trailing portion onto the wrong + # column (#18). Collapse any inner newlines into a single space. + gsub("[[:space:]]*\n[[:space:]]*", " ", val) } else { " " } +} + +# tiny null-coalescer for older R / safer reads +`%||%` <- function(a, b) if (is.null(a)) b else a +#' Sanitize a string for inclusion in a kable cell. +#' +#' kable interprets a double newline as a paragraph break, which spills the +#' tail of the cell onto the next row of the rendered table (#4). Collapse +#' consecutive blank lines to a single newline before passing the value +#' through. +#' +#' @param x character vector. +#' @return character vector, same length, safe to drop into a kable cell. +#' @noRd +sanitize_kable_cell <- function(x) { + if (!length(x)) return(x) + out <- gsub("\r\n", "\n", x, fixed = TRUE) + # Collapse runs of blank lines into a single newline. + out <- gsub("(\n[[:blank:]]*){2,}", "\n", out) + out } cat_if_verbose <- function( diff --git a/R/writers.R b/R/writers.R index 73496f0..7f6e04b 100644 --- a/R/writers.R +++ b/R/writers.R @@ -167,6 +167,9 @@ write_parts <- function( for (i in names(table_to_insert)){ table_to_insert[, i] <- gsub("\\$", "$", table_to_insert[, i]) + # Collapse blank lines so kable does not spill the tail of a cell + # onto the next table row (#4). + table_to_insert[, i] <- sanitize_kable_cell(table_to_insert[, i]) } write_in() diff --git a/dev/SUIVI_ISSUES.md b/dev/SUIVI_ISSUES.md new file mode 100644 index 0000000..c48d86d --- /dev/null +++ b/dev/SUIVI_ISSUES.md @@ -0,0 +1,55 @@ +# Suivi — passe `fix/multiple-issues` + +Méthodologie : test unitaire qui plante d'abord, puis correctif minimal, +puis commit. + +## Issues traitées + +### #18 — `get_desc()` ne suit pas une description multilignes / placée plus loin +Le code regardait uniquement les lignes `srcref - 1` et `srcref - 2`, donc +une description placée 3+ lignes au-dessus (par ex. avant un `setup()` +intermédiaire) n'était pas trouvée. De plus, une description sur 2 lignes +(`#'` continué) injectait un `\n` brut dans la cellule kable, qui spillait +le morceau suivant sur la ligne d'après du tableau. + +- **Test** : `tests/testthat/test-get_desc.R` — 4 cas (description sur 2 + lignes, description distante, pas de description, comportement par + défaut). +- **Fix** : `get_desc()` cherche maintenant le tag `@description` *le plus + proche au-dessus* de l'expectation, et collapse tout `\n` interne en + espace. +- **Commit** : `fix(get_desc): handle multiline & distant descriptions (#18)` + +### #15 — `test_down()` plante si un `test_that()` est vide +Quand un `test_that("x", {})` ne contient aucun `expect_*`, le pipe sur +`all_tests_read` retourne un `character(0)` sans noms. La ligne +`basename(names(all_tests_read))` plantait avec +`a character vector argument expected`. + +- **Test** : `tests/testthat/test-empty_test.R` — paquet jetable avec un + unique `test_that` vide ; `test_down()` doit retourner sans erreur. +- **Fix** : garde l'intermédiaire à un `setNames(character(), character())` + quand il est vide, et `were_skipped <- integer()` au lieu de `which()` + sur un `NULL`. +- **Commit** : `fix(test_down): tolerate empty test_that bodies (#15)` + +### #4 — Texte qui sort des tableaux (kable + double saut de ligne) +Un message contenant `\n\n` cassait la cellule kable parce que pandoc le +parse comme un saut de paragraphe et termine la ligne du tableau. + +- **Test** : `tests/testthat/test-sanitize_kable_cell.R` — 5 cas + (collapse, lignes blanches multiples, CRLF Windows, vectorisation, + vide). +- **Fix** : helper `sanitize_kable_cell()` (gsub des suites de + `\n[blank]*\n` en un seul `\n`) appliqué sur chaque colonne avant + `kable()`. +- **Commit** : `fix(write_parts): collapse blank lines inside table cells (#4)` + +## Issues envisagées mais non traitées dans cette passe + +| # | Pourquoi pas | +|---|---| +| #16 | Détecter `expected` comme variable plutôt que comme fixture demande de re-typer la sortie d'un test ; à arbitrer avec mainteneur. | +| #14 | Affichage de la couverture nécessite intégration avec `covr` — feature, demande design. | +| #12 | Intégration pkgdown — infra, demande design. | +| #10 | Préparation CRAN — meta. | diff --git a/tests/testthat/test-empty_test.R b/tests/testthat/test-empty_test.R new file mode 100644 index 0000000..6aab2cb --- /dev/null +++ b/tests/testthat/test-empty_test.R @@ -0,0 +1,34 @@ +test_that("test_down() does not error on a package whose only test_that is empty (#15)", { + skip_if_not_installed("withr") + + pkg_root <- tempfile(pattern = "pkg-") + dir.create(pkg_root) + on.exit(unlink(pkg_root, recursive = TRUE), add = TRUE) + file.copy( + system.file("fake.package", package = "testdown"), + pkg_root, + recursive = TRUE + ) + fake_pkg <- file.path(pkg_root, "fake.package") + testthat_dir <- file.path(fake_pkg, "tests", "testthat") + unlink(list.files(testthat_dir, full.names = TRUE)) + writeLines( + c( + 'test_that("my_fun works", {', + '})' + ), + file.path(testthat_dir, "test-empty.R") + ) + + book <- tempfile(pattern = "testdown-") + + expect_error( + suppressMessages(suppressWarnings( + withr::with_dir(fake_pkg, { + test_down(pkg = ".", open = FALSE, book_path = book) + }) + )), + NA # i.e., no error + ) + expect_true(file.exists(book)) +}) diff --git a/tests/testthat/test-get_desc.R b/tests/testthat/test-get_desc.R new file mode 100644 index 0000000..333c09d --- /dev/null +++ b/tests/testthat/test-get_desc.R @@ -0,0 +1,61 @@ +# Tests for get_desc() — covers issues #18 (multiline / non-immediate +# description) and an indirect impact on the table rendering. +# +# We exercise get_desc() by emulating the result list it consumes. +# A `result` is a named list with `$srcref` (numeric line refs + +# `srcfile` attribute pointing at a real file). + +make_fake_result <- function(file, line) { + ref <- c(line, 1L, line, 1L) + attr(ref, "srcfile") <- list(filename = file) + list(srcref = ref) +} + +write_fixture <- function(lines) { + path <- tempfile(fileext = ".R") + writeLines(lines, path) + path +} + +test_that("get_desc() collapses newlines inside a description into spaces (#18)", { + path <- write_fixture(c( + "test_that(\"two-line desc\", {", + " #' @description This description spans", + " #' two lines", + " expect_true(TRUE)", + "})" + )) + on.exit(unlink(path), add = TRUE) + res <- make_fake_result(path, line = 4L) + desc <- get_desc(res) + expect_false(grepl("\n", desc, fixed = TRUE), + info = "get_desc() must not return a newline (would break the kable cell)") + expect_match(desc, "spans two lines", fixed = TRUE) +}) + +test_that("get_desc() finds a description that is more than two lines above (#18)", { + path <- write_fixture(c( + "test_that(\"distant desc\", {", + " #' @description Top-level description", + " some_intermediate_call()", + " another_call()", + " expect_true(TRUE)", + "})" + )) + on.exit(unlink(path), add = TRUE) + res <- make_fake_result(path, line = 5L) + desc <- get_desc(res) + expect_match(desc, "Top-level description", fixed = TRUE) +}) + +test_that("get_desc() returns ' ' when there is no description tag", { + path <- write_fixture(c( + "test_that(\"no desc\", {", + " expect_true(TRUE)", + "})" + )) + on.exit(unlink(path), add = TRUE) + res <- make_fake_result(path, line = 2L) + desc <- get_desc(res) + expect_equal(desc, " ") +}) diff --git a/tests/testthat/test-sanitize_kable_cell.R b/tests/testthat/test-sanitize_kable_cell.R new file mode 100644 index 0000000..8d1cbc0 --- /dev/null +++ b/tests/testthat/test-sanitize_kable_cell.R @@ -0,0 +1,43 @@ +test_that("sanitize_kable_cell collapses blank lines (#4)", { + expect_equal( + sanitize_kable_cell("a\n\nb"), + "a\nb" + ) + expect_equal( + sanitize_kable_cell("a\n\n\nb"), + "a\nb" + ) + expect_equal( + sanitize_kable_cell("a\n \n \nb"), + "a\nb" + ) +}) + +test_that("sanitize_kable_cell normalises Windows line endings", { + expect_equal( + sanitize_kable_cell("a\r\nb"), + "a\nb" + ) + expect_equal( + sanitize_kable_cell("a\r\n\r\nb"), + "a\nb" + ) +}) + +test_that("sanitize_kable_cell leaves a single newline alone", { + expect_equal( + sanitize_kable_cell("a\nb"), + "a\nb" + ) +}) + +test_that("sanitize_kable_cell vectorises", { + expect_equal( + sanitize_kable_cell(c("a\n\nb", "c\nd", "e")), + c("a\nb", "c\nd", "e") + ) +}) + +test_that("sanitize_kable_cell handles zero-length input", { + expect_equal(sanitize_kable_cell(character()), character()) +}) From 3d38b21f37c53d3e8565a47ed222a4f691770dca Mon Sep 17 00:00:00 2001 From: Vincent Guyader Date: Sun, 26 Apr 2026 20:06:51 +0200 Subject: [PATCH 2/2] fix(get_desc): scope search to current test_that block (self-review) Self-review of the #18 fix: when a test_that block has no description of its own, the 'closest above' lookup walked back past previous test_that blocks and pulled their description. Limit the search to tags at or after the most recent test_that( line. --- R/utils.R | 36 +++++++++++++++++++++++++++++----- tests/testthat/test-get_desc.R | 18 +++++++++++++++++ 2 files changed, 49 insertions(+), 5 deletions(-) diff --git a/R/utils.R b/R/utils.R index 4150e96..c537bed 100644 --- a/R/utils.R +++ b/R/utils.R @@ -106,12 +106,22 @@ get_desc <- function( tags <- map(parsed, "tags") %>% flatten() expectation_line <- result$srcref[1] - # Pick the closest @description tag *above* this expectation. Previously - # the code only looked exactly 1 or 2 lines above, which missed - # descriptions placed further up (e.g. before intermediate setup calls - # inside the same test_that block) — see issue #18. + # Scope the search to the current test_that() block so a description + # belonging to a previous test_that doesn't bleed into this one — found + # while reviewing my own #18 fix. The block starts at the most recent + # line at or above `expectation_line` that opens a test_that() call. + block_start <- find_test_that_start(fls, expectation_line) + + # Pick the closest @description tag *above* this expectation, but + # within the same test_that block. Previously the code only looked + # exactly 1 or 2 lines above, which missed descriptions placed further + # up (e.g. before intermediate setup calls inside the same block). tag_lines <- vapply(tags, function(x) x$line %||% NA_integer_, integer(1)) - candidates_idx <- which(!is.na(tag_lines) & tag_lines < expectation_line) + candidates_idx <- which( + !is.na(tag_lines) & + tag_lines < expectation_line & + tag_lines >= block_start + ) if (length(candidates_idx)) { nearest <- candidates_idx[which.max(tag_lines[candidates_idx])] val <- tags[[nearest]]$val @@ -124,6 +134,22 @@ get_desc <- function( } } +#' Find the line number of the most recent `test_that(` call at or above +#' `line` in `fls`. Returns `1L` (start-of-file) when none is found, which +#' lets `get_desc()` fall back to file-scope behaviour. +#' +#' @param fls character vector, the file's lines. +#' @param line integer, current expectation line. +#' @noRd +find_test_that_start <- function(fls, line) { + if (line < 1L || !length(fls)) return(1L) + upper <- min(line, length(fls)) + for (i in upper:1L) { + if (grepl("\\btest_that\\s*\\(", fls[i])) return(i) + } + 1L +} + # tiny null-coalescer for older R / safer reads `%||%` <- function(a, b) if (is.null(a)) b else a diff --git a/tests/testthat/test-get_desc.R b/tests/testthat/test-get_desc.R index 333c09d..aae0711 100644 --- a/tests/testthat/test-get_desc.R +++ b/tests/testthat/test-get_desc.R @@ -48,6 +48,24 @@ test_that("get_desc() finds a description that is more than two lines above (#18 expect_match(desc, "Top-level description", fixed = TRUE) }) +test_that("get_desc() does not bleed a description across test_that blocks (self-review of #18)", { + path <- write_fixture(c( + "test_that(\"first test with desc\", {", + " #' @description Description for the FIRST test only", + " expect_true(TRUE)", + "})", + "", + "test_that(\"second test without desc\", {", + " expect_true(TRUE)", + "})" + )) + on.exit(unlink(path), add = TRUE) + res <- make_fake_result(path, line = 7L) # second test's expect line + desc <- get_desc(res) + expect_equal(desc, " ", + info = "second test_that has no description and must NOT inherit the first test's") +}) + test_that("get_desc() returns ' ' when there is no description tag", { path <- write_fixture(c( "test_that(\"no desc\", {",