split listings

NAMESPACE

@@ -175,6 +175,7 @@ export(postprocess)
 export(preprocess)
 export(reformat)
 export(report_null)
+export(rl_list)
 export(rmpt01)
 export(rmpt01_main)
 export(rmpt01_post)

NEWS.md

@@ -1,8 +1,8 @@
 # chevron 0.2.5.9009
 
 * Added assertion on class of `summaryvars` argument of `dmt01()`.
-
 * Soft deprecated `strat` argument of `kmg01_main` - use `strata` instead.
+* Additional arguments can be passed to `ael01_nollt` run method, for instance to split the resulting listing.
 
 # chevron 0.2.5
 

R/ael01_nollt.R

@@ -6,7 +6,8 @@
 #' @param dataset (`character`) the name of a table in the `adam_db` object.
 #' @param default_formatting (`list`) the default format of the listing columns. See [`rlistings::as_listing`].
 #' @param col_formatting (`list`) the format of specific listing columns. See [`rlistings::as_listing`].
-#' @returns the main function returns an `rlistings` object.
+#' @param ... additional arguments passed to [`rlistings::as_listing`].
+#' @returns the main function returns an `rlistings` or a `rl_list` object.
 #'
 #' @details
 #'  * Removes duplicate rows.
@@ -35,14 +36,23 @@ ael01_nollt_main <- function(adam_db,
   assert_list(default_formatting, types = "fmt_config", names = "unique")
   assert_list(col_formatting, null.ok = TRUE, types = "fmt_config", names = "unique")
   assert_flag(unique_rows)
-  as_listing(
-    adam_db[[dataset]],
+
+  ret <- execute_with_args(
+    as_listing,
+    df = adam_db[[dataset]],
     key_cols = key_cols,
     disp_cols = disp_cols,
     default_formatting = default_formatting,
     col_formatting = col_formatting,
-    unique_rows = unique_rows
+    unique_rows = unique_rows,
+    ...
   )
+
+  if (is(ret, "list")) {
+    do_call(rl_list, ret)
+  } else {
+    ret
+  }
 }
 
 #' @describeIn ael01_nollt Preprocessing
@@ -72,7 +82,11 @@ ael01_nollt_pre <- function(adam_db,
 #' @returns the postprocessing function returns an `rlistings` object or an `ElementaryTable` (null report).
 #'
 ael01_nollt_post <- function(tlg, ...) {
-  if (nrow(tlg) == 0) tlg <- null_report
+  if (is(tlg, "rl_list")) {
+    if (length(tlg) == 0) tlg <- null_report
+  } else {
+    if (nrow(tlg) == 0) tlg <- null_report
+  }
 
   tlg
 }

R/utils.R

@@ -137,6 +137,20 @@ gg_list <- function(...) {
   )
 }
 
+#' List of `rlistings` object
+#'
+#' @param ... (`rlistings`) objects.
+#' @returns a `rl_list` object.
+#' @export
+rl_list <- function(...) {
+  ret <- list(...)
+  assert_list(ret, types = c("listing_df"))
+  structure(
+    ret,
+    class = c("rl_list", "list")
+  )
+}
+
 #' @export
 droplevels.character <- function(x, ...) {
   x

_pkgdown.yaml

@@ -115,6 +115,7 @@ reference:
       - smart_prune
       - var_labels_for
       - gg_list
+      - rl_list
       - gg_theme_chevron
       - grob_list
       - h_format_dec

tests/testthat/test-ael01_nollt.R

@@ -47,3 +47,18 @@ test_that("ael01_nollt can handle some missing values", {
   res <- expect_silent(run(ael01_nollt, proc_data))
   expect_snapshot(cat(export_as_txt(res, lpp = 100)))
 })
+
+test_that("ael01_nollt listing can be split by an additional variable", {
+  res <- expect_silent(
+    run(
+      ael01_nollt,
+      syn_data,
+      dataset = "admh",
+      key_cols = c("MHBODSYS", "MHDECOD"),
+      disp_cols = "MHTERM",
+      split_into_pages_by_var = "SEX"
+    )
+  )
+  expect_list(res, type = "listing_df")
+  expect_snapshot(cat(export_as_txt(res, lpp = 100)))
+})

tests/testthat/test-utils.R

@@ -293,3 +293,30 @@ test_that("get_section_div works", {
     expect_identical(get_section_div(), c("", NA_character_, ""))
   )
 })
+
+# gg_list ----
+
+test_that("gg_list works as expected", {
+  p <- ggplot(mtcars, aes(x = hp, y = mpg)) +
+    geom_point()
+  p_ls <- list(a = p, b = p)
+
+  res <- expect_silent(gg_list(p))
+  expect_class(res, "gg_list")
+
+  res <- expect_silent(do_call(gg_list, p_ls))
+  expect_class(res, "gg_list")
+})
+
+# rl_list ----
+
+test_that("rl_list works as expected", {
+  l <- as_listing(iris, key_cols = "Species")
+  l_ls <- list(a = l, b = l)
+
+  res <- expect_silent(rl_list(l))
+  expect_class(res, "rl_list")
+
+  res <- expect_silent(do_call(rl_list, l_ls))
+  expect_class(res, "rl_list")
+})