formatters coverage - 90.02%

Files
Source

formats_1d <- c(
  "xx", "xx.", "xx.x", "xx.xx", "xx.xxx", "xx.xxxx",
  "xx%", "xx.%", "xx.x%", "xx.xx%", "xx.xxx%", "(N=xx)", ">999.9", ">999.99",
  "x.xxxx | (<0.0001)"
)

formats_2d <- c(
  "xx / xx", "xx. / xx.", "xx.x / xx.x", "xx.xx / xx.xx", "xx.xxx / xx.xxx",
  "N=xx (xx%)", "xx (xx%)", "xx (xx.%)", "xx (xx.x%)", "xx (xx.xx%)",
  "xx. (xx.%)", "xx.x (xx.x%)", "xx.xx (xx.xx%)",
  "(xx, xx)", "(xx., xx.)", "(xx.x, xx.x)", "(xx.xx, xx.xx)",
  "(xx.xxx, xx.xxx)", "(xx.xxxx, xx.xxxx)",
  "xx - xx", "xx.x - xx.x", "xx.xx - xx.xx",
  "xx (xx)", "xx. (xx.)", "xx.x (xx.x)", "xx.xx (xx.xx)",
  "xx (xx.)", "xx (xx.x)", "xx (xx.xx)",
  "xx.x, xx.x",
  "xx.x to xx.x"
)

formats_3d <- c(
  "xx. (xx. - xx.)",
  "xx.x (xx.x - xx.x)",
  "xx.xx (xx.xx - xx.xx)",
  "xx.xxx (xx.xxx - xx.xxx)"
)

#' @title List with currently supported formats and vertical alignments
#'
#' @description We support `xx` style format labels grouped by 1d, 2d and 3d.
#' Currently valid format labels can not be added dynamically. Format functions
#' must be used for special cases.
#'
#' @return
#' * `list_valid_format_labels()`: A nested list, with elements listing the supported 1d, 2d,
#'  and 3d format strings.
#'
#' @examples
#' list_valid_format_labels()
#'
#' @name list_formats
#' @export
list_valid_format_labels <- function() {
  structure(
    list(
      "1d" = formats_1d,
      "2d" = formats_2d,
      "3d" = formats_3d
    ),
    info = "xx does not modify the element, and xx. rounds a number to 0 digits"
  )
}
#' @return
#' * `list_valid_aligns()`: a character vector of valid vertical alignments
#'
#' @examples
#' list_valid_aligns()
#'
#' @name list_formats
#' @export
list_valid_aligns <- function() {
  c("left", "right", "center", "decimal", "dec_right", "dec_left")
}

#' @title Check if a format or alignment is supported
#'
#' @description Utility functions for checking formats and alignments.
#'
#' @param x either format string or an object returned by \code{sprintf_format}
#' @param stop_otherwise logical, if \code{x} is not a format should an error be
#'   thrown
#'
#' @note No check if the function is actually a `formatter` is performed.
#'
#' @return
#'  * `is_valid_format`: \code{TRUE} if \code{x} is \code{NULL}, a supported
#'    format string, or a function; \code{FALSE} otherwise.
#'
#' @examples
#' is_valid_format("xx.x")
#' is_valid_format("fakeyfake")
#'
#' @name check_formats
#' @export
is_valid_format <- function(x, stop_otherwise = FALSE) {
  is_valid <- is.null(x) || (length(x) == 1 && (is.function(x) || x %in% unlist(list_valid_format_labels())))

  if (stop_otherwise && !is_valid) {
    stop("format needs to be a format label, sprintf_format object, a function, or NULL")
  }

  is_valid
}
#' @param algn vector of characters that indicates the requested cell alignments.
#'
#' @return
#'  * `check_aligns`: `TRUE` if it passes the check.
#'
#' @examples
#' check_aligns(c("decimal", "dec_right"))
#'
#' @name check_formats
#' @export
check_aligns <- function(algn) {
  if (anyNA(algn)) {
    stop("Got missing-value for text alignment.")
  }
  invalid <- setdiff(algn, list_valid_aligns())
  if (length(invalid) > 0) {
    stop("Unsupported text-alignment(s): ", paste(invalid, collapse = ", "))
  }
  invisible(TRUE)
}

#' Specify text format via a `sprintf` format string
#'
#'
#' @param format character(1). A format string passed to `sprintf`.
#'
#' @export
#' @return A formatting function which wraps and will apply the specified \code{printf} style format
#'   string \code{format}.
#' @seealso \code{\link[base]{sprintf}}
#'
#' @examples
#'
#' fmtfun <- sprintf_format("(N=%i")
#' format_value(100, format = fmtfun)
#'
#' fmtfun2 <- sprintf_format("%.4f - %.2f")
#' format_value(list(12.23456, 2.724))
sprintf_format <- function(format) {
  function(x, ...) {
    do.call(sprintf, c(list(fmt = format), x))
  }
}


#' Round and prepare a value for display
#'
#' This function is used within \code{\link{format_value}} to prepare numeric values within
#' cells for formatting and display.
#'
#' @aliases rounding
#' @param x numeric(1). Value to format
#' @param digits numeric(1). Number of digits to round to, or \code{NA} to convert to a
#' character value with no rounding.
#' @param na_str character(1). The value to return if \code{x} is \code{NA}.
#'
#' @details
#' This function combines the rounding behavior of R's standards-complaint
#' \code{\link{round}} function (see the Details section of that documentation)
#' with the strict decimal display of \code{\link{sprintf}}. The exact behavior
#' is as follows:
#'
#' \enumerate{
#' \item{If \code{x} is NA, the value of \code{na_str} is returned}
#' \item{If \code{x} is non-NA but \code{digits} is NA, \code{x} is converted to a character
#' and returned}
#' \item{If \code{x} and \code{digits} are both non-NA, \code{round} is called first,
#' and then \code{sprintf} is used to convert the rounded value to a character with the
#' appropriate number of trailing zeros enforced.}
#' }
#'
#' @return A character value representing the value after rounding, containing
#' containing any trailling zeros required to display \emph{exactly} \code{digits}
#' elements.
#' @note
#' This differs from the base R \code{\link{round}} function in that \code{NA}
#' digits indicate x should be passed converted to character and returned unchanged
#' whereas \code{round(x, digits =NA)} returns \code{NA} for all values of \code{x}.
#'
#' This behavior will differ from \code{as.character(round(x, digits = digits))}
#' in the case where there are not at least \code{digits} significant digits
#' after the decimal that remain after rounding. It \emph{may} differ from
#' \code{sprintf("\%.Nf", x)} for values ending in \code{5} after the decimal place
#' on many popular operating systems due to \code{round}'s stricter adherence to the
#' `IEC 60559` standard, particularly for R versions > 4.0.0 (see Warning in \code{\link[base:round]{round}}
#' documentation).
#'
#' @export
#' @seealso \code{link{format_value}} \code{\link[base:round]{round}} \code{\link[base:sprintf]{sprintf}}
#' @examples
#'
#' round_fmt(0, digits = 3)
#' round_fmt(.395, digits = 2)
#' round_fmt(NA, digits = 1)
#' round_fmt(NA, digits = 1, na_str = "-")
#' round_fmt(2.765923, digits = NA)
round_fmt <- function(x, digits, na_str = "NA") {
  if (!is.na(digits) && digits < 0) {
    stop("round_fmt currentlyd does not support non-missing values of digits <0")
  }
  if (is.na(x)) {
    na_str
  } else if (is.na(digits)) {
    paste0(x)
  } else {
    sprfmt <- paste0("%.", digits, "f")
    sprintf(fmt = sprfmt, round(x, digits = digits))
  }
}



val_pct_helper <- function(x, dig1, dig2, na_str, pct = TRUE) {
  if (pct) {
    x[2] <- x[2] * 100
  }
  if (length(na_str) == 1) {
    na_str <- rep(na_str, 2)
  }
  paste0(
    round_fmt(x[1], digits = dig1, na_str = na_str[1]),
    " (",
    round_fmt(x[2], digits = dig2, na_str = na_str[2]),
    if (pct) "%", ")"
  )
}

sep_2d_helper <- function(x, dig1, dig2, sep, na_str, wrap = NULL) {
  ret <- paste(mapply(round_fmt, x = x, digits = c(dig1, dig2), na_str = na_str),
    collapse = sep
  )
  if (!is.null(wrap)) {
    ret <- paste(c(wrap[1], ret, wrap[2]), collapse = "")
  }
  ret
}

## na_or_round <- function(x, digits, na_str) {
##     if(is.na(x))
##         na_str
##     else
##         round(x, digits = digits)

## }

#' Converts a (possibly compound) value into a string using the \code{format} information
#'
#' @details A length-zero value for `na_str` will be interpreted as `"NA"`, as will any
#' missing values within a non-length-zero `na_str` vector.
#'
#' @param x ANY. The value to be formatted
#' @param format character(1) or function. The format label (string) or `formatter` function to apply to \code{x}.
#' @param na_str character(1). String that should be displayed when the value of \code{x} is missing.
#'   Defaults to \code{"NA"}.
#' @param output character(1). output type
#'
#' @return formatted text representing the cell \code{x}.
#' @export
#'
#' @seealso [round_fmt()]
#' @examples
#'
#' x <- format_value(pi, format = "xx.xx")
#' x
#'
#' format_value(x, output = "ascii")
#'
format_value <- function(x, format = NULL, output = c("ascii", "html"), na_str = "NA") {
  ## if(is(x, "CellValue"))
  ##     x = x[[1]]

  if (length(x) == 0) {
    return("")
  }

  output <- match.arg(output)
  if (length(na_str) == 0) {
    na_str <- "NA"
  }
  if (any(is.na(na_str))) {
    na_str[is.na(na_str)] <- "NA"
  }
  ## format <- if (!missing(format)) format else obj_format(x)


  txt <- if (all(is.na(x)) && length(na_str) == 1L) {
    na_str
  } else if (is.null(format)) {
    toString(x)
  } else if (is.function(format)) {
    format(x, output = output)
  } else if (is.character(format)) {
    l <- if (format %in% formats_1d) {
      1
    } else if (format %in% formats_2d) {
      2
    } else if (format %in% formats_3d) {
      3
    } else {
      stop(
        "unknown format label: ", format,
        ". use list_valid_format_labels() to get a list of all formats"
      )
    }
    if (format != "xx" && length(x) != l) {
      stop(
        "cell <", paste(x), "> and format ",
        format, " are of different length"
      )
    }
    if (length(na_str) < length(x)) {
      na_str <- rep(na_str, length.out = length(x))
    }
    switch(format,
      "xx" = as.character(x),
      "xx." = round_fmt(x, digits = 0, na_str = na_str),
      "xx.x" = round_fmt(x, digits = 1, na_str = na_str),
      "xx.xx" = round_fmt(x, digits = 2, na_str = na_str),
      "xx.xxx" = round_fmt(x, digits = 3, na_str = na_str),
      "xx.xxxx" = round_fmt(x, digits = 4, na_str = na_str),
      "xx%" = paste0(round_fmt(x * 100, digits = NA, na_str = na_str), "%"),
      "xx.%" = paste0(round_fmt(x * 100, digits = 0, na_str = na_str), "%"),
      "xx.x%" = paste0(round_fmt(x * 100, digits = 1, na_str = na_str), "%"),
      "xx.xx%" = paste0(round_fmt(x * 100, digits = 2, na_str = na_str), "%"),
      "xx.xxx%" = paste0(round_fmt(x * 100, digits = 3, na_str = na_str), "%"),
      "(N=xx)" = paste0("(N=", round_fmt(x, digits = NA, na_str = na_str), ")"),
      ">999.9" = ifelse(x > 999.9, ">999.9", round_fmt(x, digits = 1, na_str = na_str)),
      ">999.99" = ifelse(x > 999.99, ">999.99", round_fmt(x, digits = 2, na_str = na_str)),
      "x.xxxx | (<0.0001)" = ifelse(x < 0.0001, "<0.0001", round_fmt(x, digits = 4, na_str = na_str)),
      "xx / xx" = sep_2d_helper(x, dig1 = NA, dig2 = NA, sep = " / ", na_str = na_str),
      "xx. / xx." = sep_2d_helper(x, dig1 = 0, dig2 = 0, sep = " / ", na_str = na_str),
      "xx.x / xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " / ", na_str = na_str),
      "xx.xx / xx.xx" = sep_2d_helper(x, dig1 = 2, dig2 = 2, sep = " / ", na_str = na_str),
      "xx.xxx / xx.xxx" = sep_2d_helper(x, dig1 = 3, dig2 = 3, sep = " / ", na_str = na_str),
      "N=xx (xx%)" = paste0("N=", val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str)),
      "xx (xx%)" = val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str),
      "xx (xx.%)" = val_pct_helper(x, dig1 = NA, dig2 = 0, na_str = na_str),
      "xx (xx.x%)" = val_pct_helper(x, dig1 = NA, dig2 = 1, na_str = na_str),
      "xx (xx.xx%)" = val_pct_helper(x, dig1 = NA, dig2 = 2, na_str = na_str),
      "xx. (xx.%)" = val_pct_helper(x, dig1 = 0, dig2 = 0, na_str = na_str),
      "xx.x (xx.x%)" = val_pct_helper(x, dig1 = 1, dig2 = 1, na_str = na_str),
      "xx.xx (xx.xx%)" = val_pct_helper(x, dig1 = 2, dig2 = 2, na_str = na_str),
      "(xx, xx)" = sep_2d_helper(x,
        dig1 = NA, dig2 = NA, sep = ", ",
        na_str = na_str, wrap = c("(", ")")
      ),
      "(xx., xx.)" = sep_2d_helper(x,
        dig1 = 0, dig2 = 0, sep = ", ",
        na_str = na_str, wrap = c("(", ")")
      ),
      "(xx.x, xx.x)" = sep_2d_helper(x,
        dig1 = 1, dig2 = 1, sep = ", ",
        na_str = na_str, wrap = c("(", ")")
      ),
      "(xx.xx, xx.xx)" = sep_2d_helper(x,
        dig1 = 2, dig2 = 2, sep = ", ",
        na_str = na_str, wrap = c("(", ")")
      ),
      "(xx.xxx, xx.xxx)" = sep_2d_helper(x,
        dig1 = 3, dig2 = 3, sep = ", ",
        na_str = na_str, wrap = c("(", ")")
      ),
      "(xx.xxxx, xx.xxxx)" = sep_2d_helper(x,
        dig1 = 4, dig2 = 4, sep = ", ",
        na_str = na_str, wrap = c("(", ")")
      ),
      "xx - xx" = sep_2d_helper(x, dig1 = NA, dig2 = NA, sep = " - ", na_str = na_str),
      "xx.x - xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " - ", na_str = na_str),
      "xx.xx - xx.xx" = sep_2d_helper(x, dig1 = 2, dig2 = 2, sep = " - ", na_str = na_str),
      "xx (xx)" = val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str, pct = FALSE),
      "xx. (xx.)" = val_pct_helper(x, dig1 = 0, dig2 = 0, na_str = na_str, pct = FALSE),
      "xx.x (xx.x)" = val_pct_helper(x, dig1 = 1, dig2 = 1, na_str = na_str, pct = FALSE),
      "xx.xx (xx.xx)" = val_pct_helper(x, dig1 = 2, dig2 = 2, na_str = na_str, pct = FALSE),
      "xx (xx.)" = val_pct_helper(x, dig1 = NA, dig2 = 0, na_str = na_str, pct = FALSE),
      "xx (xx.x)" = val_pct_helper(x, dig1 = NA, dig2 = 1, na_str = na_str, pct = FALSE),
      "xx (xx.xx)" = val_pct_helper(x, dig1 = NA, dig2 = 2, na_str = na_str, pct = FALSE),
      "xx.x, xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = ", ", na_str = na_str),
      "xx.x to xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " to ", na_str = na_str),
      "xx.xx (xx.xx - xx.xx)" = paste0(
        round_fmt(x[1], digits = 2, na_str = na_str[1]), " ",
        sep_2d_helper(x[2:3],
          dig1 = 2, dig2 = 2,
          sep = " - ", na_str = na_str[2:3],
          wrap = c("(", ")")
        )
      ),
      "xx. (xx. - xx.)" = paste0(
        round_fmt(x[1], digits = 0, na_str = na_str[1]), " ",
        sep_2d_helper(x[2:3],
          dig1 = 0, dig2 = 0,
          sep = " - ", na_str = na_str[2:3],
          wrap = c("(", ")")
        )
      ),
      "xx.x (xx.x - xx.x)" = paste0(
        round_fmt(x[1], digits = 1, na_str = na_str[1]), " ",
        sep_2d_helper(x[2:3],
          dig1 = 1, dig2 = 1,
          sep = " - ", na_str = na_str[2:3],
          wrap = c("(", ")")
        )
      ),
      "xx.xxx (xx.xxx - xx.xxx)" = paste0(
        round_fmt(x[1], digits = 3, na_str = na_str[1]), " ",
        sep_2d_helper(x[2:3],
          dig1 = 3, dig2 = 3,
          sep = " - ", na_str = na_str[2:3],
          wrap = c("(", ")")
        )
      ),
      paste("format string", format, "not found")
    )
  }
  txt[is.na(txt)] <- na_str
  if (output == "ascii") {
    txt
  } else if (output == "html") {
    ## convert to tagList
    ## convert \n to <br/>

    if (identical(txt, "")) {
      txt
    } else {
      els <- unlist(strsplit(txt, "\n", fixed = TRUE))
      Map(function(el, is.last) {
        tagList(el, if (!is.last) tags$br() else NULL)
      }, els, c(rep(FALSE, length(els) - 1), TRUE))
    }
  } else {
    txt
  }
}

setClassUnion("FormatSpec", c("NULL", "character", "function", "list"))
setClassUnion("characterOrNULL", c("NULL", "character"))
setClass("fmt_config",
  slots = c(
    format = "FormatSpec",
    format_na_str = "characterOrNULL",
    align = "characterOrNULL"
  )
)

#' Format Configuration
#'
#' @param format character(1) or function. A format label (string) or `formatter` function.
#' @param na_str character(1). String that should be displayed in place of missing values.
#' @param align character(1). Alignment values should be rendered with.
#'
#' @return An object of class `fmt_config` which contains the following elements:
#'   * `format`
#'   * `na_str`
#'   * `align`
#'
#' @examples
#' fmt_config(format = "xx.xx", na_str = "-", align = "left")
#' fmt_config(format = "xx.xx - xx.xx", align = "right")
#'
#' @export
fmt_config <- function(format = NULL, na_str = "NA", align = "center") {
  new("fmt_config", format = format, format_na_str = na_str, align = align)
}

