rlistings coverage - 86.21%

Files
Source

File	Lines	Relevant	Covered	Missed	Hits / Line	Coverage
R/rlistings_methods.R	375	111	84	27	149	75.68%
R/rlistings.R	510	173	162	11	149	93.64%
R/paginate_listing.R	89	27	27	0	20	100.00%

#' Paginate listings
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Pagination of a listing. This can be vertical for long listings with many
#' 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.
#'
#' @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 (`flag`)\cr whether the paginated listing should be printed to the console
#'   (`cat(toString(x))`).
#'
#' @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))
#'
#' paginate_listing(lsting, lpp = 10)
#'
#' paginate_listing(lsting, cpp = 100, lpp = 40)
#'
#' paginate_listing(lsting, cpp = 80, lpp = 40, verbose = TRUE)
#'
#' @export
#' @rdname paginate
paginate_listing <- function(lsting,
                             page_type = "letter",
                             font_family = "Courier",
                             font_size = 8,
                             lineheight = 1,
                             landscape = FALSE,
                             pg_width = NULL,
                             pg_height = NULL,
                             margins = c(top = .5, bottom = .5, left = .75, right = .75),
                             lpp = NA_integer_,
                             cpp = NA_integer_,
                             colwidths = NULL,
                             tf_wrap = !is.null(max_width),
                             rep_cols = NULL,
                             max_width = NULL,
                             col_gap = 3,
                             fontspec = font_spec(font_family, font_size, lineheight),
                             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)

  pages <- paginate_to_mpfs(lsting,
    page_type = page_type,
    fontspec = fontspec,
    landscape = landscape,
    pg_width = pg_width,
    pg_height = pg_height,
    margins = margins,
    lpp = lpp,
    cpp = cpp,
    colwidths = colwidths,
    tf_wrap = tf_wrap,
    max_width = max_width,
    rep_cols = rep_cols,
    col_gap = col_gap,
    verbose = verbose
  )

  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, col_gap = col_gap))
      cat("\n")
    })
  }
  invisible(pages)
}


## XXX this historically has been 1, but it actually should be 1.2!!!!!
dflt_courier <- font_spec("Courier", 9, 1)

#' Methods for `listing_df` objects
#'
#' See core documentation in [formatters::formatters-package] for descriptions of these functions.
#'
#' @inheritParams formatters::toString
#' @param x (`listing_df`)\cr the listing.
#' @param ... additional parameters passed to [formatters::toString()].
#'
#' @method print listing_df
#'
#' @export
#' @name listing_methods
print.listing_df <- function(x, widths = NULL, tf_wrap = FALSE, max_width = NULL, fontspec = NULL, col_gap = 3L,  ...) {
  tryCatch({
    cat(
      toString(
        matrix_form(x, fontspec = fontspec, col_gap = col_gap),
        widths = widths,
        tf_wrap = tf_wrap,
        max_width = max_width,
        fontspec = fontspec,
        col_gap = col_gap,
        ...
      )
    )
  }, error = function(e) {
    if (nrow(x) == 0) {
      print("No observation in the listing object.")
    } else {
      stop(e)
    }
  })
  invisible(x)
}

#' @exportMethod toString
#' @name listing_methods
#' @aliases toString,listing_df-method
setMethod("toString", "listing_df", function(x, widths = NULL, fontspec = NULL, col_gap = 3L,  ...) {
  toString(
    matrix_form(x, fontspec = fontspec, col_gap = col_gap),
    fontspec = fontspec,
    col_gap = col_gap,
    widths = widths,
    ...
  )
})

## because rle in base is too much of a stickler for being atomic
basic_run_lens <- function(x) {
  n <- length(x)
  if (n == 0) {
    return(integer())
  }

  y <- x[-1L] != x[-n]
  i <- c(which(y), n)
  diff(c(0L, i))
}

#' @param df (`listing_df`)\cr the listing.
#' @param colnm (`string`)\cr column name.
#' @param colvec (`vector`)\cr column values based on `colnm`.
#'
#' @rdname vec_nlines
#' @keywords internal
format_colvector <- function(df, colnm, colvec = df[[colnm]]) {
  if (missing(colvec) && !(colnm %in% names(df))) {
    stop("column ", colnm, " not found")
  }
  na_str <- obj_na_str(colvec)
  if (is.null(na_str) || all(is.na(na_str))) {
    na_str <- rep("-", max(1L, length(na_str)))
  }

  strvec <- vapply(colvec, format_value, "", format = obj_format(colvec), na_str = na_str)
  strvec
}

#' Utilities for formatting a listing column
#'
#' For `vec_nlines`, calculate the number of lines each element of a column vector will
#' take to render. For `format_colvector`,
#'
#' @param vec (`vector`)\cr a column vector to be rendered into ASCII.
#' @param max_width (`numeric(1)` or `NULL`)\cr the width to render the column with.
#' @return (`numeric`)\cr a vector of the number of lines element-wise that will be
#'   needed to render the elements of `vec` to width `max_width`.
#'
#' @keywords internal
setGeneric("vec_nlines", function(vec, max_width = NULL, fontspec = dflt_courier) standardGeneric("vec_nlines"))

#' @param vec (`vector`)\cr a vector.
#'
#' @rdname vec_nlines
#' @keywords internal
setMethod("vec_nlines", "ANY", function(vec, max_width = NULL, fontspec = dflt_courier) {
  if (is.null(max_width)) {
    max_width <- floor(0.9 * getOption("width")) # default of base::strwrap
    # NB: flooring as it is used as <= (also in base::strwrap)
  }
  # in formatters for characters
  unlist(lapply(format_colvector(colvec = vec), nlines, max_width = max_width, fontspec = fontspec))
})

## setMethod("vec_nlines", "character", function(vec, max_width = NULL) {
##     strvec <- wrap_txt(format_colvector(colvec = vec), width = max_width, collapse = "\n")
##     mtchs <- gregexpr("\n", strvec, fixed = TRUE)
##     1L + vapply(mtchs, function(vi) sum(vi > 0), 1L)
## })

## setMethod("vec_nlines", "factor", function(vec, max_width = NULL) {
##   lvl_nlines <- vec_nlines(levels(vec), max_width = max_width)
##   ret <- lvl_nlines[vec]
##   ret[is.na(ret)] <- format_value(NA_character
## })

#' Make pagination data frame for a listing
#'
#' @inheritParams formatters::make_row_df
#' @param tt (`listing_df`)\cr the listing to be rendered.
#' @param visible_only (`flag`)\cr ignored, as listings do not have
#'   non-visible structural elements.
#'
#' @return a `data.frame` with pagination information.
#'
#' @seealso [formatters::make_row_df()]
#'
#' @examples
#' lsting <- as_listing(mtcars)
#' mf <- matrix_form(lsting)
#'
#' @export
setMethod(
  "make_row_df", "listing_df",
  function(tt, colwidths = NULL, visible_only = TRUE,
           rownum = 0,
           indent = 0L,
           path = character(),
           incontent = FALSE,
           repr_ext = 0L,
           repr_inds = integer(),
           sibpos = NA_integer_,
           nsibs = NA_integer_,
           fontspec = dflt_courier) {
    ## assume sortedness by keycols
    keycols <- get_keycols(tt)
    dispcols <- listing_dispcols(tt)
    abs_rownumber <- seq_along(tt[[1]])
    if (length(keycols) >= 1) {
      runlens <- basic_run_lens(tt[[tail(keycols, 1)]])
    } else {
      runlens <- rep(1, NROW(tt))
    }
    sibpos <- unlist(lapply(runlens, seq_len))
    nsibs <- rep(runlens, times = runlens)
    extents <- rep(1L, nrow(tt))
    if (length(colwidths) > 0 && length(colwidths) != length(dispcols)) {
      stop(
        "Non-null colwidths vector must be the same length as the number of display columns.\n",
        "Got: ", length(colwidths), "(", length(dispcols), " disp cols)."
      )
    }
    if (length(colwidths) > 0) {
      names(colwidths) <- dispcols
    }
    ## extents is a row-wise vector of extents, for each col, we update
    ## if that column has any rows wider than the previously recorded extent.
    for (col in dispcols) {
      ## duplicated from matrix_form method, refactor!
      col_ext <- vec_nlines(tt[[col]], max_width = colwidths[col], fontspec = fontspec)
      extents <- ifelse(col_ext > extents, col_ext, extents)
    }
    ret <- data.frame(
      label = "", name = "",
      abs_rownumber = abs_rownumber,
      path = I(as.list(rep(NA_character_, NROW(tt)))),
      pos_in_siblings = sibpos,
      n_siblings = nsibs,
      self_extent = extents,
      par_extent = 0L,
      reprint_inds = I(replicate(NROW(tt), list(integer()))),
      node_class = "listing_df",
      indent = 0L,
      nrowrefs = 0L, ## XXX this doesn't support footnotes
      ncellrefs = 0L, ## XXX this doesn't support footnotes
      nreflines = 0L, ## XXX this doesn't support footnotes
      force_page = FALSE,
      page_title = NA_character_,
      trailing_sep = NA_character_
    )
    stopifnot(identical(
      names(ret),
      names(pagdfrow(
        nm = "", lab = "", rnum = 1L, pth = NA_character_, extent = 1L,
        rclass = ""
      ))
    ))
    ret
  }
)

