Allow page splitting by parameter in pagination

NAMESPACE

@@ -10,8 +10,8 @@ export(export_as_txt)
 export(get_keycols)
 export(is_keycol)
 export(listing_dispcols)
-export(pag_listing_indices)
 export(paginate_listing)
+export(split_into_pages_by_var)
 exportMethods("[")
 exportMethods("main_footer<-")
 exportMethods("main_title<-")

NEWS.md

@@ -3,6 +3,10 @@
  * Added relevant tests for new line characters' handling in footnotes and titles.
  * Added cheatsheet.
  * Change title of "Getting Started with rlistings" vignette to "Getting Started".
+ * Added function `split_into_pages_by_var` to split a listing into a list of listings according to values of a given 
+   variable. This enables page splits by variable when paginating.
+ * Removed defunct function `pag_listing_indices`.
+ * Refactored `paginate_listing` to use directly `paginate_to_mpfs` function from `formatters` package.
 
 ## rlistings 0.2.7
  * Applied `styler` and resolved package lint. Changed default indentation from 4 spaces to 2.

R/paginate_listing.R

@@ -3,29 +3,26 @@
 #' @description `r lifecycle::badge("experimental")`
 #'
 #' Pagination of a listing. This can be vertical for long listings with many
-#' rows or horizontal if there are many columns.
+#' rows and/or horizontal if there are many columns. This function is a wrapper of
+#' [formatters::paginate_to_mpfs()] and it is mainly meant for exploration and testing.
 #'
-#' @param lsting listing_df. The listing to paginate.
-#' @param lpp numeric(1) or NULL. Number of row lines (not counting titles and
-#'   footers) to have per page. Standard is `70` while `NULL` disables vertical
-#'   pagination.
-#' @param cpp numeric(1) or NULL. Width (in characters) of the pages for
-#'   horizontal pagination. `NULL` (the default) indicates no horizontal
-#'   pagination should be done.
 #' @inheritParams formatters::pag_indices_inner
 #' @inheritParams formatters::vert_pag_indices
 #' @inheritParams formatters::page_lcpp
 #' @inheritParams formatters::toString
+#' @param lsting (`listing_df` or `list`)\cr the listing or list of listings to paginate.
+#' @param lpp (`numeric(1)` or `NULL`)\cr number of rows/lines (excluding titles and footers)
+#'   to include per page. Standard is `70` while `NULL` disables vertical pagination.
+#' @param cpp (`numeric(1)` or `NULL`)\cr width (in characters) of the pages for horizontal
+#'   pagination. `NULL` (the default) indicates no horizontal pagination should be done.
+#' @param print_pages (`logical(1)`)\cr whether to also print the paginated listing to console
+#'   (`cat(toString(x))`).
 #'
-#' @returns A list of listings' objects that are meant to be on separated pages.
-#'   For `pag_tt_indices` a list of paginated-groups of row-indices of `lsting`.
-#'
-#' @rdname paginate
+#' @return A list of `listing_df` objects where each list element corresponds to a separate page.
 #'
 #' @examples
 #' dat <- ex_adae
 #' lsting <- as_listing(dat[1:25, ], disp_cols = c("USUBJID", "AESOC", "RACE", "AETOXGR", "BMRKR1"))
-#'
 #' mat <- matrix_form(lsting)
 #'
 #' cat(toString(mat))
@@ -35,12 +32,9 @@
 #' paginate_listing(lsting, cpp = 100, lpp = 40)
 #'
 #' paginate_listing(lsting, cpp = 80, lpp = 40, verbose = TRUE)
-#' @export
 #'