## #' Page Dimensions
## #'
## #' Dimensions for mapping page dimensions to text dimensions
## #' @references https://www.ietf.org/rfc/rfc0678.txt
## #' @export
## #' @rdname pagedims
## lpi_vert <- 6
## #' @export
## #' @rdname pagedims
## cpi_horiz <- 10
## #' @export
## #' @rdname pagedims
## horiz_margin_chars <- 13
## #' @export
## #' @rdname pagedims
## horiz_margin_inches <- horiz_margin_chars / cpi_horiz
## #' @export
## #' @rdname pagedims
## vert_margin_lines <- 6
## #' @export
## #' @rdname pagedims
## vert_margin_inches <- vert_margin_lines / lpi_vert

## #' Physical Page dimensions to chars x lines
## #'
## #' Calculate number of lines long and characters wide a page size is,
## #' after excluding margins
## #' @export
## #' @examples
## #' phys_page_to_lc()
## phys_page_to_lc <- function(width = 8.5, len = 11,
##                             h_margin = horiz_margin_inches,
##                             v_margin = vert_margin_inches) {
##     lgl_width <- width - h_margin
##     lgl_len <- len - v_margin
##     c(chars_wide = floor(lgl_width * cpi_horiz),
##       lines_long = floor(lgl_len * lpi_vert))
## }

#' @name pagination_algo
#' @rdname pagination_algo
#' @title Pagination
#' @section Pagination Algorithm:
#'
#' Pagination  is performed independently in  the vertical  and horizontal
#' directions based solely on a *pagination data.frame*, which includes the
#' following information for each row/column:
#'
#'  - number of  lines/characters rendering the row  will take **after
#'    word-wrapping** (`self_extent`)
#'  - the indices (`reprint_inds`)  and number of lines (`par_extent`)
#'    of the rows which act as **context** for the row
#'  - the row's number of siblings and position within its siblings
#'
#' Given `lpp`  (`cpp`) already  adjusted for rendered  elements which
#' are  not rows/columns  and a  dataframe of  pagination information,
#' pagination is  performed via  the following  algorithm, and  with a
#' `start = 1`:
#'
#' Core Pagination Algorithm:
#' 1. Initial guess for pagination point is `start + lpp` (`start + cpp`)
#'
#' 2. While the guess is not a valid pagination position, and `guess >
#'    start`, decrement guess and repeat
#'   - an error is thrown if all possible pagination positions between
#'     `start` and `start + lpp` (`start + cpp`) would ever be `< start`
#'     after decrementing
#' 3. Retain pagination index
#' 4. if pagination  point was less than  `NROW(tt)` (`ncol(tt)`), set
#'    `start` to `pos + 1`, and repeat steps (1) - (4).
#'
#' Validating pagination position:
#'
#' Given an (already adjusted) `lpp` or `cpp` value, a pagination is invalid if:
#'
#'   - The rows/columns on the page would take  more than (adjusted) `lpp` lines/`cpp`
#'     characters to render **including**
#'     - word-wrapping
#'     - (vertical only) context repetition
#'   - (vertical only) footnote messages  and or section divider lines
#'     take up too many lines after rendering rows
#'   - (vertical only) row is a label or content (row-group summary) row
#'   - (vertical only)  row at the pagination point  has siblings, and
#'     it has less than `min_siblings` preceding or following siblings
#'   - pagination would occur within a sub-table listed in `nosplitin`
#'
NULL

#' Create row of pagination data frame
#' @param nm character(1). Name
#' @param lab character(1). Label
#' @param rnum numeric(1). Absolute row number
#' @param pth character or NULL. Path within larger table
#' @param sibpos integer(1). Position among sibling rows
#' @param nsibs integer(1). Number of siblings (including self).
#' @param extent numeric(1). Number of lines required to print the row
#' @param colwidths numeric. Column widths
#' @param repext integer(1). Number of lines required to reprint all context for this row if it appears directly
#'   after pagination.
#' @param repind integer. Vector of row numbers to be reprinted if this row appears directly after pagination.
#' @param indent integer. Indent
#' @param rclass character(1). Class of row object.
#' @param nrowrefs integer(1). Number of row referential footnotes for this row
#' @param ncellrefs integer(1). Number of cell referential footnotes for the cells in this row
#' @param nreflines integer(1). Total number of lines required by all referential footnotes
#' @param force_page logical(1). Currently Ignored.
#' @param page_title logical(1). Currently Ignored.
#' @param trailing_sep character(1). The string to used as a separator below this row during printing (or
#' `NA_character_` for no separator).
#' @param row ANY. Object representing the row, which is used for default values of \code{nm}, \code{lab},
#' \code{extent} and \code{rclass} if provided. Must have methods for \code{obj_name}, \code{obj_label},
#' and \code{nlines}, respectively, for default values of \code{nm}, \code{lab} and \code{extent} to
#' be retrieved, respectively.
#'
#' @return a single row data.frame with the columns appropriate for a pagination info data frame.
#' @export
pagdfrow <- function(row,
                     nm = obj_name(row),
                     lab = obj_label(row),
                     rnum,
                     pth,
                     sibpos = NA_integer_,
                     nsibs = NA_integer_,
                     extent = nlines(row, colwidths),
                     colwidths = NULL,
                     repext = 0L,
                     repind = integer(),
                     indent = 0L,
                     rclass = class(row),
                     nrowrefs = 0L,
                     ncellrefs = 0L,
                     nreflines = 0L,
                     # ref_df = .make_ref_df(NULL, NULL),
                     force_page = FALSE,
                     page_title = NA_character_,
                     trailing_sep = NA_character_) {
  data.frame(
    label = lab,
    name = nm,
    abs_rownumber = rnum,
    path = I(list(pth)),
    pos_in_siblings = sibpos,
    n_siblings = nsibs,
    self_extent = extent,
    par_extent = repext,
    reprint_inds = I(rep(list(unlist(repind)), length.out = length(nm))),
    node_class = rclass,
    indent = max(0L, indent),
    nrowrefs = nrowrefs,
    ncellrefs = ncellrefs,
    nreflines = nreflines,
    # ref_info_df = I(list(ref_df)),
    force_page = force_page,
    page_title = page_title,
    trailing_sep = trailing_sep,
    stringsAsFactors = FALSE,
    row.names = NULL,
    check.names = FALSE,
    fix.empty.names = FALSE
  )
}


calc_ref_nlines_df <- function(pagdf) {
  ## XXX XXX XXX this is dangerous and wrong!!!
  if (is.null(pagdf$ref_info_df) && sum(pagdf$nreflines) == 0) {
    return(ref_df_row()[0, ])
  }
  refdf <- do.call(rbind.data.frame, pagdf$ref_info_df)
  if (NROW(refdf) == 0) {
    return(ref_df_row()[0, ])
  }
  unqsyms <- !duplicated(refdf$symbol)
  refdf[unqsyms, , drop = FALSE]
}


build_fail_msg <- function(row, lines, raw_rowlines,
                           start, guess, rep_ext, n_reprint,
                           reflines, n_refs, sectlines) {
  if (row) {
    spacetype <- "lines"
    spacetype_abr <- "lns"
    structtype_abr <- "rws"
    sprintf(
      paste(
        "\t....................... FAIL: requires %d %s [raw: %d %s (%d %s), rep.",
        "context: %d %s (%d %s), refs: %d %s (%d)  sect. divs: %d %s]."
      ),
      lines,
      spacetype,
      raw_rowlines,
      spacetype_abr,
      guess - start + 1, # because it includes both start and guess
      structtype_abr,
      rep_ext,
      spacetype_abr,
      n_reprint,
      structtype_abr,
      reflines,
      spacetype_abr,
      n_refs,
      sectlines,
      spacetype_abr
    )
  } else { ## !row
    spacetype <- "chars"
    spacetype_abr <- "chars"
    structtype_abr <- "cols"
    sprintf(
      "\t....................... FAIL: requires %d %s (%d %s).",
      lines,
      spacetype,
      guess - start + 1, # because it includes both start and guess
      structtype_abr
    )
  }
}

valid_pag <- function(pagdf,
                      guess,
                      start,
                      rlpp,
                      min_sibs,
                      nosplit = NULL,
                      div_height = 1L,
                      verbose = FALSE,
                      row = TRUE,
                      have_col_fnotes = FALSE) {
  rw <- pagdf[guess, ]


  if (verbose) {
    message(
      "Checking pagination after ",
      paste(ifelse(row, "row", "column"), guess)
    )
  }
  raw_rowlines <- sum(pagdf[start:guess, "self_extent"] - pagdf[start:guess, "nreflines"])

  refdf_ii <- calc_ref_nlines_df(pagdf[start:guess, ])
  reflines <- if (row) sum(refdf_ii$nlines, 0L) else 0L
  if (reflines > 0 && !have_col_fnotes) {
    reflines <- reflines + div_height + 1L
  }

  ##  reflines <- sum(pagdf[start:guess, "nreflines"])
  rowlines <- raw_rowlines + reflines ## sum(pagdf[start:guess, "self_extent"]) - reflines
  ## self extent includes reflines
  ## self extent does ***not*** currently include trailing sep
  ## we don't include the trailing_sep for guess because if we paginate here it won't be printed
  sectlines <- if (start == guess) 0L else sum(!is.na(pagdf[start:(guess - 1), "trailing_sep"]))
  lines <- rowlines + sectlines # guess - start + 1 because inclusive of start
  rep_ext <- pagdf$par_extent[start]
  if (lines > rlpp) {
    if (verbose) {
      structtype <- ifelse(row, "rows", "columns")
      structtype_abr <- ifelse(row, "rows", "cols")
      spacetype <- ifelse(row, "lines", "chars")
      spacetype_abr <- ifelse(row, "lns", "chrs")
      msg <- build_fail_msg(
        row, lines, raw_rowlines, start, guess, rep_ext, length(pagdf$reprint_inds[[start]]),
        reflines, NROW(refdf_ii), sectlines
      )
      message(msg)
    }
    return(FALSE)
  }
  if (rw[["node_class"]] %in% c("LabelRow", "ContentRow")) {
    if (verbose) {
      message("\t....................... FAIL: last row is a label or content row")
    }
    return(FALSE)
  }

  sibpos <- rw[["pos_in_siblings"]]
  nsib <- rw[["n_siblings"]]
  # okpos <- min(min_sibs + 1, rw[["n_siblings"]])
  if (sibpos != nsib) {
    retfalse <- FALSE
    if (sibpos < min_sibs + 1) {
      retfalse <- TRUE
      if (verbose) {
        message(
          "\t....................... FAIL: last row had only ", sibpos - 1,
          " preceding siblings, needed ", min_sibs
        )
      }
    } else if (nsib - sibpos < min_sibs + 1) {
      retfalse <- TRUE
      if (verbose) {
        message(
          "\t....................... FAIL: last row had only ", nsib - sibpos - 1,
          " following siblings, needed ", min_sibs
        )
      }
    }
    if (retfalse) {
      return(FALSE)
    }
  }
  if (guess < nrow(pagdf) && length(nosplit > 0)) {
    ## paths end at the leaf name which is *always* different
    curpth <- head(unlist(rw$path), -1)
    nxtpth <- head(unlist(pagdf$path[[guess + 1]]), -1)

    inplay <- nosplit[(nosplit %in% intersect(curpth, nxtpth))]
    if (length(inplay) > 0) {
      ok_split <- vapply(inplay, function(var) {
        !identical(curpth[match(var, curpth) + 1], nxtpth[match(var, nxtpth) + 1])
      }, TRUE)

      curvals <- curpth[match(inplay, curpth) + 1]
      nxtvals <- nxtpth[match(inplay, nxtpth) + 1]
      if (!all(ok_split)) {
        if (verbose) {
          message(
            "\t....................... FAIL: nosplit variable [",
            inplay[min(which(!ok_split))], "] would be constant [",
            curvals, "] across this pagebreak."
          )
        }
        return(FALSE)
      }
    }
  }
  if (verbose) {
    message("\t....................... OK [", lines + rep_ext, if (row) " lines]" else " chars]")
  }
  TRUE
}


find_pag <- function(pagdf,
                     start,
                     guess,
                     rlpp,
                     min_siblings,
                     nosplitin = character(),
                     verbose = FALSE,
                     row = TRUE,
                     have_col_fnotes = FALSE,
                     div_height = 1L,
                     do_error = FALSE) {
  origuess <- guess
  while (guess >= start && !valid_pag(
    pagdf, guess,
    start = start, rlpp = rlpp, min_sibs = min_siblings,
    nosplit = nosplitin, verbose, row = row, have_col_fnotes = have_col_fnotes,
    div_height = div_height
  )) {
    guess <- guess - 1
  }
  if (guess < start) {
    if (isFALSE(do_error)) {
      find_pag(
        pagdf = pagdf,
        start = start,
        guess = origuess,
        rlpp = rlpp,
        min_siblings = min_siblings,
        nosplitin = nosplitin,
        verbose = TRUE,
        row = row,
        have_col_fnotes = have_col_fnotes,
        div_height = div_height,
        do_error = TRUE
      )
    }
    stop(
      "Unable to find any valid pagination split\ between ",
      ifelse(row, "rows ", "columns "), start, " and ", origuess, ". \n",
      "Inserted ", ifelse(row, "cpp (column-space, content per page) ", "lpp (row-space, lines per page) "),
      ": ", pagdf$par_extent[start] + rlpp, "\n",
      "Need-to-repeat-in-each-page space (key values): ", pagdf$par_extent[start], "\n",
      "Remaining space: ", rlpp, "\n",
      "Current space needed (with padding): ", pagdf$self_extent[start]
    )
  }
  guess
}


#' Find Pagination Indices From Pagination Info Dataframe
#'
#' Pagination methods should typically call the `make_row_df` method
#' for their object and then call this function on the resulting
#' pagination info data.frame.
#'
#' @details `pab_indices_inner` implements the Core Pagination Algorithm
#' for a single direction (vertical if `row = TRUE`, the default, horizontal otherwise)
#' based on the pagination dataframe and (already adjusted for non-body rows/columns)
#' lines (or characters) per page.
#'
#' @inheritSection pagination_algo Pagination Algorithm
#' @param pagdf data.frame. A pagination info data.frame as created by
#' either `make_rows_df` or `make_cols_df`.
#' @param rlpp numeric. Maximum number of \emph{row} lines per page (not including header materials), including
#'   (re)printed header and context rows
#' @param min_siblings  numeric. Minimum sibling rows which must appear on either side of pagination row for a
#'   mid-subtable split to be valid. Defaults to 2.
#' @param nosplitin character. List of names of sub-tables where page-breaks are not allowed, regardless of other
#'   considerations. Defaults to none.
#' @param verbose logical(1). Should additional informative messages about the search for
#' pagination breaks be shown. Defaults to \code{FALSE}.
#' @param row logical(1). Is pagination happening in row
#' space (`TRUE`, the default) or column space (`FALSE`)
#' @param have_col_fnotes logical(1). Does the table-like object being rendered have
#' column-associated referential footnotes.
#' @param div_height numeric(1). The height of the divider line when the
#' associated object is rendered. Defaults to `1`.
#' @return A list containing the vector of row numbers, broken up by page
#'
#' @examples
#' mypgdf <- basic_pagdf(row.names(mtcars))
#'
#' paginds <- pag_indices_inner(mypgdf, rlpp = 15, min_siblings = 0)
#' lapply(paginds, function(x) mtcars[x, ])
#'
#' @export
pag_indices_inner <- function(pagdf, rlpp,
                              min_siblings,
                              nosplitin = character(),
                              verbose = FALSE,
                              row = TRUE,
                              have_col_fnotes = FALSE,
                              div_height = 1L) {
  start <- 1
  nr <- nrow(pagdf)
  ret <- list()
  while (start <= nr) {
    adjrlpp <- rlpp - pagdf$par_extent[start]
    if (adjrlpp <= 0) {
      if (row) {
        stop("Lines of repeated context (plus header materials) larger than specified lines per page")
      } else {
        stop("Width of row labels equal to or larger than specified characters per page.")
      }
    }
    guess <- min(nr, start + adjrlpp - 1)
    end <- find_pag(pagdf, start, guess,
      rlpp = adjrlpp,
      min_siblings = min_siblings,
      nosplitin = nosplitin,
      verbose = verbose,
      row = row,
      have_col_fnotes = have_col_fnotes,
      div_height = div_height
    )
    ret <- c(ret, list(c(
      pagdf$reprint_inds[[start]],
      start:end
    )))
    start <- end + 1
  }
  ret
}

#' Find Column Indices for Vertical Pagination
#' @param  obj   ANY.  object   to   be  paginated.   Must  have   a
#'     \code{\link{matrix_form}} method.
#' @param cpp numeric(1). Number of characters per page (width)
#' @param colwidths numeric vector.  Column widths (in characters) for
#'     use with vertical pagination.
#' @param rep_cols numeric(1). Number of \emph{columns} (not including
#'     row labels) to be repeated on every page. Defaults to 0
#' @inheritParams pag_indices_inner
#'
#' @return A list partitioning the vector of column indices
#' into subsets for 1 or more horizontally paginated pages.
#'
#' @examples
#' mf <- basic_matrix_form(df = mtcars)
#' colpaginds <- vert_pag_indices(mf)
#' lapply(colpaginds, function(j) mtcars[, j, drop = FALSE])
#' @export
vert_pag_indices <- function(obj, cpp = 40, colwidths = NULL, verbose = FALSE, rep_cols = 0L) {
  mf <- matrix_form(obj, TRUE)
  clwds <- colwidths %||% propose_column_widths(mf)
  if (is.null(mf_cinfo(mf))) { ## like always, ugh.
    mf <- mpf_infer_cinfo(mf, colwidths = clwds, rep_cols = rep_cols)
  }

  has_rlabs <- mf_has_rlabels(mf)
  rlabs_flag <- as.integer(has_rlabs)
  rlab_extent <- if (has_rlabs) clwds[1] else 0L

  # rep_extent <- pdf$par_extent[nrow(pdf)]
  rcpp <- cpp - table_inset(mf) - rlab_extent # rep_extent - table_inset(mf) - rlab_extent
  if (verbose) {
    message(
      "Adjusted characters per page: ", rcpp,
      " [original: ", cpp,
      ", table inset: ", table_inset(mf), if (has_rlabs) paste0(", row labels: ", clwds[1]),
      "]"
    )
  }
  res <- pag_indices_inner(mf_cinfo(mf),
    rlpp = rcpp, # cpp - sum(clwds[seq_len(rep_cols)]),
    verbose = verbose,
    min_siblings = 1,
    row = FALSE
  )
  res
}