##     tt$sibpos <- unlist(lapply(
##     ## don't support pathing for now
##     tt$path <- I(lapply(1:NROW(tt),
##                     function(i) {
##         retpath <- character(2*length(keycols))
##         for(j in seq_along(keycols)) {
##             retpath[2*j - 1] <- keycols[j]
##             retpath[2*j] <- tt[i, keycols[j], drop = TRUE]
##         }
##         retpath
##     }))
##     spl <- split(tt, tt[keycols])
##     spl <- spl[vapply(spl, function(y) NROW(y) > 0, NA)]
##     dfs <- lapply(spl, function(df) {
##         df <- df[order(df$abs_rownumber),]
##         ndf <- NROW(df)
##         lapply(1:ndf, function(i) {
##             rw <- df[i,]
##             stopifnot(nrow(rw) == 1)
##             pagdfrow(nm = "",
##                      lab = "",
##                      rnum = rw$abs_rownumber,
##                      pth = NA_character_,
##                      sibpos = i,
##                      nsibs = ndf,
##                      extent = 1L,
##                      rclass = "listing_df",
##                      repind = integer())
##         })
##     })
##     ret <- do.call(rbind, unlist(dfs, recursive = FALSE))
##     ret <- ret[order(ret$abs_rownumber),]
##     ret
## })

#' @inheritParams base::Extract
#' @param x (`listing_df`)\cr the listing.
#' @param i (`any`)\cr object passed to base `[` methods.
#' @param j (`any`)\cr object passed to base `[` methods.
#'
#' @export
#' @aliases [,listing_df-method
#' @rdname listing_methods
setMethod(
  "[", "listing_df",
  function(x, i, j, drop = FALSE) {
    xattr <- attributes(x)
    xattr$names <- xattr$names[j]
    res <- NextMethod()
    if (!drop) {
      attributes(res) <- xattr
    }
    res
  }
)

#' @rdname listing_methods
#' @param obj (`listing_df`)\cr the listing.
#'
#' @return
#' * Accessor methods return the value of the aspect of `obj`.
#' * Setter methods return `obj` with the relevant element of the listing updated.
#'
#' @examples
#' lsting <- as_listing(mtcars)
#' main_title(lsting) <- "Hi there"
#'
#' main_title(lsting)
#'
#' @export
setMethod(
  "main_title", "listing_df",
  function(obj) attr(obj, "main_title") %||% character()
)

#' @rdname listing_methods
#' @export
setMethod(
  "subtitles", "listing_df",
  function(obj) attr(obj, "subtitles") %||% character()
)

#' @rdname listing_methods
#' @export
setMethod(
  "main_footer", "listing_df",
  function(obj) attr(obj, "main_footer") %||% character()
)

#' @rdname listing_methods
#' @export
setMethod(
  "prov_footer", "listing_df",
  function(obj) attr(obj, "prov_footer") %||% character()
)

.chk_value <- function(val, fname, len_one = FALSE, null_ok = TRUE) {
  if (null_ok && is.null(val)) {
    return(TRUE)
  }
  if (!is.character(val)) {
    stop("value for ", fname, " must be a character, got ",
      "object of class: ", paste(class(val), collapse = ","),
      call. = FALSE
    )
  }
  if (len_one && length(val) > 1) {
    stop(
      "value for ", fname, " must be length <= 1, got ",
      "vector of length ", length(val)
    )
  }
  TRUE
}

#' @rdname listing_methods
#' @export
setMethod(
  "main_title<-", "listing_df",
  function(obj, value) {
    ## length 1 restriction is to match rtables behavior
    ## which currently enforces this (though incompletely)
    .chk_value(value, "main_title", len_one = TRUE)
    attr(obj, "main_title") <- value
    obj
  }
)

#' @rdname listing_methods
#' @export
setMethod(
  "subtitles<-", "listing_df",
  function(obj, value) {
    .chk_value(value, "subtitles")
    attr(obj, "subtitles") <- value
    obj
  }
)

#' @rdname listing_methods
#' @export
setMethod(
  "main_footer<-", "listing_df",
  function(obj, value) {
    .chk_value(value, "main_footer")
    attr(obj, "main_footer") <- value
    obj
  }
)

#' @rdname listing_methods
#' @export
setMethod(
  "prov_footer<-", "listing_df",
  function(obj, value) {
    .chk_value(value, "prov_footer")
    attr(obj, "prov_footer") <- value
    obj
  }
)

#' @rdname listing_methods
#' @export
setMethod(
  "num_rep_cols", "listing_df",
  function(obj) {
    length(get_keycols(obj))
  }
)

setOldClass(c("listing_df", "tbl_df", "tbl", "data.frame"))
setOldClass(c("MatrixPrintForm", "list"))

