rlistings coverage - 88.60%

Files
Source

## #' Print a listing to the terminal
## #' @param x listing_df. the listing
## #' @param ... ANY. unused
## #' @return prints the listing object to the screen and silently returns the object
## #' @export
## setMethod("print", "listing_df",
##           function(x, ...) {
##     cat(toString(listing_matrix_form(x)))
##     invisible(x)
## })

#' Methods for `listing_df` objects
#'
#' See core documentation in \code{formatters} for descriptions
#' of these functions.
#'
#' @export
#' @inheritParams formatters::toString
#' @param x listing_df. The listing.
#' @param ... dots. See `toString` method in \code{formatters} for all parameters.
#' @method print listing_df
#' @name listing_methods
print.listing_df <- function(x, widths = NULL, tf_wrap = FALSE, max_width = NULL, ...) {
  cat(toString(matrix_form(x), widths = widths, tf_wrap = tf_wrap, max_width = max_width, ...))
  invisible(x)
}

#' @exportMethod toString
#' @name listing_methods
#' @aliases toString,listing_df-method
setMethod("toString", "listing_df", function(x, ...) {
  toString(matrix_form(x), ...)
})

## 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))
}


#' @rdname vec_nlines
#' @param df listing_df. The listing.
#' @param colnm Column name
#' @param colvec Column values based on colnm
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 any vector. A column vector to be rendered into ASCII.
#' @param max_width numeric (or NULL). The width the column will be
#' rendered in.
#' @return a numeric vector of the number of lines elementwise that
#' will be needed to render the elements of \code{vec} to width
#' \code{max_width}.
#' @keywords internal
setGeneric("vec_nlines", function(vec, max_width = NULL) standardGeneric("vec_nlines"))

#' @rdname vec_nlines
#' @param vec A vector.
#' @keywords internal
setMethod("vec_nlines", "ANY", function(vec, max_width = NULL) {
  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))
})