mpf_infer_cinfo <- function(mf, colwidths = NULL, rep_cols = num_rep_cols(mf)) {
  if (!is(rep_cols, "numeric") || is.na(rep_cols) || rep_cols < 0) {
    stop("got invalid number of columns to be repeated: ", rep_cols)
  }
  clwds <- (colwidths %||% mf_col_widths(mf)) %||% propose_column_widths(mf)
  has_rlabs <- mf_has_rlabels(mf)
  rlabs_flag <- as.integer(has_rlabs)
  rlab_extent <- if (has_rlabs) clwds[1] else 0L
  sqstart <- rlabs_flag + 1L # rep_cols + 1L

  pdfrows <- lapply(
    (sqstart):ncol(mf$strings),
    function(i) {
      rownum <- i - rlabs_flag
      rep_inds <- seq_len(rep_cols)[seq_len(rep_cols) < rownum]
      rep_extent_i <- sum(0L, clwds[rlabs_flag + rep_inds]) + mf$col_gap * length(rep_inds)
      pagdfrow(
        row = NA,
        nm = rownum,
        lab = rownum,
        rnum = rownum,
        pth = NA,
        extent = clwds[i] + mf$col_gap,
        repext = rep_extent_i, # sum(clwds[rep_cols]) + mf$col_gap * max(0, (length(rep_cols) - 1)),
        repind = rep_inds, # rep_cols,
        rclass = "stuff",
        sibpos = 1 - 1,
        nsibs = 1 - 1
      )
    }
  )
  pdf <- do.call(rbind, pdfrows)

  refdf <- mf_fnote_df(mf)
  pdf <- splice_fnote_info_in(pdf, refdf, row = FALSE)
  mf_cinfo(mf) <- pdf
  mf
}


#' Basic/spoof pagination info dataframe
#'
#' Returns a minimal pagination info data.frame (with no sibling/footnote/etc info).
#' @inheritParams basic_matrix_form
#' @param rnames character. Vector of row names
#' @param labs character. Vector of row labels (defaults to names)
#' @param rnums integer. Vector of row numbers. Defaults to `seq_along(rnames)`.
#' @param extents integer. Number of lines each row will take to print, defaults to 1 for all rows
#' @param rclass character. Class(es) for the rows. Defaults to "NA"
#'
#' @return A data.frame suitable for use in both the `matrix_print_form` constructor and the pagination machinery
#'
#' @examples
#'
#' basic_pagdf(c("hi", "there"))
#' @export
basic_pagdf <- function(rnames, labs = rnames, rnums = seq_along(rnames),
                        extents = 1L,
                        rclass = "NA",
                        parent_path = "root") {
  rws <- mapply(pagdfrow,
    nm = rnames, lab = labs, extent = extents,
    rclass = rclass, rnum = rnums, pth = lapply(rnames, function(x) c(parent_path, x)),
    SIMPLIFY = FALSE, nsibs = 1, sibpos = 1
  )
  res <- do.call(rbind.data.frame, rws)
  res$n_siblings <- nrow(res)
  res$pos_in_siblings <- seq_along(res$n_siblings)
  res
}




## write paginate() which operates **solely** on a MatrixPrintForm obj


page_size_spec <- function(lpp, cpp, max_width) {
  structure(list(
    lpp = lpp,
    cpp = cpp,
    max_width = max_width
  ), class = "page_size_spec")
}


non_null_na <- function(x) !is.null(x) && is.na(x)


calc_lcpp <- function(page_type = NULL,
                      landscape = FALSE,
                      pg_width = page_dim(page_type)[if (landscape) 2 else 1],
                      pg_height = page_dim(page_type)[if (landscape) 1 else 2],
                      font_family = "Courier",
                      font_size = 8, # grid parameters
                      cpp = NA_integer_,
                      lpp = NA_integer_,
                      tf_wrap = TRUE,
                      max_width = NULL,
                      lineheight = 1,
                      margins = c(bottom = .5, left = .75, top = .5, right = .75),
                      colwidths,
                      col_gap,
                      inset) {
  pg_lcpp <- page_lcpp(
    page_type = page_type,
    landscape = landscape,
    font_family = font_family,
    font_size = font_size,
    lineheight = lineheight,
    margins = margins,
    pg_width = pg_width,
    pg_height = pg_height
  )

  if (non_null_na(lpp)) {
    lpp <- pg_lcpp$lpp
  }
  if (non_null_na(cpp)) {
    cpp <- pg_lcpp$cpp
  }
  stopifnot(!is.na(cpp))
  if (!tf_wrap && !is.null(max_width)) {
    warning("tf_wrap is FALSE - ignoring non-null max_width value.")
    max_width <- NULL
  } else if (tf_wrap && is.null(max_width)) {
    max_width <- cpp
  }
  if (is.character(max_width) && identical(max_width, "auto")) {
    max_width <- inset + sum(colwidths) + (length(colwidths) - 1) * col_gap
  }
  page_size_spec(lpp = lpp, cpp = cpp, max_width = max_width)
}


calc_rlpp <- function(pg_size_spec, mf, colwidths, tf_wrap, verbose) {
  lpp <- pg_size_spec$lpp
  max_width <- pg_size_spec$max_width

  dh <- divider_height(mf)
  if (any(nzchar(all_titles(mf)))) {
    ## +1 is for blank line between subtitles and divider
    ## dh is for divider line **between subtitles and column labels**
    ## other divider line is accounted for in cinfo_lines
    if (!tf_wrap) {
      tlines <- length(all_titles(mf))
    } else {
      tlines <- sum(nlines(all_titles(mf), colwidths = colwidths, max_width = max_width))
    }
    tlines <- tlines + dh + 1L
  } else {
    tlines <- 0
  }

  ## dh for divider line between column labels and table body
  cinfo_lines <- mf_nlheader(mf) + dh

  if (verbose) {
    message(
      "Determining lines required for header content: ",
      tlines, " title and ", cinfo_lines, " table header lines"
    )
  }

  refdf <- mf_fnote_df(mf)
  cfn_df <- refdf[is.na(refdf$row) & !is.na(refdf$col), ]

  flines <- 0L
  mnfoot <- main_footer(mf)
  havemn <- length(mnfoot) && any(nzchar(mnfoot))
  if (havemn) {
    flines <- nlines(
      mnfoot,
      colwidths = colwidths,
      max_width = max_width - table_inset(mf)
    )
  }
  prfoot <- prov_footer(mf)
  if (length(prfoot) && any(nzchar(prfoot))) {
    flines <- flines + nlines(prov_footer(mf), colwidths = colwidths, max_width = max_width)
    if (havemn) {
      flines <- flines + 1L
    } ## space between main and prov footer.
  }
  ## this time its for the divider between the footers and whatever is above them
  ## (either table body or referential footnotes)
  if (flines > 0) {
    flines <- flines + dh + 1L
  }
  ## this time its for the divider between the referential footnotes and
  ## the table body IFF we have any, otherwise that divider+blanks pace doesn't get drawn
  if (NROW(cfn_df) > 0) {
    cinfo_lines <- cinfo_lines + sum(cfn_df$nlines)
    flines <- flines + dh + 1L
  }

  if (verbose) {
    message(
      "Determining lines required for footer content",
      if (NROW(cfn_df) > 0) " [column fnotes present]",
      ": ", flines, " lines"
    )
  }

  ret <- lpp - flines - tlines - cinfo_lines

  if (verbose) {
    message("Lines per page available for tables rows: ", ret, " (original: ", lpp, ")")
  }
  ret
}


calc_rcpp <- function(pg_size_spec, mf, colwidths) {
  cpp <- pg_size_spec$cpp

  cpp - table_inset(mf) - colwidths[1] - mf_colgap(mf)
}


splice_idx_lists <- function(lsts) {
  list(
    pag_row_indices = do.call(c, lapply(lsts, function(xi) xi$pag_row_indices)),
    pag_col_indices = do.call(c, lapply(lsts, function(yi) yi$pag_col_indices))
  )
}



#' @title Paginate a table-like object for rendering
#'
#' @description
#' These functions perform or diagnose bi-directional pagination on
#' an object.
#'
#' `paginate_to_mpfs` renders `obj` into the `MatrixPrintForm` (`MPF`)
#' intermediate representation, and then paginates that `MPF` into
#' component `MPF`s each corresponding to an individual page and
#' returns those in a list.
#'
#' `paginate_indices` renders `obj` into an `MPF`, then uses
#' that representation to calculate the rows and columns of
#' `obj` corresponding to each page of the pagination of `obj`,
#' but simply returns these indices rather than paginating
#' \code{obj} itself (see details for an important caveat).
#'
#' `diagnose_pagination` attempts pagination via `paginate_to_mpfs`
#' and then returns diagnostic information which explains why page
#' breaks were positioned where they were, or alternatively why
#' no valid paginations could be found.
#'
#' @details
#'
#' All three of these functions generally support all classes which have
#' a corresponding `matrix_form` method which returns a valid `MatrixPrintForm`
#' object (including `MatrixPrintForm` objects themselves).
#'
#' `paginate_indices` is directly called by `paginate_to_mpfs` (and thus
#' `diagnose_pagination`). For most classes, and most tables represented
#' by supported classes, calling `paginate_to_mpfs` is equivalent to a
#' manual `paginate_indices -> subset obj into pages -> matrix_form`
#' workflow.
#'
#' The exception to this equivalence is objects which support 'forced pagination',
#' or pagination logic which built into the object itself rather than being a
#' function of space on a page. Forced pagination generally involves the creation
#' of, e.g., page-specific titles which apply to these forced paginations.
#' `paginate_to_mpfs` and `diagnose_pagination` support forced pagination by
#' automatically calling the `do_forced_pagination` generic on the object
#' and then paginating each object returned by that generic separately. The
#' assumption here, then, is that page-specific titles and such are
#' handled by the class' `do_forced_pagination` method.
#'
#' `paginate_indices`, on the other hand, \emph{does not support forced pagination},
#' because it returns only a set of  indices for row and column subsetting for each page,
#' and thus cannot retain any changes, e.g., to titles, done within `do_forced_paginate`.
#' `paginate_indices` does call `do_forced_paginate`, but instead of continuing, it
#' throws an error in the case that the result is more than a single "page".
#'
#' @inheritParams vert_pag_indices
#' @inheritParams pag_indices_inner
#' @inheritParams page_lcpp
#' @inheritParams toString
#' @inheritParams propose_column_widths
#' @param lpp numeric(1) or NULL. Lines per page. if NA (the default,
#'     this is calculated automatically based on the specified page
#'     size). `NULL` indicates no vertical pagination should occur.
#' @param cpp numeric(1) or NULL. Width in characters per page. if NA (the default,
#'     this is calculated automatically based on the specified page
#'     size). `NULL` indicates no horizontal pagination should occur.

#' @param pg_size_spec page_size_spec. A pre-calculated page
#'     size specification. Typically this is not set in end user code.
#' @param col_gap numeric(1). Currently unused.
#' @return for `paginate_indices` a list with two elements of the same
#'     length:   `pag_row_indices`,    and   `pag_col_indices`.    For
#'     `paginate_to_mpfs`,   a  list   of  `MatrixPrintForm` objects
#'     representing each individual page after pagination (including
#'     forced pagination if necessary).
#' @export
#' @aliases paginate pagination
#' @examples
#' mpf <- basic_matrix_form(mtcars)
#'
#' paginate_indices(mpf, pg_width = 5, pg_height = 3)
#'
#' paginate_to_mpfs(mpf, pg_width = 5, pg_height = 3)
paginate_indices <- function(obj,
                             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_,
                             min_siblings = 2,
                             nosplitin = character(),
                             colwidths = NULL,
                             tf_wrap = FALSE,
                             max_width = NULL,
                             indent_size = 2,
                             pg_size_spec = NULL,
                             rep_cols = num_rep_cols(obj),
                             col_gap = 3,
                             verbose = FALSE) {
  ## this MUST alsways return a list, inluding list(obj) when
  ## no forced pagination is needed! otherwise stuff breaks for things
  ## based on s3 classes that are lists underneath!!!
  fpags <- do_forced_paginate(obj)

  ## if we have more than one forced "page",
  ## paginate each of them individually and return the result.
  ## forced pagination is ***currently*** only vertical, so
  ## we don't have to worry about divying up colwidths here,
  ## but we will if we ever allow force_paginate to do horiz
  ## pagination.
  if (length(fpags) > 1) {
    stop(
      "forced pagination is required for this object (class: ", class(obj)[1],
      ") this is not supported in paginate_indices. Use paginate_to_mpfs or call ",
      "do_forced_paginate on your object and paginate each returned section separately."
    )
  }


  ## I'm not sure this is worth doing.
  ## ## We can't support forced pagination here, but we can support calls to,
  ## ## e.g., paginate_indices(do_forced_pag(tt))
  ## if(is.list(obj) && !is.object(obj)) {
  ##     res <- lapply(obj, paginate_indices,
  ##                   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,
  ##                   tf_wrap = tf_wrap,
  ##                   max_width = max_width,
  ##                   colwidths = colwidths,
  ##                   min_siblings = min_siblings,
  ##                   nosplitin = nosplitin,
  ##                   col_gap = col_gap,
  ##                   ## not setting num_rep_cols here cause it wont' get it right
  ##                   verbose = verbose)
  ##     return(splice_idx_lists(res))
  ## }
  ## order is annoying here, since we won't actually need the mpf if
  ## we run into forced pagination, but life is short and this should work fine.
  mpf <- matrix_form(obj, TRUE, TRUE, indent_size = indent_size)
  if (is.null(colwidths)) {
    colwidths <- mf_col_widths(mpf) %||% propose_column_widths(mpf)
  } else {
    mf_col_widths(mpf) <- colwidths
  }
  if (NROW(mf_cinfo(mpf)) == 0) {
    mpf <- mpf_infer_cinfo(mpf, colwidths, rep_cols)
  }


  if (is.null(pg_size_spec)) {
    pg_size_spec <- calc_lcpp(
      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,
      tf_wrap = tf_wrap,
      max_width = max_width,
      colwidths = colwidths,
      inset = table_inset(mpf),
      col_gap = col_gap
    )
  }

  ## we can't support forced pagination in paginate_indices because
  ## forced pagination is generally going to set page titles, which
  ## we can't preserve when just returning lists of indices.
  ## Instead we make a hard assumption here that any forced pagination
  ## has already occured.





  ## this wraps the cell contents AND shoves referential footnote
  ## info into mf_rinfo(mpf)
  mpf <- do_cell_fnotes_wrap(mpf, colwidths, max_width, tf_wrap = tf_wrap)

  if (is.null(pg_size_spec$lpp)) {
    pag_row_indices <- list(seq_len(mf_nrow(mpf)))
  } else {
    pag_row_indices <- pag_indices_inner(
      pagdf = mf_rinfo(mpf),
      rlpp = calc_rlpp(
        pg_size_spec, mpf,
        colwidths = colwidths,
        tf_wrap = tf_wrap, verbose = verbose
      ),
      verbose = verbose,
      min_siblings = min_siblings,
      nosplitin = nosplitin
    )
  }

  if (is.null(pg_size_spec$cpp)) {
    pag_col_indices <- list(seq_len(mf_ncol(mpf)))
  } else {
    pag_col_indices <- vert_pag_indices(
      mpf,
      cpp = pg_size_spec$cpp, colwidths = colwidths,
      rep_cols = rep_cols, verbose = verbose
    )
  }

  list(pag_row_indices = pag_row_indices, pag_col_indices = pag_col_indices)
}

setGeneric("has_page_title", function(obj) standardGeneric("has_page_title"))

setMethod("has_page_title", "ANY", function(obj) length(page_titles(obj)) > 0)

#' @rdname paginate_indices
#' @export
paginate_to_mpfs <- function(obj,
                             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_,
                             min_siblings = 2,
                             nosplitin = character(),
                             colwidths = NULL,
                             tf_wrap = FALSE,
                             max_width = NULL,
                             indent_size = 2,
                             pg_size_spec = NULL,
                             rep_cols = num_rep_cols(obj),
                             col_gap = 2,
                             verbose = FALSE) {
  mpf <- matrix_form(obj, TRUE, TRUE, indent_size = indent_size)
  if (is.null(colwidths)) {
    colwidths <- mf_col_widths(mpf) %||% propose_column_widths(mpf)
  } else {
    mf_col_widths(mpf) <- colwidths
  }
  if (NROW(mf_cinfo(mpf)) == 0) {
    mpf <- mpf_infer_cinfo(mpf, colwidths, rep_cols)
  }


  if (is.null(pg_size_spec)) {
    pg_size_spec <- calc_lcpp(
      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,
      tf_wrap = tf_wrap,
      max_width = max_width,
      colwidths = colwidths,
      inset = table_inset(mpf),
      col_gap = col_gap
    )
  }
  ## this MUST alsways return a list, inluding list(obj) when
  ## no forced pagination is needed! otherwise stuff breaks for things
  ## based on s3 classes that are lists underneath!!!
  fpags <- do_forced_paginate(obj)

  ## if we have more than one forced "page",
  ## paginate each of them individually and return the result.
  ## forced pagination is ***currently*** only vertical, so
  ## we don't have to worry about divying up colwidths here,
  ## but we will if we ever allow force_paginate to do horiz
  ## pagination.
  if (length(fpags) > 1) {
    deep_pag <- lapply(
      fpags, paginate_to_mpfs,
      pg_size_spec = pg_size_spec,
      colwidths = colwidths,
      min_siblings = min_siblings,
      nosplitin = nosplitin,
      verbose = verbose
    )
    return(unlist(deep_pag, recursive = FALSE))
  } else if (has_page_title(fpags[[1]])) {
    obj <- fpags[[1]]
  }


  ## we run into forced pagination, but life is short and this should work fine.
  mpf <- matrix_form(obj, TRUE, TRUE, indent_size = indent_size)
  if (is.null(colwidths)) {
    colwidths <- mf_col_widths(mpf) %||% propose_column_widths(mpf)
  }
  mf_col_widths(mpf) <- colwidths

  page_indices <- paginate_indices(
    obj = obj,
    ## 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,
    pg_size_spec = pg_size_spec,
    ## lpp = lpp,
    ## cpp = cpp,
    min_siblings = min_siblings,
    nosplitin = nosplitin,
    colwidths = colwidths,
    tf_wrap = tf_wrap,
    ## max_width = max_width,
    rep_cols = rep_cols,
    verbose = verbose
  )

  # This needs to be fixed better
  if (inherits(fpags[[1]], "listing_df") && length(fpags) < 2) {
    pagmats <- lapply(
      page_indices$pag_row_indices,
      function(ii) {
        mf_tmp <- matrix_form(obj[ii, ], TRUE, TRUE, indent_size = indent_size)
        mf_col_widths(mf_tmp) <- colwidths
        mf_tmp
      }
    )
  } else {
    pagmats <- lapply(page_indices$pag_row_indices, function(ii) {
      mpf_subset_rows(mpf, ii)
    })
  }

  ## these chunks now carry around their (correctly subset) col widths...
  res <- lapply(pagmats, function(matii) {
    lapply(page_indices$pag_col_indices, function(jj) {
      mpf_subset_cols(matii, jj)
    })
  })

  unlist(res, recursive = FALSE)
}


