as_markdown uses dots, with_* refactor

- `as_markdown` now accepts ... parameter instead of an x argument - Replace `quartools:::check_extension_arg` with `rlang::arg_match0` - majority of tests utilise snapshots instead of equivalence testing
ElianHugh · Nov 19, 2023 · 51e779f · 51e779f
1 parent 0fed7c8
commit 51e779f
Show file tree

Hide file tree

Showing 10 changed files with 244 additions and 50 deletions.
diff --git a/R/errors.R b/R/errors.R
diff --git a/R/misc.R b/R/misc.R
@@ -3,15 +3,15 @@
 #' This is a wrapper around [base::paste0] which sets the class of the resulting
 #' character vector to "knit_asis". This means that the [knitr::knitr] engine will render
 #' the character vector as markdown content, rather than as an R value.
-#' @param x object to convert to character vector
+#' @param ... dots to convert to character vector
 #' @inheritParams base::paste0
 #' @examples
 #' as_markdown(c("Hello world!"))
 #' @return character vector of length 1
 #' @export
-as_markdown <- function(x, collapse = "") {
+as_markdown <- function(..., collapse = "") {
     structure(
-        paste0(x, collapse = collapse),
+        paste0(..., collapse = collapse),
         class = c("knit_asis", "quarto_block")
     )
 }

diff --git a/R/with.R b/R/with.R
@@ -1,3 +1,12 @@
+handle_extensions <- function(extension, valid_extensions) {
+    if (!is.null(extension)) {
+        rlang::arg_match0(extension, valid_extensions)
+        extension_string <- paste0("-", extension)
+        return(extension_string)
+    }
+    return("")
+}
+
 #' Temporarily modify page layout
 #' @description
 #' Create a div block that modifies the current quarto layout column temporarily.
@@ -13,36 +22,32 @@
 #' @return character vector of length 1
 #' @rdname page-layout
 with_body_column <- function(..., attr = NULL, outset = FALSE, extension = NULL) {
-    check_extension_arg(extension, c("left", "right"))
+    extension_string <- handle_extensions(extension, c("left", "right"))
     outset_string <- ifelse(isTRUE(outset), "-outset", "")
-    extension_string <- ifelse(!is.null(extension), paste0("-", extension), "")
     cls <- sprintf(".column-body%s%s", outset_string, extension_string)
     div(..., attr = c(cls, attr))
 }
 
 #' @export
 #' @rdname page-layout
 with_page_column <- function(..., attr = NULL, extension = NULL) {
-    check_extension_arg(extension, c("left", "right"))
-    extension_string <- ifelse(!is.null(extension), paste0("-", extension), "")
+    extension_string <- handle_extensions(extension, c("left", "right"))
     cls <- sprintf(".column-page%s", extension_string)
     div(..., attr = c(cls, attr))
 }
 
 #' @export
 #' @rdname page-layout
 with_screen_inset_column <- function(..., attr = NULL, extension = NULL) {
-    check_extension_arg(extension, c("left", "right", "shaded"))
-    extension_string <- ifelse(!is.null(extension), paste0("-", extension), "")
+    extension_string <- handle_extensions(extension, c("left", "right", "shaded"))
     cls <- sprintf(".column-screen-inset%s", extension_string)
     div(..., attr = c(cls, attr))
 }
 
 #' @export
 #' @rdname page-layout
 with_screen_column <- function(..., attr = NULL, extension = NULL) {
-    check_extension_arg(extension, c("left", "right"))
-    extension_string <- ifelse(!is.null(extension), paste0("-", extension), "")
+    extension_string <- handle_extensions(extension, c("left", "right"))
     cls <- sprintf(".column-screen%s", extension_string)
     div(..., attr = c(cls, attr))
 }

diff --git a/man/as_markdown.Rd b/man/as_markdown.Rd
diff --git a/tests/testthat/_snaps/elements.md b/tests/testthat/_snaps/elements.md
@@ -0,0 +1,42 @@
+# element output is accurate
+
+    Code
+      div("Hello world!")
+    Output
+      
+      
+      :::{}
+      
+      Hello world!
+      
+      :::
+      
+
+---
+
+    Code
+      div("This is a tip!", attr = ".callout-tip")
+    Output
+      
+      
+      :::{.callout-tip}
+      
+      This is a tip!
+      
+      :::
+      
+
+---
+
+    Code
+      span()
+    Output
+      []{}
+
+---
+
+    Code
+      span("Hello world!", attr = ".bold")
+    Output
+      [Hello world!]{.bold}
+
diff --git a/tests/testthat/_snaps/misc.md b/tests/testthat/_snaps/misc.md
@@ -0,0 +1,30 @@
+# mdapply works
+
+    Code
+      mdapply(input, function(x) {
+        div(x$msg, attr = sprintf(".callout-%s", x$type))
+      })
+    Output
+      
+      
+      :::{.callout-tip}
+      
+      a tip
+      
+      :::
+      
+      
+      :::{.callout-warning}
+      
+      a warning
+      
+      :::
+      
+      
+      :::{.callout-message}
+      
+      a message
+      
+      :::
+      
+
diff --git a/tests/testthat/_snaps/with.md b/tests/testthat/_snaps/with.md
@@ -0,0 +1,126 @@
+# with_*() output is as expected
+
+    Code
+      input[[i]]
+    Output
+      
+      
+      :::{.column-body .bar}
+      
+      foo
+      
+      :::
+      
+
+---
+
+    Code
+      input[[i]]
+    Output
+      
+      
+      :::{.column-page .bar}
+      
+      foo
+      
+      :::
+      
+
+---
+
+    Code
+      input[[i]]
+    Output
+      
+      
+      :::{.column-screen-inset .bar}
+      
+      foo
+      
+      :::
+      
+
+---
+
+    Code
+      input[[i]]
+    Output
+      
+      
+      :::{.column-screen .bar}
+      
+      foo
+      
+      :::
+      
+
+---
+
+    Code
+      input[[i]]
+    Output
+      
+      
+      :::{.column-margin .bar}
+      
+      foo
+      
+      :::
+      
+
+---
+
+    Code
+      extensions_input[[i]]
+    Output
+      
+      
+      :::{.column-body-left .bar}
+      
+      foo
+      
+      :::
+      
+
+---
+
+    Code
+      extensions_input[[i]]
+    Output
+      
+      
+      :::{.column-page-right .bar}
+      
+      foo
+      
+      :::
+      
+
+---
+
+    Code
+      extensions_input[[i]]
+    Output
+      
+      
+      :::{.column-screen-inset-shaded .bar}
+      
+      foo
+      
+      :::
+      
+
+---
+
+    Code
+      extensions_input[[i]]
+    Output
+      
+      
+      :::{.column-screen-left .bar}
+      
+      foo
+      
+      :::
+      
+
diff --git a/tests/testthat/test_elements.R b/tests/testthat/test_elements.R
@@ -1,12 +1,8 @@
-test_that("div() output is accurate", {
-    expect_true(div() == "\n\n:::{}\n\n\n\n:::\n")
-    expect_true(div("Hello world!") == "\n\n:::{}\n\nHello world!\n\n:::\n")
-    expect_true(div("This is a tip!", attr = ".callout-tip") == "\n\n:::{.callout-tip}\n\nThis is a tip!\n\n:::\n")
-})
-
-test_that("span output is accurate", {
-    expect_true(span() == "[]{}")
-    expect_true(span("Hello world!", attr = ".bold") == "[Hello world!]{.bold}")
+test_that("element output is accurate", {
+    expect_snapshot(div("Hello world!"))
+    expect_snapshot(div("This is a tip!", attr = ".callout-tip"))
+    expect_snapshot(span())
+    expect_snapshot(span("Hello world!", attr = ".bold"))
 })
 
 test_that("unnamed dots throw errors", {

diff --git a/tests/testthat/test_misc.R b/tests/testthat/test_misc.R
@@ -5,13 +5,12 @@ test_that("mdapply works", {
         list(type = "warning", msg = "a warning"),
         list(type = "message", msg = "a message")
     )
-    res <- mdapply(
-        input,
-        function(x) {
-            div(x$msg, attr = sprintf(".callout-%s", x$type))
-        }
-    )
-    expect_true(
-        res == "\n\n:::{.callout-tip}\n\na tip\n\n:::\n\n\n:::{.callout-warning}\n\na warning\n\n:::\n\n\n:::{.callout-message}\n\na message\n\n:::\n" # nolint: line_length_linter.
+    expect_snapshot(
+        mdapply(
+            input,
+            function(x) {
+                div(x$msg, attr = sprintf(".callout-%s", x$type))
+            }
+        )
     )
 })
diff --git a/tests/testthat/test_with.R b/tests/testthat/test_with.R
@@ -6,17 +6,23 @@ test_that("with_*() output is as expected", {
         with_screen_column("foo", attr = ".bar"),
         with_margin_column("foo", attr = ".bar")
     )
-    expectations <- list(
-        "\n\n:::{.column-body .bar}\n\nfoo\n\n:::\n",
-        "\n\n:::{.column-page .bar}\n\nfoo\n\n:::\n",
-        "\n\n:::{.column-screen-inset .bar}\n\nfoo\n\n:::\n",
-        "\n\n:::{.column-screen .bar}\n\nfoo\n\n:::\n",
-        "\n\n:::{.column-margin .bar}\n\nfoo\n\n:::\n"
-    )
 
     lapply(seq_along(input), function(i) {
-        expect_true(input[[i]] == expectations[[i]])
+        expect_snapshot(input[[i]])
     })
+
+    extensions_input <- list(
+        with_body_column("foo", attr = ".bar", extension = "left"),
+        with_page_column("foo", attr = ".bar", extension = "right"),
+        with_screen_inset_column("foo", attr = ".bar", extension = "shaded"),
+        with_screen_column("foo", attr = ".bar", extension = "left")
+    )
+
+    lapply(seq_along(extensions_input), function(i) {
+        expect_snapshot(extensions_input[[i]])
+    })
+
+
 })
 
 test_that("with_*() disallows invalid extensions", {