-#' @return for `paginate_listing` a list containing separate
-#' `listing_df` objects for each page, for `pag_listing_indices`,
-#' a list of indices in the direction being paginated corresponding
-#' to the individual pages in that dimension.
+#' @export
+#' @rdname paginate
 paginate_listing <- function(lsting,
                              page_type = "letter",
                              font_family = "Courier",
@@ -52,17 +46,20 @@ paginate_listing <- function(lsting,
                              margins = c(top = .5, bottom = .5, left = .75, right = .75),
                              lpp = NA_integer_,
                              cpp = NA_integer_,
-                             colwidths = propose_column_widths(lsting),
+                             colwidths = NULL,
                              tf_wrap = !is.null(max_width),
+                             rep_cols = NULL,
                              max_width = NULL,
-                             verbose = FALSE) {
-  checkmate::assert_class(lsting, "listing_df")
+                             verbose = FALSE,
+                             print_pages = TRUE) {
+  checkmate::assert_multi_class(lsting, c("listing_df", "list"))
   checkmate::assert_numeric(colwidths, lower = 0, len = length(listing_dispcols(lsting)), null.ok = TRUE)
   checkmate::assert_flag(tf_wrap)
   checkmate::assert_count(max_width, null.ok = TRUE)
   checkmate::assert_flag(verbose)
+  checkmate::assert_flag(print_pages)
 
-  indx <- paginate_indices(lsting,
+  pages <- paginate_to_mpfs(lsting,
     page_type = page_type,
     font_family = font_family,
     font_size = font_size,
@@ -76,49 +73,17 @@ paginate_listing <- function(lsting,
     colwidths = colwidths,
     tf_wrap = tf_wrap,
     max_width = max_width,
-    rep_cols = length(get_keycols(lsting)),
+    rep_cols = rep_cols,
     verbose = verbose
   )
 
-  vert_pags <- lapply(
-    indx$pag_row_indices,
-    function(ii) lsting[ii, ]
-  )
-  dispnames <- listing_dispcols(lsting)
-  full_pag <- lapply(
-    vert_pags,
-    function(onepag) {
-      if (!is.null(indx$pag_col_indices)) {
-        lapply(
-          indx$pag_col_indices,
-          function(jj) {
-            res <- onepag[, dispnames[jj], drop = FALSE]
-            listing_dispcols(res) <- intersect(dispnames, names(res))
-            res
-          }
-        )
-      } else {
-        list(onepag)
-      }
-    }
-  )
-
-  ret <- unlist(full_pag, recursive = FALSE)
-  ret
-}
-
-#' @title Defunct functions
-#'
-#' @description
-#' These functions are defunct and their symbols will be removed entirely
-#' in a future release.
-#' @rdname defunct
-#' @inheritParams paginate_listing
-#' @export
-pag_listing_indices <- function(lsting,
-                                lpp = 15,
-                                colwidths = NULL,
-                                max_width = NULL,
-                                verbose = FALSE) {
-  .Defunct("paginate_indices", package = "formatters")
+  if (print_pages) {
+    nothing <- lapply(seq_along(pages), function(pagi) {
+      cat("--- Page", paste0(pagi, "/", length(pages)), "---\n")
+      # It is NULL because paginate_mpfs takes care of it
+      cat(toString(pages[[pagi]], widths = NULL, tf_wrap = tf_wrap, max_width = max_width))
+      cat("\n")
+    })
+  }
+  invisible(pages)
 }

R/rlistings.R

@@ -37,6 +37,9 @@ setOldClass(c("MatrixPrintForm", "list"))
 #'   for the listing, or `NULL` (the default).
 #' @param prov_footer character or NULL. A vector of provenance strings
 #'   for the listing, or `NULL` (the default). Each string element is placed on a new line.
+#' @param split_into_pages_by_var character or NULL. The name of a column for which the
+#'   listing should be split into pages, one for each level of the column. Check
+#'   [split_into_pages_by_var()] for more details.
 #' @param vec any. A column vector from a `listing_df` to be annotated as a key column.
 #'
 #' @return A `listing_df` object, sorted by the key columns.
@@ -138,7 +141,8 @@ as_listing <- function(df,
                        main_title = NULL,
                        subtitles = NULL,
                        main_footer = NULL,
-                       prov_footer = NULL) {
+                       prov_footer = NULL,
+                       split_into_pages_by_var = NULL) {
   if (length(non_disp_cols) > 0 && length(intersect(key_cols, non_disp_cols)) > 0) {
     stop(
       "Key column also listed in non_disp_cols. All key columns are by",
@@ -171,7 +175,9 @@ as_listing <- function(df,
   varlabs <- var_labels(df, fill = TRUE)
   o <- do.call(order, df[key_cols])
   if (is.unsorted(o)) {
-    message("sorting incoming data by key columns")
+    if (interactive()) {
+      message("sorting incoming data by key columns")
+    }
     df <- df[o, ]
   }
 
@@ -189,7 +195,7 @@ as_listing <- function(df,
 
   row_all_na <- apply(df[cols], 1, function(x) all(is.na(x)))
   if (any(row_all_na)) {
-    message("rows that only contain NA values have been trimmed")
+    warning("rows that only contain NA values have been trimmed")
     df <- df[!row_all_na, ]
   }
 
@@ -221,12 +227,18 @@ as_listing <- function(df,
   if (unique_rows) df <- df[!duplicated(df[, cols]), ]
 
   class(df) <- c("listing_df", class(df))
+
   ## these all work even when the value is NULL
   main_title(df) <- main_title
   main_footer(df) <- main_footer
   subtitles(df) <- subtitles
   prov_footer(df) <- prov_footer
   listing_dispcols(df) <- cols
+
+  if (!is.null(split_into_pages_by_var)) {
+    df <- split_into_pages_by_var(df, split_into_pages_by_var)
+  }
+
   df
 }
 
@@ -342,6 +354,7 @@ setMethod(
         ncol = ncol(fullmat)
       ),
       row_info = make_row_df(obj),
+      listing_keycols = keycols, # It is always something
       nlines_header = 1, # We allow only one level of headers and nl expansion happens after
       nrow_header = 1,
       has_topleft = FALSE,
@@ -435,3 +448,51 @@ add_listing_col <- function(df,
   df <- add_listing_dispcol(df, name)
   df
 }
+
+#' Split Listing by Values of a Variable
+#'
+#' @description `r lifecycle::badge("experimental")`
+#'
+#' Split is performed based on unique values of the given parameter present in the listing.
+#' Each listing can only be split by variable once. If this function is applied prior to
+#' pagination, parameter values will be separated by page.
+#'
+#' @param lsting listing_df. The listing to split.
+#' @param var character. Name of the variable to split on.
+#' @param page_prefix character. Prefix to be appended with the split value (`var` level),
+#'   at the end of the subtitles, corresponding to each resulting list element (listing).
+#'
+#' @return A list of `lsting_df` objects each corresponding to a unique value of `var`.
+#'
+#' @note This function should only be used after the complete listing has been created. The
+#'   listing cannot be modified further after applying this function.
+#'
+#' @examples
+#' dat <- ex_adae[1:20, ]
+#'
+#' lsting <- as_listing(
+#'   dat,
+#'   key_cols = c("USUBJID", "AGE"),
+#'   disp_cols = "SEX",
+#'   main_title = "title",
+#'   main_footer = "footer"
+#' ) %>%
+#'   add_listing_col("BMRKR1", format = "xx.x") %>%
+#'   split_into_pages_by_var("SEX")
+#'
+#' lsting
+#'
+#' @export
+split_into_pages_by_var <- function(lsting, var, page_prefix = var) {
+  checkmate::assert_class(lsting, "listing_df")
+  checkmate::assert_choice(var, names(lsting))
+
+  lsting_by_var <- list()
+  for (lvl in unique(lsting[[var]])) {
+    var_desc <- paste0(page_prefix, ": ", lvl)
+    lsting_by_var[[lvl]] <- lsting[lsting[[var]] == lvl, ]
+    subtitles(lsting_by_var[[lvl]]) <- c(subtitles(lsting), var_desc)
+  }
+
+  lsting_by_var
+}