#' @importFrom utils capture.output
#' @details
#'
#' `diagnose_pagination` attempts pagination and then, regardless of success
#' or failure, returns diagnostic information about pagination
#' attempts (if any) after each row and column.
#'
#' The diagnostics data reflects the final time the pagination algorithm
#' evaluated a page break at the specified location, regardless of how
#' many times the position was assessed total.
#'
#' To get information about intermediate attempts, perform pagination
#' with `verbose = TRUE` and inspect the messages in order.
#'
#' @return For `diagnose_pagination` a list containing:
#'
#' \describe{
#' \item{`lpp_diagnostics`}{diagnostic information regarding lines per page}
#' \item{`row_diagnostics`}{basic information about rows, whether pagination was attempted
#'   after each row, and the final result of such an attempt, if made}
#' \item{`cpp_diagnostics}{diagnostic information regarding columns per page}
#' \item{`col_diagnostics`}{(very) basic information about leaf columns, whether pagination
#'   was attempted after each leaf column, ad the final result of such attempts, if made}
#' }
#'
#' @note  For  `diagnose_pagination`,   the  column  labels  are  not
#'     displayed  in  the  `col_diagnostics` element  due  to  certain
#'     internal  implementation details;  rather  the diagnostics  are
#'     reported in terms of absolute (leaf) column position. This is a
#'     known  limitation,  and  may  eventually be  changed,  but  the
#'     information remains useful as it is currently reported.
#'
#' @note `diagnose_pagination` is intended for interactive debugging
#' use and \emph{should not be programmed against}, as the exact
#' content and form of the  verbose messages it captures and
#' returns is subject to change.
#'
#' @note because `diagnose_pagination` relies on `capture.output(type = "message")`,
#' it cannot be used within the `testthat` (and likely other) testing frameworks,
#' and likely cannot be used within `knitr`/`rmarkdown` contexts either,
#' as this clashes with those systems' capture of messages.
#'
#' @export
#'
#' @rdname paginate_indices
#' @examples
#'
#' diagnose_pagination(mpf, pg_width = 5, pg_height = 3)
#' clws <- propose_column_widths(mpf)
#' clws[1] <- floor(clws[1] / 3)
#' dgnost <- diagnose_pagination(mpf, pg_width = 5, pg_height = 3, colwidths = clws)
#' try(diagnose_pagination(mpf, pg_width = 1)) # fails
#'
diagnose_pagination <- function(obj,
                                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_,
                                min_siblings = 2,
                                nosplitin = character(),
                                colwidths = propose_column_widths(matrix_form(obj, TRUE)),
                                tf_wrap = FALSE,
                                max_width = NULL,
                                indent_size = 2,
                                pg_size_spec = NULL,
                                rep_cols = num_rep_cols(obj),
                                col_gap = 2,
                                verbose = FALSE,
                                ...) {
  fpag <- do_forced_paginate(obj)
  if (length(fpag) > 1) {
    return(lapply(
      fpag,
      diagnose_pagination,
      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,
      tf_wrap = tf_wrap,
      max_width = max_width,
      colwidths = colwidths,
      col_gap = col_gap,
      min_siblings = min_siblings,
      nosplitin = nosplitin
    ))
  }

  mpf <- matrix_form(obj, TRUE)
  msgres <- capture.output(
    {
      tmp <- try(
        paginate_to_mpfs(
          obj,
          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,
          tf_wrap = tf_wrap,
          max_width = max_width,
          colwidths = colwidths,
          col_gap = col_gap,
          min_siblings = min_siblings,
          nosplitin = nosplitin,
          verbose = TRUE
        )
      )
    },
    type = "message"
  )
  if (is(tmp, "try-error") && grepl("Width of row labels equal to or larger", tmp)) {
    cond <- attr(tmp, "condition")
    stop(conditionMessage(cond), call. = conditionCall(cond))
  }

  lpp_diagnostic <- grep("^(Determining lines|Lines per page available).*$", msgres, value = TRUE)
  cpp_diagnostic <- unique(grep("^Adjusted characters per page.*$", msgres, value = TRUE))

  mpf <- do_cell_fnotes_wrap(mpf, widths = colwidths, max_width = max_width, tf_wrap = tf_wrap)
  mpf <- mpf_infer_cinfo(mpf, colwidths = colwidths)

  rownls <- grep("Checking pagination after row", msgres, fixed = TRUE)
  rownum <- as.integer(gsub("[^[:digit:]]*(.*)$", "\\1", msgres[rownls]))
  rowmsgs <- vapply(unique(rownum), function(ii) {
    idx <- max(which(rownum == ii))
    gsub("\\t[.]*", "", msgres[rownls[idx] + 1])
  }, "")

  msgdf <- data.frame(
    abs_rownumber = unique(rownum),
    final_pag_result = rowmsgs, stringsAsFactors = FALSE
  )
  rdf <- mf_rinfo(mpf)[, c("abs_rownumber", "label", "self_extent", "par_extent", "node_class")]
  rdf$pag_attempted <- rdf$abs_rownumber %in% rownum
  row_diagnose <- merge(rdf, msgdf, by = "abs_rownumber", all.x = TRUE)

  colnls <- grep("Checking pagination after column", msgres, fixed = TRUE)
  colnum <- as.integer(gsub("[^[:digit:]]*(.*)$", "\\1", msgres[colnls]))
  colmsgs <- vapply(unique(colnum), function(ii) {
    idx <- max(which(colnum == ii))
    gsub("\\t[.]*", "", msgres[colnls[idx] + 1])
  }, "")

  colmsgdf <- data.frame(
    abs_rownumber = unique(colnum),
    final_pag_result = colmsgs,
    stringsAsFactors = FALSE
  )
  cdf <- mf_cinfo(mpf)[, c("abs_rownumber", "self_extent")]
  cdf$pag_attempted <- cdf$abs_rownumber %in% colnum
  col_diagnose <- merge(cdf, colmsgdf, by = "abs_rownumber", all.x = TRUE)
  names(col_diagnose) <- gsub("^abs_rownumber$", "abs_colnumber", names(col_diagnose))
  list(
    lpp_diagnostics = lpp_diagnostic,
    row_diagnostics = row_diagnose,
    cpp_diagnostics = cpp_diagnostic,
    col_diagnostics = col_diagnose
  )
}

#' Return an object with a label attribute
#'
#' @param x an object
#' @param label label attribute to to attached to  \code{x}
#'
#' @export
#' @return \code{x} labeled by \code{label}. Note: the exact mechanism of labeling should be
#' considered an internal implementation detail, but the label will always be retrieved via \code{obj_label}.
#' @examples
#' x <- with_label(c(1, 2, 3), label = "Test")
#' obj_label(x)
with_label <- function(x, label) {
  obj_label(x) <- label
  x
}


#' Get Label Attributes of Variables in a \code{data.frame}
#'
#' Variable labels can be stored as a \code{label} attribute for each variable.
#' This functions returns a named character vector with the variable labels
#' (empty sting if not specified)
#'
#' @param x a \code{data.frame} object
#' @param fill boolean in case the \code{label} attribute does not exist if
#'   \code{TRUE} the variable names is returned, otherwise \code{NA}
#'
#' @return a named character vector with the variable labels, the names
#'   correspond to the variable names
#'
#' @export
#'
#' @examples
#' x <- iris
#' var_labels(x)
#' var_labels(x) <- paste("label for", names(iris))
#' var_labels(x)
var_labels <- function(x, fill = FALSE) {
  stopifnot(is.data.frame(x))
  if (NCOL(x) == 0) {
    return(character())
  }

  y <- Map(function(col, colname) {
    label <- attr(col, "label")

    if (is.null(label)) {
      if (fill) {
        colname
      } else {
        NA_character_
      }
    } else {
      if (!is.character(label) && !(length(label) == 1)) {
        stop("label for variable ", colname, "is not a character string")
      }
      as.vector(label)
    }
  }, x, colnames(x))

  labels <- unlist(y, recursive = FALSE, use.names = TRUE)

  if (!is.character(labels)) {
    stop("label extraction failed")
  }

  labels
}


#' Set Label Attributes of All Variables in a \code{data.frame}
#'
#' Variable labels can be stored as a \code{label} attribute for each variable.
#' This functions sets all non-missing (non-NA) variable labels in a \code{data.frame}
#'
#' @inheritParams var_labels
#' @param value new variable labels, \code{NA} removes the variable label
#'
#' @return modifies the variable labels of \code{x}
#'
#' @export
#'
#' @examples
#' x <- iris
#' var_labels(x)
#' var_labels(x) <- paste("label for", names(iris))
#' var_labels(x)
#'
#' if (interactive()) {
#'   View(x) # in RStudio data viewer labels are displayed
#' }
`var_labels<-` <- function(x, value) {
  stopifnot(
    is.data.frame(x),
    is.character(value),
    ncol(x) == length(value)
  )

  theseq <- if (!is.null(names(value))) names(value) else seq_along(x)
  # across columns of x
  for (j in theseq) {
    attr(x[[j]], "label") <- if (!is.na(value[j])) {
      value[j]
    } else {
      NULL
    }
  }

  x
}


#' Copy and Change Variable Labels of a \code{data.frame}
#'
#' Relabel a subset of the variables
#'
#' @inheritParams var_labels<-
#' @param ... name-value pairs, where name corresponds to a variable name in
#'   \code{x} and the value to the new variable label
#'
#' @return a copy of \code{x} with changed labels according to \code{...}
#'
#' @export
#'
#' @examples
#' x <- var_relabel(iris, Sepal.Length = "Sepal Length of iris flower")
#' var_labels(x)
#'
var_relabel <- function(x, ...) {
  # todo: make this function more readable / code easier
  stopifnot(is.data.frame(x))
  if (missing(...)) {
    return(x)
  }
  dots <- list(...)
  varnames <- names(dots)
  stopifnot(!is.null(varnames))

  map_varnames <- match(varnames, colnames(x))

  if (any(is.na(map_varnames))) {
    stop("variables: ", paste(varnames[is.na(map_varnames)], collapse = ", "), " not found")
  }

  if (any(vapply(dots, Negate(is.character), logical(1)))) {
    stop("all variable labels must be of type character")
  }

  for (i in seq_along(map_varnames)) {
    attr(x[[map_varnames[[i]]]], "label") <- dots[[i]]
  }

  x
}


#' Remove Variable Labels of a \code{data.frame}
#'
#' Removing labels attributes from a variables in a data frame
#'
#' @param x a \code{data.frame} object
#'
#' @return the same data frame as \code{x} stripped of variable labels
#'
#' @export
#'
#' @examples
#' x <- var_labels_remove(iris)
var_labels_remove <- function(x) {
  stopifnot(is.data.frame(x))

  for (i in seq_len(ncol(x))) {
    attr(x[[i]], "label") <- NULL
  }

  x
}

#' @title Default horizontal separator
#'
#' @description The default horizontal separator character which can be
#' displayed in the current `charset` for use in rendering table-likes.
#'
#' @param hsep_char character(1). Character that will be set in the R environment
#'   options as default for creating the horizontal separator. It needs to be
#'   single character. Use `getOption("formatters_default_hsep")` to get its current
#'   value (`NULL` if not set).
#'
#' @return `unicode` 2014 (long dash for generating solid horizontal line)
#' if in a locale that uses a UTF character set, otherwise an ASCII hyphen
#' with a once-per-session warning.
#'
#' @examples
#' default_hsep()
#' set_default_hsep("o")
#' default_hsep()
#'
#' @name default_horizontal_sep
#' @export
default_hsep <- function() {
  system_default_hsep <- getOption("formatters_default_hsep")

  if (is.null(system_default_hsep)) {
    if (any(grepl("^UTF", utils::localeToCharset()))) {
      hsep <- "\u2014"
    } else {
      if (interactive()) {
        warning(
          "Detected non-UTF charset. Falling back to '-' ",
          "as default header/body separator. This warning ",
          "will only be shown once per R session."
        ) # nocov
      } # nocov
      hsep <- "-" # nocov
    }
  } else {
    hsep <- system_default_hsep
  }
  hsep
}

#' @name default_horizontal_sep
#' @export
set_default_hsep <- function(hsep_char) {
  checkmate::assert_character(hsep_char, n.chars = 1, len = 1, null.ok = TRUE)
  options("formatters_default_hsep" = hsep_char)
}

.calc_cell_widths <- function(mat, colwidths, col_gap) {
  spans <- mat$spans
  keep_mat <- mat$display
  body <- mat$strings

  nr <- nrow(body)

  cell_widths_mat <- matrix(rep(colwidths, nr), nrow = nr, byrow = TRUE)
  nc <- ncol(cell_widths_mat)

  for (i in seq_len(nrow(body))) {
    if (any(!keep_mat[i, ])) { # any spans?
      j <- 1
      while (j <= nc) {
        nj <- spans[i, j]
        j <- if (nj > 1) {
          js <- seq(j, j + nj - 1)
          cell_widths_mat[i, js] <- sum(cell_widths_mat[i, js]) + col_gap * (nj - 1)
          j + nj
        } else {
          j + 1
        }
      }
    }
  }
  cell_widths_mat
}


# Main function that does the wrapping
do_cell_fnotes_wrap <- function(mat, widths, max_width, tf_wrap) {
  col_gap <- mf_colgap(mat)
  ncchar <- sum(widths) + (length(widths) - 1) * col_gap
  inset <- table_inset(mat)

  ## Text wrapping checks
  if (tf_wrap) {
    if (is.null(max_width)) {
      max_width <- getOption("width", 80L)
    } else if (is.character(max_width) && identical(max_width, "auto")) {
      max_width <- ncchar + inset
    }
    assert_number(max_width, lower = 0)
  }

  ## Check for having the right number of widths
  stopifnot(length(widths) == ncol(mat$strings))

  ## format the to ASCII
  cell_widths_mat <- .calc_cell_widths(mat, widths, col_gap)

  # Check that indentation is correct (it works only for body)
  .check_indentation(mat, row_col_width = cell_widths_mat[, 1, drop = TRUE])
  mod_ind_list <- .modify_indentation(mat, cell_widths_mat, do_what = "remove")
  mfs <- mod_ind_list[["mfs"]]
  cell_widths_mat <- mod_ind_list[["cell_widths_mat"]]

  # Main wrapper
  mf_strings(mat) <- matrix(
    unlist(mapply(wrap_string,
      str = mfs,
      width = cell_widths_mat,
      collapse = "\n"
    )),
    ncol = ncol(mfs)
  )

  ## XXXXX this is wrong and will break for listings cause we don't know when
  ## we need has_topleft to be FALSE!!!!!!!!!!
  mat <- mform_handle_newlines(mat)

  ## this updates extents in rinfo AND nlines in ref_fnotes_df
  mat <- update_mf_nlines(mat, max_width = max_width)

  # Re-indenting
  mf_strings(mat) <- .modify_indentation(mat, cell_widths_mat, do_what = "add")[["mfs"]]
  .check_indentation(mat) # all went well

  mat
}

# Helper function to see if body indentation matches (minimum)
# It sees if there is AT LEAST the indentation contained in rinfo
.check_indentation <- function(mat, row_col_width = NULL) {
  # mf_nrheader(mat) # not useful
  mf_nlh <- mf_nlheader(mat)
  mf_lgrp <- mf_lgrouping(mat)
  mf_str <- mf_strings(mat)
  # we base everything on the groupings -> unique indentation identifiers
  if (!is.null(mf_rinfo(mat))) { # this happens in rare cases with rtables::rtable()
    mf_ind <- c(rep(0, mf_nrheader(mat)), mf_rinfo(mat)$indent) # XXX to fix with topleft
  } else {
    mf_ind <- rep(0, mf_nrheader(mat))
  }
  ind_std <- paste0(rep(" ", mat$indent_size), collapse = "")

  # Expected indent (-x negative numbers should not appear at this stage)
  stopifnot(all(mf_ind >= 0))
  real_indent <- vapply(mf_ind, function(ii) {
    paste0(rep(ind_std, ii), collapse = "")
  }, character(1))

  if (!is.null(row_col_width) && any(row_col_width > 0) && !is.null(mf_rinfo(mat))) { # third is rare case
    # Self consistency test for row_col_width (same groups should have same width)
    # This should not be necessary (nocov)
    consistency_check <- vapply(unique(mf_lgrp), function(ii) {
      width_per_grp <- row_col_width[which(mf_lgrp == ii)]
      all(width_per_grp == width_per_grp[1])
    }, logical(1))
    stopifnot(all(consistency_check))

    # Taking only one width for each indentation grouping
    unique_row_col_width <- row_col_width[match(unique(mf_lgrp), mf_lgrp)]

    # Exception for check: case with summarize_row_groups and (hence) content_rows
    nchar_real_indent <- nchar(real_indent)
    body_rows <- seq(mf_nrheader(mat) + 1, length(nchar_real_indent))
    nchar_real_indent[body_rows] <- nchar_real_indent[body_rows] +
      as.numeric(mf_rinfo(mat)$node_class != "ContentRow")
    # xxx I think all of the above is a bit buggy honestly (check ContentRows!!!)

    if (any(nchar_real_indent > unique_row_col_width)) {
      stop(
        "Inserted width for row label column is not wide enough. ",
        "We found the following rows that do not have at least indentation * ind_size + 1",
        " characters to allow text to be shown after indentation: ",
        paste0(which(nchar(real_indent) + 1 > unique_row_col_width), collapse = " ")
      )
    }
  }

  # Main detector
  correct_indentation <- vapply(seq_along(mf_lgrp), function(xx) {
    grouping <- mf_lgrp[xx]
    if (nzchar(real_indent[grouping])) {
      has_correct_indentation <- stringi::stri_detect(
        mf_str[xx, 1],
        regex = paste0("^", real_indent[grouping])
      )
      return(has_correct_indentation || !nzchar(mf_str[xx, 1])) # "" is still an ok indentation
    }
    # Cases where no indent are true by definition
    return(TRUE)
  }, logical(1))

  if (any(!correct_indentation)) {
    stop(
      "We discovered indentation mismatches between the matrix_form and the indentation",
      " predefined in mf_rinfo. This should not happen. Contact the maintainer."
    ) # nocov
  }
}
# Helper function that takes out or adds the proper indentation
.modify_indentation <- function(mat, cell_widths_mat, do_what = c("remove", "add")) {
  # Extract info
  mfs <- mf_strings(mat) # we work on mfs
  mf_nlh <- mf_nlheader(mat)
  mf_l <- mf_lgrouping(mat)
  if (!is.null(mf_rinfo(mat))) { # this happens in rare cases with rtables::rtable()
    mf_ind <- c(rep(0, mf_nrheader(mat)), mf_rinfo(mat)$indent) # XXX to fix with topleft
  } else {
    mf_ind <- rep(0, mf_nrheader(mat))
  }
  stopifnot(length(mf_ind) == length(unique(mf_l))) # Check for indentation and grouping
  ind_std <- paste0(rep(" ", mat$indent_size), collapse = "") # standard size of indent 1

  # Create real indentation
  real_indent <- sapply(mf_ind, function(ii) paste0(rep(ind_std, ii), collapse = ""))

  # Use groupings to add or remove proper indentation
  lbl_row <- mfs[, 1, drop = TRUE]
  for (ii in seq_along(lbl_row)) {
    grp <- mf_l[ii]
    if (nzchar(real_indent[grp])) {
      # Update also the widths!!
      if (do_what[1] == "remove") {
        cell_widths_mat[ii, 1] <- cell_widths_mat[ii, 1] - nchar(real_indent[grp])
        mfs[ii, 1] <- stringi::stri_replace(lbl_row[ii], "", regex = paste0("^", real_indent[grp]))
      } else if (do_what[1] == "add") {
        mfs[ii, 1] <- paste0(real_indent[grp], lbl_row[ii])
      } else {
        stop("do_what needs to be remove or add.") # nocov
      }
    } else {
      mfs[ii, 1] <- lbl_row[ii]
    }
  }
  # Final return
  return(list("mfs" = mfs, "cell_widths_mat" = cell_widths_mat))
}