## 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 dataframe for a listing
#' @export
#' @inheritParams formatters::make_row_df
#' @param tt listing_df. The listing to be rendered
#' @param visible_only logical(1). Ignored, as listings
#' do not have non-visible structural elements.
#'
#' @examples
#' lsting <- as_listing(mtcars)
#' mf <- matrix_form(lsting)
#'
#' @return a data.frame with pagination information.
#' @seealso \code{\link[formatters]{make_row_df}}
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_) {
    ## 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])
      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
## })

#' @export
#' @param x listing_df. The listing.
#' @inheritParams base::Extract
#' @param i ANY. Passed to base `[` methods.
#' @param j ANY. Passed to base `[` methods.
#' @aliases [,listing_df-method
#' @rdname listing_methods
#' @keywords internal
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 The object.
#' @export
#' @return for getter methods, the value of the aspect of
#' \code{obj}; for setter methods, \code{obj} with
#' the relevant element of the listing updated.
#'
#' @examples
#'
#' lsting <- as_listing(mtcars)
#' main_title(lsting) <- "Hi there"
#'
#' main_title(lsting)
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"))

#' @rdname listings
#' @title Create a Listing from a `data.frame` or `tibble`
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Creates listings by using `cols` and `key_cols` to produce a compact and
#' elegant representation of the `data.frame` or `tibble` in input.
#'
#' @param df data.frame or listing_df. The (non-listing) data.frame to be converted to a listing or
#'   the listing_df to be modified.
#' @param key_cols character. 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. 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. Names of non-key columns to be excluded as display
#'   columns. All other non-key columns are then treated as display columns. Invalid if
#'   `disp_cols` is non-NULL.
#' @param unique_rows logical(1). Should only unique rows be included in the listing. Defaults to `FALSE`.
#' @param default_formatting list. 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. 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 character(1) or NULL. The main title for the listing, or
#'   `NULL` (the default). Must be length 1 non-NULL.
#' @param subtitles character or NULL. A vector of subtitle(s) for the
#'   listing, or `NULL` (the default).
#' @param main_footer character or NULL. A vector of main footer lines
#'   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 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.
#'
#' @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 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
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) {
  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`.")
  }

  df <- as_tibble(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")
    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)) {
    message("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
  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)))
}

#' @export
#' @inherit formatters::matrix_form
#' @seealso [formatters::matrix_form()]
#' @param indent_rownames logical(1). Silently ignored, as listings do not have row names
#' nor indenting structure.
#'
#' @examples
#'
#' lsting <- as_listing(mtcars)
#' mf <- matrix_form(lsting)
#'
#' @return a `MatrixPrintForm` object
setMethod(
  "matrix_form", "listing_df",
  rix_form <- function(obj, indent_rownames = FALSE) {
    ##  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
      )
    )

    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)
      ),
      row_info = make_row_df(obj),
      nlines_header = 1, ## XXX this is probably wrong!!!
      nrow_header = 1,
      has_topleft = FALSE,
      has_rowlabs = FALSE,
      expand_newlines = TRUE,
      main_title = main_title(obj),
      subtitles = subtitles(obj),
      page_titles = page_titles(obj),
      main_footer = main_footer(obj),
      prov_footer = prov_footer(obj)
    )
  }
)


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

#' @export
#' @param new character. Names of columns to be added to
#' the set of display columns.
#' @rdname listings
add_listing_dispcol <- function(df, new) {
  listing_dispcols(df) <- c(listing_dispcols(df), new)
  df
}
#' @export
#' @param value character. New value.
#' @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
}



#' @rdname listings
#'
#' @param name character(1). Name of the existing or new column to be
#'   displayed when the listing is rendered.
#' @param fun function or NULL. A function which accepts \code{df} and
#'   returns the vector for a new column, which is added to \code{df} as
#'   \code{name}, or NULL if marking an existing column as
#'   a listing column.
#' @inheritParams formatters::fmt_config
#'
#' @return `df`, with `name` created (if necessary) and marked for
#'   display during rendering.
#'
#' @export
add_listing_col <- function(df,
                            name,
                            fun = NULL,
                            format = NULL,
                            na_str = "NA",
                            align = "left") {
  if (!is.null(fun)) {
    vec <- fun(df)
  } 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)) {
    vec <- df[[name]]
    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
}

#' Paginate listings
#'
#' @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.
#'
#' @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
#'
#' @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
#'
#' @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
#'
#' @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.
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 = propose_column_widths(lsting),
                             tf_wrap = !is.null(max_width),
                             max_width = NULL,
                             verbose = FALSE) {
  checkmate::assert_class(lsting, "listing_df")
  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)

  indx <- paginate_indices(lsting,
    page_type = page_type,
    font_family = font_family,
    font_size = font_size,
    lineheight = lineheight,
    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 = length(get_keycols(lsting)),
    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")
}

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 or horizontal if there are many columns.
7		#'
8		#' @param lsting listing_df. The listing to paginate.
9		#' @param lpp numeric(1) or NULL. Number of row lines (not counting titles and
10		#' footers) to have per page. Standard is `70` while `NULL` disables vertical
11		#' pagination.
12		#' @param cpp numeric(1) or NULL. Width (in characters) of the pages for
13		#' horizontal pagination. `NULL` (the default) indicates no horizontal
14		#' pagination should be done.
15		#' @inheritParams formatters::pag_indices_inner
16		#' @inheritParams formatters::vert_pag_indices
17		#' @inheritParams formatters::page_lcpp
18		#' @inheritParams formatters::toString
19		#'
20		#' @returns A list of listings' objects that are meant to be on separated pages.
21		#' For `pag_tt_indices` a list of paginated-groups of row-indices of `lsting`.
22		#'
23		#' @rdname paginate
24		#'
25		#' @examples
26		#' dat <- ex_adae
27		#' lsting <- as_listing(dat[1:25, ], disp_cols = c("USUBJID", "AESOC", "RACE", "AETOXGR", "BMRKR1"))
28		#'
29		#' mat <- matrix_form(lsting)
30		#'
31		#' cat(toString(mat))
32		#'
33		#' paginate_listing(lsting, lpp = 10)
34		#'
35		#' paginate_listing(lsting, cpp = 100, lpp = 40)
36		#'
37		#' paginate_listing(lsting, cpp = 80, lpp = 40, verbose = TRUE)
38		#' @export
39		#'
40		#' @return for `paginate_listing` a list containing separate
41		#' `listing_df` objects for each page, for `pag_listing_indices`,
42		#' a list of indices in the direction being paginated corresponding
43		#' to the individual pages in that dimension.
44		paginate_listing <- function(lsting,
45		page_type = "letter",
46		font_family = "Courier",
47		font_size = 8,
48		lineheight = 1,
49		landscape = FALSE,
50		pg_width = NULL,
51		pg_height = NULL,
52		margins = c(top = .5, bottom = .5, left = .75, right = .75),
53		lpp = NA_integer_,
54		cpp = NA_integer_,
55		colwidths = propose_column_widths(lsting),
56		tf_wrap = !is.null(max_width),
57		max_width = NULL,
58		verbose = FALSE) {
59	21x	checkmate::assert_class(lsting, "listing_df")
60	21x	checkmate::assert_numeric(colwidths, lower = 0, len = length(listing_dispcols(lsting)), null.ok = TRUE)
61	20x	checkmate::assert_flag(tf_wrap)
62	20x	checkmate::assert_count(max_width, null.ok = TRUE)
63	20x	checkmate::assert_flag(verbose)
64
65	20x	indx <- paginate_indices(lsting,
66	20x	page_type = page_type,
67	20x	font_family = font_family,
68	20x	font_size = font_size,
69	20x	lineheight = lineheight,
70	20x	landscape = landscape,
71	20x	pg_width = pg_width,
72	20x	pg_height = pg_height,
73	20x	margins = margins,
74	20x	lpp = lpp,
75	20x	cpp = cpp,
76	20x	colwidths = colwidths,
77	20x	tf_wrap = tf_wrap,
78	20x	max_width = max_width,
79	20x	rep_cols = length(get_keycols(lsting)),
80	20x	verbose = verbose
81		)
82
83	20x	vert_pags <- lapply(
84	20x	indx$pag_row_indices,
85	20x	function(ii) lsting[ii, ]
86		)
87	20x	dispnames <- listing_dispcols(lsting)
88	20x	full_pag <- lapply(
89	20x	vert_pags,
90	20x	function(onepag) {
91	29x	if (!is.null(indx$pag_col_indices)) {
92	29x	lapply(
93	29x	indx$pag_col_indices,
94	29x	function(jj) {
95	78x	res <- onepag[, dispnames[jj], drop = FALSE]
96	78x	listing_dispcols(res) <- intersect(dispnames, names(res))
97	78x	res
98		}
99		)
100		} else {
101	!	list(onepag)
102		}
103		}
104		)
105
106	20x	ret <- unlist(full_pag, recursive = FALSE)
107	20x	ret
108		}
109
110		#' @title Defunct functions
111		#'
112		#' @description
113		#' These functions are defunct and their symbols will be removed entirely
114		#' in a future release.
115		#' @rdname defunct
116		#' @inheritParams paginate_listing
117		#' @export
118		pag_listing_indices <- function(lsting,
119		lpp = 15,
120		colwidths = NULL,
121		max_width = NULL,
122		verbose = FALSE) {
123	1x	.Defunct("paginate_indices", package = "formatters")
124		}

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

1		setOldClass(c("listing_df", "tbl_df", "tbl", "data.frame"))
2		setOldClass(c("MatrixPrintForm", "list"))
3
4		#' @rdname listings
5		#' @title Create a Listing from a `data.frame` or `tibble`
6		#'
7		#' @description `r lifecycle::badge("experimental")`
8		#'
9		#' Creates listings by using `cols` and `key_cols` to produce a compact and
10		#' elegant representation of the `data.frame` or `tibble` in input.
11		#'
12		#' @param df data.frame or listing_df. The (non-listing) data.frame to be converted to a listing or
13		#' the listing_df to be modified.
14		#' @param key_cols character. Names of columns which should be treated as key columns
15		#' when rendering the listing. Key columns allow you to group repeat occurrences.
16		#' @param disp_cols character or NULL. Names of non-key columns which should be displayed when
17		#' the listing is rendered. Defaults to all columns of `df` not named in `key_cols` or
18		#' `non_disp_cols`.
19		#' @param non_disp_cols character or NULL. Names of non-key columns to be excluded as display
20		#' columns. All other non-key columns are then treated as display columns. Invalid if
21		#' `disp_cols` is non-NULL.
22		#' @param unique_rows logical(1). Should only unique rows be included in the listing. Defaults to `FALSE`.
23		#' @param default_formatting list. A named list of default column format configurations to apply when rendering the
24		#' listing. Each name-value pair consists of a name corresponding to a data class (or "numeric" for all unspecified
25		#' numeric classes) and a value of type `fmt_config` with the format configuration that should be implemented for
26		#' columns of that class. If named element "all" is included in the list, this configuration will be used for all
27		#' data classes not specified. Objects of type `fmt_config` can take 3 arguments: `format`, `na_str`, and `align`.
28		#' @param col_formatting list. A named list of custom column formatting configurations to apply to specific columns
29		#' when rendering the listing. Each name-value pair consists of a name corresponding to a column name and a value of
30		#' type `fmt_config` with the formatting configuration that should be implemented for that column. Objects of type
31		#' `fmt_config` can take 3 arguments: `format`, `na_str`, and `align`. Defaults to `NULL`.
32		#' @param main_title character(1) or NULL. The main title for the listing, or
33		#' `NULL` (the default). Must be length 1 non-NULL.
34		#' @param subtitles character or NULL. A vector of subtitle(s) for the
35		#' listing, or `NULL` (the default).
36		#' @param main_footer character or NULL. A vector of main footer lines
37		#' for the listing, or `NULL` (the default).
38		#' @param prov_footer character or NULL. A vector of provenance strings
39		#' for the listing, or `NULL` (the default). Each string element is placed on a new line.
40		#' @param vec any. A column vector from a `listing_df` to be annotated as a key column.
41		#'
42		#' @return A `listing_df` object, sorted by the key columns.
43		#'
44		#' @details 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 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		#'
74		#' @examples
75		#' dat <- ex_adae
76		#'
77		#' # This example demonstrates the listing with key_cols (values are grouped by USUBJID) and
78		#' # multiple lines in prov_footer
79		#' lsting <- as_listing(dat[1:25, ],
80		#' key_cols = c("USUBJID", "AESOC"),
81		#' main_title = "Example Title for Listing",
82		#' subtitles = "This is the subtitle for this Adverse Events Table",
83		#' main_footer = "Main footer for the listing",
84		#' prov_footer = c(
85		#' "You can even add a subfooter", "Second element is place on a new line",
86		#' "Third string"
87		#' )
88		#' ) %>%
89		#' add_listing_col("AETOXGR") %>%
90		#' add_listing_col("BMRKR1", format = "xx.x") %>%
91		#' add_listing_col("AESER / AREL", fun = function(df) paste(df$AESER, df$AREL, sep = " / "))
92		#'
93		#' mat <- matrix_form(lsting)
94		#'
95		#' cat(toString(mat))
96		#'
97		#' # This example demonstrates the listing table without key_cols
98		#' # and specifying the cols with disp_cols.
99		#' dat <- ex_adae
100		#' lsting <- as_listing(dat[1:25, ],
101		#' disp_cols = c("USUBJID", "AESOC", "RACE", "AETOXGR", "BMRKR1")
102		#' )
103		#'
104		#' mat <- matrix_form(lsting)
105		#'
106		#' cat(toString(mat))
107		#'
108		#' # This example demonstrates a listing with format configurations specified
109		#' # via the default_formatting and col_formatting arguments
110		#' dat <- ex_adae
111		#' dat$AENDY[3:6] <- NA
112		#' lsting <- as_listing(dat[1:25, ],
113		#' key_cols = c("USUBJID", "AESOC"),
114		#' disp_cols = c("STUDYID", "SEX", "ASEQ", "RANDDT", "ASTDY", "AENDY"),
115		#' default_formatting = list(
116		#' all = fmt_config(align = "left"),
117		#' numeric = fmt_config(
118		#' format = "xx.xx",
119		#' na_str = "<No data>",
120		#' align = "right"
121		#' )
122		#' )
123		#' ) %>%
124		#' add_listing_col("BMRKR1", format = "xx.x", align = "center")
125		#'
126		#' mat <- matrix_form(lsting)
127		#'
128		#' cat(toString(mat))
129		#'
130		#' @export
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	40x	if (length(non_disp_cols) > 0 && length(intersect(key_cols, non_disp_cols)) > 0) {
143	1x	stop("Key column also listed in non_disp_cols. All key columns are by",
144	1x	" definition display columns.")
145		}
146	39x	if (!is.null(disp_cols) && !is.null(non_disp_cols)) {
147	1x	stop("Got non-null values for both disp_cols and non_disp_cols. This is not supported.")
148	38x	} else if (is.null(disp_cols)) {
149		## non_disp_cols NULL is ok here
150	15x	cols <- setdiff(names(df), c(key_cols, non_disp_cols))
151		} else {
152		## disp_cols non-null, non_disp_cols NULL
153	23x	cols <- disp_cols
154		}
155	38x	if (!all(sapply(default_formatting, is, class2 = "fmt_config"))) {
156	!	stop("All format configurations supplied in `default_formatting`",
157	!	" must be of type `fmt_config`.")
158		}
159	38x	if (!(is.null(col_formatting) \|\| all(sapply(col_formatting, is, class2 = "fmt_config")))) {
160	!	stop("All format configurations supplied in `col_formatting`",
161	!	" must be of type `fmt_config`.")
162		}
163
164	38x	df <- as_tibble(df)
165	38x	varlabs <- var_labels(df, fill = TRUE)
166	38x	o <- do.call(order, df[key_cols])
167	38x	if (is.unsorted(o)) {
168	20x	message("sorting incoming data by key columns")
169	20x	df <- df[o, ]
170		}
171
172		## reorder the full set of cols to ensure key columns are first
173	38x	ordercols <- c(key_cols, setdiff(names(df), key_cols))
174	38x	df <- df[, ordercols]
175	38x	var_labels(df) <- varlabs[ordercols]
176
177	38x	for (cnm in key_cols) {
178	57x	df[[cnm]] <- as_keycol(df[[cnm]])
179		}
180
181		## key cols must be leftmost cols
182	38x	cols <- c(key_cols, setdiff(cols, key_cols))
183
184	38x	row_all_na <- apply(df[cols], 1, function(x) all(is.na(x)))
185	38x	if (any(row_all_na)) {
186	1x	message("rows that only contain NA values have been trimmed")
187	1x	df <- df[!row_all_na, ]
188		}
189
190		# set col format configs
191	38x	df[cols] <- lapply(cols, function(col) {
192	231x	col_class <- tail(class(df[[col]]), 1)
193	231x	col_fmt_class <- if (!col_class %in% names(default_formatting) && is.numeric(df[[col]])) "numeric" else col_class
194	231x	col_fmt <- if (col %in% names(col_formatting)) {
195	6x	col_formatting[[col]]
196	231x	} else if (col_fmt_class %in% names(default_formatting)) {
197	6x	default_formatting[[col_fmt_class]]
198		} else {
199	219x	if (!"all" %in% names(default_formatting)) {
200	!	stop("Format configurations must be supplied for all listing columns. ",
201	!	"To cover all remaining columns please add an 'all' configuration",
202	!	" to `default_formatting`.")
203		}
204	219x	default_formatting[["all"]]
205		}
206		# ANY attr <- fmt_config slot
207	231x	obj_format(df[[col]]) <- obj_format(col_fmt)
208	231x	obj_na_str(df[[col]]) <- if (is.null(obj_na_str(col_fmt))) "NA" else obj_na_str(col_fmt)
209	231x	obj_align(df[[col]]) <- if (is.null(obj_align(col_fmt))) "left" else obj_align(col_fmt)
210	231x	df[[col]]
211		})
212
213	2x	if (unique_rows) df <- df[!duplicated(df[, cols]), ]
214
215	38x	class(df) <- c("listing_df", class(df))
216		## these all work even when the value is NULL
217	38x	main_title(df) <- main_title
218	38x	main_footer(df) <- main_footer
219	38x	subtitles(df) <- subtitles
220	38x	prov_footer(df) <- prov_footer
221	38x	listing_dispcols(df) <- cols
222	38x	df
223		}
224
225
226		#' @export
227		#' @rdname listings
228		as_keycol <- function(vec) {
229	57x	if (is.factor(vec)) {
230	13x	lab <- obj_label(vec)
231	13x	vec <- as.character(vec)
232	13x	obj_label(vec) <- lab
233		}
234	57x	class(vec) <- c("listing_keycol", class(vec))
235	57x	vec
236		}
237
238
239		#' @export
240		#' @rdname listings
241		is_keycol <- function(vec) {
242	3973x	inherits(vec, "listing_keycol")
243		}
244
245
246
247		#' @export
248		#' @rdname listings
249		get_keycols <- function(df) {
250	247x	names(which(sapply(df, is_keycol)))
251		}
252
253		#' @export
254		#' @inherit formatters::matrix_form
255		#' @seealso [formatters::matrix_form()]
256		#' @param indent_rownames logical(1). Silently ignored, as listings do not have row names
257		#' nor indenting structure.
258		#'
259		#' @examples
260		#'
261		#' lsting <- as_listing(mtcars)
262		#' mf <- matrix_form(lsting)
263		#'
264		#' @return a `MatrixPrintForm` object
265		setMethod(
266		"matrix_form", "listing_df",
267		rix_form <- function(obj, indent_rownames = FALSE) {
268		## we intentionally silently ignore indent_rownames because listings have
269		## no rownames, but formatters::vert_pag_indices calls matrix_form(obj, TRUE)
270		## unconditionally.
271	109x	cols <- attr(obj, "listing_dispcols")
272	109x	listing <- obj[, cols]
273	109x	atts <- attributes(obj)
274	109x	atts$names <- cols
275	109x	attributes(listing) <- atts
276	109x	keycols <- get_keycols(listing)
277
278
279	109x	bodymat <- matrix("",
280	109x	nrow = nrow(listing),
281	109x	ncol = ncol(listing)
282		)
283
284	109x	colnames(bodymat) <- names(listing)
285
286
287	109x	curkey <- ""
288	109x	for (i in seq_along(keycols)) {
289	159x	kcol <- keycols[i]
290	159x	kcolvec <- listing[[kcol]]
291	159x	kcolvec <- vapply(kcolvec, format_value, "", format = obj_format(kcolvec), na_str = obj_na_str(kcolvec))
292	159x	curkey <- paste0(curkey, kcolvec)
293	159x	disp <- c(TRUE, tail(curkey, -1) != head(curkey, -1))
294	159x	bodymat[disp, kcol] <- kcolvec[disp]
295		}
296
297	109x	nonkeycols <- setdiff(names(listing), keycols)
298	109x	if (length(nonkeycols) > 0) {
299	108x	for (nonk in nonkeycols) {
300	312x	vec <- listing[[nonk]]
301	312x	vec <- vapply(vec, format_value, "", format = obj_format(vec), na_str = obj_na_str(vec))
302	312x	bodymat[, nonk] <- vec
303		}
304		}
305
306
307	109x	fullmat <- rbind(
308	109x	var_labels(listing, fill = TRUE),
309	109x	bodymat
310		)
311
312	109x	colaligns <- rbind(
313	109x	rep("center", length(cols)),
314	109x	matrix(sapply(listing, obj_align),
315	109x	ncol = length(cols),
316	109x	nrow = nrow(fullmat) - 1,
317	109x	byrow = TRUE
318		)
319		)
320
321	109x	MatrixPrintForm(
322	109x	strings = fullmat,
323	109x	spans = matrix(1,
324	109x	nrow = nrow(fullmat),
325	109x	ncol = ncol(fullmat)
326		),
327	109x	ref_fnotes = list(),
328	109x	aligns = colaligns,
329	109x	formats = matrix(1,
330	109x	nrow = nrow(fullmat),
331	109x	ncol = ncol(fullmat)
332		),
333	109x	row_info = make_row_df(obj),
334	109x	nlines_header = 1, ## XXX this is probably wrong!!!
335	109x	nrow_header = 1,
336	109x	has_topleft = FALSE,
337	109x	has_rowlabs = FALSE,
338	109x	expand_newlines = TRUE,
339	109x	main_title = main_title(obj),
340	109x	subtitles = subtitles(obj),
341	109x	page_titles = page_titles(obj),
342	109x	main_footer = main_footer(obj),
343	109x	prov_footer = prov_footer(obj)
344		)
345		}
346		)
347
348
349		#' @export
350		#' @rdname listings
351	170x	listing_dispcols <- function(df) attr(df, "listing_dispcols") %\|\|% character()
352
353		#' @export
354		#' @param new character. Names of columns to be added to
355		#' the set of display columns.
356		#' @rdname listings
357		add_listing_dispcol <- function(df, new) {
358	17x	listing_dispcols(df) <- c(listing_dispcols(df), new)
359	17x	df
360		}
361		#' @export
362		#' @param value character. New value.
363		#' @rdname listings
364		`listing_dispcols<-` <- function(df, value) {
365	133x	if (!is.character(value)) {
366	!	stop(
367	!	"dispcols must be a character vector of column names, got ",
368	!	"object of class: ", paste(class(value), collapse = ",")
369		)
370		}
371	133x	chk <- setdiff(value, names(df)) ## remember setdiff is not symmetrical
372	133x	if (length(chk) > 0) {
373	!	stop(
374	!	"listing display columns must be columns in the underlying data. ",
375	!	"Column(s) ", paste(chk, collapse = ", "), " not present in the data."
376		)
377		}
378	133x	attr(df, "listing_dispcols") <- unique(value)
379	133x	df
380		}
381
382
383
384		#' @rdname listings
385		#'
386		#' @param name character(1). Name of the existing or new column to be
387		#' displayed when the listing is rendered.
388		#' @param fun function or NULL. A function which accepts \code{df} and
389		#' returns the vector for a new column, which is added to \code{df} as
390		#' \code{name}, or NULL if marking an existing column as
391		#' a listing column.
392		#' @inheritParams formatters::fmt_config
393		#'
394		#' @return `df`, with `name` created (if necessary) and marked for
395		#' display during rendering.
396		#'
397		#' @export
398		add_listing_col <- function(df,
399		name,
400		fun = NULL,
401		format = NULL,
402		na_str = "NA",
403		align = "left") {
404	17x	if (!is.null(fun)) {
405	!	vec <- fun(df)
406	17x	} else if (name %in% names(df)) {
407	17x	vec <- df[[name]]
408		} else {
409	!	stop(
410	!	"Column '", name, "' not found. name argument must specify an existing column when ",
411	!	"no generating function (fun argument) is specified."
412		)
413		}
414
415	17x	if (!is.null(format)) {
416	7x	vec <- df[[name]]
417	7x	obj_format(vec) <- format
418		}
419
420	17x	obj_na_str(vec) <- na_str
421	17x	obj_align(vec) <- align
422
423		## this works for both new and existing columns
424	17x	df[[name]] <- vec
425	17x	df <- add_listing_dispcol(df, name)
426	17x	df
427		}