#' Create a listing from a `data.frame` or `tibble`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Create listings displaying `key_cols` and `disp_cols` to produce a compact and
#' elegant representation of the input `data.frame` or `tibble`.
#'
#' @param df (`data.frame` or `listing_df`)\cr the `data.frame` to be converted to a listing or
#'   `listing_df` to be modified.
#' @param key_cols (`character`)\cr vector of names of columns which should be treated as *key columns*
#'   when rendering the listing. Key columns allow you to group repeat occurrences.
#' @param disp_cols (`character` or `NULL`)\cr vector of names of non-key columns which should be
#'   displayed when the listing is rendered. Defaults to all columns of `df` not named in `key_cols` or
#'   `non_disp_cols`.
#' @param non_disp_cols (`character` or `NULL`)\cr vector of names of non-key columns to be excluded as display
#'   columns. All other non-key columns are treated as display columns. Ignored if `disp_cols` is non-`NULL`.
#' @param unique_rows (`flag`)\cr whether only unique rows should be included in the listing. Defaults to `FALSE`.
#' @param default_formatting (`list`)\cr a named list of default column format configurations to apply when rendering
#'   the listing. Each name-value pair consists of a name corresponding to a data class (or "numeric" for all
#'   unspecified numeric classes) and a value of type `fmt_config` with the format configuration that should be
#'   implemented for columns of that class. If named element "all" is included in the list, this configuration will be
#'   used for all data classes not specified. Objects of type `fmt_config` can take 3 arguments: `format`, `na_str`,
#'   and `align`.
#' @param col_formatting (`list`)\cr a named list of custom column formatting configurations to apply to specific
#'   columns when rendering the listing. Each name-value pair consists of a name corresponding to a column name and a
#'   value of type `fmt_config` with the formatting configuration that should be implemented for that column. Objects
#'   of type `fmt_config` can take 3 arguments: `format`, `na_str`, and `align`. Defaults to `NULL`.
#' @param main_title (`string` or `NULL`)\cr the main title for the listing, or `NULL` (the default).
#' @param subtitles (`character` or `NULL`)\cr a vector of subtitles for the listing, or `NULL` (the default).
#' @param main_footer (`character` or `NULL`)\cr a vector of main footer lines for the listing, or `NULL` (the default).
#' @param prov_footer (`character` or `NULL`)\cr a vector of provenance footer lines 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`)\cr the name of a variable for on the listing should be split
#'   into pages, with each page corresponding to one unique value/level of the variable. See
#'   [split_into_pages_by_var()] for more details.
#' @param vec (`string`)\cr name of a column vector from a `listing_df` object to be annotated as a key column.
#'
#' @return A `listing_df` object, sorted by its key columns.
#'
#' @details
#' At its core, a `listing_df` object is a `tbl_df` object with a customized
#' print method  and support for the formatting and pagination machinery provided by
#' the `formatters` package.
#'
#' `listing_df` objects have two 'special' types of columns: key columns and display columns.
#'
#' Key columns act as indexes, which means a number of things in practice.
#'
#' All key columns are also display columns.
#'
#' `listing_df` objects are always sorted by their set of key columns at creation time.
#' Any `listing_df` object which is not sorted by its full set of key columns (e.g.,
#' one whose rows have been reordered explicitly during creation) is invalid and the behavior
#' when rendering or paginating that object is undefined.
#'
#' Each value of a key column is printed only once per page and per unique combination of
#' values for all higher-priority (i.e., to the left of it) key columns. Locations
#' where a repeated value would have been printed within a key column for the same
#' higher-priority-key combination on the same page are rendered as empty space.
#' Note, determination of which elements to display within a key column at rendering is
#' based on the underlying value; any non-default formatting applied to the column
#' has no effect on this behavior.
#'
#' Display columns are columns which should be rendered, but are not key columns. By
#' default this is all non-key columns in the incoming data, but in need not be.
#' Columns in the underlying data which are neither key nor display columns remain
#' within the object available for computations but *are not rendered during
#' printing or export of the listing*.
#'
#' @examples
#' dat <- ex_adae
#'
#' # This example demonstrates the listing with key_cols (values are grouped by USUBJID) and
#' # multiple lines in prov_footer
#' lsting <- as_listing(dat[1:25, ],
#'   key_cols = c("USUBJID", "AESOC"),
#'   main_title = "Example Title for Listing",
#'   subtitles = "This is the subtitle for this Adverse Events Table",
#'   main_footer = "Main footer for the listing",
#'   prov_footer = c(
#'     "You can even add a subfooter", "Second element is place on a new line",
#'     "Third string"
#'   )
#' ) %>%
#'   add_listing_col("AETOXGR") %>%
#'   add_listing_col("BMRKR1", format = "xx.x") %>%
#'   add_listing_col("AESER / AREL", fun = function(df) paste(df$AESER, df$AREL, sep = " / "))
#'
#' mat <- matrix_form(lsting)
#'
#' cat(toString(mat))
#'
#' # This example demonstrates the listing table without key_cols
#' # and specifying the cols with disp_cols.
#' dat <- ex_adae
#' lsting <- as_listing(dat[1:25, ],
#'   disp_cols = c("USUBJID", "AESOC", "RACE", "AETOXGR", "BMRKR1")
#' )
#'
#' mat <- matrix_form(lsting)
#'
#' cat(toString(mat))
#'
#' # This example demonstrates a listing with format configurations specified
#' # via the default_formatting and col_formatting arguments
#' dat <- ex_adae
#' dat$AENDY[3:6] <- NA
#' lsting <- as_listing(dat[1:25, ],
#'   key_cols = c("USUBJID", "AESOC"),
#'   disp_cols = c("STUDYID", "SEX", "ASEQ", "RANDDT", "ASTDY", "AENDY"),
#'   default_formatting = list(
#'     all = fmt_config(align = "left"),
#'     numeric = fmt_config(
#'       format = "xx.xx",
#'       na_str = "<No data>",
#'       align = "right"
#'     )
#'   )
#' ) %>%
#'   add_listing_col("BMRKR1", format = "xx.x", align = "center")
#'
#' mat <- matrix_form(lsting)
#'
#' cat(toString(mat))
#'
#' @export
#' @rdname listings
as_listing <- function(df,
                       key_cols = names(df)[1],
                       disp_cols = NULL,
                       non_disp_cols = NULL,
                       unique_rows = FALSE,
                       default_formatting = list(all = fmt_config()),
                       col_formatting = NULL,
                       main_title = NULL,
                       subtitles = NULL,
                       main_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",
      " definition display columns."
    )
  }
  if (!is.null(disp_cols) && !is.null(non_disp_cols)) {
    stop("Got non-null values for both disp_cols and non_disp_cols. This is not supported.")
  } else if (is.null(disp_cols)) {
    ## non_disp_cols NULL is ok here
    cols <- setdiff(names(df), c(key_cols, non_disp_cols))
  } else {
    ## disp_cols non-null, non_disp_cols NULL
    cols <- disp_cols
  }
  if (!all(sapply(default_formatting, is, class2 = "fmt_config"))) {
    stop(
      "All format configurations supplied in `default_formatting`",
      " must be of type `fmt_config`."
    )
  }
  if (!(is.null(col_formatting) || all(sapply(col_formatting, is, class2 = "fmt_config")))) {
    stop(
      "All format configurations supplied in `col_formatting`",
      " must be of type `fmt_config`."
    )
  }

  if (any(sapply(df, inherits, "difftime"))) {
    stop("One or more variables in the dataframe have class 'difftime'. Please convert to factor or character.")
  }

  df <- as_tibble(df)
  varlabs <- var_labels(df, fill = TRUE)
  o <- do.call(order, df[key_cols])
  if (is.unsorted(o)) {
    if (interactive()) {
      message("sorting incoming data by key columns")
    }
    df <- df[o, ]
  }

  ## reorder the full set of cols to ensure key columns are first
  ordercols <- c(key_cols, setdiff(names(df), key_cols))
  df <- df[, ordercols]
  var_labels(df) <- varlabs[ordercols]

  for (cnm in key_cols) {
    df[[cnm]] <- as_keycol(df[[cnm]])
  }

  ## key cols must be leftmost cols
  cols <- c(key_cols, setdiff(cols, key_cols))

  row_all_na <- apply(df[cols], 1, function(x) all(is.na(x)))
  if (any(row_all_na)) {
    warning("rows that only contain NA values have been trimmed")
    df <- df[!row_all_na, ]
  }

  # set col format configs
  df[cols] <- lapply(cols, function(col) {
    col_class <- tail(class(df[[col]]), 1)
    col_fmt_class <- if (!col_class %in% names(default_formatting) && is.numeric(df[[col]])) "numeric" else col_class
    col_fmt <- if (col %in% names(col_formatting)) {
      col_formatting[[col]]
    } else if (col_fmt_class %in% names(default_formatting)) {
      default_formatting[[col_fmt_class]]
    } else {
      if (!"all" %in% names(default_formatting)) {
        stop(
          "Format configurations must be supplied for all listing columns. ",
          "To cover all remaining columns please add an 'all' configuration",
          " to `default_formatting`."
        )
      }
      default_formatting[["all"]]
    }
    # ANY attr <- fmt_config slot
    obj_format(df[[col]]) <- obj_format(col_fmt)
    obj_na_str(df[[col]]) <- if (is.null(obj_na_str(col_fmt))) "NA" else obj_na_str(col_fmt)
    obj_align(df[[col]]) <- if (is.null(obj_align(col_fmt))) "left" else obj_align(col_fmt)
    df[[col]]
  })

  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
}

#' @export
#' @rdname listings
as_keycol <- function(vec) {
  if (is.factor(vec)) {
    lab <- obj_label(vec)
    vec <- as.character(vec)
    obj_label(vec) <- lab
  }
  class(vec) <- c("listing_keycol", class(vec))
  vec
}

#' @export
#' @rdname listings
is_keycol <- function(vec) {
  inherits(vec, "listing_keycol")
}

#' @export
#' @rdname listings
get_keycols <- function(df) {
  names(which(sapply(df, is_keycol)))
}

#' @inherit formatters::matrix_form
#' @param indent_rownames (`flag`)\cr silently ignored, as listings do not have row names
#'   nor indenting structure.
#' @param expand_newlines (`flag`)\cr this should always be `TRUE` for listings. We keep it
#'   for debugging reasons.
#'
#' @return a [formatters::MatrixPrintForm] object.
#'
#' @seealso [formatters::matrix_form()]
#'
#' @examples
#' lsting <- as_listing(mtcars)
#' mf <- matrix_form(lsting)
#'
#' @export
setMethod(
  "matrix_form", "listing_df",
  rix_form <- function(obj, indent_rownames = FALSE, expand_newlines = TRUE, fontspec = font_spec, col_gap = 3L) {
    ##  we intentionally silently ignore indent_rownames because listings have
    ## no rownames, but formatters::vert_pag_indices calls matrix_form(obj, TRUE)
    ## unconditionally.
    cols <- attr(obj, "listing_dispcols")
    listing <- obj[, cols]
    atts <- attributes(obj)
    atts$names <- cols
    attributes(listing) <- atts
    keycols <- get_keycols(listing)

    bodymat <- matrix("",
      nrow = nrow(listing),
      ncol = ncol(listing)
    )

    colnames(bodymat) <- names(listing)

    curkey <- ""
    for (i in seq_along(keycols)) {
      kcol <- keycols[i]
      kcolvec <- listing[[kcol]]
      kcolvec <- vapply(kcolvec, format_value, "", format = obj_format(kcolvec), na_str = obj_na_str(kcolvec))
      curkey <- paste0(curkey, kcolvec)
      disp <- c(TRUE, tail(curkey, -1) != head(curkey, -1))
      bodymat[disp, kcol] <- kcolvec[disp]
    }

    nonkeycols <- setdiff(names(listing), keycols)
    if (length(nonkeycols) > 0) {
      for (nonk in nonkeycols) {
        vec <- listing[[nonk]]
        vec <- vapply(vec, format_value, "", format = obj_format(vec), na_str = obj_na_str(vec))
        bodymat[, nonk] <- vec
      }
    }

    fullmat <- rbind(
      var_labels(listing, fill = TRUE),
      bodymat
    )

    colaligns <- rbind(
      rep("center", length(cols)),
      matrix(sapply(listing, obj_align),
        ncol = length(cols),
        nrow = nrow(fullmat) - 1,
        byrow = TRUE
      )
    )

    if (any(grepl("([{}])", fullmat))) {
      stop(
        "Labels cannot contain { or } due to their use for indicating referential footnotes.\n",
        "These are not supported at the moment in {rlistings}."
      )
    }

    MatrixPrintForm(
      strings = fullmat,
      spans = matrix(1,
        nrow = nrow(fullmat),
        ncol = ncol(fullmat)
      ),
      ref_fnotes = list(),
      aligns = colaligns,
      formats = matrix(1,
        nrow = nrow(fullmat),
        ncol = ncol(fullmat)
      ),
      listing_keycols = keycols, # It is always something
      row_info = make_row_df(obj, fontspec = fontspec),
      nlines_header = 1, # We allow only one level of headers and nl expansion happens after
      nrow_header = 1,
      has_topleft = FALSE,
      has_rowlabs = FALSE,
      expand_newlines = expand_newlines,
      main_title = main_title(obj),
      subtitles = subtitles(obj),
      page_titles = page_titles(obj),
      main_footer = main_footer(obj),
      prov_footer = prov_footer(obj),
      col_gap = col_gap,
      fontspec = fontspec,
      rep_cols = length(keycols)
    )
  }
)