## take a character vector and return whether the value is
## a string version of a number or not
is_number_str <- function(vec) {
  is.na(as.numeric(vec))
}

is_dec_align <- function(vec) {
  # "c" is not an alignment method we define in `formatters`,
  # but the reverse dependency package `tables` will need
  sdiff <- setdiff(vec, c(list_valid_aligns(), "c"))
  if (length(sdiff) > 0) {
    stop("Invalid text-alignment(s): ", paste(sdiff, collapse = ", "))
  }
  grepl("dec", vec)
}

any_dec_align <- function(vec) any(is_dec_align(vec))

#' Decimal Alignment
#'
#' @description Aligning decimal values of string matrix. Allowed alignments are: `dec_left`,
#'  `dec_right` and `decimal`.
#'
#' @param string_mat character matrix. String matrix component of matrix print form object.
#' @param align_mat character matrix. Aligns matrix component of matrix print form object.
#'  Should contain either `dec_left`, `dec_right` or `decimal` for values to be decimal aligned.
#'
#' @details Decimal alignment left and right (`dec_left` and `dec_right`) are different to
#'  center decimal alignment `decimal` only in the case some padding is present. This may
#'  happen if column widths are wider by setting parameters `widths` in `toString` or
#'  `colwidths` in `paginate_*` accordingly. It will be also the case (more common) of
#'  wider column names. Decimal alignment is not supported along with cell wrapping.
#'
#' @examples
#' dfmf <- basic_matrix_form(mtcars[1:5, ])
#' aligns <- mf_aligns(dfmf)
#' aligns[, -c(1)] <- "dec_left"
#' decimal_align(mf_strings(dfmf), aligns)
#'
#' @return Processed string matrix of matrix print form with decimal aligned values.
#'
#' @seealso [toString] and [MatrixPrintForm]
#'
#' @export
decimal_align <- function(string_mat, align_mat) {
  ## Evaluate if any values are to be decimal aligned
  if (!any_dec_align(align_mat)) {
    return(string_mat)
  }
  for (i in seq(1, ncol(string_mat))) {
    ## Take a column and its decimal alignments
    col_i <- as.character(string_mat[, i])
    align_col_i <- is_dec_align(align_mat[, i])

    ## !( A || B) -> !A && !B  DeMorgan's Law
    ## Are there any values to be decimal aligned? safe if
    if (any(align_col_i) && any(!grepl("^[0-9]\\.", col_i))) {
      ## Extract values not to be aligned (NAs, non-numbers,
      ##  doesn't say "decimal" in alignment matrix)
      ## XXX FIXME because this happens after formatting, we can't tell the difference between
      ## non-number strings which come from na_str+ NA  value and strings which just aren't numbers.
      ## this is a problem that should eventually be fixed.
      nas <- vapply(col_i, is.na, FUN.VALUE = logical(1))
      nonnum <- !grepl("[0-9]", col_i)
      ## No grepl("[a-zA-Z]", col_i) because this excludes N=xx, e.g.
      nonalign <- nas | nonnum | !align_col_i
      col_ia <- col_i[!nonalign]

      ## Do decimal alignment
      if (length(col_ia) > 0) {
        # Special case: scientific notation
        has_sc_not <- grepl("\\d+[e|E][\\+|\\-]\\d+", col_ia)
        if (any(has_sc_not)) {
          stop(
            "Found values using scientific notation between the ones that",
            " needs to be decimal aligned (aligns is decimal, dec_left or dec_right).",
            " Please consider using format functions to get a complete decimal ",
            "(e.g. formatC)."
          )
        }

        ## Count the number of numbers in the string
        matches <- gregexpr("\\d+\\.\\d+|\\d+", col_ia)
        more_than_one <- vapply(matches, function(x) {
          sum(attr(x, "match.length") > 0) > 1
        }, logical(1))
        ## Throw error in case any have more than 1 numbers
        if (any(more_than_one)) {
          stop(
            "Decimal alignment is not supported for multiple values. ",
            "Found the following string with multiple numbers ",
            "(first 3 selected from column ", col_i[1], "): '",
            paste0(col_ia[more_than_one][seq(1, 3)], collapse = "', '"),
            "'"
          )
        }
        ## General split (only one match -> the first)
        main_regexp <- regexpr("\\d+", col_ia)
        left <- regmatches(col_ia, main_regexp, invert = FALSE)
        right <- regmatches(col_ia, main_regexp, invert = TRUE)
        right <- sapply(right, "[[", 2)
        something_left <- sapply(strsplit(col_ia, "\\d+"), "[[", 1)
        left <- paste0(something_left, left)
        if (!checkmate::test_set_equal(paste0(left, right), col_ia)) {
          stop(
            "Split string list lost some piece along the way. This ",
            "should not have happened. Please contact the maintainer."
          )
        } # nocov
        separator <- sapply(right, function(x) {
          if (nzchar(x)) {
            substr(x, 1, 1)
          } else {
            c(" ")
          }
        }, USE.NAMES = FALSE)
        right <- sapply(right, function(x) {
          if (nchar(x) > 1) {
            substr(x, 2, nchar(x))
          } else {
            c("")
          }
        }, USE.NAMES = FALSE)
        ## figure out whether we need space separators (at least one had a "." or not)
        if (!any(grepl("[^[:space:]]", separator))) {
          separator <- gsub("[[:space:]]*", "", separator)
        }
        ## modify the piece with spaces
        left_mod <- paste0(spaces(max(nchar(left), na.rm = TRUE) - nchar(left)), left)
        right_mod <- paste0(right, spaces(max(nchar(right), na.rm = TRUE) - nchar(right)))
        # Put everything together
        aligned <- paste(left_mod, separator, right_mod, sep = "")
        string_mat[!nonalign, i] <- aligned
      }
    }
  }
  string_mat
}

# toString ---------------------------------------------------------------------
# main printing code for MatrixPrintForm
#

#' @title Main printing system: `toString`
#'
#' @description
#' All objects that are printed to console pass by `toString`. This function allows
#' fundamental formatting specifications for the final output, like column widths and
#' relative wrapping (`width`), title and footer wrapping (`tf_wrap = TRUE` and
#' `max_width`), or horizontal separator character (e.g. `hsep = "+"`).
#'
#' @inheritParams MatrixPrintForm
#' @param widths numeric (or  `NULL`). (proposed) widths for the columns
#'     of \code{x}. The expected length  of this numeric vector can be
#'     retrieved with  `ncol() + 1`  as the  column of row  names must
#'     also be considered.
#' @param hsep character(1). Characters to repeat to create
#'     header/body separator line. If `NULL`, the object value will be
#'     used. If `" "`, an empty separator will be printed. Check [default_hsep()]
#'     for more information.
#' @param tf_wrap logical(1). Should  the texts for  title, subtitle,
#'     and footnotes be wrapped?
#' @param max_width integer(1), character(1) or `NULL`. Width that title
#'     and   footer   (including   footnotes)  materials   should   be
#'     word-wrapped to. If `NULL`, it is  set to the current print width
#'     of the  session (`getOption("width")`). If set to `"auto"`,
#'     the width of the table (plus any table inset) is used. Ignored
#'     completely if `tf_wrap` is `FALSE`.
#'
#' @details
#'
#' Manual insertion of newlines is not supported when `tf_wrap` is on
#' and will result in a warning and undefined wrapping behavior. Passing
#' vectors of already split strings remains supported, however in this
#' case each string is word-wrapped separately with the behavior
#' described above.
#'
#' @seealso [wrap_string()]
#'
#' @examples
#' mform <- basic_matrix_form(mtcars)
#' cat(toString(mform))
#'
#' @return A character string containing the ASCII rendering
#' of the table-like object represented by `x`
#'
#' @rdname tostring
#' @exportMethod toString
setMethod("toString", "MatrixPrintForm", function(x,
                                                  widths = NULL,
                                                  tf_wrap = FALSE,
                                                  max_width = NULL,
                                                  col_gap = mf_colgap(x),
                                                  hsep = NULL) {
  checkmate::assert_flag(tf_wrap)

  mat <- matrix_form(x, indent_rownames = TRUE)

  # Check for \n in mat strings -> if there are any, matrix_form did not work
  if (any(grepl("\n", mf_strings(mat)))) {
    stop(
      "Found newline characters (\\n) in string matrix produced by matrix_form. ",
      "This is not supported and implies missbehavior on the first parsing (in matrix_form). ",
      "Please contact the maintainer or file an issue."
    ) # nocov
  }

  # Check that expansion worked for header -> should not happen
  if (!is.null(mf_rinfo(mat)) && # rare case of rtables::rtable()
    (length(mf_lgrouping(mat)) != nrow(mf_strings(mat)) || # non-unique grouping test # nolint
      mf_nrheader(mat) + nrow(mf_rinfo(mat)) != length(unique(mf_lgrouping(mat))))) { # nolint
    stop(
      "The sum of the expected nrows header and nrows of content table does ",
      "not match the number of rows in the string matrix. To our knowledge, ",
      "this is usually of a problem in solving newline characters (\\n) in the header. ",
      "Please contact the maintaner or file an issue."
    ) # nocov
  }

  inset <- table_inset(mat)

  # if cells are decimal aligned, run propose column widths
  # if the provided widths is less than proposed width, return an error
  if (any_dec_align(mf_aligns(mat))) {
    aligned <- propose_column_widths(x)

    # catch any columns that require widths more than what is provided
    if (!is.null(widths)) {
      how_wide <- sapply(seq_along(widths), function(i) c(widths[i] - aligned[i]))
      too_wide <- how_wide < 0
      if (any(too_wide)) {
        desc_width <- paste(paste(
          names(which(too_wide)),
          paste0("(", how_wide[too_wide], ")")
        ), collapse = ", ")
        stop(
          "Inserted width(s) for column(s) ", desc_width,
          " is(are) not wide enough for the desired alignment."
        )
      }
    }
  }

  # Column widths are fixed here
  if (is.null(widths)) {
    # if mf does not have widths -> propose them
    widths <- mf_col_widths(x) %||% propose_column_widths(x)
  } else {
    mf_col_widths(x) <- widths
  }

  # Total number of characters for the table
  ncchar <- sum(widths) + (length(widths) - 1) * col_gap

  ## Text wrapping checks (widths)
  if (tf_wrap) {
    if (is.null(max_width)) {
      max_width <- getOption("width", 80L)
    } else if (is.character(max_width) && identical(max_width, "auto")) {
      max_width <- ncchar + inset
    }
    assert_number(max_width, lower = 0)
  }

  # Main wrapper function for table core
  mat <- do_cell_fnotes_wrap(mat, widths, max_width = max_width, tf_wrap = tf_wrap)

  body <- mf_strings(mat)
  aligns <- mf_aligns(mat)
  keep_mat <- mf_display(mat)
  ## spans <- mat$spans
  mf_ri <- mf_rinfo(mat)
  ref_fnotes <- mf_rfnotes(mat)
  nl_header <- mf_nlheader(mat)

  cell_widths_mat <- .calc_cell_widths(mat, widths, col_gap)

  # decimal alignment
  if (any_dec_align(aligns)) {
    body <- decimal_align(body, aligns)
  }

  # Content is a matrix of cells with the right amount of spaces
  content <- matrix(mapply(padstr, body, cell_widths_mat, aligns), ncol = ncol(body))
  content[!keep_mat] <- NA

  # Define gap string and divisor string
  gap_str <- strrep(" ", col_gap)
  if (is.null(hsep)) {
    hsep <- horizontal_sep(mat)
  }
  div <- substr(strrep(hsep, ncchar), 1, ncchar)
  hsd <- header_section_div(mat)
  if (!is.na(hsd)) {
    hsd <- substr(strrep(hsd, ncchar), 1, ncchar)
  } else {
    hsd <- NULL # no divisor
  }

  # text head (paste w/o NA content header and gap string)
  txt_head <- apply(head(content, nl_header), 1, .paste_no_na, collapse = gap_str)

  # txt body
  sec_seps_df <- mf_ri[, c("abs_rownumber", "trailing_sep"), drop = FALSE]
  if (!is.null(sec_seps_df) && any(!is.na(sec_seps_df$trailing_sep))) {
    bdy_cont <- tail(content, -nl_header)
    ## unfortunately we count "header rows" wrt line grouping so it
    ## doesn't match the real (i.e. body) rows as is
    row_grouping <- tail(mf_lgrouping(mat), - nl_header) - mf_nrheader(mat)
    nrbody <- NROW(bdy_cont)
    stopifnot(length(row_grouping) == nrbody)
    ## all rows with non-NA section divs and the final row (regardless of NA status)
    ## fixes #77
    sec_seps_df <- sec_seps_df[unique(c(
      which(!is.na(sec_seps_df$trailing_sep)),
      NROW(sec_seps_df)
    )), ]
    txt_body <- character()
    sec_strt <- 1
    section_rws <- sec_seps_df$abs_rownumber
    for (i in seq_len(NROW(section_rws))) {
      cur_rownum <- section_rws[i]
      sec_end <- max(which(row_grouping == cur_rownum))
      txt_body <- c(
        txt_body,
        apply(bdy_cont[seq(sec_strt, sec_end), , drop = FALSE],
          1,
          .paste_no_na,
          collapse = gap_str
        ),
        ## don't print section dividers if they would be the last thing before the
        ## footer divider
        ## this also ensures an extraneous sec div won't be printed if we have non-sec-div
        ## rows after the last sec div row (#77)
        if (sec_end < nrbody) {
          substr(
            strrep(sec_seps_df$trailing_sep[i], ncchar), 1,
            ncchar - inset
          )
        }
      )
      sec_strt <- sec_end + 1
    }
  } else {
    # This is the usual default pasting
    txt_body <- apply(tail(content, -nl_header), 1, .paste_no_na, collapse = gap_str)
  }

  # retrieving titles and footers
  allts <- all_titles(mat)

  ref_fnotes <- reorder_ref_fnotes(ref_fnotes)
  # Fix for ref_fnotes with \n characters XXX this does not count in the pagination
  if (any(grepl("\n", ref_fnotes))) {
    ref_fnotes <- unlist(strsplit(ref_fnotes, "\n", fixed = TRUE))
  }

  allfoots <- list(
    "main_footer" = main_footer(mat),
    "prov_footer" = prov_footer(mat),
    "ref_footnotes" = ref_fnotes
  )
  allfoots <- allfoots[!sapply(allfoots, is.null)]

  ## Wrapping titles if they go beyond the horizontally allowed space
  if (tf_wrap) {
    new_line_warning(allts)
    allts <- wrap_txt(allts, max_width)
  }
  titles_txt <- if (any(nzchar(allts))) c(allts, "", .do_inset(div, inset)) else NULL

  # Wrapping footers if they go beyond the horizontally allowed space
  if (tf_wrap) {
    new_line_warning(allfoots)
    allfoots$main_footer <- wrap_txt(allfoots$main_footer, max_width - inset)
    allfoots$ref_footnotes <- wrap_txt(allfoots$ref_footnotes, max_width - inset)
    ## no - inset here because the prov_footer is not inset
    allfoots$prov_footer <- wrap_txt(allfoots$prov_footer, max_width)
  }

  # Final return
  paste0(
    paste(c(
      titles_txt, # .do_inset(div, inset) happens if there are any titles
      .do_inset(txt_head, inset),
      .do_inset(div, inset),
      .do_inset(hsd, inset), # header_section_div if present
      .do_inset(txt_body, inset),
      .footer_inset_helper(allfoots, div, inset)
    ), collapse = "\n"),
    "\n"
  )
})

.do_inset <- function(x, inset) {
  if (inset == 0 || !any(nzchar(x))) {
    return(x)
  }
  padding <- strrep(" ", inset)
  if (is.character(x)) {
    x <- paste0(padding, x)
  } else if (is(x, "matrix")) {
    x[, 1] <- .do_inset(x[, 1, drop = TRUE], inset)
  }
  x
}


.inset_div <- function(txt, div, inset) {
  c(.do_inset(div, inset), "", txt)
}

.footer_inset_helper <- function(footers_v, div, inset) {
  div_done <- FALSE # nolint
  fter <- footers_v$main_footer
  prvf <- footers_v$prov_footer
  rfn <- footers_v$ref_footnotes
  footer_txt <- .do_inset(rfn, inset)
  if (any(nzchar(footer_txt))) {
    footer_txt <- .inset_div(footer_txt, div, inset)
  }
  if (any(vapply(
    footers_v, function(x) any(nzchar(x)),
    TRUE
  ))) {
    if (any(nzchar(prvf))) {
      provtxt <- c(
        if (any(nzchar(fter))) "",
        prvf
      )
    } else {
      provtxt <- character()
    }
    footer_txt <- c(
      footer_txt,
      .inset_div(
        c(
          .do_inset(fter, inset),
          provtxt
        ),
        div,
        inset
      )
    )
  }
  footer_txt
}

reorder_ref_fnotes <- function(fns) {
  ind <- gsub("\\{(.*)\\}.*", "\\1", fns)
  ind_num <- suppressWarnings(as.numeric(ind))
  is_num <- !is.na(ind_num)
  is_asis <- ind == fns

  if (all(is_num)) {
    ord_num <- order(ind_num)
    ord_char <- NULL
    ord_other <- NULL
  } else {
    ord_num <- order(ind_num[is_num])
    ord_char <- order(ind[!is_num & !is_asis])
    ord_other <- order(ind[is_asis])
  }
  c(fns[is_num][ord_num], fns[!is_num & !is_asis][ord_char], ind[is_asis][ord_other])
}

new_line_warning <- function(str_v) {
  if (any(unlist(sapply(str_v, grepl, pattern = "\n")))) {
    msg <- c(
      "Detected manual newlines when automatic title/footer word-wrapping is on.",
      "This is unsupported and will result in undefined behavior. Please either ",
      "utilize automatic word-wrapping with newline characters inserted, or ",
      "turn off automatic wrapping and wordwrap all contents manually by inserting ",
      "newlines."
    )
    warning(paste0(msg, collapse = ""))
  }
}


#' Wrap a string to within a precise width
#'
#' @description
#' Core wrapping functionality that preserve white spaces. Only `"\n"` is not supported
#' by core functionality [stringi::stri_wrap()]. This is usually solved before hand by
#' [matrix_form()]. If the width is smaller than any large word, these will be truncated
#' after `width` characters. If the split leaves trailing groups of empty spaces,
#' they will be dropped.
#'
#' @param str character. String to be wrapped. If it is a character vector or
#'   a list, it will be looped as a list and returned with `unlist(use.names = FALSE)`.
#' @param width numeric(1). Width, in characters, that the
#'   text should be wrapped at.
#' @param collapse character(1) or `NULL`. If the words that have been split should
#'   be pasted together with the collapse character. This is usually done internally
#'   with `"\n"` to have the wrapping updated along with other internal values.
#'
#' @details Word wrapping happens as with [stringi::stri_wrap()]
#'   with the following exception: individual words which are longer
#'   than `max_width` are broken up in a way that fits with the rest of the
#'   word wrapping.
#'
#' @return A string if `str` is one element and if `collapse = NULL`. Otherwise, is
#'   a list of elements (if `length(str) > 1`) that can contain strings or vector of
#'   characters (if `collapse = NULL`).
#'
#' @examples
#' str <- list(
#'   "  , something really  \\tnot  very good", # \t needs to be escaped
#'   "  but I keep it12   "
#' )
#' wrap_string(str, 5, collapse = "\n")
#'
#' @name wrap_string
#' @export
wrap_string <- function(str, width, collapse = NULL) {
  if (length(str) > 1) {
    return(
      unlist(
        lapply(str, wrap_string, width = width, collapse = collapse),
        use.names = FALSE
      )
    )
  }
  str <- unlist(str, use.names = FALSE) # it happens is one list element
  if (!length(str) || !nzchar(str) || is.na(str)) {
    return(str)
  }
  checkmate::assert_character(str)
  checkmate::assert_int(width, lower = 1)

  if (any(grepl("\\n", str))) {
    stop(
      "Found \\n in a string that was meant to be wrapped. This should not happen ",
      "because matrix_form should take care of them before this step (toString, ",
      "i.e. the printing machinery). Please contact the maintaner or file an issue."
    )
  }

  # str can be also a vector or list. In this case simplify manages the output


1		#' Return an object with a label attribute
2		#'
3		#' @param x an object
4		#' @param label label attribute to to attached to \code{x}
5		#'
6		#' @export
7		#' @return \code{x} labeled by \code{label}. Note: the exact mechanism of labeling should be
8		#' considered an internal implementation detail, but the label will always be retrieved via \code{obj_label}.
9		#' @examples
10		#' x <- with_label(c(1, 2, 3), label = "Test")
11		#' obj_label(x)
12		with_label <- function(x, label) {
13	1x	obj_label(x) <- label
14	1x	x
15		}
16
17
18		#' Get Label Attributes of Variables in a \code{data.frame}
19		#'
20		#' Variable labels can be stored as a \code{label} attribute for each variable.
21		#' This functions returns a named character vector with the variable labels
22		#' (empty sting if not specified)
23		#'
24		#' @param x a \code{data.frame} object
25		#' @param fill boolean in case the \code{label} attribute does not exist if
26		#' \code{TRUE} the variable names is returned, otherwise \code{NA}
27		#'
28		#' @return a named character vector with the variable labels, the names
29		#' correspond to the variable names
30		#'
31		#' @export
32		#'
33		#' @examples
34		#' x <- iris
35		#' var_labels(x)
36		#' var_labels(x) <- paste("label for", names(iris))
37		#' var_labels(x)
38		var_labels <- function(x, fill = FALSE) {
39	4x	stopifnot(is.data.frame(x))
40	4x	if (NCOL(x) == 0) {
41	1x	return(character())
42		}
43
44	3x	y <- Map(function(col, colname) {
45	33x	label <- attr(col, "label")
46
47	33x	if (is.null(label)) {
48	11x	if (fill) {
49	!	colname
50		} else {
51	3x	NA_character_
52		}
53		} else {
54	22x	if (!is.character(label) && !(length(label) == 1)) {
55	!	stop("label for variable ", colname, "is not a character string")
56		}
57	22x	as.vector(label)
58		}
59	3x	}, x, colnames(x))
60
61	3x	labels <- unlist(y, recursive = FALSE, use.names = TRUE)
62
63	3x	if (!is.character(labels)) {
64	!	stop("label extraction failed")
65		}
66
67	3x	labels
68		}
69
70
71		#' Set Label Attributes of All Variables in a \code{data.frame}
72		#'
73		#' Variable labels can be stored as a \code{label} attribute for each variable.
74		#' This functions sets all non-missing (non-NA) variable labels in a \code{data.frame}
75		#'
76		#' @inheritParams var_labels
77		#' @param value new variable labels, \code{NA} removes the variable label
78		#'
79		#' @return modifies the variable labels of \code{x}
80		#'
81		#' @export
82		#'
83		#' @examples
84		#' x <- iris
85		#' var_labels(x)
86		#' var_labels(x) <- paste("label for", names(iris))
87		#' var_labels(x)
88		#'
89		#' if (interactive()) {
90		#' View(x) # in RStudio data viewer labels are displayed
91		#' }
92		`var_labels<-` <- function(x, value) {
93	1x	stopifnot(
94	1x	is.data.frame(x),
95	1x	is.character(value),
96	1x	ncol(x) == length(value)
97		)
98
99	1x	theseq <- if (!is.null(names(value))) names(value) else seq_along(x)
100		# across columns of x
101	1x	for (j in theseq) {
102	11x	attr(x[[j]], "label") <- if (!is.na(value[j])) {
103	11x	value[j]
104		} else {
105	!	NULL
106		}
107		}
108
109	1x	x
110		}
111
112
113		#' Copy and Change Variable Labels of a \code{data.frame}
114		#'
115		#' Relabel a subset of the variables
116		#'
117		#' @inheritParams var_labels<-
118		#' @param ... name-value pairs, where name corresponds to a variable name in
119		#' \code{x} and the value to the new variable label
120		#'
121		#' @return a copy of \code{x} with changed labels according to \code{...}
122		#'
123		#' @export
124		#'
125		#' @examples
126		#' x <- var_relabel(iris, Sepal.Length = "Sepal Length of iris flower")
127		#' var_labels(x)
128		#'
129		var_relabel <- function(x, ...) {
130		# todo: make this function more readable / code easier
131	1x	stopifnot(is.data.frame(x))
132	1x	if (missing(...)) {
133	!	return(x)
134		}
135	1x	dots <- list(...)
136	1x	varnames <- names(dots)
137	1x	stopifnot(!is.null(varnames))
138
139	1x	map_varnames <- match(varnames, colnames(x))
140
141	1x	if (any(is.na(map_varnames))) {
142	!	stop("variables: ", paste(varnames[is.na(map_varnames)], collapse = ", "), " not found")
143		}
144
145	1x	if (any(vapply(dots, Negate(is.character), logical(1)))) {
146	!	stop("all variable labels must be of type character")
147		}
148
149	1x	for (i in seq_along(map_varnames)) {
150	1x	attr(x[[map_varnames[[i]]]], "label") <- dots[[i]]
151		}
152
153	1x	x
154		}
155
156
157		#' Remove Variable Labels of a \code{data.frame}
158		#'
159		#' Removing labels attributes from a variables in a data frame
160		#'
161		#' @param x a \code{data.frame} object
162		#'
163		#' @return the same data frame as \code{x} stripped of variable labels
164		#'
165		#' @export
166		#'
167		#' @examples
168		#' x <- var_labels_remove(iris)
169		var_labels_remove <- function(x) {
170	1x	stopifnot(is.data.frame(x))
171
172	1x	for (i in seq_len(ncol(x))) {
173	11x	attr(x[[i]], "label") <- NULL
174		}
175
176	1x	x
177		}

1		formats_1d <- c(
2		"xx", "xx.", "xx.x", "xx.xx", "xx.xxx", "xx.xxxx",
3		"xx%", "xx.%", "xx.x%", "xx.xx%", "xx.xxx%", "(N=xx)", ">999.9", ">999.99",
4		"x.xxxx \| (<0.0001)"
5		)
6
7		formats_2d <- c(
8		"xx / xx", "xx. / xx.", "xx.x / xx.x", "xx.xx / xx.xx", "xx.xxx / xx.xxx",
9		"N=xx (xx%)", "xx (xx%)", "xx (xx.%)", "xx (xx.x%)", "xx (xx.xx%)",
10		"xx. (xx.%)", "xx.x (xx.x%)", "xx.xx (xx.xx%)",
11		"(xx, xx)", "(xx., xx.)", "(xx.x, xx.x)", "(xx.xx, xx.xx)",
12		"(xx.xxx, xx.xxx)", "(xx.xxxx, xx.xxxx)",
13		"xx - xx", "xx.x - xx.x", "xx.xx - xx.xx",
14		"xx (xx)", "xx. (xx.)", "xx.x (xx.x)", "xx.xx (xx.xx)",
15		"xx (xx.)", "xx (xx.x)", "xx (xx.xx)",
16		"xx.x, xx.x",
17		"xx.x to xx.x"
18		)
19
20		formats_3d <- c(
21		"xx. (xx. - xx.)",
22		"xx.x (xx.x - xx.x)",
23		"xx.xx (xx.xx - xx.xx)",
24		"xx.xxx (xx.xxx - xx.xxx)"
25		)
26
27		#' @title List with currently supported formats and vertical alignments
28		#'
29		#' @description We support `xx` style format labels grouped by 1d, 2d and 3d.
30		#' Currently valid format labels can not be added dynamically. Format functions
31		#' must be used for special cases.
32		#'
33		#' @return
34		#' * `list_valid_format_labels()`: A nested list, with elements listing the supported 1d, 2d,
35		#' and 3d format strings.
36		#'
37		#' @examples
38		#' list_valid_format_labels()
39		#'
40		#' @name list_formats
41		#' @export
42		list_valid_format_labels <- function() {
43	54x	structure(
44	54x	list(
45	54x	"1d" = formats_1d,
46	54x	"2d" = formats_2d,
47	54x	"3d" = formats_3d
48		),
49	54x	info = "xx does not modify the element, and xx. rounds a number to 0 digits"
50		)
51		}
52		#' @return
53		#' * `list_valid_aligns()`: a character vector of valid vertical alignments
54		#'
55		#' @examples
56		#' list_valid_aligns()
57		#'
58		#' @name list_formats
59		#' @export
60		list_valid_aligns <- function() {
61	5916x	c("left", "right", "center", "decimal", "dec_right", "dec_left")
62		}
63
64		#' @title Check if a format or alignment is supported
65		#'
66		#' @description Utility functions for checking formats and alignments.
67		#'
68		#' @param x either format string or an object returned by \code{sprintf_format}
69		#' @param stop_otherwise logical, if \code{x} is not a format should an error be
70		#' thrown
71		#'
72		#' @note No check if the function is actually a `formatter` is performed.
73		#'
74		#' @return
75		#' * `is_valid_format`: \code{TRUE} if \code{x} is \code{NULL}, a supported
76		#' format string, or a function; \code{FALSE} otherwise.
77		#'
78		#' @examples
79		#' is_valid_format("xx.x")
80		#' is_valid_format("fakeyfake")
81		#'
82		#' @name check_formats
83		#' @export
84		is_valid_format <- function(x, stop_otherwise = FALSE) {
85	51x	is_valid <- is.null(x) \|\| (length(x) == 1 && (is.function(x) \|\| x %in% unlist(list_valid_format_labels())))
86
87	51x	if (stop_otherwise && !is_valid) {
88	!	stop("format needs to be a format label, sprintf_format object, a function, or NULL")
89		}
90
91	51x	is_valid
92		}
93		#' @param algn vector of characters that indicates the requested cell alignments.
94		#'
95		#' @return
96		#' * `check_aligns`: `TRUE` if it passes the check.
97		#'
98		#' @examples
99		#' check_aligns(c("decimal", "dec_right"))
100		#'
101		#' @name check_formats
102		#' @export
103		check_aligns <- function(algn) {
104	!	if (anyNA(algn)) {
105	!	stop("Got missing-value for text alignment.")
106		}
107	!	invalid <- setdiff(algn, list_valid_aligns())
108	!	if (length(invalid) > 0) {
109	!	stop("Unsupported text-alignment(s): ", paste(invalid, collapse = ", "))
110		}
111	!	invisible(TRUE)
112		}
113
114		#' Specify text format via a `sprintf` format string
115		#'
116		#'
117		#' @param format character(1). A format string passed to `sprintf`.
118		#'
119		#' @export
120		#' @return A formatting function which wraps and will apply the specified \code{printf} style format
121		#' string \code{format}.
122		#' @seealso \code{\link[base]{sprintf}}
123		#'
124		#' @examples
125		#'
126		#' fmtfun <- sprintf_format("(N=%i")
127		#' format_value(100, format = fmtfun)
128		#'
129		#' fmtfun2 <- sprintf_format("%.4f - %.2f")
130		#' format_value(list(12.23456, 2.724))
131		sprintf_format <- function(format) {
132	1x	function(x, ...) {
133	1x	do.call(sprintf, c(list(fmt = format), x))
134		}
135		}
136
137
138		#' Round and prepare a value for display
139		#'
140		#' This function is used within \code{\link{format_value}} to prepare numeric values within
141		#' cells for formatting and display.
142		#'
143		#' @aliases rounding
144		#' @param x numeric(1). Value to format
145		#' @param digits numeric(1). Number of digits to round to, or \code{NA} to convert to a
146		#' character value with no rounding.
147		#' @param na_str character(1). The value to return if \code{x} is \code{NA}.
148		#'
149		#' @details
150		#' This function combines the rounding behavior of R's standards-complaint
151		#' \code{\link{round}} function (see the Details section of that documentation)
152		#' with the strict decimal display of \code{\link{sprintf}}. The exact behavior
153		#' is as follows:
154		#'
155		#' \enumerate{
156		#' \item{If \code{x} is NA, the value of \code{na_str} is returned}
157		#' \item{If \code{x} is non-NA but \code{digits} is NA, \code{x} is converted to a character
158		#' and returned}
159		#' \item{If \code{x} and \code{digits} are both non-NA, \code{round} is called first,
160		#' and then \code{sprintf} is used to convert the rounded value to a character with the
161		#' appropriate number of trailing zeros enforced.}
162		#' }
163		#'
164		#' @return A character value representing the value after rounding, containing
165		#' containing any trailling zeros required to display \emph{exactly} \code{digits}
166		#' elements.
167		#' @note
168		#' This differs from the base R \code{\link{round}} function in that \code{NA}
169		#' digits indicate x should be passed converted to character and returned unchanged
170		#' whereas \code{round(x, digits =NA)} returns \code{NA} for all values of \code{x}.
171		#'
172		#' This behavior will differ from \code{as.character(round(x, digits = digits))}
173		#' in the case where there are not at least \code{digits} significant digits
174		#' after the decimal that remain after rounding. It \emph{may} differ from
175		#' \code{sprintf("\%.Nf", x)} for values ending in \code{5} after the decimal place
176		#' on many popular operating systems due to \code{round}'s stricter adherence to the
177		#' `IEC 60559` standard, particularly for R versions > 4.0.0 (see Warning in \code{\link[base:round]{round}}
178		#' documentation).
179		#'
180		#' @export
181		#' @seealso \code{link{format_value}} \code{\link[base:round]{round}} \code{\link[base:sprintf]{sprintf}}
182		#' @examples
183		#'
184		#' round_fmt(0, digits = 3)
185		#' round_fmt(.395, digits = 2)
186		#' round_fmt(NA, digits = 1)
187		#' round_fmt(NA, digits = 1, na_str = "-")
188		#' round_fmt(2.765923, digits = NA)
189		round_fmt <- function(x, digits, na_str = "NA") {
190	193x	if (!is.na(digits) && digits < 0) {
191	!	stop("round_fmt currentlyd does not support non-missing values of digits <0")
192		}
193	193x	if (is.na(x)) {
194	4x	na_str
195	189x	} else if (is.na(digits)) {
196	41x	paste0(x)
197		} else {
198	148x	sprfmt <- paste0("%.", digits, "f")
199	148x	sprintf(fmt = sprfmt, round(x, digits = digits))
200		}
201		}
202
203
204
205		val_pct_helper <- function(x, dig1, dig2, na_str, pct = TRUE) {
206	32x	if (pct) {
207	18x	x[2] <- x[2] * 100
208		}
209	32x	if (length(na_str) == 1) {
210	!	na_str <- rep(na_str, 2)
211		}
212	32x	paste0(
213	32x	round_fmt(x[1], digits = dig1, na_str = na_str[1]),
214		" (",
215	32x	round_fmt(x[2], digits = dig2, na_str = na_str[2]),
216	32x	if (pct) "%", ")"
217		)
218		}
219
220		sep_2d_helper <- function(x, dig1, dig2, sep, na_str, wrap = NULL) {
221	43x	ret <- paste(mapply(round_fmt, x = x, digits = c(dig1, dig2), na_str = na_str),
222	43x	collapse = sep
223		)
224	43x	if (!is.null(wrap)) {
225	20x	ret <- paste(c(wrap[1], ret, wrap[2]), collapse = "")
226		}
227	43x	ret
228		}
229
230		## na_or_round <- function(x, digits, na_str) {
231		## if(is.na(x))
232		## na_str
233		## else
234		## round(x, digits = digits)
235
236		## }
237
238		#' Converts a (possibly compound) value into a string using the \code{format} information
239		#'
240		#' @details A length-zero value for `na_str` will be interpreted as `"NA"`, as will any
241		#' missing values within a non-length-zero `na_str` vector.
242		#'
243		#' @param x ANY. The value to be formatted
244		#' @param format character(1) or function. The format label (string) or `formatter` function to apply to \code{x}.
245		#' @param na_str character(1). String that should be displayed when the value of \code{x} is missing.
246		#' Defaults to \code{"NA"}.
247		#' @param output character(1). output type
248		#'
249		#' @return formatted text representing the cell \code{x}.
250		#' @export
251		#'
252		#' @seealso [round_fmt()]
253		#' @examples
254		#'
255		#' x <- format_value(pi, format = "xx.xx")
256		#' x
257		#'
258		#' format_value(x, output = "ascii")
259		#'
260		format_value <- function(x, format = NULL, output = c("ascii", "html"), na_str = "NA") {
261		## if(is(x, "CellValue"))
262		## x = x[[1]]
263
264	5073x	if (length(x) == 0) {
265	1x	return("")
266		}
267
268	5072x	output <- match.arg(output)
269	5072x	if (length(na_str) == 0) {
270	1x	na_str <- "NA"
271		}
272	5072x	if (any(is.na(na_str))) {
273	1x	na_str[is.na(na_str)] <- "NA"
274		}
275		## format <- if (!missing(format)) format else obj_format(x)
276
277
278	5072x	txt <- if (all(is.na(x)) && length(na_str) == 1L) {
279	21x	na_str
280	5072x	} else if (is.null(format)) {
281	!	toString(x)
282	5072x	} else if (is.function(format)) {
283	1x	format(x, output = output)
284	5072x	} else if (is.character(format)) {
285	5050x	l <- if (format %in% formats_1d) {
286	4972x	1
287	5050x	} else if (format %in% formats_2d) {
288	69x	2
289	5050x	} else if (format %in% formats_3d) {
290	8x	3
291		} else {
292	1x	stop(
293	1x	"unknown format label: ", format,
294	1x	". use list_valid_format_labels() to get a list of all formats"
295		)
296		}
297	5049x	if (format != "xx" && length(x) != l) {
298	2x	stop(
299	2x	"cell <", paste(x), "> and format ",
300	2x	format, " are of different length"
301		)
302		}
303	5047x	if (length(na_str) < length(x)) {
304	73x	na_str <- rep(na_str, length.out = length(x))
305		}
306	5047x	switch(format,
307	4934x	"xx" = as.character(x),
308	3x	"xx." = round_fmt(x, digits = 0, na_str = na_str),
309	6x	"xx.x" = round_fmt(x, digits = 1, na_str = na_str),
310	3x	"xx.xx" = round_fmt(x, digits = 2, na_str = na_str),
311	3x	"xx.xxx" = round_fmt(x, digits = 3, na_str = na_str),
312	3x	"xx.xxxx" = round_fmt(x, digits = 4, na_str = na_str),
313	2x	"xx%" = paste0(round_fmt(x * 100, digits = NA, na_str = na_str), "%"),
314	2x	"xx.%" = paste0(round_fmt(x * 100, digits = 0, na_str = na_str), "%"),
315	2x	"xx.x%" = paste0(round_fmt(x * 100, digits = 1, na_str = na_str), "%"),
316	2x	"xx.xx%" = paste0(round_fmt(x * 100, digits = 2, na_str = na_str), "%"),
317	2x	"xx.xxx%" = paste0(round_fmt(x * 100, digits = 3, na_str = na_str), "%"),
318	1x	"(N=xx)" = paste0("(N=", round_fmt(x, digits = NA, na_str = na_str), ")"),
319	3x	">999.9" = ifelse(x > 999.9, ">999.9", round_fmt(x, digits = 1, na_str = na_str)),
320	3x	">999.99" = ifelse(x > 999.99, ">999.99", round_fmt(x, digits = 2, na_str = na_str)),
321	3x	"x.xxxx \| (<0.0001)" = ifelse(x < 0.0001, "<0.0001", round_fmt(x, digits = 4, na_str = na_str)),
322	2x	"xx / xx" = sep_2d_helper(x, dig1 = NA, dig2 = NA, sep = " / ", na_str = na_str),
323	2x	"xx. / xx." = sep_2d_helper(x, dig1 = 0, dig2 = 0, sep = " / ", na_str = na_str),
324	2x	"xx.x / xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " / ", na_str = na_str),
325	2x	"xx.xx / xx.xx" = sep_2d_helper(x, dig1 = 2, dig2 = 2, sep = " / ", na_str = na_str),
326	2x	"xx.xxx / xx.xxx" = sep_2d_helper(x, dig1 = 3, dig2 = 3, sep = " / ", na_str = na_str),
327	2x	"N=xx (xx%)" = paste0("N=", val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str)),
328	3x	"xx (xx%)" = val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str),
329	2x	"xx (xx.%)" = val_pct_helper(x, dig1 = NA, dig2 = 0, na_str = na_str),
330	2x	"xx (xx.x%)" = val_pct_helper(x, dig1 = NA, dig2 = 1, na_str = na_str),
331	2x	"xx (xx.xx%)" = val_pct_helper(x, dig1 = NA, dig2 = 2, na_str = na_str),
332	2x	"xx. (xx.%)" = val_pct_helper(x, dig1 = 0, dig2 = 0, na_str = na_str),
333	3x	"xx.x (xx.x%)" = val_pct_helper(x, dig1 = 1, dig2 = 1, na_str = na_str),
334	2x	"xx.xx (xx.xx%)" = val_pct_helper(x, dig1 = 2, dig2 = 2, na_str = na_str),
335	2x	"(xx, xx)" = sep_2d_helper(x,
336	2x	dig1 = NA, dig2 = NA, sep = ", ",
337	2x	na_str = na_str, wrap = c("(", ")")
338		),
339	2x	"(xx., xx.)" = sep_2d_helper(x,
340	2x	dig1 = 0, dig2 = 0, sep = ", ",
341	2x	na_str = na_str, wrap = c("(", ")")
342		),
343	2x	"(xx.x, xx.x)" = sep_2d_helper(x,
344	2x	dig1 = 1, dig2 = 1, sep = ", ",
345	2x	na_str = na_str, wrap = c("(", ")")
346		),
347	2x	"(xx.xx, xx.xx)" = sep_2d_helper(x,
348	2x	dig1 = 2, dig2 = 2, sep = ", ",
349	2x	na_str = na_str, wrap = c("(", ")")
350		),
351	2x	"(xx.xxx, xx.xxx)" = sep_2d_helper(x,
352	2x	dig1 = 3, dig2 = 3, sep = ", ",
353	2x	na_str = na_str, wrap = c("(", ")")
354		),
355	2x	"(xx.xxxx, xx.xxxx)" = sep_2d_helper(x,
356	2x	dig1 = 4, dig2 = 4, sep = ", ",
357	2x	na_str = na_str, wrap = c("(", ")")
358		),
359	2x	"xx - xx" = sep_2d_helper(x, dig1 = NA, dig2 = NA, sep = " - ", na_str = na_str),
360	5x	"xx.x - xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " - ", na_str = na_str),
361	2x	"xx.xx - xx.xx" = sep_2d_helper(x, dig1 = 2, dig2 = 2, sep = " - ", na_str = na_str),
362	2x	"xx (xx)" = val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str, pct = FALSE),
363	2x	"xx. (xx.)" = val_pct_helper(x, dig1 = 0, dig2 = 0, na_str = na_str, pct = FALSE),
364	2x	"xx.x (xx.x)" = val_pct_helper(x, dig1 = 1, dig2 = 1, na_str = na_str, pct = FALSE),
365	2x	"xx.xx (xx.xx)" = val_pct_helper(x, dig1 = 2, dig2 = 2, na_str = na_str, pct = FALSE),
366	2x	"xx (xx.)" = val_pct_helper(x, dig1 = NA, dig2 = 0, na_str = na_str, pct = FALSE),
367	2x	"xx (xx.x)" = val_pct_helper(x, dig1 = NA, dig2 = 1, na_str = na_str, pct = FALSE),
368	2x	"xx (xx.xx)" = val_pct_helper(x, dig1 = NA, dig2 = 2, na_str = na_str, pct = FALSE),
369	2x	"xx.x, xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = ", ", na_str = na_str),
370	2x	"xx.x to xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " to ", na_str = na_str),
371	2x	"xx.xx (xx.xx - xx.xx)" = paste0(
372	2x	round_fmt(x[1], digits = 2, na_str = na_str[1]), " ",
373	2x	sep_2d_helper(x[2:3],
374	2x	dig1 = 2, dig2 = 2,
375	2x	sep = " - ", na_str = na_str[2:3],
376	2x	wrap = c("(", ")")
377		)
378		),
379	2x	"xx. (xx. - xx.)" = paste0(
380	2x	round_fmt(x[1], digits = 0, na_str = na_str[1]), " ",
381	2x	sep_2d_helper(x[2:3],
382	2x	dig1 = 0, dig2 = 0,
383	2x	sep = " - ", na_str = na_str[2:3],
384	2x	wrap = c("(", ")")
385		)
386		),
387	2x	"xx.x (xx.x - xx.x)" = paste0(
388	2x	round_fmt(x[1], digits = 1, na_str = na_str[1]), " ",
389	2x	sep_2d_helper(x[2:3],
390	2x	dig1 = 1, dig2 = 1,
391	2x	sep = " - ", na_str = na_str[2:3],
392	2x	wrap = c("(", ")")
393		)
394		),
395	2x	"xx.xxx (xx.xxx - xx.xxx)" = paste0(
396	2x	round_fmt(x[1], digits = 3, na_str = na_str[1]), " ",
397	2x	sep_2d_helper(x[2:3],
398	2x	dig1 = 3, dig2 = 3,
399	2x	sep = " - ", na_str = na_str[2:3],
400	2x	wrap = c("(", ")")
401		)
402		),
403	!	paste("format string", format, "not found")
404		)
405		}
406	5069x	txt[is.na(txt)] <- na_str
407	5069x	if (output == "ascii") {
408	5068x	txt
409	1x	} else if (output == "html") {
410		## convert to tagList
411		## convert \n to <br/>
412
413	1x	if (identical(txt, "")) {
414	!	txt
415		} else {
416	1x	els <- unlist(strsplit(txt, "\n", fixed = TRUE))
417	1x	Map(function(el, is.last) {
418	1x	tagList(el, if (!is.last) tags$br() else NULL)
419	1x	}, els, c(rep(FALSE, length(els) - 1), TRUE))
420		}
421		} else {
422	!	txt
423		}
424		}
425
426		setClassUnion("FormatSpec", c("NULL", "character", "function", "list"))
427		setClassUnion("characterOrNULL", c("NULL", "character"))
428		setClass("fmt_config",
429		slots = c(
430		format = "FormatSpec",
431		format_na_str = "characterOrNULL",
432		align = "characterOrNULL"
433		)
434		)
435
436		#' Format Configuration
437		#'
438		#' @param format character(1) or function. A format label (string) or `formatter` function.
439		#' @param na_str character(1). String that should be displayed in place of missing values.
440		#' @param align character(1). Alignment values should be rendered with.
441		#'
442		#' @return An object of class `fmt_config` which contains the following elements:
443		#' * `format`
444		#' * `na_str`
445		#' * `align`
446		#'
447		#' @examples
448		#' fmt_config(format = "xx.xx", na_str = "-", align = "left")
449		#' fmt_config(format = "xx.xx - xx.xx", align = "right")
450		#'
451		#' @export
452		fmt_config <- function(format = NULL, na_str = "NA", align = "center") {
453	2x	new("fmt_config", format = format, format_na_str = na_str, align = align)
454		}