#' @export
#' @rdname listings
listing_dispcols <- function(df) attr(df, "listing_dispcols") %||% character()

#' @param new (`character`)\cr vector of names of columns to be added to
#'   the set of display columns.
#'
#' @export
#' @rdname listings
add_listing_dispcol <- function(df, new) {
  listing_dispcols(df) <- c(listing_dispcols(df), new)
  df
}

#' @param value (`string`)\cr new value.
#'
#' @export
#' @rdname listings
`listing_dispcols<-` <- function(df, value) {
  if (!is.character(value)) {
    stop(
      "dispcols must be a character vector of column names, got ",
      "object of class: ", paste(class(value), collapse = ",")
    )
  }
  chk <- setdiff(value, names(df)) ## remember setdiff is not symmetrical
  if (length(chk) > 0) {
    stop(
      "listing display columns must be columns in the underlying data. ",
      "Column(s) ", paste(chk, collapse = ", "), " not present in the data."
    )
  }
  attr(df, "listing_dispcols") <- unique(value)
  df
}

#' @inheritParams formatters::fmt_config
#' @param name (`string`)\cr name of the existing or new column to be
#'   displayed when the listing is rendered.
#' @param fun (`function` or `NULL`)\cr a function which accepts `df` and
#'   returns the vector for a new column, which is added to `df` as
#'   `name`, or `NULL` if marking an existing column as a listing column.
#'
#' @return `df` with `name` created (if necessary) and marked for
#'   display during rendering.
#'
#' @export
#' @rdname listings
add_listing_col <- function(df,
                            name,
                            fun = NULL,
                            format = NULL,
                            na_str = "NA",
                            align = "left") {
  if (!is.null(fun)) {
    vec <- with_label(fun(df), name)
  } else if (name %in% names(df)) {
    vec <- df[[name]]
  } else {
    stop(
      "Column '", name, "' not found. name argument must specify an existing column when ",
      "no generating function (fun argument) is specified."
    )
  }

  if (!is.null(format)) {
    obj_format(vec) <- format
  }

  obj_na_str(vec) <- na_str
  obj_align(vec) <- align

  ## this works for both new and existing columns
  df[[name]] <- vec
  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`)\cr the listing to split.
#' @param var (`string`)\cr name of the variable to split on. If the column is a factor,
#'   the resulting list follows the order of the levels.
#' @param page_prefix (`string`)\cr 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))

  # Pre-processing in case of factor variable
  levels_or_vals <- if (is.factor(lsting[[var]])) {
    lvls <- levels(lsting[[var]])
    lvls[lvls %in% unique(lsting[[var]])] # Filter out missing values
  } else {
    unique(lsting[[var]])
  }

  # Main list creator (filters rows by var)
  lsting_by_var <- list()
  for (lvl in levels_or_vals) {
    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
}

1		#' Paginate listings
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' Pagination of a listing. This can be vertical for long listings with many
6		#' rows and/or horizontal if there are many columns. This function is a wrapper of
7		#' [formatters::paginate_to_mpfs()] and it is mainly meant for exploration and testing.
8		#'
9		#' @inheritParams formatters::pag_indices_inner
10		#' @inheritParams formatters::vert_pag_indices
11		#' @inheritParams formatters::page_lcpp
12		#' @inheritParams formatters::toString
13		#' @param lsting (`listing_df` or `list`)\cr the listing or list of listings to paginate.
14		#' @param lpp (`numeric(1)` or `NULL`)\cr number of rows/lines (excluding titles and footers)
15		#' to include per page. Standard is `70` while `NULL` disables vertical pagination.
16		#' @param cpp (`numeric(1)` or `NULL`)\cr width (in characters) of the pages for horizontal
17		#' pagination. `NULL` (the default) indicates no horizontal pagination should be done.
18		#' @param print_pages (`flag`)\cr whether the paginated listing should be printed to the console
19		#' (`cat(toString(x))`).
20		#'
21		#' @return A list of `listing_df` objects where each list element corresponds to a separate page.
22		#'
23		#' @examples
24		#' dat <- ex_adae
25		#' lsting <- as_listing(dat[1:25, ], disp_cols = c("USUBJID", "AESOC", "RACE", "AETOXGR", "BMRKR1"))
26		#' mat <- matrix_form(lsting)
27		#' cat(toString(mat))
28		#'
29		#' paginate_listing(lsting, lpp = 10)
30		#'
31		#' paginate_listing(lsting, cpp = 100, lpp = 40)
32		#'
33		#' paginate_listing(lsting, cpp = 80, lpp = 40, verbose = TRUE)
34		#'
35		#' @export
36		#' @rdname paginate
37		paginate_listing <- function(lsting,
38		page_type = "letter",
39		font_family = "Courier",
40		font_size = 8,
41		lineheight = 1,
42		landscape = FALSE,
43		pg_width = NULL,
44		pg_height = NULL,
45		margins = c(top = .5, bottom = .5, left = .75, right = .75),
46		lpp = NA_integer_,
47		cpp = NA_integer_,
48		colwidths = NULL,
49		tf_wrap = !is.null(max_width),
50		rep_cols = NULL,
51		max_width = NULL,
52		col_gap = 3,
53		fontspec = font_spec(font_family, font_size, lineheight),
54		verbose = FALSE,
55		print_pages = TRUE) {
56	24x	checkmate::assert_multi_class(lsting, c("listing_df", "list"))
57	24x	checkmate::assert_numeric(colwidths, lower = 0, len = length(listing_dispcols(lsting)), null.ok = TRUE)
58	23x	checkmate::assert_flag(tf_wrap)
59	23x	checkmate::assert_count(max_width, null.ok = TRUE)
60	23x	checkmate::assert_flag(verbose)
61	23x	checkmate::assert_flag(print_pages)
62
63	23x	pages <- paginate_to_mpfs(lsting,
64	23x	page_type = page_type,
65	23x	fontspec = fontspec,
66	23x	landscape = landscape,
67	23x	pg_width = pg_width,
68	23x	pg_height = pg_height,
69	23x	margins = margins,
70	23x	lpp = lpp,
71	23x	cpp = cpp,
72	23x	colwidths = colwidths,
73	23x	tf_wrap = tf_wrap,
74	23x	max_width = max_width,
75	23x	rep_cols = rep_cols,
76	23x	col_gap = col_gap,
77	23x	verbose = verbose
78		)
79
80	23x	if (print_pages) {
81	1x	nothing <- lapply(seq_along(pages), function(pagi) {
82	2x	cat("--- Page", paste0(pagi, "/", length(pages)), "---\n")
83		# It is NULL because paginate_mpfs takes care of it
84	2x	cat(toString(pages[[pagi]], widths = NULL, tf_wrap = tf_wrap, max_width = max_width, col_gap = col_gap))
85	2x	cat("\n")
86		})
87		}
88	23x	invisible(pages)
89		}

1
2		## XXX this historically has been 1, but it actually should be 1.2!!!!!
3		dflt_courier <- font_spec("Courier", 9, 1)
4
5		#' Methods for `listing_df` objects
6		#'
7		#' See core documentation in [formatters::formatters-package] for descriptions of these functions.
8		#'
9		#' @inheritParams formatters::toString
10		#' @param x (`listing_df`)\cr the listing.
11		#' @param ... additional parameters passed to [formatters::toString()].
12		#'
13		#' @method print listing_df
14		#'
15		#' @export
16		#' @name listing_methods
17		print.listing_df <- function(x, widths = NULL, tf_wrap = FALSE, max_width = NULL, fontspec = NULL, col_gap = 3L, ...) {
18	!	tryCatch({
19	!	cat(
20	!	toString(
21	!	matrix_form(x, fontspec = fontspec, col_gap = col_gap),
22	!	widths = widths,
23	!	tf_wrap = tf_wrap,
24	!	max_width = max_width,
25	!	fontspec = fontspec,
26	!	col_gap = col_gap,
27		...
28		)
29		)
30	!	}, error = function(e) {
31	!	if (nrow(x) == 0) {
32	!	print("No observation in the listing object.")
33		} else {
34	!	stop(e)
35		}
36		})
37	!	invisible(x)
38		}
39
40		#' @exportMethod toString
41		#' @name listing_methods
42		#' @aliases toString,listing_df-method
43		setMethod("toString", "listing_df", function(x, widths = NULL, fontspec = NULL, col_gap = 3L, ...) {
44	6x	toString(
45	6x	matrix_form(x, fontspec = fontspec, col_gap = col_gap),
46	6x	fontspec = fontspec,
47	6x	col_gap = col_gap,
48	6x	widths = widths,
49		...
50		)
51		})
52
53		## because rle in base is too much of a stickler for being atomic
54		basic_run_lens <- function(x) {
55	170x	n <- length(x)
56	170x	if (n == 0) {
57	!	return(integer())
58		}
59
60	170x	y <- x[-1L] != x[-n]
61	170x	i <- c(which(y), n)
62	170x	diff(c(0L, i))
63		}
64
65		#' @param df (`listing_df`)\cr the listing.
66		#' @param colnm (`string`)\cr column name.
67		#' @param colvec (`vector`)\cr column values based on `colnm`.
68		#'
69		#' @rdname vec_nlines
70		#' @keywords internal
71		format_colvector <- function(df, colnm, colvec = df[[colnm]]) {
72	702x	if (missing(colvec) && !(colnm %in% names(df))) {
73	!	stop("column ", colnm, " not found")
74		}
75	702x	na_str <- obj_na_str(colvec)
76	702x	if (is.null(na_str) \|\| all(is.na(na_str))) {
77	!	na_str <- rep("-", max(1L, length(na_str)))
78		}
79
80	702x	strvec <- vapply(colvec, format_value, "", format = obj_format(colvec), na_str = na_str)
81	702x	strvec
82		}
83
84		#' Utilities for formatting a listing column
85		#'
86		#' For `vec_nlines`, calculate the number of lines each element of a column vector will
87		#' take to render. For `format_colvector`,
88		#'
89		#' @param vec (`vector`)\cr a column vector to be rendered into ASCII.
90		#' @param max_width (`numeric(1)` or `NULL`)\cr the width to render the column with.
91		#' @return (`numeric`)\cr a vector of the number of lines element-wise that will be
92		#' needed to render the elements of `vec` to width `max_width`.
93		#'
94		#' @keywords internal
95	702x	setGeneric("vec_nlines", function(vec, max_width = NULL, fontspec = dflt_courier) standardGeneric("vec_nlines"))
96
97		#' @param vec (`vector`)\cr a vector.
98		#'
99		#' @rdname vec_nlines
100		#' @keywords internal
101		setMethod("vec_nlines", "ANY", function(vec, max_width = NULL, fontspec = dflt_courier) {
102	702x	if (is.null(max_width)) {
103	702x	max_width <- floor(0.9 * getOption("width")) # default of base::strwrap
104		# NB: flooring as it is used as <= (also in base::strwrap)
105		}
106		# in formatters for characters
107	702x	unlist(lapply(format_colvector(colvec = vec), nlines, max_width = max_width, fontspec = fontspec))
108		})
109
110		## setMethod("vec_nlines", "character", function(vec, max_width = NULL) {
111		## strvec <- wrap_txt(format_colvector(colvec = vec), width = max_width, collapse = "\n")
112		## mtchs <- gregexpr("\n", strvec, fixed = TRUE)
113		## 1L + vapply(mtchs, function(vi) sum(vi > 0), 1L)
114		## })
115
116		## setMethod("vec_nlines", "factor", function(vec, max_width = NULL) {
117		## lvl_nlines <- vec_nlines(levels(vec), max_width = max_width)
118		## ret <- lvl_nlines[vec]
119		## ret[is.na(ret)] <- format_value(NA_character
120		## })
121
122		#' Make pagination data frame for a listing
123		#'
124		#' @inheritParams formatters::make_row_df
125		#' @param tt (`listing_df`)\cr the listing to be rendered.
126		#' @param visible_only (`flag`)\cr ignored, as listings do not have
127		#' non-visible structural elements.
128		#'
129		#' @return a `data.frame` with pagination information.
130		#'
131		#' @seealso [formatters::make_row_df()]
132		#'
133		#' @examples
134		#' lsting <- as_listing(mtcars)
135		#' mf <- matrix_form(lsting)
136		#'
137		#' @export
138		setMethod(
139		"make_row_df", "listing_df",
140		function(tt, colwidths = NULL, visible_only = TRUE,
141		rownum = 0,
142		indent = 0L,
143		path = character(),
144		incontent = FALSE,
145		repr_ext = 0L,
146		repr_inds = integer(),
147		sibpos = NA_integer_,
148		nsibs = NA_integer_,
149		fontspec = dflt_courier) {
150		## assume sortedness by keycols
151	171x	keycols <- get_keycols(tt)
152	171x	dispcols <- listing_dispcols(tt)
153	171x	abs_rownumber <- seq_along(tt[[1]])
154	171x	if (length(keycols) >= 1) {
155	170x	runlens <- basic_run_lens(tt[[tail(keycols, 1)]])
156		} else {
157	1x	runlens <- rep(1, NROW(tt))
158		}
159	171x	sibpos <- unlist(lapply(runlens, seq_len))
160	171x	nsibs <- rep(runlens, times = runlens)
161	171x	extents <- rep(1L, nrow(tt))
162	171x	if (length(colwidths) > 0 && length(colwidths) != length(dispcols)) {
163	!	stop(
164	!	"Non-null colwidths vector must be the same length as the number of display columns.\n",
165	!	"Got: ", length(colwidths), "(", length(dispcols), " disp cols)."
166		)
167		}
168	171x	if (length(colwidths) > 0) {
169	!	names(colwidths) <- dispcols
170		}
171		## extents is a row-wise vector of extents, for each col, we update
172		## if that column has any rows wider than the previously recorded extent.
173	171x	for (col in dispcols) {
174		## duplicated from matrix_form method, refactor!
175	702x	col_ext <- vec_nlines(tt[[col]], max_width = colwidths[col], fontspec = fontspec)
176	702x	extents <- ifelse(col_ext > extents, col_ext, extents)
177		}
178	171x	ret <- data.frame(
179	171x	label = "", name = "",
180	171x	abs_rownumber = abs_rownumber,
181	171x	path = I(as.list(rep(NA_character_, NROW(tt)))),
182	171x	pos_in_siblings = sibpos,
183	171x	n_siblings = nsibs,
184	171x	self_extent = extents,
185	171x	par_extent = 0L,
186	171x	reprint_inds = I(replicate(NROW(tt), list(integer()))),
187	171x	node_class = "listing_df",
188	171x	indent = 0L,
189	171x	nrowrefs = 0L, ## XXX this doesn't support footnotes
190	171x	ncellrefs = 0L, ## XXX this doesn't support footnotes
191	171x	nreflines = 0L, ## XXX this doesn't support footnotes
192	171x	force_page = FALSE,
193	171x	page_title = NA_character_,
194	171x	trailing_sep = NA_character_
195		)
196	171x	stopifnot(identical(
197	171x	names(ret),
198	171x	names(pagdfrow(
199	171x	nm = "", lab = "", rnum = 1L, pth = NA_character_, extent = 1L,
200	171x	rclass = ""
201		))
202		))
203	171x	ret
204		}
205		)
206
207		## tt$sibpos <- unlist(lapply(
208		## ## don't support pathing for now
209		## tt$path <- I(lapply(1:NROW(tt),
210		## function(i) {
211		## retpath <- character(2*length(keycols))
212		## for(j in seq_along(keycols)) {
213		## retpath[2*j - 1] <- keycols[j]
214		## retpath[2*j] <- tt[i, keycols[j], drop = TRUE]
215		## }
216		## retpath
217		## }))
218		## spl <- split(tt, tt[keycols])
219		## spl <- spl[vapply(spl, function(y) NROW(y) > 0, NA)]
220		## dfs <- lapply(spl, function(df) {
221		## df <- df[order(df$abs_rownumber),]
222		## ndf <- NROW(df)
223		## lapply(1:ndf, function(i) {
224		## rw <- df[i,]
225		## stopifnot(nrow(rw) == 1)
226		## pagdfrow(nm = "",
227		## lab = "",
228		## rnum = rw$abs_rownumber,
229		## pth = NA_character_,
230		## sibpos = i,
231		## nsibs = ndf,
232		## extent = 1L,
233		## rclass = "listing_df",
234		## repind = integer())
235		## })
236		## })
237		## ret <- do.call(rbind, unlist(dfs, recursive = FALSE))
238		## ret <- ret[order(ret$abs_rownumber),]
239		## ret
240		## })
241
242		#' @inheritParams base::Extract
243		#' @param x (`listing_df`)\cr the listing.
244		#' @param i (`any`)\cr object passed to base `[` methods.
245		#' @param j (`any`)\cr object passed to base `[` methods.
246		#'
247		#' @export
248		#' @aliases [,listing_df-method
249		#' @rdname listing_methods
250		setMethod(
251		"[", "listing_df",
252		function(x, i, j, drop = FALSE) {
253	!	xattr <- attributes(x)
254	!	xattr$names <- xattr$names[j]
255	!	res <- NextMethod()
256	!	if (!drop) {
257	!	attributes(res) <- xattr
258		}
259	!	res
260		}
261		)
262
263		#' @rdname listing_methods
264		#' @param obj (`listing_df`)\cr the listing.
265		#'
266		#' @return
267		#' * Accessor methods return the value of the aspect of `obj`.
268		#' * Setter methods return `obj` with the relevant element of the listing updated.
269		#'
270		#' @examples
271		#' lsting <- as_listing(mtcars)
272		#' main_title(lsting) <- "Hi there"
273		#'
274		#' main_title(lsting)
275		#'
276		#' @export
277		setMethod(
278		"main_title", "listing_df",
279	173x	function(obj) attr(obj, "main_title") %\|\|% character()
280		)
281
282		#' @rdname listing_methods
283		#' @export
284		setMethod(
285		"subtitles", "listing_df",
286	183x	function(obj) attr(obj, "subtitles") %\|\|% character()
287		)
288
289		#' @rdname listing_methods
290		#' @export
291		setMethod(
292		"main_footer", "listing_df",
293	172x	function(obj) attr(obj, "main_footer") %\|\|% character()
294		)
295
296		#' @rdname listing_methods
297		#' @export
298		setMethod(
299		"prov_footer", "listing_df",
300	172x	function(obj) attr(obj, "prov_footer") %\|\|% character()
301		)
302
303		.chk_value <- function(val, fname, len_one = FALSE, null_ok = TRUE) {
304	254x	if (null_ok && is.null(val)) {
305	209x	return(TRUE)
306		}
307	45x	if (!is.character(val)) {
308	4x	stop("value for ", fname, " must be a character, got ",
309	4x	"object of class: ", paste(class(val), collapse = ","),
310	4x	call. = FALSE
311		)
312		}
313	41x	if (len_one && length(val) > 1) {
314	1x	stop(
315	1x	"value for ", fname, " must be length <= 1, got ",
316	1x	"vector of length ", length(val)
317		)
318		}
319	40x	TRUE
320		}
321
322		#' @rdname listing_methods
323		#' @export
324		setMethod(
325		"main_title<-", "listing_df",
326		function(obj, value) {
327		## length 1 restriction is to match rtables behavior
328		## which currently enforces this (though incompletely)
329	63x	.chk_value(value, "main_title", len_one = TRUE)
330	61x	attr(obj, "main_title") <- value
331	61x	obj
332		}
333		)
334
335		#' @rdname listing_methods
336		#' @export
337		setMethod(
338		"subtitles<-", "listing_df",
339		function(obj, value) {
340	70x	.chk_value(value, "subtitles")
341	69x	attr(obj, "subtitles") <- value
342	69x	obj
343		}
344		)
345
346		#' @rdname listing_methods
347		#' @export
348		setMethod(
349		"main_footer<-", "listing_df",
350		function(obj, value) {
351	61x	.chk_value(value, "main_footer")
352	60x	attr(obj, "main_footer") <- value
353	60x	obj
354		}
355		)
356
357		#' @rdname listing_methods
358		#' @export
359		setMethod(
360		"prov_footer<-", "listing_df",
361		function(obj, value) {
362	60x	.chk_value(value, "prov_footer")
363	59x	attr(obj, "prov_footer") <- value
364	59x	obj
365		}
366		)
367
368		#' @rdname listing_methods
369		#' @export
370		setMethod(
371		"num_rep_cols", "listing_df",
372		function(obj) {
373	93x	length(get_keycols(obj))
374		}
375		)

1		setOldClass(c("listing_df", "tbl_df", "tbl", "data.frame"))
2		setOldClass(c("MatrixPrintForm", "list"))
3
4		#' Create a listing from a `data.frame` or `tibble`
5		#'
6		#' @description `r lifecycle::badge("experimental")`
7		#'
8		#' Create listings displaying `key_cols` and `disp_cols` to produce a compact and
9		#' elegant representation of the input `data.frame` or `tibble`.
10		#'
11		#' @param df (`data.frame` or `listing_df`)\cr the `data.frame` to be converted to a listing or
12		#' `listing_df` to be modified.
13		#' @param key_cols (`character`)\cr vector of names of columns which should be treated as key columns
14		#' when rendering the listing. Key columns allow you to group repeat occurrences.
15		#' @param disp_cols (`character` or `NULL`)\cr vector of names of non-key columns which should be
16		#' displayed when the listing is rendered. Defaults to all columns of `df` not named in `key_cols` or
17		#' `non_disp_cols`.
18		#' @param non_disp_cols (`character` or `NULL`)\cr vector of names of non-key columns to be excluded as display
19		#' columns. All other non-key columns are treated as display columns. Ignored if `disp_cols` is non-`NULL`.
20		#' @param unique_rows (`flag`)\cr whether only unique rows should be included in the listing. Defaults to `FALSE`.
21		#' @param default_formatting (`list`)\cr a named list of default column format configurations to apply when rendering
22		#' the listing. Each name-value pair consists of a name corresponding to a data class (or "numeric" for all
23		#' unspecified numeric classes) and a value of type `fmt_config` with the format configuration that should be
24		#' implemented for columns of that class. If named element "all" is included in the list, this configuration will be
25		#' used for all data classes not specified. Objects of type `fmt_config` can take 3 arguments: `format`, `na_str`,
26		#' and `align`.
27		#' @param col_formatting (`list`)\cr a named list of custom column formatting configurations to apply to specific
28		#' columns when rendering the listing. Each name-value pair consists of a name corresponding to a column name and a
29		#' value of type `fmt_config` with the formatting configuration that should be implemented for that column. Objects
30		#' of type `fmt_config` can take 3 arguments: `format`, `na_str`, and `align`. Defaults to `NULL`.
31		#' @param main_title (`string` or `NULL`)\cr the main title for the listing, or `NULL` (the default).
32		#' @param subtitles (`character` or `NULL`)\cr a vector of subtitles for the listing, or `NULL` (the default).
33		#' @param main_footer (`character` or `NULL`)\cr a vector of main footer lines for the listing, or `NULL` (the default).
34		#' @param prov_footer (`character` or `NULL`)\cr a vector of provenance footer lines for the listing, or `NULL`
35		#' (the default). Each string element is placed on a new line.
36		#' @param split_into_pages_by_var (`character` or `NULL`)\cr the name of a variable for on the listing should be split
37		#' into pages, with each page corresponding to one unique value/level of the variable. See
38		#' [split_into_pages_by_var()] for more details.
39		#' @param vec (`string`)\cr name of a column vector from a `listing_df` object to be annotated as a key column.
40		#'
41		#' @return A `listing_df` object, sorted by its key columns.
42		#'
43		#' @details
44		#' At its core, a `listing_df` object is a `tbl_df` object with a customized
45		#' print method and support for the formatting and pagination machinery provided by
46		#' the `formatters` package.
47		#'
48		#' `listing_df` objects have two 'special' types of columns: key columns and display columns.
49		#'
50		#' Key columns act as indexes, which means a number of things in practice.
51		#'
52		#' All key columns are also display columns.
53		#'
54		#' `listing_df` objects are always sorted by their set of key columns at creation time.
55		#' Any `listing_df` object which is not sorted by its full set of key columns (e.g.,
56		#' one whose rows have been reordered explicitly during creation) is invalid and the behavior
57		#' when rendering or paginating that object is undefined.
58		#'
59		#' Each value of a key column is printed only once per page and per unique combination of
60		#' values for all higher-priority (i.e., to the left of it) key columns. Locations
61		#' where a repeated value would have been printed within a key column for the same
62		#' higher-priority-key combination on the same page are rendered as empty space.
63		#' Note, determination of which elements to display within a key column at rendering is
64		#' based on the underlying value; any non-default formatting applied to the column
65		#' has no effect on this behavior.
66		#'
67		#' Display columns are columns which should be rendered, but are not key columns. By
68		#' default this is all non-key columns in the incoming data, but in need not be.
69		#' Columns in the underlying data which are neither key nor display columns remain
70		#' within the object available for computations but *are not rendered during
71		#' printing or export of the listing*.
72		#'
73		#' @examples
74		#' dat <- ex_adae
75		#'
76		#' # This example demonstrates the listing with key_cols (values are grouped by USUBJID) and
77		#' # multiple lines in prov_footer
78		#' lsting <- as_listing(dat[1:25, ],
79		#' key_cols = c("USUBJID", "AESOC"),
80		#' main_title = "Example Title for Listing",
81		#' subtitles = "This is the subtitle for this Adverse Events Table",
82		#' main_footer = "Main footer for the listing",
83		#' prov_footer = c(
84		#' "You can even add a subfooter", "Second element is place on a new line",
85		#' "Third string"
86		#' )
87		#' ) %>%
88		#' add_listing_col("AETOXGR") %>%
89		#' add_listing_col("BMRKR1", format = "xx.x") %>%
90		#' add_listing_col("AESER / AREL", fun = function(df) paste(df$AESER, df$AREL, sep = " / "))
91		#'
92		#' mat <- matrix_form(lsting)
93		#'
94		#' cat(toString(mat))
95		#'
96		#' # This example demonstrates the listing table without key_cols
97		#' # and specifying the cols with disp_cols.
98		#' dat <- ex_adae
99		#' lsting <- as_listing(dat[1:25, ],
100		#' disp_cols = c("USUBJID", "AESOC", "RACE", "AETOXGR", "BMRKR1")
101		#' )
102		#'
103		#' mat <- matrix_form(lsting)
104		#'
105		#' cat(toString(mat))
106		#'
107		#' # This example demonstrates a listing with format configurations specified
108		#' # via the default_formatting and col_formatting arguments
109		#' dat <- ex_adae
110		#' dat$AENDY[3:6] <- NA
111		#' lsting <- as_listing(dat[1:25, ],
112		#' key_cols = c("USUBJID", "AESOC"),
113		#' disp_cols = c("STUDYID", "SEX", "ASEQ", "RANDDT", "ASTDY", "AENDY"),
114		#' default_formatting = list(
115		#' all = fmt_config(align = "left"),
116		#' numeric = fmt_config(
117		#' format = "xx.xx",
118		#' na_str = "<No data>",
119		#' align = "right"
120		#' )
121		#' )
122		#' ) %>%
123		#' add_listing_col("BMRKR1", format = "xx.x", align = "center")
124		#'
125		#' mat <- matrix_form(lsting)
126		#'
127		#' cat(toString(mat))
128		#'
129		#' @export
130		#' @rdname listings
131		as_listing <- function(df,
132		key_cols = names(df)[1],
133		disp_cols = NULL,
134		non_disp_cols = NULL,
135		unique_rows = FALSE,
136		default_formatting = list(all = fmt_config()),
137		col_formatting = NULL,
138		main_title = NULL,
139		subtitles = NULL,
140		main_footer = NULL,
141		prov_footer = NULL,
142		split_into_pages_by_var = NULL) {
143	64x	if (length(non_disp_cols) > 0 && length(intersect(key_cols, non_disp_cols)) > 0) {
144	1x	stop(
145	1x	"Key column also listed in non_disp_cols. All key columns are by",
146	1x	" definition display columns."
147		)
148		}
149	63x	if (!is.null(disp_cols) && !is.null(non_disp_cols)) {
150	1x	stop("Got non-null values for both disp_cols and non_disp_cols. This is not supported.")
151	62x	} else if (is.null(disp_cols)) {
152		## non_disp_cols NULL is ok here
153	27x	cols <- setdiff(names(df), c(key_cols, non_disp_cols))
154		} else {
155		## disp_cols non-null, non_disp_cols NULL
156	35x	cols <- disp_cols
157		}
158	62x	if (!all(sapply(default_formatting, is, class2 = "fmt_config"))) {
159	1x	stop(
160	1x	"All format configurations supplied in `default_formatting`",
161	1x	" must be of type `fmt_config`."
162		)
163		}
164	61x	if (!(is.null(col_formatting) \|\| all(sapply(col_formatting, is, class2 = "fmt_config")))) {
165	2x	stop(
166	2x	"All format configurations supplied in `col_formatting`",
167	2x	" must be of type `fmt_config`."
168		)
169		}
170
171	59x	if (any(sapply(df, inherits, "difftime"))) {
172	1x	stop("One or more variables in the dataframe have class 'difftime'. Please convert to factor or character.")
173		}
174
175	58x	df <- as_tibble(df)
176	58x	varlabs <- var_labels(df, fill = TRUE)
177	58x	o <- do.call(order, df[key_cols])
178	58x	if (is.unsorted(o)) {
179	29x	if (interactive()) {
180	!	message("sorting incoming data by key columns")
181		}
182	29x	df <- df[o, ]
183		}
184
185		## reorder the full set of cols to ensure key columns are first
186	58x	ordercols <- c(key_cols, setdiff(names(df), key_cols))
187	58x	df <- df[, ordercols]
188	58x	var_labels(df) <- varlabs[ordercols]
189
190	58x	for (cnm in key_cols) {
191	89x	df[[cnm]] <- as_keycol(df[[cnm]])
192		}
193
194		## key cols must be leftmost cols
195	58x	cols <- c(key_cols, setdiff(cols, key_cols))
196
197	58x	row_all_na <- apply(df[cols], 1, function(x) all(is.na(x)))
198	58x	if (any(row_all_na)) {
199	1x	warning("rows that only contain NA values have been trimmed")
200	1x	df <- df[!row_all_na, ]
201		}
202
203		# set col format configs
204	58x	df[cols] <- lapply(cols, function(col) {
205	291x	col_class <- tail(class(df[[col]]), 1)
206	291x	col_fmt_class <- if (!col_class %in% names(default_formatting) && is.numeric(df[[col]])) "numeric" else col_class
207	291x	col_fmt <- if (col %in% names(col_formatting)) {
208	7x	col_formatting[[col]]
209	291x	} else if (col_fmt_class %in% names(default_formatting)) {
210	6x	default_formatting[[col_fmt_class]]
211		} else {
212	278x	if (!"all" %in% names(default_formatting)) {
213	1x	stop(
214	1x	"Format configurations must be supplied for all listing columns. ",
215	1x	"To cover all remaining columns please add an 'all' configuration",
216	1x	" to `default_formatting`."
217		)
218		}
219	277x	default_formatting[["all"]]
220		}
221		# ANY attr <- fmt_config slot
222	290x	obj_format(df[[col]]) <- obj_format(col_fmt)
223	290x	obj_na_str(df[[col]]) <- if (is.null(obj_na_str(col_fmt))) "NA" else obj_na_str(col_fmt)
224	290x	obj_align(df[[col]]) <- if (is.null(obj_align(col_fmt))) "left" else obj_align(col_fmt)
225	290x	df[[col]]
226		})
227
228	3x	if (unique_rows) df <- df[!duplicated(df[, cols]), ]
229
230	57x	class(df) <- c("listing_df", class(df))
231
232		## these all work even when the value is NULL
233	57x	main_title(df) <- main_title
234	57x	main_footer(df) <- main_footer
235	57x	subtitles(df) <- subtitles
236	57x	prov_footer(df) <- prov_footer
237	57x	listing_dispcols(df) <- cols
238
239	57x	if (!is.null(split_into_pages_by_var)) {
240	1x	df <- split_into_pages_by_var(df, split_into_pages_by_var)
241		}
242
243	57x	df
244		}
245
246		#' @export
247		#' @rdname listings
248		as_keycol <- function(vec) {
249	89x	if (is.factor(vec)) {
250	17x	lab <- obj_label(vec)
251	17x	vec <- as.character(vec)
252	17x	obj_label(vec) <- lab
253		}
254	89x	class(vec) <- c("listing_keycol", class(vec))
255	89x	vec
256		}
257
258		#' @export
259		#' @rdname listings
260		is_keycol <- function(vec) {
261	8111x	inherits(vec, "listing_keycol")
262		}
263
264		#' @export
265		#' @rdname listings
266		get_keycols <- function(df) {
267	436x	names(which(sapply(df, is_keycol)))
268		}
269
270		#' @inherit formatters::matrix_form
271		#' @param indent_rownames (`flag`)\cr silently ignored, as listings do not have row names
272		#' nor indenting structure.
273		#' @param expand_newlines (`flag`)\cr this should always be `TRUE` for listings. We keep it
274		#' for debugging reasons.
275		#'
276		#' @return a [formatters::MatrixPrintForm] object.
277		#'
278		#' @seealso [formatters::matrix_form()]
279		#'
280		#' @examples
281		#' lsting <- as_listing(mtcars)
282		#' mf <- matrix_form(lsting)
283		#'
284		#' @export
285		setMethod(
286		"matrix_form", "listing_df",
287		rix_form <- function(obj, indent_rownames = FALSE, expand_newlines = TRUE, fontspec = font_spec, col_gap = 3L) {
288		## we intentionally silently ignore indent_rownames because listings have
289		## no rownames, but formatters::vert_pag_indices calls matrix_form(obj, TRUE)
290		## unconditionally.
291	171x	cols <- attr(obj, "listing_dispcols")
292	171x	listing <- obj[, cols]
293	171x	atts <- attributes(obj)
294	171x	atts$names <- cols
295	171x	attributes(listing) <- atts
296	171x	keycols <- get_keycols(listing)
297
298	171x	bodymat <- matrix("",
299	171x	nrow = nrow(listing),
300	171x	ncol = ncol(listing)
301		)
302
303	171x	colnames(bodymat) <- names(listing)
304
305	171x	curkey <- ""
306	171x	for (i in seq_along(keycols)) {
307	257x	kcol <- keycols[i]
308	257x	kcolvec <- listing[[kcol]]
309	257x	kcolvec <- vapply(kcolvec, format_value, "", format = obj_format(kcolvec), na_str = obj_na_str(kcolvec))
310	257x	curkey <- paste0(curkey, kcolvec)
311	257x	disp <- c(TRUE, tail(curkey, -1) != head(curkey, -1))
312	257x	bodymat[disp, kcol] <- kcolvec[disp]
313		}
314
315	171x	nonkeycols <- setdiff(names(listing), keycols)
316	171x	if (length(nonkeycols) > 0) {
317	164x	for (nonk in nonkeycols) {
318	446x	vec <- listing[[nonk]]
319	446x	vec <- vapply(vec, format_value, "", format = obj_format(vec), na_str = obj_na_str(vec))
320	446x	bodymat[, nonk] <- vec
321		}
322		}
323
324	171x	fullmat <- rbind(
325	171x	var_labels(listing, fill = TRUE),
326	171x	bodymat
327		)
328
329	171x	colaligns <- rbind(
330	171x	rep("center", length(cols)),
331	171x	matrix(sapply(listing, obj_align),
332	171x	ncol = length(cols),
333	171x	nrow = nrow(fullmat) - 1,
334	171x	byrow = TRUE
335		)
336		)
337
338	171x	if (any(grepl("([{}])", fullmat))) {
339	1x	stop(
340	1x	"Labels cannot contain { or } due to their use for indicating referential footnotes.\n",
341	1x	"These are not supported at the moment in {rlistings}."
342		)
343		}
344
345	170x	MatrixPrintForm(
346	170x	strings = fullmat,
347	170x	spans = matrix(1,
348	170x	nrow = nrow(fullmat),
349	170x	ncol = ncol(fullmat)
350		),
351	170x	ref_fnotes = list(),
352	170x	aligns = colaligns,
353	170x	formats = matrix(1,
354	170x	nrow = nrow(fullmat),
355	170x	ncol = ncol(fullmat)
356		),
357	170x	listing_keycols = keycols, # It is always something
358	170x	row_info = make_row_df(obj, fontspec = fontspec),
359	170x	nlines_header = 1, # We allow only one level of headers and nl expansion happens after
360	170x	nrow_header = 1,
361	170x	has_topleft = FALSE,
362	170x	has_rowlabs = FALSE,
363	170x	expand_newlines = expand_newlines,
364	170x	main_title = main_title(obj),
365	170x	subtitles = subtitles(obj),
366	170x	page_titles = page_titles(obj),
367	170x	main_footer = main_footer(obj),
368	170x	prov_footer = prov_footer(obj),
369	170x	col_gap = col_gap,
370	170x	fontspec = fontspec,
371	170x	rep_cols = length(keycols)
372		)
373		}
374		)
375
376		#' @export
377		#' @rdname listings
378	218x	listing_dispcols <- function(df) attr(df, "listing_dispcols") %\|\|% character()
379
380		#' @param new (`character`)\cr vector of names of columns to be added to
381		#' the set of display columns.
382		#'
383		#' @export
384		#' @rdname listings
385		add_listing_dispcol <- function(df, new) {
386	21x	listing_dispcols(df) <- c(listing_dispcols(df), new)
387	21x	df
388		}
389
390		#' @param value (`string`)\cr new value.
391		#'
392		#' @export
393		#' @rdname listings
394		`listing_dispcols<-` <- function(df, value) {
395	78x	if (!is.character(value)) {
396	!	stop(
397	!	"dispcols must be a character vector of column names, got ",
398	!	"object of class: ", paste(class(value), collapse = ",")
399		)
400		}
401	78x	chk <- setdiff(value, names(df)) ## remember setdiff is not symmetrical
402	78x	if (length(chk) > 0) {
403	!	stop(
404	!	"listing display columns must be columns in the underlying data. ",
405	!	"Column(s) ", paste(chk, collapse = ", "), " not present in the data."
406		)
407		}
408	78x	attr(df, "listing_dispcols") <- unique(value)
409	78x	df
410		}
411
412		#' @inheritParams formatters::fmt_config
413		#' @param name (`string`)\cr name of the existing or new column to be
414		#' displayed when the listing is rendered.
415		#' @param fun (`function` or `NULL`)\cr a function which accepts `df` and
416		#' returns the vector for a new column, which is added to `df` as
417		#' `name`, or `NULL` if marking an existing column as a listing column.
418		#'
419		#' @return `df` with `name` created (if necessary) and marked for
420		#' display during rendering.
421		#'
422		#' @export
423		#' @rdname listings
424		add_listing_col <- function(df,
425		name,
426		fun = NULL,
427		format = NULL,
428		na_str = "NA",
429		align = "left") {
430	21x	if (!is.null(fun)) {
431	1x	vec <- with_label(fun(df), name)
432	20x	} else if (name %in% names(df)) {
433	20x	vec <- df[[name]]
434		} else {
435	!	stop(
436	!	"Column '", name, "' not found. name argument must specify an existing column when ",
437	!	"no generating function (fun argument) is specified."
438		)
439		}
440
441	21x	if (!is.null(format)) {
442	10x	obj_format(vec) <- format
443		}
444
445	21x	obj_na_str(vec) <- na_str
446	21x	obj_align(vec) <- align
447
448		## this works for both new and existing columns
449	21x	df[[name]] <- vec
450	21x	df <- add_listing_dispcol(df, name)
451	21x	df
452		}
453
454		#' Split Listing by Values of a Variable
455		#'
456		#' @description `r lifecycle::badge("experimental")`
457		#'
458		#' Split is performed based on unique values of the given parameter present in the listing.
459		#' Each listing can only be split by variable once. If this function is applied prior to
460		#' pagination, parameter values will be separated by page.
461		#'
462		#' @param lsting (`listing_df`)\cr the listing to split.
463		#' @param var (`string`)\cr name of the variable to split on. If the column is a factor,
464		#' the resulting list follows the order of the levels.
465		#' @param page_prefix (`string`)\cr prefix to be appended with the split value (`var` level),
466		#' at the end of the subtitles, corresponding to each resulting list element (listing).
467		#'
468		#' @return A list of `lsting_df` objects each corresponding to a unique value of `var`.
469		#'
470		#' @note This function should only be used after the complete listing has been created. The
471		#' listing cannot be modified further after applying this function.
472		#'
473		#' @examples
474		#' dat <- ex_adae[1:20, ]
475		#'
476		#' lsting <- as_listing(
477		#' dat,
478		#' key_cols = c("USUBJID", "AGE"),
479		#' disp_cols = "SEX",
480		#' main_title = "title",
481		#' main_footer = "footer"
482		#' ) %>%
483		#' add_listing_col("BMRKR1", format = "xx.x") %>%
484		#' split_into_pages_by_var("SEX")
485		#'
486		#' lsting
487		#'
488		#' @export
489		split_into_pages_by_var <- function(lsting, var, page_prefix = var) {
490	6x	checkmate::assert_class(lsting, "listing_df")
491	5x	checkmate::assert_choice(var, names(lsting))
492
493		# Pre-processing in case of factor variable
494	5x	levels_or_vals <- if (is.factor(lsting[[var]])) {
495	5x	lvls <- levels(lsting[[var]])
496	5x	lvls[lvls %in% unique(lsting[[var]])] # Filter out missing values
497		} else {
498	!	unique(lsting[[var]])
499		}
500
501		# Main list creator (filters rows by var)
502	5x	lsting_by_var <- list()
503	5x	for (lvl in levels_or_vals) {
504	10x	var_desc <- paste0(page_prefix, ": ", lvl)
505	10x	lsting_by_var[[lvl]] <- lsting[lsting[[var]] == lvl, ]
506	10x	subtitles(lsting_by_var[[lvl]]) <- c(subtitles(lsting), var_desc)
507		}
508
509	5x	lsting_by_var
510		}