1		.need_pag <- function(page_type, pg_width, pg_height, cpp, lpp) {
2	!	!(is.null(page_type) && is.null(pg_width) && is.null(pg_height) && is.null(cpp) && is.null(lpp))
3		}
4
5		#' Export a table-like object to plain (ASCII) text with page break
6		#'
7		#' This function converts \code{x} to a \code{MatrixPrintForm} object via
8		#' \code{matrix_form}, paginates it via \code{paginate}, converts each
9		#' page to ASCII text via \code{toString}, and emits the strings to \code{file},
10		#' separated by \code{page_break}.
11		#'
12		#' @inheritParams paginate_indices
13		#' @inheritParams toString
14		#' @inheritParams propose_column_widths
15		#' @param x ANY. The table-like object to export. Must have an
16		#' applicable \code{matrix_form} method.
17		#' @param file character(1) or NULL. If non-NULL, the path to write a
18		#' text file to containing the \code{x} rendered as ASCII text,
19		#' @param page_break character(1). Page break symbol (defaults to
20		#' outputting \code{"\\n\\s"}).
21		#' @param paginate logical(1). Whether pagination should be performed,
22		#' defaults to \code{TRUE} if page size is specified (including
23		#' the default).
24		#' @details if \code{x} has an \code{num_rep_cols} method, the value
25		#' returned by it will be used for \code{rep_cols} by default, if
26		#' not, 0 will be used.
27		#'
28		#' If \code{x} has an applicable \code{do_mand_paginate} method, it will be invoked
29		#' during the pagination process.
30		#'
31		#' @return if \code{file} is NULL, the total paginated and then concatenated
32		#' string value, otherwise the file that was written.
33		#' @export
34		#' @examples
35		#' export_as_txt(basic_matrix_form(mtcars), pg_height = 5, pg_width = 4)
36		export_as_txt <- function(x,
37		file = NULL,
38		page_type = NULL,
39		landscape = FALSE,
40		pg_width = page_dim(page_type)[if (landscape) 2 else 1],
41		pg_height = page_dim(page_type)[if (landscape) 1 else 2],
42		font_family = "Courier",
43		font_size = 8, # grid parameters
44		lineheight = 1L,
45		margins = c(top = .5, bottom = .5, left = .75, right = .75),
46		paginate = TRUE,
47		cpp = NA_integer_,
48		lpp = NA_integer_,
49		...,
50		hsep = NULL,
51		indent_size = 2,
52		tf_wrap = paginate,
53		max_width = NULL,
54		colwidths = NULL,
55		min_siblings = 2,
56		nosplitin = character(),
57		rep_cols = num_rep_cols(x),
58		verbose = FALSE,
59		page_break = "\\s\\n") {
60	4x	if (paginate) {
61	4x	pages <- paginate_to_mpfs(
62	4x	x,
63	4x	page_type = page_type,
64	4x	font_family = font_family,
65	4x	font_size = font_size,
66	4x	lineheight = lineheight,
67	4x	landscape = landscape,
68	4x	pg_width = pg_width,
69	4x	pg_height = pg_height,
70	4x	margins = margins,
71	4x	lpp = lpp,
72	4x	cpp = cpp,
73	4x	min_siblings = min_siblings,
74	4x	nosplitin = nosplitin,
75	4x	colwidths = colwidths,
76	4x	tf_wrap = tf_wrap,
77	4x	max_width = max_width,
78	4x	indent_size = indent_size,
79	4x	verbose = verbose,
80	4x	rep_cols = rep_cols
81		)
82		} else {
83	!	mf <- matrix_form(x, TRUE, TRUE, indent_size = indent_size)
84	!	mf_col_widths(mf) <- colwidths %\|\|% propose_column_widths(mf)
85	!	pages <- list(mf)
86		}
87		## we dont' set widths here because we already but that info on mpf
88		## so its on each of the pages.
89	4x	strings <- vapply(
90	4x	pages, toString, "",
91	4x	widths = NULL,
92	4x	hsep = hsep, tf_wrap = tf_wrap, max_width = max_width
93		)
94	4x	res <- paste(strings, collapse = page_break)
95
96	4x	if (is.null(file)) {
97	2x	res
98		} else {
99	2x	cat(res, file = file)
100		}
101		}
102
103
104
105		## ## TODO this needs to be in terms of a MPF, so ncol(tt) needs to change
106
107		## ## if(!is.null(colwidths) && length(colwidths) != ncol(tt) + 1)
108		## ## stop("non-null colwidths argument must have length ncol(tt) + 1 [",
109		## ## ncol(tt) + 1, "], got length ", length(colwidths))
110
111		## mpf <- matrix_form(x, indent_rownames = TRUE)
112
113		## ps_spec <- calc_lcpp(page_type = page_type,
114		## landscape = landscape,
115		## pg_width = pg_width,
116		## pg_height = pg_height,
117		## font_family = font_family,
118		## cpp = cpp,
119		## lpp = lpp)
120
121		## ## This needs to return list(x) in cases where no pagination was necessary
122		## idx_lst <- paginate(mpf, .page_size_spec = ps_spec, colwidths = colwidths,
123		## tf_wrap = tf_wrap, ## XXX I think we don't need this
124		## ...)
125
126		## tbls <- lapply(idx_lst, function(ii)
127		## ## XXX how do we partition the colwidths ???
128		## ## Also this is gross make it a function!!!
129		## res <- paste(mapply(function(tb, cwidths, ...) {
130		## ## 1 and +1 are because cwidths includes rowlabel 'column'
131		## cinds <- c(1, .figure_out_colinds(tb, tt) + 1L)
132		## toString(tb, widths = cwidths[cinds], ...)
133		## },
134		## MoreArgs = list(hsep = hsep,
135		## indent_size = indent_size,
136		## tf_wrap = tf_wrap,
137		## max_width = max_width,
138		## cwidths = colwidths),
139		## SIMPLIFY = FALSE,
140		## tb = tbls),
141		## collapse = page_break)
142
143		## if(!is.null(file))
144		## cat(res, file = file)
145		## else
146		## res
147		## }
148
149
150
151
152		## In use, must be tested
153		prep_header_line <- function(mf, i) {
154	2x	ret <- mf$strings[i, mf$display[i, , drop = TRUE], drop = TRUE]
155	2x	ret
156		}
157
158		## margin_lines_to_in <- function(margins, font_size, font_family) {
159		## tmpfile <- tempfile(fileext = ".pdf")
160		## gp_plot <- gpar(fontsize = font_size, fontfamily = font_family)
161		## pdf(file = tmpfile, width = 20, height = 20)
162		## on.exit({
163		## dev.off()
164		## file.remove(tmpfile)
165		## })
166		## grid.newpage()
167		## pushViewport(plotViewport(margins = margins, gp = gp_plot))
168		## c(
169		## bottom = convertHeight(unit(margins["bottom"], "lines"), "inches", valueOnly = TRUE),
170		## left = convertWidth(unit(1, "strwidth", strrep("m", margins["left"])), "inches", valueOnly = TRUE),
171		## top = convertHeight(unit(margins["top"], "lines"), "inches", valueOnly = TRUE),
172		## right = convertWidth(unit(1, "strwidth", strrep("m", margins["right"])), "inches", valueOnly = TRUE)
173		## )
174		## }
175
176
177
178
179		mpf_to_dfbody <- function(mpf, colwidths) {
180	2x	mf <- matrix_form(mpf, indent_rownames = TRUE)
181	2x	nlr <- mf_nlheader(mf)
182	2x	if (is.null(colwidths)) {
183	!	colwidths <- propose_column_widths(mf)
184		}
185	2x	mf$strings[1:nlr, 1] <- ifelse(nzchar(mf$strings[1:nlr, 1, drop = TRUE]),
186	2x	mf$strings[1:nlr, 1, drop = TRUE],
187	2x	strrep(" ", colwidths)
188		)
189
190
191	2x	myfakedf <- as.data.frame(tail(mf$strings, -nlr))
192	2x	myfakedf
193		}
194
195
196		#' Transform `MPF` to `RTF`
197		#'
198		#' Experimental export to `RTF` via the `r2rtf` package
199		#'
200		#' @inheritParams page_lcpp
201		#' @inheritParams toString
202		#' @inheritParams grid::plotViewport
203		#' @param mpf `MatrixPrintForm`. `MatrixPrintForm` object.
204		#' @param colwidths character(1). Column widths.
205		#' @details This function provides a low-level coercion of a
206		#' `MatrixPrintForm` object into text containing the corresponding
207		#' table in `RTF`. Currently, no pagination is done at this level,
208		#' and should be done prior to calling this function, though that
209		#' may change in the future.
210		#'
211		#' @return An `RTF` object
212		#' @export
213		mpf_to_rtf <- function(mpf,
214		colwidths = NULL,
215		page_type = "letter",
216		pg_width = page_dim(page_type)[if (landscape) 2 else 1],
217		pg_height = page_dim(page_type)[if (landscape) 1 else 2],
218		landscape = FALSE,
219		margins = c(4, 4, 4, 4),
220		font_size = 8,
221		...) {
222	2x	if (!requireNamespace("r2rtf")) {
223	!	stop("RTF export requires the 'r2rtf' package, please install it.")
224		}
225	2x	mpf <- matrix_form(mpf, indent_rownames = TRUE)
226	2x	nlr <- mf_nlheader(mpf)
227	2x	if (is.null(colwidths)) {
228	!	colwidths <- propose_column_widths(mpf)
229		}
230	2x	mpf$strings[1:nlr, 1] <- ifelse(nzchar(mpf$strings[1:nlr, 1, drop = TRUE]),
231	2x	mpf$strings[1:nlr, 1, drop = TRUE],
232	2x	strrep(" ", colwidths)
233		)
234
235	2x	myfakedf <- mpf_to_dfbody(mpf, colwidths)
236
237	2x	rtfpg <- r2rtf::rtf_page(myfakedf,
238	2x	width = pg_width,
239	2x	height = pg_height,
240	2x	orientation = if (landscape) "landscape" else "portrait",
241	2x	margin = c(0.1, 0.1, 0.1, 0.1, 0.1, 0.1),
242	2x	nrow = 10000L
243	2x	) ## dont allow r2rtf to restrict lines per page beyond actual real eastate
244	2x	rtfpg <- r2rtf::rtf_title(rtfpg, main_title(mpf), subtitles(mpf), text_font = 1)
245	2x	for (i in seq_len(nlr)) {
246	2x	hdrlndat <- prep_header_line(mpf, i)
247	2x	rtfpg <- r2rtf::rtf_colheader(rtfpg,
248	2x	paste(hdrlndat, collapse = " \| "),
249	2x	col_rel_width = unlist(tapply(colwidths,
250	2x	cumsum(mpf$display[i, , drop = TRUE]),
251	2x	sum,
252	2x	simplify = FALSE
253		)),
254	2x	border_top = c("", rep(if (i > 1) "single" else "", length(hdrlndat) - 1)),
255	2x	text_font = 9, ## this means Courier New for some insane reason
256	2x	text_font_size = font_size
257		)
258		}
259
260	2x	rtfpg <- r2rtf::rtf_body(rtfpg,
261	2x	col_rel_width = colwidths,
262	2x	text_justification = c("l", rep("c", ncol(myfakedf) - 1)),
263	2x	text_format = "",
264	2x	text_font = 9,
265	2x	text_font_size = font_size
266		)
267
268	2x	for (i in seq_along(mpf$ref_footnotes)) {
269	4x	rtfpg <- r2rtf::rtf_footnote(rtfpg,
270	4x	mpf$ref_footnotes[i],
271	4x	border_top = if (i == 1) "single" else "",
272	4x	border_bottom = if (i == length(mpf$ref_footnotes)) "single" else "",
273	4x	text_font = 9
274		)
275		}
276
277	2x	if (length(main_footer(mpf)) > 0) {
278	2x	rtfpg <- r2rtf::rtf_footnote(rtfpg, main_footer(mpf), text_font = 9)
279		}
280	2x	if (length(prov_footer(mpf)) > 0) {
281	2x	rtfpg <- r2rtf::rtf_source(rtfpg, prov_footer(mpf), text_font = 9)
282		}
283
284	2x	rtfpg
285		}
286
287		## Not currently in use, previous alternate ways to get to RTF
288
289		## ## XXX Experimental. Not to be exported without approval
290		## mpf_to_huxtable <- function(obj) {
291		## if (!requireNamespace("huxtable")) {
292		## stop("mpf_to_huxtable requires the huxtable package")
293		## }
294		## mf <- matrix_form(obj, indent_rownames = TRUE)
295		## nlr <- mf_nlheader(mf)
296		## myfakedf <- as.data.frame(tail(mf$strings, -nlr))
297		## ret <- huxtable::as_hux(myfakedf, add_colnames = FALSE)
298		## mf$strings[!mf$display] <- ""
299		## for (i in seq_len(nlr)) {
300		## arglist <- c(
301		## list(ht = ret, after = i - 1),
302		## as.list(mf$strings[i, ])
303		## )
304		## ret <- do.call(huxtable::insert_row, arglist)
305
306		## spanspl <- split(
307		## seq_len(ncol(mf$strings)),
308		## cumsum(mf$display[i, ])
309		## )
310
311
312		## for (j in seq_along(spanspl)) {
313		## if (length(spanspl[[j]]) > 1) {
314		## ret <- huxtable::merge_cells(ret, row = i, col = spanspl[[j]])
315		## }
316		## }
317		## }
318		## ret <- huxtable::set_header_rows(ret, seq_len(nlr), TRUE)
319		## huxtable::font(ret) <- "courier"
320		## huxtable::font_size(ret) <- 6
321		## huxtable::align(ret)[
322		## seq_len(nrow(ret)),
323		## seq_len(ncol(ret))
324		## ] <- mf$aligns
325		## ret
326		## }
327
328		## ## XXX Experimental. Not to be exported without approval
329		## mpf_to_rtf <- function(obj, ..., file) {
330		## huxt <- mpf_to_huxtable(obj)
331		## ## a bunch more stuff here
332		## huxtable::quick_rtf(huxt, ..., file = file)
333		## }
334
335
336
337
338		## ## XXX Experimental. Not to be exported without approval
339		## mpf_to_gt <- function(obj) {
340		## requireNamespace("gt")
341		## mf <- matrix_form(obj, indent_rownames = TRUE)
342		## nlh <- mf_nlheader(mf)
343		## body_df <- as.data.frame(mf$strings[-1 * seq_len(nlh), ])
344		## varnamerow <- mf_nrheader(mf)
345		## ## detect if we have counts
346		## if (any(nzchar(mf$formats[seq_len(nlh), ]))) {
347		## varnamerow <- varnamerow - 1
348		## }
349
350		## rlbl_lst <- as.list(mf$strings[nlh, , drop = TRUE])
351		## names(rlbl_lst) <- names(body_df)
352
353		## ret <- gt::gt(body_df, rowname_col = "V1")
354		## ret <- gt::cols_label(ret, .list = rlbl_lst)
355		## if (nlh > 1) {
356		## for (i in 1:(nlh - 1)) {
357		## linedat <- mf$strings[i, , drop = TRUE]
358		## splvec <- cumsum(mf$display[i, , drop = TRUE])
359		## spl <- split(seq_along(linedat), splvec)
360		## for (j in seq_along(spl)) {
361		## vns <- names(body_df)[spl[[j]]]
362		## labval <- linedat[spl[[j]][1]]
363		## ret <- gt::tab_spanner(ret,
364		## label = labval,
365		## columns = {{ vns }},
366		## level = nlh - i,
367		## id = paste0(labval, j)
368		## )
369		## }
370		## }
371		## }
372
373		## ret <- gt::opt_css(ret, css = "th.gt_left { white-space:pre;}")
374
375		## ret
376		## }
377
378
379
380		#' Export table to `RTF`
381		#'
382		#' Experimental export to the `RTF` format.
383		#'
384		#' @details `RTF` export occurs by via the following steps
385		#'
386		#' \itemize{
387		#' \item{the table is paginated to the page size (Vertically and horizontally)}
388		#' \item{Each separate page is converted to a `MatrixPrintForm` and from there to `RTF`-encoded text}
389		#' \item{Separate `RTFs` text chunks are combined and written out as a single `RTF` file}
390		#' }
391		#'
392		#' Conversion of `MatrixPrintForm` objects to `RTF` is done via [formatters::mpf_to_rtf()].
393		#' @inheritParams export_as_txt
394		#' @inheritParams toString
395		#' @inheritParams grid::plotViewport
396		#' @inheritParams paginate_to_mpfs
397		#' @export
398
399		export_as_rtf <- function(x,
400		file = NULL,
401		colwidths = propose_column_widths(matrix_form(x, TRUE)),
402		page_type = "letter",
403		pg_width = page_dim(page_type)[if (landscape) 2 else 1],
404		pg_height = page_dim(page_type)[if (landscape) 1 else 2],
405		landscape = FALSE,
406		margins = c(bottom = .5, left = .75, top = .5, right = .75),
407		font_size = 8,
408		font_family = "Courier",
409		...) {
410	1x	if (!requireNamespace("r2rtf")) {
411	!	stop("RTF export requires the r2rtf package, please install it.")
412		}
413	1x	if (is.null(names(margins))) {
414	!	names(margins) <- marg_order
415		}
416
417	1x	fullmf <- matrix_form(x, indent_rownames = TRUE)
418	1x	req_ncols <- ncol(fullmf) + as.numeric(mf_has_rlabels(fullmf))
419	1x	if (!is.null(colwidths) && length(colwidths) != req_ncols) {
420	!	stop(
421	!	"non-null colwidths argument must have length ncol(x) (+ 1 if row labels are present) [",
422	!	req_ncols, "], got length ", length(colwidths)
423		)
424		}
425
426	1x	true_width <- pg_width - sum(margins[c("left", "right")])
427	1x	true_height <- pg_height - sum(margins[c("top", "bottom")])
428
429	1x	mpfs <- paginate_to_mpfs(
430	1x	fullmf,
431	1x	font_family = font_family, font_size = font_size,
432	1x	pg_width = true_width,
433	1x	pg_height = true_height,
434	1x	margins = c(bottom = 0, left = 0, top = 0, right = 0),
435	1x	lineheight = 1.25,
436	1x	colwidths = colwidths,
437		...
438		)
439
440	1x	rtftxts <- lapply(mpfs, function(mf) {
441	2x	r2rtf::rtf_encode(mpf_to_rtf(mf,
442	2x	colwidths = mf_col_widths(mf),
443	2x	page_type = page_type,
444	2x	pg_width = pg_width,
445	2x	pg_height = pg_height,
446	2x	font_size = font_size,
447	2x	margins = c(top = 0, left = 0, bottom = 0, right = 0)
448		))
449		})
450	1x	restxt <- paste(
451	1x	rtftxts[[1]]$start,
452	1x	paste(
453	1x	sapply(rtftxts, function(x) x$body),
454	1x	collapse = "\n{\\pard\\fs2\\par}\\page{\\pard\\fs2\\par}\n"
455		),
456	1x	rtftxts[[1]]$end
457		)
458	1x	if (!is.null(file)) {
459	1x	cat(restxt, file = file)
460		} else {
461	!	restxt
462		}
463		}
464
465
466		#' Export as PDF
467		#'
468		#' The PDF output is based on the ASCII output created with [toString()]
469		#'
470		#' @inheritParams export_as_txt
471		#' @param file file to write, must have `.pdf` extension
472		#' @param width Deprecated, please use `pg_width` or specify
473		#' `page_type`. The width of the graphics region in inches
474		#' @param height Deprecated, please use `pg_height` or specify
475		#' `page_type`. The height of the graphics region in inches
476		#' @param fontsize Deprecated, please use `font_size`. The size of
477		#' text (in points)
478		#' @param margins numeric(4). The number of lines/characters of margin on the
479		#' bottom, left, top, and right sides of the page.
480		#'
481		#' @importFrom grDevices pdf
482		#' @importFrom grid textGrob grid.newpage gpar pushViewport plotViewport unit grid.draw
483		#' convertWidth convertHeight grobHeight grobWidth
484		#'
485		#' @details By default, pagination is performed with default
486		#' `cpp` and `lpp` defined by specified page dimensions and margins.
487		#' User-specified `lpp` and `cpp` values override this, and should
488		#' be used with caution.
489		#'
490		#' Title and footer materials are also word-wrapped by default
491		#' (unlike when printed to the terminal), with `cpp`, as
492		#' defined above, as the default `max_width`.
493		#'
494		#' @seealso [export_as_txt()]
495		#'
496		#' @importFrom grid textGrob get.gpar
497		#' @importFrom grDevices dev.off
498		#' @importFrom tools file_ext
499		#' @export
500		#'
501		#' @examples
502		#' \dontrun{
503		#' tf <- tempfile(fileext = ".pdf")
504		#' export_as_pdf(basic_matrix_form(mtcars), file = tf, pg_height = 4)
505		#'
506		#' tf <- tempfile(fileext = ".pdf")
507		#' export_as_pdf(basic_matrix_form(mtcars), file = tf, lpp = 8)
508		#' }
509		export_as_pdf <- function(x,
510		file,
511		page_type = "letter",
512		landscape = FALSE,
513		pg_width = page_dim(page_type)[if (landscape) 2 else 1],
514		pg_height = page_dim(page_type)[if (landscape) 1 else 2],
515		width = NULL,
516		height = NULL, # passed to pdf()
517		margins = c(4, 4, 4, 4),
518		min_siblings = 2,
519		font_family = "Courier",
520		font_size = 8,
521		fontsize = font_size,
522		paginate = TRUE,
523		lpp = NULL,
524		cpp = NULL,
525		hsep = "-",
526		indent_size = 2,
527		tf_wrap = TRUE,
528		max_width = NULL,
529		colwidths = propose_column_widths(x)) {
530	!	stopifnot(tools::file_ext(file) != ".pdf")
531	!	if (!is.null(colwidths) && length(colwidths) != ncol(x) + 1) {
532	!	stop(
533	!	"non-null colwidths argument must have length ncol(x) + 1 [",
534	!	ncol(x) + 1, "], got length ", length(colwidths)
535		)
536		}
537	!	gp_plot <- grid::gpar(fontsize = font_size, fontfamily = font_family)
538
539	!	if (!is.null(height)) {
540	!	pg_height <- height
541		}
542
543	!	if (!is.null(width)) {
544	!	pg_width <- width
545		}
546
547	!	if (missing(font_size) && !missing(fontsize)) {
548	!	font_size <- fontsize
549		}
550	!	pdf(file = file, width = pg_width, height = pg_height)
551	!	on.exit(dev.off())
552	!	grid::grid.newpage()
553	!	grid::pushViewport(grid::plotViewport(margins = margins, gp = gp_plot))
554
555	!	cur_gpar <- grid::get.gpar()
556	!	if (is.null(lpp)) {
557	!	lpp <- floor(grid::convertHeight(grid::unit(1, "npc"), "lines", valueOnly = TRUE) /
558	!	(cur_gpar$cex * cur_gpar$lineheight)) - sum(margins[c(1, 3)]) # bottom, top # nolint
559		}
560	!	if (is.null(cpp)) {
561	!	cpp <- floor(grid::convertWidth(grid::unit(1, "npc"), "inches", valueOnly = TRUE) *
562	!	font_lcpi(font_family, font_size, cur_gpar$lineheight)$cpi) - sum(margins[c(2, 4)]) # left, right # nolint
563		}
564	!	if (tf_wrap && is.null(max_width)) {
565	!	max_width <- cpp
566		}
567
568	!	if (paginate) {
569	!	tbls <- paginate_to_mpfs(
570	!	x,
571	!	page_type = page_type,
572	!	font_family = font_family,
573	!	font_size = font_size,
574	!	lineheight = cur_gpar$lineheight,
575	!	landscape = landscape,
576	!	pg_width = pg_width,
577	!	pg_height = pg_height,
578	!	margins = margins,
579	!	lpp = lpp,
580	!	cpp = cpp,
581	!	min_siblings = min_siblings,
582	!	nosplitin = character(),
583	!	colwidths = colwidths,
584	!	tf_wrap = tf_wrap,
585	!	max_width = max_width,
586	!	indent_size = indent_size,
587	!	verbose = FALSE,
588	!	rep_cols = num_rep_cols(x)
589		)
590		} else {
591	!	mf <- matrix_form(x, TRUE, TRUE, indent_size = indent_size)
592	!	mf_col_widths(mf) <- colwidths %\|\|% propose_column_widths(mf)
593	!	tbls <- list(mf)
594		}
595
596	!	gtbls <- lapply(tbls, function(txt) {
597	!	grid::textGrob(
598	!	label = toString(txt,
599	!	widths = txt$col_widths + 1, hsep = hsep,
600	!	tf_wrap = tf_wrap, max_width = max_width
601		),
602	!	x = grid::unit(0, "npc"), y = grid::unit(1, "npc"),
603	!	just = c("left", "top")
604		)
605		})
606
607	!	npages <- length(gtbls)
608	!	exceeds_width <- rep(FALSE, npages)
609	!	exceeds_height <- rep(FALSE, npages)
610
611	!	for (i in seq_along(gtbls)) {
612	!	g <- gtbls[[i]]
613
614	!	if (i > 1) {
615	!	grid::grid.newpage()
616	!	grid::pushViewport(grid::plotViewport(margins = margins, gp = gp_plot))
617		}
618
619	!	if (grid::convertHeight(grid::grobHeight(g), "inches", valueOnly = TRUE) >
620	!	grid::convertHeight(grid::unit(1, "npc"), "inches", valueOnly = TRUE)) { # nolint
621	!	exceeds_height[i] <- TRUE
622	!	warning("height of page ", i, " exceeds the available space")
623		}
624	!	if (grid::convertWidth(grid::grobWidth(g), "inches", valueOnly = TRUE) >
625	!	grid::convertWidth(grid::unit(1, "npc"), "inches", valueOnly = TRUE)) { # nolint
626	!	exceeds_width[i] <- TRUE
627	!	warning("width of page ", i, " exceeds the available space")
628		}
629
630	!	grid::grid.draw(g)
631		}
632	!	list(
633	!	file = file, npages = npages, exceeds_width = exceeds_width, exceeds_height = exceeds_height,
634	!	lpp = lpp, cpp = cpp
635		)
636		}