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
  ret <- .go_stri_wrap(str, width)

  # Check if it went fine
  if (any(nchar(ret) > width)) {
    which_exceeded <- which(nchar(ret) > width)

    # Recursive for loop to take word interval
    while (length(which_exceeded) > 0) {
      we_i <- which_exceeded[1]
      # Is there space for some part of the next word?
      char_threshold <- width * (2 / 3) + 0.01 # if too little space -> no previous word
      smart_condition <- nchar(ret[we_i - 1]) + 1 < char_threshold # +1 is for spaces
      if (we_i - 1 > 0 && smart_condition) {
        we_interval <- unique(c(we_i - 1, we_i))
        we_interval <- we_interval[
          (we_interval < (length(ret) + 1)) &
            (we_interval > 0)
        ]
      } else {
        we_interval <- we_i
      }
      # Split words and collapse (needs unique afterwards)
      ret[we_interval] <- split_words_by(
        paste0(ret[we_interval], collapse = " "),
        width
      )
      # Taking out repetitions if there are more than one
      if (length(we_interval) > 1) {
        ret <- ret[-we_interval[-1]]
        we_interval <- we_interval[1]
      }
      # Paste together and rerun if it is not the same as original ret
      ret_collapse <- paste0(ret, collapse = " ")

      # Checking if we are stuck in a loop
      ori_wrapped_txt_v <- .go_stri_wrap(str, width)
      cur_wrapped_txt_v <- .go_stri_wrap(ret_collapse, width)
      broken_char_ori <- sum(nchar(ori_wrapped_txt_v) > width) # how many issues there were
      broken_char_cur <- sum(nchar(cur_wrapped_txt_v) > width) # how many issues there are

      if (setequal(ori_wrapped_txt_v, cur_wrapped_txt_v) ||
          broken_char_cur >= broken_char_ori) { # we did not solve the current issue!
        # help function: Very rare case where the recursion is stuck in a loop
        ret_tmp <- force_split_words_by(ret[we_interval], width) # here we_interval is only one ind
        ret <- append(ret, ret_tmp, we_interval)[-we_interval]
        which_exceeded <- which(nchar(ret) > width)
      } else {
        return(wrap_string(str = ret_collapse, width = width, collapse = collapse))
      }
    }
  }

  if (!is.null(collapse)) {
    return(paste0(ret, collapse = collapse))
  }

  return(ret)
}

.go_stri_wrap <- function(str, w) {
  stringi::stri_wrap(str,
    width = w,
    normalize = FALSE, # keeps spaces
    simplify = TRUE, # If FALSE makes it a list with str elements
    indent = 0
  )
}

# help function: Very rare case where the recursion is stuck in a loop
force_split_words_by <- function(ret, width) {
  which_exceeded <- which(nchar(ret) > width)
  ret_tmp <- NULL
  for (ii in seq_along(ret)) {
    if (ii %in% which_exceeded) {
      wrd_i <- ret[ii]
      init_v <- seq(1, nchar(wrd_i), by = width)
      end_v <- c(init_v[-1] - 1, nchar(wrd_i))
      str_v_tmp <- stringi::stri_sub(wrd_i, from = init_v, to = end_v)
      ret_tmp <- c(ret_tmp, str_v_tmp[!grepl("^\\s+$", str_v_tmp) & nzchar(str_v_tmp)])
    } else {
      ret_tmp <- c(ret_tmp, ret[ii])
    }
  }
  ret_tmp
}

# Helper fnc to split the words and collapse them with space
split_words_by <- function(wrd, width) {
  vapply(wrd, function(wrd_i) {
    init_v <- seq(1, nchar(wrd_i), by = width)
    end_v <- c(init_v[-1] - 1, nchar(wrd_i))
    fin_str_v <- substring(wrd_i, init_v, end_v)
    is_only_spaces <- grepl("^\\s+$", fin_str_v)
    # We pop only spaces at this point
    if (all(is_only_spaces)) {
      fin_str_v <- fin_str_v[1] # keep only one width-sized empty
    } else {
      fin_str_v <- fin_str_v[!is_only_spaces] # hybrid text + \s
    }

    # Collapse the string
    paste0(fin_str_v, collapse = " ")
  }, character(1), USE.NAMES = FALSE)
}

#' @describeIn wrap_string function that flattens the list of wrapped strings with
#'   `unist(str, use.names = FALSE)`. This is deprecated, use [wrap_string()] instead.
#' @examples
#' wrap_txt(str, 5, collapse = NULL)
#'
#' @export
wrap_txt <- function(str, width, collapse = NULL) {
  unlist(wrap_string(str, width, collapse), use.names = FALSE)
}

pad_vert_top <- function(x, len, default = "") {
  c(x, rep(default, len - length(x)))
}

pad_vert_bottom <- function(x, len, default = "") {
  c(rep(default, len - length(x)), x)
}

pad_vec_to_len <- function(vec, len, cpadder = pad_vert_top, rlpadder = cpadder) {
  dat <- unlist(lapply(vec[-1], cpadder, len = len))
  dat <- c(rlpadder(vec[[1]], len = len), dat)
  matrix(dat, nrow = len)
}

rep_vec_to_len <- function(vec, len, ...) {
  matrix(unlist(lapply(vec, rep, times = len)),
    nrow = len
  )
}


safe_strsplit <- function(x, split, ...) {
  ret <- strsplit(x, split, ...)
  lapply(ret, function(reti) if (length(reti) == 0) "" else reti)
}

.expand_mat_rows_inner <- function(i, mat, row_nlines, expfun, ...) {
  leni <- row_nlines[i]
  rw <- mat[i, ]
  if (is.character(rw)) {
    rw <- safe_strsplit(rw, "\n", fixed = TRUE)
  }
  expfun(rw, len = leni, ...)
}

expand_mat_rows <- function(mat, row_nlines = apply(mat, 1, nlines), expfun = pad_vec_to_len, ...) {
  rinds <- seq_len(nrow(mat))
  exprows <- lapply(rinds, .expand_mat_rows_inner,
    mat = mat,
    row_nlines = row_nlines,
    expfun = expfun,
    ...
  )
  do.call(rbind, exprows)
}


#' Transform vectors of spans (with duplication) to Visibility vector
#'
#' @param spans numeric. A vector of spans, with each span value repeated
#' for the cells it covers.
#'
#' @details
#'
#' The values of \code{spans} are assumed to be repeated to such that
#' each individual position covered by the span has the repeated value.
#'
#' This means that each block of values in \code{span} must be of a length
#' at least equal to its value (i.e. two 2s, three 3s, etc).
#'
#' This function correctly handles cases where two spans of the same size
#' are next to each other; i.e., a block of four 2s represents two large
#' cells each of which span two individual cells.
#' @export
#' @note
#'
#' Currently no  checking or  enforcement is done  that the  vector of
#' spans is valid in the sense described in the Details section above.
#' @examples
#'
#' spans_to_viscell(c(2, 2, 2, 2, 1, 3, 3, 3))
#' @return a logical vector the same length as `spans` indicating
#' whether the contents of a string vector with those spans
spans_to_viscell <- function(spans) {
  if (!is.vector(spans)) {
    spans <- as.vector(spans)
  }
  myrle <- rle(spans)
  unlist(
    mapply(
      function(vl, ln) {
        rep(c(TRUE, rep(FALSE, vl - 1L)), times = ln / vl)
      },
      SIMPLIFY = FALSE,
      vl = myrle$values,
      ln = myrle$lengths
    ),
    recursive = FALSE
  )
}


#' Propose Column Widths based on an object's `MatrixPrintForm` form
#'
#' The row names are also considered a column for the output
#'
#' @param x `MatrixPrintForm` object, or an object with a `matrix_form`
#' method.
#' @param indent_size numeric(1). Indent size in characters. Ignored
#' when `x` is already a `MatrixPrintForm` object in favor of information
#' there.
#'
#' @examples
#' mf <- basic_matrix_form(mtcars)
#' propose_column_widths(mf)
#'
#' @export
#' @return a vector of column widths based on the content of \code{x}
#' for use in printing and pagination.
## ' @examples
## ' library(dplyr)
## ' library(rtables)
## ' iris2 <- iris %>%
## '   group_by(Species) %>%
## '   mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
## '   ungroup()
## '
## ' l <- basic_table() %>%
## '   split_cols_by("Species") %>%
## '   split_cols_by("group") %>%
## '   analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary) , format = "xx.xx")
## '
## ' tbl <- build_table(l, iris2)
## ' mf <- matrix_form(tbl)
## ' propose_column_widths(mf)
propose_column_widths <- function(x, indent_size = 2) {
  if (!is(x, "MatrixPrintForm")) {
    x <- matrix_form(x, indent_rownames = TRUE, indent_size = indent_size)
  }
  body <- mf_strings(x)
  spans <- mf_spans(x)
  aligns <- mf_aligns(x)
  display <- mf_display(x)

  # compute decimal alignment if asked in alignment matrix
  if (any_dec_align(aligns)) {
    body <- decimal_align(body, aligns)
  }

  chars <- nchar(body)

  # first check column widths without colspan
  has_spans <- spans != 1
  chars_ns <- chars
  chars_ns[has_spans] <- 0
  widths <- apply(chars_ns, 2, max)

  # now check if the colspans require extra width
  if (any(has_spans)) {
    has_row_spans <- apply(has_spans, 1, any)

    chars_sp <- chars[has_row_spans, , drop = FALSE]
    spans_sp <- spans[has_row_spans, , drop = FALSE]
    disp_sp <- display[has_row_spans, , drop = FALSE]

    nc <- ncol(spans)
    for (i in seq_len(nrow(chars_sp))) {
      for (j in seq_len(nc)) {
        if (disp_sp[i, j] && spans_sp[i, j] != 1) {
          i_cols <- seq(j, j + spans_sp[i, j] - 1)

          nchar_i <- chars_sp[i, j]
          cw_i <- widths[i_cols]
          available_width <- sum(cw_i)

          if (nchar_i > available_width) {
            # need to update widths to fit content with colspans
            # spread width among columns
            widths[i_cols] <- cw_i + spread_integer(nchar_i - available_width, length(cw_i))
          }
        }
      }
    }
  }
  widths
}




#' Pad a string and align within string
#'
#' @param x string
#' @param n number  of  character  of the  output  string,  if `n  <
#'     nchar(x)` an error is thrown
#' @param just  character(1).   Text  alignment   justification  to
#'     use. Defaults to `center`. Must be `center`, `right`, `left`,
#'     `dec_right`, `dec_left` or `decimal`.
#'
#' @export
#' @examples
#'
#' padstr("abc", 3)
#' padstr("abc", 4)
#' padstr("abc", 5)
#' padstr("abc", 5, "left")
#' padstr("abc", 5, "right")
#'
#' if (interactive()) {
#'   padstr("abc", 1)
#' }
#' @return `x`, padded to be a string of `n` characters
#'
padstr <- function(x, n, just = list_valid_aligns()) {
  just <- match.arg(just)

  if (length(x) != 1) stop("length of x needs to be 1 and not", length(x))
  if (is.na(n) || !is.numeric(n) || n < 0) stop("n needs to be numeric and > 0")

  if (is.na(x)) x <- "<NA>"

  nc <- nchar(x)

  if (n < nc) stop("\"", x, "\" has more than ", n, " characters")

  switch(just,
    center = {
      pad <- (n - nc) / 2
      paste0(spaces(floor(pad)), x, spaces(ceiling(pad)))
    },
    left = paste0(x, spaces(n - nc)),
    right = paste0(spaces(n - nc), x),
    decimal = {
      pad <- (n - nc) / 2
      paste0(spaces(floor(pad)), x, spaces(ceiling(pad)))
    },
    dec_left = paste0(x, spaces(n - nc)),
    dec_right = paste0(spaces(n - nc), x)
  )
}

spaces <- function(n) {
  strrep(" ", n)
}


.paste_no_na <- function(x, ...) {
  paste(na.omit(x), ...)
}


#' spread `x` into `len` elements
#'
#' @param x numeric(1). The number to spread
#' @param len numeric(1). The number of times to repeat \code{x}
#'
#' @export
#' @return if \code{x} is a scalar "whole number" value (see \code{\link{is.wholenumber}}),
#' the value \code{x} repeated \code{len} times. If not, an error is thrown.
#' @examples
#' spread_integer(3, 1)
#' spread_integer(0, 3)
#' spread_integer(1, 3)
#' spread_integer(2, 3)
#' spread_integer(3, 3)
#' spread_integer(4, 3)
#' spread_integer(5, 3)
#' spread_integer(6, 3)
#' spread_integer(7, 3)
spread_integer <- function(x, len) {
  stopifnot(
    is.wholenumber(x), length(x) == 1, x >= 0,
    is.wholenumber(len), length(len) == 1, len >= 0,
    !(len == 0 && x > 0)
  )


  if (len == 0) {
    integer(0)
  } else {
    y <- rep(floor(x / len), len)
    i <- 1
    while (sum(y) < x) {
      y[i] <- y[i] + 1
      if (i == len) {
        i <- 1
      } else {
        i <- i + 1
      }
    }
    y
  }
}



#' `is.wholenumber`
#'
#' @param x numeric(1). A numeric value
#' @param tol numeric(1). A precision tolerance.
#'
#' @return \code{TRUE} if \code{x} is within \code{tol} of zero,
#' \code{FALSE} otherwise.
#'
#' @export
#' @examples
#' is.wholenumber(5)
#' is.wholenumber(5.00000000000000001)
#' is.wholenumber(.5)
#'
is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) {
  abs(x - round(x)) < tol
}

### This file defines the generics which make up the interface `formatters` offers.
### Defining methods for these generics for a new table-like class should be fully
### sufficient for hooking that class up to the `formatters` pagination and rendering
### machinery.


#' @import methods
#' @include matrix_form.R
#'
#' @title Make row layout summary data.frames for use during pagination
#'
#' @description
#' All relevant information about table rows (e.g. indentations) is summarized in a data.frames.
#' This function works ONLY on `rtables` and `rlistings` objects, and not on their print counterparts
#' (like `MatrixPrintForm`).
#'
#' @name make_row_df
#'
#' @param tt ANY. Object representing the table-like object to be summarized.
#' @param visible_only logical(1). Should only visible aspects of the table structure be reflected in this summary.
#'   Defaults to \code{TRUE}. May not be supported by all methods.
#' @param incontent logical(1). Internal detail do not set manually.
#' @param repr_ext integer(1). Internal detail do not set manually.
#' @param repr_inds integer. Internal detail do not set manually.
#' @param sibpos integer(1). Internal detail do not set manually.
#' @param nsibs integer(1). Internal detail do not set manually.
#' @param rownum numeric(1). Internal detail do not set manually.
#' @param indent integer(1). Internal detail do not set manually.

#' @param colwidths numeric. Internal detail do not set manually.
#' @param  path character.  Path  to  the (sub)table  represented  by
#'     \code{tt}. Defaults to \code{character()}
#' @param max_width numeric(1) or NULL. Maximum width for title/footer
#' materials.
#'
#' @details When  \code{visible_only} is  \code{TRUE} (the  default),
#'     methods should  return a  data.frame with  exactly one  row per
#'     visible  row in  the table-like  object.  This  is useful  when
#'     reasoning about  how a table  will print, but does  not reflect
#'     the full pathing space of the structure (though the paths which
#'     are given will all work as is).
#'
#' If  supported,  when  \code{visible_only}  is  \code{FALSE},  every
#' structural element of the table (in row-space) will be reflected in
#' the  returned data.frame,  meaning the  full pathing-space  will be
#' represented but some rows in  the layout summary will not represent
#' printed rows in the table as it is displayed.
#'
#' Most arguments beyond \code{tt} and \code{visible_only} are present so that
#' `make_row_df` methods can call `make_row_df` recursively and retain information,
#' and should not be set during a top-level call
#'
#' @note the technically present root tree node is excluded from the summary returned by
#' both \code{make_row_df} and \code{make_col_df} (see `rtables::make_col_df`), as it is simply the
#' row/column structure of \code{tt} and thus not useful for pathing or pagination.
#' @return a data.frame of row/column-structure information used by the pagination machinery.
#'
#' @rdname make_row_df
#' @export
## nocov start
setGeneric("make_row_df", function(tt, colwidths = NULL, visible_only = TRUE,
                                   rownum = 0,
                                   indent = 0L,
                                   path = character(),
                                   incontent = FALSE,
                                   repr_ext = 0L,
                                   repr_inds = integer(),
                                   sibpos = NA_integer_,
                                   nsibs = NA_integer_,
                                   max_width = NULL) {
  standardGeneric("make_row_df")
})

#' @rdname make_row_df
setMethod("make_row_df", "MatrixPrintForm", function(tt, colwidths = NULL, visible_only = TRUE,
                                                     rownum = 0,
                                                     indent = 0L,
                                                     path = character(),
                                                     incontent = FALSE,
                                                     repr_ext = 0L,
                                                     repr_inds = integer(),
                                                     sibpos = NA_integer_,
                                                     nsibs = NA_integer_,
                                                     max_width = NULL) {
  stop(
    "make_row_df can be used only on {rtables} table objects, and not on `matrix_form`-",
    "generated objects (MatrixPrintForm)."
  )
})
## nocov end


#' Transform `rtable` to a list of matrices which can be used for outputting
#'
#' Although `rtables` are represented as a tree data structure when outputting the table to ASCII or HTML it is
#' useful to map the `rtable` to an in between state with the formatted cells in a matrix form.
#'
#' @param obj ANY. Object to be transformed into a ready-to-render form (a `MatrixPrintForm` object)
#' @param indent_rownames logical(1), if TRUE the column with the row names in the `strings` matrix of has indented row
#' names (strings pre-fixed)
#' @param expand_newlines logical(1). Should the matrix form generated
#'     expand  rows  whose  values   contain  newlines  into  multiple
#'     'physical'  rows  (as  they  will  appear  when  rendered  into
#'     ASCII). Defaults to \code{TRUE}
#' @param indent_size numeric(1). Number of spaces to be used per level of indent (if supported by
#' the relevant method). Defaults to 2.
#' @export
#'
#' @details
#'
#' The strings in the return object are defined as follows: row labels are those determined by \code{summarize_rows} and
#' cell values are determined using \code{get_formatted_cells}.
#' (Column labels are calculated using a non-exported internal function.
#'
#' @return A `MatrixPrintForm` classed list with the following elements:
#' \describe{
#' \item{strings}{The content, as it should be printed, of the top-left material, column headers, row labels, and
#'   cell values of \code{tt}}
#' \item{spans}{The column-span information for each print-string in the strings matrix}
#' \item{aligns}{The text alignment for each print-string in the strings matrix}
#' \item{display}{Whether each print-string in the strings matrix should be printed or not}.
#' \item{row_info}{the data.frame generated by \code{summarize_rows(tt)}}
#' }
#'
#' With an additional \code{nrow_header} attribute indicating the number of pseudo "rows"  the
#' column structure defines.
setGeneric("matrix_form", function(obj,
                                   indent_rownames = FALSE,
                                   expand_newlines = TRUE,
                                   indent_size = 2) {
  standardGeneric("matrix_form")
})


#' @rdname matrix_form
#' @export
setMethod("matrix_form", "MatrixPrintForm", function(obj,
                                                     indent_rownames = FALSE,
                                                     expand_newlines = TRUE,
                                                     indent_size = 2) {
  obj
})


## Generics for `toString` and helper functions


## this is where we will take word wrapping
## into account when it is added
##
## ALL calculations of vertical space for pagination
## purposes must go through nlines and divider_height!!!!!!!!

## this will be customizable someday. I have foreseen it (spooky noises)
#' Divider Height
#'
#' @param obj ANY. Object.
#' @return The height, in lines of text, of the divider between
#' header and body. Currently returns \code{1L} for the default method.
#' @export
#' @examples
#' divider_height(mtcars)
setGeneric("divider_height", function(obj) standardGeneric("divider_height"))

#' @rdname divider_height
#' @export
setMethod(
  "divider_height", "ANY",
  function(obj) 1L
)

#' Number of lines required to print a value
#' @param x ANY. The object to be printed
#' @param colwidths numeric. Column widths (if necessary).
#' @param max_width numeric(1). Width strings should be wrapped to
#' when determining how many lines they require.
#' @return A scalar numeric indicating the number of lines needed
#' to render the object \code{x}.
#' @export
setGeneric(
  "nlines",
  function(x, colwidths = NULL, max_width = NULL) standardGeneric("nlines")
)

## XXX beware. I think it is dangerous
#' @export
#' @rdname nlines
setMethod(
  "nlines", "list",
  function(x, colwidths, max_width) {
    if (length(x) == 0) {
      0L
    } else {
      sum(unlist(vapply(x, nlines, NA_integer_, colwidths = colwidths, max_width = max_width)))
    }
  }
)

#' @export
#' @rdname nlines
setMethod("nlines", "NULL", function(x, colwidths, max_width) 0L)

#' @export
#' @rdname nlines
setMethod("nlines", "character", function(x, colwidths, max_width) {
  if (length(x) == 0) {
    return(0L)
  }

  sum(vapply(strsplit(x, "\n", fixed = TRUE),
    function(xi, max_width) {
      if (length(xi) == 0) {
        1L
      } else if (length(max_width) == 0) { ## this happens with strsplit("", "\n")
        length(xi)
      } else {
        length(wrap_txt(xi, max_width))
      }
    }, 1L,
    max_width = max_width
  ))
})



#' @title `toString`
#'
#' @description Transform a complex object into a string representation ready
#' to be printed or written to a plain-text file
#'
#' @param x ANY. Object to be prepared for rendering.
#' @param ... Passed to individual methods.
#' @rdname tostring
#' @export
setGeneric("toString", function(x, ...) standardGeneric("toString"))

## preserve S3 behavior
setMethod("toString", "ANY", base::toString) ## nocov

#' @title Print
#'
#' @description Print an R object. see \code{[base::print()]}
#' @inheritParams base::print
#' @rdname basemethods
setMethod("print", "ANY", base::print) ## nocov










## General/"universal" property `getter` and `setter` generics and stubs

#' @title Label, Name and Format accessor generics
#'
#' @description `Getters` and `setters` for basic, relatively universal attributes
#' of "table-like" objects"
#'
#' @name lab_name
#' @param obj ANY. The object.
#' @param value character(1)/FormatSpec. The new value of the attribute.
#' @return the name, format or label of \code{obj} for `getters`, or \code{obj} after modification
#' for setters.
#' @aliases obj_name
#' @export

## no exported methods so we do nocov
# nocov start
setGeneric("obj_name", function(obj) standardGeneric("obj_name"))


#' @rdname lab_name
#' @export
setGeneric("obj_name<-", function(obj, value) standardGeneric("obj_name<-"))
# nocov end

#' @seealso with_label
#' @rdname lab_name
#' @export
setGeneric("obj_label", function(obj) standardGeneric("obj_label"))

#' @rdname lab_name
#' @param value character(1). The new label
#' @export
setGeneric("obj_label<-", function(obj, value) standardGeneric("obj_label<-"))

#' @rdname lab_name
#' @exportMethod obj_label
setMethod("obj_label", "ANY", function(obj) attr(obj, "label"))

#' @rdname lab_name
#' @exportMethod obj_label<-
setMethod(
  "obj_label<-", "ANY",
  function(obj, value) {
    attr(obj, "label") <- value
    obj
  }
)

#' @rdname lab_name
#' @export
setGeneric("obj_format", function(obj) standardGeneric("obj_format"))
## this covers rcell, etc
#' @rdname lab_name
#' @exportMethod obj_format
setMethod("obj_format", "ANY", function(obj) attr(obj, "format", exact = TRUE))
#' @rdname lab_name
#' @export
setMethod("obj_format", "fmt_config", function(obj) obj@format)

#' @export
#' @rdname lab_name
setGeneric("obj_format<-", function(obj, value) standardGeneric("obj_format<-"))
## this covers rcell, etc
#' @exportMethod obj_format<-
#' @rdname lab_name
setMethod("obj_format<-", "ANY", function(obj, value) {
  attr(obj, "format") <- value
  obj
})
#' @rdname lab_name
#' @export
setMethod("obj_format<-", "fmt_config", function(obj, value) {
  obj@format <- value
  obj
})

#' @rdname lab_name
#' @export
setGeneric("obj_na_str", function(obj) standardGeneric("obj_na_str"))
#' @rdname lab_name
#' @exportMethod obj_na_str
setMethod("obj_na_str", "ANY", function(obj) attr(obj, "format_na_str", exact = TRUE))
#' @rdname lab_name
#' @export
setMethod("obj_na_str", "fmt_config", function(obj) obj@format_na_str)

#' @rdname lab_name
#' @export
setGeneric("obj_na_str<-", function(obj, value) standardGeneric("obj_na_str<-"))
#' @exportMethod obj_na_str<-
#' @rdname lab_name
setMethod("obj_na_str<-", "ANY", function(obj, value) {
  attr(obj, "format_na_str") <- value
  obj
})
#' @rdname lab_name
#' @export
setMethod("obj_na_str<-", "fmt_config", function(obj, value) {
  obj@format_na_str <- value
  obj
})

#' @rdname lab_name
#' @export
setGeneric("obj_align", function(obj) standardGeneric("obj_align"))
#' @rdname lab_name
#' @exportMethod obj_align
setMethod("obj_align", "ANY", function(obj) attr(obj, "align", exact = TRUE))
#' @rdname lab_name
#' @export
setMethod("obj_align", "fmt_config", function(obj) obj@align)

#' @rdname lab_name
#' @export
setGeneric("obj_align<-", function(obj, value) standardGeneric("obj_align<-"))
#' @exportMethod obj_align<-
#' @rdname lab_name
setMethod("obj_align<-", "ANY", function(obj, value) {
  attr(obj, "align") <- value
  obj
})
#' @rdname lab_name
#' @export
setMethod("obj_align<-", "fmt_config", function(obj, value) {
  obj@align <- value
  obj
})

#' General title/footer accessors
#'
#' @param obj ANY. Object to extract information from.
#' @export
#' @rdname title_footer
#' @return A character scalar (`main_title`), a character vector (`main_footer`), or
#' vector of length zero or more (`subtitles`, `page_titles`,
#' `prov_footer`) containing the relevant title/footer contents
setGeneric("main_title", function(obj) standardGeneric("main_title"))

#' @export
#' @rdname title_footer
setMethod(
  "main_title", "MatrixPrintForm",
  function(obj) obj$main_title
)

##' @rdname title_footer
##' @export
setGeneric("main_title<-", function(obj, value) standardGeneric("main_title<-"))
##' @rdname title_footer
##' @export
setMethod(
  "main_title<-", "MatrixPrintForm",
  function(obj, value) {
    obj$main_title <- value
    obj
  }
)



#' @export
#' @rdname title_footer
setGeneric("subtitles", function(obj) standardGeneric("subtitles")) ## nocov

#' @export
#' @rdname title_footer
setMethod(
  "subtitles", "MatrixPrintForm",
  function(obj) obj$subtitles
)

##' @rdname title_footer
##' @export
setGeneric("subtitles<-", function(obj, value) standardGeneric("subtitles<-")) ## nocov

##' @rdname title_footer
##' @export
setMethod(
  "subtitles<-", "MatrixPrintForm",
  function(obj, value) {
    obj$subtitles <- value
    obj
  }
)

#' @export
#' @rdname title_footer
setGeneric("page_titles", function(obj) standardGeneric("page_titles"))

#' @export
#' @rdname title_footer
setMethod(
  "page_titles", "MatrixPrintForm",
  function(obj) obj$page_titles
)
#' @rdname title_footer
#' @export
setMethod("page_titles", "ANY", function(obj) NULL)

##' @rdname title_footer
##' @export
setGeneric("page_titles<-", function(obj, value) standardGeneric("page_titles<-"))

#' @export
#' @rdname title_footer
setMethod(
  "page_titles<-", "MatrixPrintForm",
  function(obj, value) {
    if (!is.character(value)) {
      stop("page titles must be in the form of a character vector, got object of class ", class(value))
    }
    obj$page_titles <- value
    obj
  }
)



#' @export
#' @rdname title_footer
setGeneric("main_footer", function(obj) standardGeneric("main_footer"))

#' @export
#' @rdname title_footer
setMethod(
  "main_footer", "MatrixPrintForm",
  function(obj) obj$main_footer
)

#' @rdname title_footer
#' @param value character. New value.
#' @export
setGeneric("main_footer<-", function(obj, value) standardGeneric("main_footer<-"))



#' @export
#' @rdname title_footer
setMethod(
  "main_footer<-", "MatrixPrintForm",
  function(obj, value) {
    if (!is.character(value)) {
      stop("main footer must be a character vector. Got object of class ", class(value))
    }
    obj$main_footer <- value
    obj
  }
)


#' @export
#' @rdname title_footer
setGeneric("prov_footer", function(obj) standardGeneric("prov_footer"))

#' @export
#' @rdname title_footer
setMethod(
  "prov_footer", "MatrixPrintForm",
  function(obj) obj$prov_footer
)

#' @rdname title_footer
#' @export
setGeneric("prov_footer<-", function(obj, value) standardGeneric("prov_footer<-"))

#' @export
#' @rdname title_footer
setMethod(
  "prov_footer<-", "MatrixPrintForm",
  function(obj, value) {
    if (!is.character(value)) {
      stop("provenance footer must be a character vector. Got object of class ", class(value))
    }
    obj$prov_footer <- value
    obj
  }
)




#' @rdname title_footer
#' @export
all_footers <- function(obj) c(main_footer(obj), prov_footer(obj))

#' @rdname title_footer
#' @export
all_titles <- function(obj) c(main_title(obj), subtitles(obj), page_titles(obj))


#' Access or (recursively) set table inset.
#'
#' Table inset is the amount of characters that the body of
#' a table, referential footnotes, and main footer material
#' are inset from the left-alignment of the titles and provenance
#' footer materials.
#'
#' @param obj ANY. Object to get or (recursively if necessary) set
#' table inset for.
#' @param value character(1). String to use as new header/body separator.
#'
#' @return for `table_inset` the integer value that the table body
#' (including column heading information and section dividers),
#' referential footnotes, and main footer should be inset from the
#' left alignment of the titles and provenance footers during rendering.
#' For `table_inset<-`, the `obj`, with the new table_inset value
#' applied recursively to it and all its subtables.
#'
#' @export
setGeneric("table_inset", function(obj) standardGeneric("table_inset"))

#' @rdname table_inset
#' @export
setMethod(
  "table_inset", "MatrixPrintForm",
  function(obj) obj$table_inset
)


#' @rdname table_inset
#' @export
setGeneric("table_inset<-", function(obj, value) standardGeneric("table_inset<-"))

#' @rdname table_inset
#' @export
setMethod(
  "table_inset<-", "MatrixPrintForm",
  function(obj, value) {
    newval <- as.integer(value)
    if (is.na(newval) || newval < 0) {
      stop("Got invalid value for table_inset: ", newval)
    }
    obj$table_inset <- newval
    obj
  }
)




#' Generic for Performing "Forced Pagination"
#'
#' Forced pagination is pagination which happens regardless of
#' position on page. The object is expected to have all information
#' necessary to locate such page breaks, and the `do_forced_pag`
#' method is expected to fully perform those paginations.
#'
#' @param obj The object to be paginated.
#'
#' The `ANY` method simply returns a list of length one, containing
#' `obj`.
#'
#' @return a list of subobjects, which will be further paginated
#' by the standard pagination algorithm.
#'
#'
#' @export
setGeneric("do_forced_paginate", function(obj) standardGeneric("do_forced_paginate"))

#' @export
#' @rdname do_forced_paginate
setMethod("do_forced_paginate", "ANY", function(obj) list(obj))

#' Number of repeated columns
#'
#' When called on a table-like object using the formatters framework,
#' this method should return the number of columns which are mandatorily
#' repeated after each horizontal pagination.
#'
#' Absent a class-specific method, this function returns 0, indicating
#' no always-repeated columns.
#'
#' @param obj ANY. A table-like object.
#' @note This number \emph{does not include row labels}, the repetition
#' of which is handled separately.
#'
#' @return an integer.
#' @export
#' @examples
#' mpf <- basic_matrix_form(mtcars)
#' num_rep_cols(mpf)
setGeneric("num_rep_cols", function(obj) standardGeneric("num_rep_cols"))
#' @export
#' @rdname num_rep_cols
setMethod("num_rep_cols", "ANY", function(obj) 0L)

# header_section_div -----------------------------------------------------------
#' @keywords internal
setGeneric("header_section_div", function(obj) standardGeneric("header_section_div"))
#' @keywords internal
setMethod(
  "header_section_div", "MatrixPrintForm",
  function(obj) obj$header_section_div
)
#' @keywords internal
setGeneric("header_section_div<-", function(obj, value) standardGeneric("header_section_div<-"))
#' @keywords internal
setMethod(
  "header_section_div<-", "MatrixPrintForm",
  function(obj, value) {
    obj$header_section_div <- value
    obj
  }
)
# horizontal_sep ---------------------------------------------------------------
#' @keywords internal
setGeneric("horizontal_sep", function(obj) standardGeneric("horizontal_sep"))
#' @keywords internal
setMethod(
  "horizontal_sep", "MatrixPrintForm",
  function(obj) obj$horizontal_sep
)
#' @keywords internal
setGeneric("horizontal_sep<-", function(obj, value) standardGeneric("horizontal_sep<-"))
#' @keywords internal
setMethod(
  "horizontal_sep<-", "MatrixPrintForm",
  function(obj, value) {
    obj$horizontal_sep <- value
    obj
  }
)

#' @import grid
#' @import grDevices
NULL
## https://www.ietf.org/rfc/rfc0678.txt

## This assumes fixed font size, monospaced font

std_cpi <- 10L
std_lpi <- 6L


std_full_pg_wd_in <- 8.5

std_full_pg_ht_in <- 11

std_log_pg_wd_chars <- 72

std_log_pg_ht_lines <- 60

std_marg_ht <- round((std_full_pg_ht_in - std_log_pg_ht_lines / std_lpi) / 2, 2)
std_marg_wd <- round((std_full_pg_wd_in - std_log_pg_wd_chars / std_cpi) / 2, 2)

std_margins <- list(
  top = std_marg_ht,
  bottom = std_marg_ht,
  left = std_marg_wd,
  right = std_marg_wd
)

## does not appear to be used anywhere
## to_inches_num <- function(x) {
##   if (is(x, "unit")) {
##     x <- unclass(convertUnit(x, "inches"))
##   }
##   x
## }

## Physical size, does not take margins into account
pg_dim_names <- list(
  letter = c(8.5, 11),
  a4 = c(8.27, 11.69),
  legal = c(8.5, 14)
)


#'
#' Supported Named Page `TypesList` supported named page types
#'
#' @return for `page_types` a character vector of supported page types,
#' for `page_dim` the dimensions (width, then height) of the selected page type.
#'
#' @export
#' @examples
#' page_types()
#' page_dim("a4")
page_types <- function() {
  names(pg_dim_names)
}

#' @export
#' @param page_type character(1). The name of a page size specification. Call
#'   `page_types` for supported values.
#' @rdname page_types
page_dim <- function(page_type) {
  if (is.null(page_type)) {
    return(NULL)
  }
  if (!page_type %in% page_types()) {
    stop("Unrecognized page-size specification: ", page_type)
  }
  pg_dim_names[[page_type]]
}



#' Calculate lines per inch and characters per inch for font
#'
#' @inheritParams page_lcpp
#'
#' @details This function creates opens pdf graphics device  writing to an temporary file,
#' then utilizes [grid::convertWidth()] and [grid::convertHeight()] to calculate
#' lines per inch and characters per inch for the specified font family, size, and
#' line height.
#'
#' An error is thrown if the font is not monospaced (determined by comparing
#' the effective widths of the `M` and `.` glyphs).
#' @return named list with `cpi` and `lpi`, the characters and lines per
#' inch, respectively.
#'
#' @examples
#' \dontrun{
#' font_lcpi()
#'
#' font_lcpi(font_size = 8)
#'
#' font_lcpi(font_size = 8, lineheight = 1.1)
#' }
#'
#' @keywords internal
font_lcpi <- function(font_family = "Courier", font_size = 8, lineheight = 1) {
  tmppdf <- tempfile(fileext = ".pdf")
  pdf(tmppdf)
  on.exit(dev.off())
  grid.newpage()
  gp <- gpar(fontfamily = font_family, fontsize = font_size, lineheight = lineheight)
  pushViewport(plotViewport(gp = gp))
  if (convertWidth(unit(1, "strwidth", "."), "inches", valueOnly = TRUE) !=
    convertWidth(unit(1, "strwidth", "M"), "inches", valueOnly = TRUE)) { # nolint
    stop(
      "The font family you selected - ",
      font_family,
      " - does not appear to be monospaced. This is not supported."
    )
  }
  list(
    cpi = 1 / convertWidth(unit(1, "strwidth", "h"), "inches", valueOnly = TRUE),
    lpi = convertHeight(unit(1, "inches"), "lines", valueOnly = TRUE)
  )
}

marg_order <- c("bottom", "left", "top", "right")

#' Determine lines per page (`LPP`) and characters per page (`CPP`) based on font and page type
#'
#' @param  page_type  character(1).   Name   of  a  page  type.   See
#'     `page_types`.   Ignored when  `pg_width` and  `pg_height`
#'     are set directly.
#' @param  landscape logical(1). Should the  dimensions of `page_type`
#'     be inverted  for landscape?  Defaults to  `FALSE`, ignored when
#'     `pg_width` and `pg_height` are set directly.
#' @param font_family character(1). Name of a font family. An error
#'     will be thrown if the family named is not monospaced. Defaults
#'     to Courier.
#' @param font_size numeric(1). Font size, defaults to 12.
#' @param lineheight numeric(1). Line height, defaults to 1.
#' @param margins numeric(4). Named numeric vector containing `'bottom'`,
#'     `'left'`, `'top'`, and `'right'` margins in inches. Defaults
#'     to `.5` inches for both vertical margins and `.75` for both
#'     horizontal margins.
#' @param pg_width numeric(1). Page width in inches.
#' @param pg_height numeric(1). Page height in inches.
#'
#' @return a named list containing `LPP` (lines per page) and `CPP` (characters per page)
#' elements suitable for use by the pagination machinery.
#'
#' @export
#' @examples
#' page_lcpp()
#' page_lcpp(font_size = 10)
#' page_lcpp("a4", font_size = 10)
#'
#' page_lcpp(margins = c(top = 1, bottom = 1, left = 1, right = 1))
#' page_lcpp(pg_width = 10, pg_height = 15)
page_lcpp <- function(page_type = page_types(),
                      landscape = FALSE,
                      font_family = "Courier",
                      font_size = 8,
                      lineheight = 1,
                      margins = c(top = .5, bottom = .5, left = .75, right = .75),
                      pg_width = NULL,
                      pg_height = NULL) {
  if (is.null(page_type)) {
    page_type <- page_types()[1]
  } else {
    page_type <- match.arg(page_type)
  }

  if (is.null(names(margins))) {
    names(margins) <- marg_order
  } else {
    margins <- margins[marg_order]
  }
  if (any(is.na(margins))) {
    stop("margins argument must have names 'bottom', 'left', 'top' and 'right'.")
  }
  lcpi <- font_lcpi(
    font_family = font_family,
    font_size = font_size,
    lineheight = lineheight
  )

  wdpos <- ifelse(landscape, 2, 1)
  pg_width <- pg_width %||% pg_dim_names[[page_type]][wdpos]
  pg_height <- pg_height %||% pg_dim_names[[page_type]][-wdpos]

  pg_width <- pg_width - sum(margins[c("left", "right")])
  pg_height <- pg_height - sum(margins[c("top", "bottom")])

  list(
    cpp = floor(lcpi[["cpi"]] * pg_width),
    lpp = floor(lcpi[["lpi"]] * pg_height)
  )
}

## pg_types <- list(
##     "fsrp" = c(cpp = 110, lpp = 66),
##     "fsrp8" = c(cpp = 110, lpp = 66),
##     "fsrp7" = c(cpp = 110, lpp = 75),
##     "fsrl" = c(cpp = 149, lpp = 51),
##     "fsrl8" = c(cpp = 149, lpp = 51),
##     "fsrl7" = c(cpp = 150, lpp = 59),
##     "erp" = c(cpp = 96, lpp = 66),
##     "erp8" = c(cpp = 96, lpp = 66),
##     "erl" = c(cpp = 149, lpp = 45),
##     "erl8" = c(cpp = 149, lpp = 45),
##     "sasp" = c(cpp = 93, lpp = 73),
##     "sasp8" = c(cpp = 93, lpp = 73),
##     "sasl" = c(cpp = 134, lpp = 52),
##     "sasl8" = c(cpp = 134, lpp = 52),
##     "sasp7" = c(cpp = 107, lpp = 92),
##     "sasl7" = c(cpp = 154, lpp = 64),
##     "sasp6" = c(cpp = 125, lpp = 108),
##     "sasl6" = c(cpp = 180, lpp = 75),
##     "sasp10" = c(cpp = 78, lpp = 64),
##     "sasl10" = c(cpp = 108, lpp = 45),
##     "sasp9" = c(cpp = 87, lpp = 71),
##     "sasl9" = c(cpp = 120, lpp = 51),
##     "rapidp10" = c(cpp = 78, lpp = 64),
##     "rapidl10" = c(cpp = 108, lpp = 45),
##     "rapidp9" = c(cpp = 87, lpp = 71),
##     "rapidl9" = c(cpp = 120, lpp = 51),
##     "rapidp" = c(cpp = 93, lpp = 73),
##     "rapidp8" = c(cpp = 93, lpp = 73),
##     "rapidl" = c(cpp = 134, lpp = 52),
##     "rapidl8" = c(cpp = 134, lpp = 52),
##     "rapidp7" = c(cpp = 107, lpp = 92),
##     "rapidl7" = c(cpp = 154, lpp = 64),
##     "rapidp6" = c(cpp = 125, lpp = 108),
##     "rapidl6" = c(cpp = 180, lpp = 75),
##     "shibal" = c(cpp = 170, lpp = 48),
##     "shibal10" = c(cpp = 137, lpp = 39),
##     "shibal8" = c(cpp = 170, lpp = 48),
##     "shibal7" = c(cpp = 194, lpp = 56),
##     "shibal6" = c(cpp = 225, lpp = 65),
##     "shibap" = c(cpp = 112, lpp = 78),
##     "shibap10" = c(cpp = 89, lpp = 64),
##     "shibap8" = c(cpp = 112, lpp = 78),
##     "shibap7" = c(cpp = 127, lpp = 92),
##     "shibap6" = c(cpp = 148, lpp = 108))






## courier_fontsize_lcpi_df <- tribble(
##     ~courier_size,   ~cpi,                                      ~lpi,
##      6,              floor(129 / pg_dim_names[["letter"]][1]),  floor(85 / pg_dim_names[["letter"]][2]),
##      7,              floor(110 / pg_dim_names[["letter"]][1]),  floor(76 / pg_dim_names[["letter"]][2]),
##      8,              floor(95 / pg_dim_names[["letter"]][1]),   floor(68 / pg_dim_names[["letter"]][2]),
##      9,              floor(84 / pg_dim_names[["letter"]][1]),   floor(61 / pg_dim_names[["letter"]][2]),
##     10,              floor(75 / pg_dim_names[["letter"]][1]),   floor(56 / pg_dim_names[["letter"]][2])
## )

## courier_lcpi <- function(size) {
##     grid.newpage()
##     gp <- gpar(fontfamily="Courier New", fontsize = size, lineheight = 1)
##     pushViewport(plotViewport( gp = gp))
##     list(cpi = round(1/convertWidth(unit(1, "strwidth", "h"), "inches", valueOnly = TRUE), 0),
##          lpi = round(convertHeight(unit(1, "inches"), "lines", valueOnly = TRUE), 0))
## }

## until we do it for real

#' @title Matrix Print Form - Intermediate Representation for ASCII Table Printing
#'
#' @name MatrixPrintForm-class
#'
#' @rdname MatrixPrintForm_class
#' @aliases MatrixPrintForm-class
#' @exportClass MatrixPrintForm
setOldClass(c("MatrixPrintForm", "list"))


mform_handle_newlines <- function(matform) {
  # Retrieving relevant information
  has_topleft <- mf_has_topleft(matform)
  strmat <- mf_strings(matform)
  frmmat <- mf_formats(matform)
  spamat <- mf_spans(matform)
  alimat <- mf_aligns(matform)
  nr_header <- mf_nrheader(matform)
  nl_inds_header <- seq(1, mf_nlheader(matform))
  hdr_inds <- 1:nr_header

  # hack that is necessary only if bottom aligned
  topleft_has_nl_char <- FALSE
  if (has_topleft) {
    tl <- strmat[nl_inds_header, 1, drop = TRUE]
    strmat[nl_inds_header, 1] <- ""
    tl <- tl[nzchar(tl)] # we are not interested in initial "" but we cover initial \n
    topleft_has_nl_char <- any(grepl("\n", tl))
    tl_to_add_back <- strsplit(paste0(tl, collapse = "\n"), split = "\n", fixed = TRUE)[[1]]
    how_many_nl <- length(tl_to_add_back)
  }

  # pre-proc in case of wrapping and \n
  line_grouping <- mf_lgrouping(matform)
  strmat <- .compress_mat(strmat, line_grouping, "nl")
  frmmat <- .compress_mat(frmmat, line_grouping, "unique") # never not unique
  spamat <- .compress_mat(spamat, line_grouping, "unique")
  alimat <- .compress_mat(alimat, line_grouping, "unique")
  line_grouping <- unique(line_grouping)

  # nlines detects if there is a newline character
  row_nlines <- apply(strmat, 1, function(x) max(vapply(x, nlines, 1L), 1L))

  if (has_topleft && (sum(row_nlines[nl_inds_header]) < how_many_nl)) {
    row_nlines[1] <- row_nlines[1] + how_many_nl - sum(row_nlines[nl_inds_header])
  }

  # There is something to change
  if (any(row_nlines > 1) || topleft_has_nl_char) {
    # False: Padder should be bottom aligned if no topleft (case of rlistings)
    # It is always bottom: tl_padder <- ifelse(has_topleft, pad_vert_top, pad_vert_bottom)

    newstrmat <- rbind(
      cbind(
        expand_mat_rows(strmat[hdr_inds, 1, drop = FALSE],
          row_nlines[hdr_inds],
          cpadder = pad_vert_bottom # topleft info is NOT top aligned
        ),
        expand_mat_rows(strmat[hdr_inds, -1, drop = FALSE],
          row_nlines[hdr_inds],
          cpadder = pad_vert_bottom # colnames are bottom aligned
        )
      ),
      expand_mat_rows(strmat[-1 * hdr_inds, , drop = FALSE], row_nlines[-hdr_inds])
    )

    newfrmmat <- rbind(
      expand_mat_rows(
        frmmat[hdr_inds, , drop = FALSE],
        row_nlines[hdr_inds],
        cpadder = pad_vert_bottom
      ),
      expand_mat_rows(frmmat[-1 * hdr_inds, , drop = FALSE], row_nlines[-hdr_inds])
    )

    if (has_topleft) {
      starts_from_ind <- if (sum(row_nlines[hdr_inds]) - how_many_nl > 0) {
        sum(row_nlines[hdr_inds]) - how_many_nl
      } else {
        0
      }
      newstrmat[starts_from_ind + seq_along(tl_to_add_back), 1] <- tl_to_add_back
    }

    mf_strings(matform) <- newstrmat
    mf_formats(matform) <- newfrmmat
    mf_spans(matform) <- expand_mat_rows(spamat, row_nlines, rep_vec_to_len)
    mf_aligns(matform) <- expand_mat_rows(alimat, row_nlines, rep_vec_to_len)
    ##    mf_display(matform) <- expand_mat_rows(mf_display(matform), row_nlines, rep_vec_to_len)
    mf_lgrouping(matform) <- rep(line_grouping, times = row_nlines)
  }

  matform
}

# Helper function to recompact the lines following line groupings to then have them expanded again
.compress_mat <- function(mat, line_grouping, collapse_method = c("nl", "unique")) {
  list_compacted_mat <- lapply(unique(line_grouping), function(lg) {
    apply(mat, 2, function(mat_cols) {
      col_vec <- mat_cols[which(line_grouping == lg)]
      if (collapse_method[1] == "nl") {
        paste0(col_vec, collapse = "\n")
      } else {
        val <- unique(col_vec)
        val <- val[nzchar(val)]
        if (length(val) > 1) {
          stop("Problem in linegroupings! Some do not have the same values.") # nocov
        } else if (length(val) < 1) {
          val <- "" # Case in which it is only ""
        }
        val[[1]]
      }
    })
  })
  do.call("rbind", list_compacted_mat)
}

disp_from_spans <- function(spans) {
  display <- matrix(rep(TRUE, length(spans)), ncol = ncol(spans))

  print_cells_mat <- spans == 1L
  if (!all(print_cells_mat)) {
    display_rws <- lapply(
      seq_len(nrow(spans)),
      function(i) {
        print_cells <- print_cells_mat[i, ]
        row <- spans[i, ]
        ##         display <- t(apply(spans, 1, function(row) {
        ## print_cells <- row == 1

        if (!all(print_cells)) {
          ## need to calculate which cell need to be printed
          print_cells <- spans_to_viscell(row)
        }
        print_cells
      }
    )
    display <- do.call(rbind, display_rws)
  }
  display
}

## constructor
#' @title Matrix Print Form - Intermediate Representation for ASCII Table Printing
#'
#' @note The bare constructor for the `MatrixPrintForm` should generally
#' only be called by `matrix_form` custom methods, and almost never from other code.
#'
#' @param  strings character  matrix.  Matrix  of formatted,  ready to
#'     display  strings  organized as  they  will  be positioned  when
#'     rendered.   Elements that  span more  than one  column must  be
#'     followed  by  the  correct number  of  placeholders  (typically
#'     either empty strings or repeats of the value).
#' @param  spans  numeric  matrix.    Matrix  of  same  dimension  as
#'     \code{strings}  giving   the  spanning  information   for  each
#'     element.    Must  be   repeated   to   match  placeholders   in
#'     \code{strings}.
#' @param  aligns character  matrix.   Matrix  of same  dimension  as
#'     \code{strings} giving  the text alignment information  for each
#'     element. Must  be   repeated   to   match  placeholders   in
#'     \code{strings}. Must be a supported text alignment. See
#'     [decimal_align] allowed values.
#' @param formats  matrix. Matrix  of same dimension
#'     as  \code{strings} giving  the text  format information  for
#'     each  element.   Must  be  repeated to  match  placeholders  in
#'     \code{strings}.
#' @param  row_info   data.frame.   Data.frame  with  row-information
#'     necessary for pagination (XXX document exactly what that is).
#' @param  line_grouping integer. Sequence of  integers indicating how
#'     print  lines  correspond  to   semantic  rows  in  the  object.
#'     Typically   this   should   not    be   set   manually   unless
#'     `expact_newlines` is set to \code{FALSE}.
#' @param  ref_fnotes  list.   Referential  footnote  information  if
#'     applicable.
#' @param  nlines_header numeric(1). Number  of lines taken up  by the
#'     values of the header (i.e. not including the divider).
#' @param nrow_header numeric(1).  Number of \emph{rows} corresponding
#'     to the header.
#' @param  has_topleft logical(1).  Does the  corresponding table have
#'     'top left information' which should be treated differently when
#'     expanding  newlines.   Ignored   if  \code{expand_newlines}  is
#'     \code{FALSE}.
#' @param has_rowlabs  logical(1). Do  the matrices  (\code{strings},
#'     \code{spans},  \code{aligns})   each  contain  a   column  that
#'     corresponds  with  row  labels  (Rather than  with  table  cell
#'     values).  Defaults to \code{TRUE}.
#' @param main_title character(1). Main title as a string.
#' @param subtitles character. Subtitles, as a character vector.
#' @param page_titles character.  Page-specific titles, as a character
#'     vector.
#' @param main_footer character(1). Main footer as a string.
#' @param prov_footer character. Provenance footer information as a
#'     character vector.
#' @param header_section_div character(1). Divider to be used between header
#'     and body sections.
#' @param horizontal_sep character(1). Horizontal separator to be used for printing
#'     divisors between header and table body and between different footers.
#' @param expand_newlines logical(1). Should the matrix form generated
#'     expand  rows  whose  values   contain  newlines  into  multiple
#'     'physical'  rows  (as  they  will  appear  when  rendered  into
#'     ASCII). Defaults to \code{TRUE}
#' @param col_gap numeric(1). Space (in characters) between columns
#' @param table_inset numeric(1). Table inset. See
#' \code{\link{table_inset}}
#' @param colwidths numeric. NULL, or a vector of column rendering widths.
#'     if non-NULL, must have length equal to `ncol(strings)`
#' @param indent_size numeric(1). Number of spaces to be used per level of indent (if supported by
#' the relevant method). Defaults to 2.
#' @export
#' @return An object of class `MatrixPrintForm`. Currently this is
#' implemented as an S3 class inheriting from list with the following
#' elements:
#' \describe{
#' \item{\code{strings}}{see argument}
#' \item{\code{spans}}{see argument}
#' \item{\code{aligns}}{see argument}
#' \item{\code{display}}{logical matrix of same dimension as `strings`
#' that specifies whether an element in `strings` will be displayed
#' when the table is rendered}
#' \item{\code{formats}}{see argument}
#' \item{\code{row_info}}{see argument}
#' \item{\code{line_grouping}}{see argument}
#' \item{\code{ref_footnotes}}{see argument}
#' \item{\code{main_title}}{see argument}
#' \item{\code{subtitles}}{see argument}
#' \item{\code{page_titles}}{see argument}
#' \item{\code{main_footer}}{see argument}
#' \item{\code{prov_footer}}{see argument}
#' \item{\code{header_section_div}}{see argument}
#' \item{\code{horizontal_sep}}{see argument}
#' \item{\code{col_gap}}{see argument}
#' \item{\code{table_inset}}{see argument}
#' }
#'
#' as well as the following attributes:
#' \describe{
#' \item{\code{nlines_header}}{see argument}
#' \item{\code{nrow_header}}{see argument}
#' \item{\code{ncols}}{number of columns \emph{of the table}, not including
#' any row names/row labels}
#' }
MatrixPrintForm <- function(strings = NULL,
                            spans,
                            aligns,
                            formats,
                            row_info,
                            line_grouping = seq_len(NROW(strings)),
                            ref_fnotes = list(),
                            nlines_header,
                            nrow_header,
                            has_topleft = TRUE,
                            has_rowlabs = has_topleft,
                            expand_newlines = TRUE,
                            main_title = "",
                            subtitles = character(),
                            page_titles = character(),
                            main_footer = "",
                            prov_footer = character(),
                            header_section_div = NA_character_,
                            horizontal_sep = default_hsep(),
                            col_gap = 3,
                            table_inset = 0L,
                            colwidths = NULL,
                            indent_size = 2) {
  display <- disp_from_spans(spans)

  ncs <- if (has_rowlabs) ncol(strings) - 1 else ncol(strings)
  ret <- structure(
    list(
      strings = strings,
      spans = spans,
      aligns = aligns,
      display = display,
      formats = formats,
      row_info = row_info,
      line_grouping = line_grouping,
      ref_footnotes = ref_fnotes,
      main_title = main_title,
      subtitles = subtitles,
      page_titles = page_titles,
      main_footer = main_footer,
      prov_footer = prov_footer,
      header_section_div = header_section_div,
      horizontal_sep = horizontal_sep,
      col_gap = col_gap,
      table_inset = as.integer(table_inset),
      has_topleft = has_topleft,
      indent_size = indent_size,
      col_widths = colwidths
    ),
    nrow_header = nrow_header,
    ncols = ncs,
    class = c("MatrixPrintForm", "list")
  )

  ## .do_mat_expand(ret)
  if (expand_newlines) {
    ret <- mform_handle_newlines(ret)
  }


  ##  ret <- shove_refdf_into_rowinfo(ret)
  if (is.null(colwidths)) {
    colwidths <- propose_column_widths(ret)
  }
  mf_col_widths(ret) <- colwidths
  ret <- mform_build_refdf(ret)
  ret
}


#' Create a row for a referential footnote information dataframe
#'
#' @inheritParams nlines
#' @param row_path character. row path (`NA_character_` for none)
#' @param col_path character. column path (`NA_character_` for none)
#' @param row integer(1). Integer position of the row.
#' @param col integer(1). Integer position of the column.
#' @param symbol character(1). Symbol for the reference. `NA_character_` to use the `ref_index` automatically.
#' @param ref_index integer(1). The index of the footnote, used for ordering even when symbol is not NA
#' @param msg character(1). The string message, not including the symbol portion (`{symbol} - `)
#'
#' @return a single row data.frame with the appropriate columns.
#'
#' @export
#'
ref_df_row <- function(row_path = NA_character_,
                       col_path = NA_character_,
                       row = NA_integer_,
                       col = NA_integer_,
                       symbol = NA_character_,
                       ref_index = NA_integer_,
                       msg = NA_character_,
                       max_width = NULL) {
  nlines <- nlines(msg, max_width = max_width)
  data.frame(
    row_path = I(list(row_path)),
    col_path = I(list(col_path)),
    row = row,
    col = col,
    symbol = symbol,
    ref_index = ref_index,
    msg = msg,
    nlines = nlines,
    stringsAsFactors = FALSE
  )
}


## this entire thing is a hatchetjob of a hack which should not be necessary.
## mf_rinfo(mform) should have the relevant info in it and
## mf_cinfo(mform) should be non-null (!!!) and have the info in it
## in which case this becomes silly and dumb, but here we are, so here we go.
infer_ref_info <- function(mform, colspace_only) {
  if (colspace_only) {
    idx <- seq_len(mf_nlheader(mform))
  } else {
    idx <- seq_len(nrow(mf_strings(mform)))
  }


  hasrlbs <- mf_has_rlabels(mform)

  strs <- mf_strings(mform)[idx, , drop = FALSE]

  ## they're nested so \\2 is the inner one, without the brackets
  refs <- gsub("^[^{]*([{]([^}]+)[}]){0,1}$", "\\2", strs)
  ## handle spanned values
  refs[!mf_display(mform)[idx, ]] <- ""

  ## we want to count across rows first, not down columns, cause
  ## thats how footnote numbering works
  refs_inorder <- as.vector(t(refs))
  keepem <- nzchar(refs_inorder)
  if (sum(keepem) == 0) {
    return(ref_df_row()[0, ])
  }

  refs_spl <- strsplit(refs_inorder[keepem], ", ", fixed = TRUE)
  runvec <- vapply(refs_spl, length, 1L)



  row_index <- as.vector(
    t(do.call(cbind, replicate(ncol(strs), list(mf_lgrouping(mform)[idx] - mf_nlheader(mform)))))
  )[keepem]
  row_index[row_index < 1] <- NA_integer_
  c_torep <- if (hasrlbs) c(NA_integer_, seq(1, ncol(strs) - 1)) else seq_len(ncol(strs))
  col_index <- rep(c_torep, nrow(strs))[keepem]




  ret <- data.frame(
    symbol = unlist(refs_spl),
    row_path = I(mf_rinfo(mform)$path[rep(row_index, times = runvec)]),
    row = rep(row_index, times = runvec),
    col = rep(col_index, times = runvec)
  )
  ret$msg <- vapply(ret$symbol, function(sym) {
    fullmsg <- unique(grep(paste0("{", sym, "}"), fixed = TRUE, mf_rfnotes(mform), value = TRUE))
    gsub("^[{][^}]+[}] - ", "", fullmsg)
  }, "")


  col_pths <- mf_col_paths(mform)
  ret$col_path <- replicate(nrow(ret), list(NA_character_))
  non_na_col <- !is.na(ret$col)
  ret$col_path[non_na_col] <- col_pths[ret$col[non_na_col]]
  ret$ref_index <- match(ret$symbol, unique(ret$symbol))
  ##
  ret$nlines <- vapply(paste0("{", ret$symbol, "} - ", ret$msg), nlines, 1L)
  ret <- ret[, names(ref_df_row())]
  ret
}

mform_build_refdf <- function(mform) {
  rdf <- mf_rinfo(mform)
  cref_rows <- infer_ref_info(mform, colspace_only = TRUE)
  ## this will recheck sometimes but its safer and shouldn't
  ## be too prohibitively costly
  if (NROW(rdf$ref_info_df) > 0 && sum(sapply(rdf$ref_info_df, NROW)) > 0) {
    cref_rows <- infer_ref_info(mform, colspace_only = TRUE)
    rref_rows <- rdf$ref_info_df
  } else {
    cref_rows <- infer_ref_info(mform, colspace_only = FALSE)
    rref_rows <- list()
  }
  mf_fnote_df(mform) <- do.call(rbind.data.frame, c(list(cref_rows), rref_rows))
  update_mf_nlines(mform, colwidths = mf_col_widths(mform), max_width = NULL)
}









## constructor with snake_case naming convention
#' @rdname MatrixPrintForm
#' @export
matrix_print_form <- MatrixPrintForm


## hide the implementation behind abstraction in case we decide we want a real class someday
#' `Setters` and `getters` for aspects of `MatrixPrintForm` Objects
#'
#' Most of these functions, particularly the `settters`, are intended
#' almost exclusively for internal use in, e.g., `matrix_form` methods,
#' and should generally not be called by end users.
#'
#' @param mf `MatrixPrintForm(1)`. A `MatrixPrintForm` object
#' @param value ANY. The new value for the component in question.
#' @return The element of the `MatrixPrintForm` associated with the `getter`, or
#' the modified `MatrixPrintForm` object in the case of a `setter`.
#' @export
#' @rdname mpf_accessors
mf_strings <- function(mf) mf$strings

#' @export
#' @rdname mpf_accessors

mf_spans <- function(mf) mf$spans
#' @export
#' @rdname mpf_accessors

mf_aligns <- function(mf) mf$aligns

#' @export
#' @rdname mpf_accessors
mf_display <- function(mf) mf$display

#' @export
#' @rdname mpf_accessors
mf_formats <- function(mf) mf$formats

#' @export
#' @rdname mpf_accessors
mf_rinfo <- function(mf) mf$row_info

#' @export
#' @rdname mpf_accessors
mf_cinfo <- function(mf) mf$col_info


#' @export
#' @rdname mpf_accessors
mf_has_topleft <- function(mf) mf$has_topleft

#' @export
#' @rdname mpf_accessors
mf_lgrouping <- function(mf) mf$line_grouping

#' @export
#' @rdname mpf_accessors
mf_rfnotes <- function(mf) mf$ref_footnotes

#' @export
#' @rdname mpf_accessors
mf_nlheader <- function(mf) sum(mf_lgrouping(mf) <= mf_nrheader(mf))

#' @export
#' @rdname mpf_accessors
mf_nrheader <- function(mf) attr(mf, "nrow_header", exact = TRUE)


#' @export
#' @rdname mpf_accessors
mf_colgap <- function(mf) mf$col_gap




## XXX should this be exported? not sure if there's a point
mf_col_paths <- function(mf) {
  if (!is.null(mf_cinfo(mf))) {
    mf_cinfo(mf)$path
  } else {
    as.list(paste0("col", seq_len(nrow(mf_strings(mf)) - mf_has_topleft(mf))))
  }
}


mf_col_widths <- function(mf) {
  mf$col_widths
}

`mf_col_widths<-` <- function(mf, value) {
  if (!is.null(value) && length(value) != NCOL(mf_strings(mf))) {
    stop(
      "Number of column widths (", length(value), ") does not match ",
      "number of columns in strings matrix (", NCOL(mf_strings(mf)), ")."
    )
  }
  mf$col_widths <- value
  mf
}

mf_fnote_df <- function(mf) {
  mf$ref_fnote_df
}

`mf_fnote_df<-` <- function(mf, value) {
  stopifnot(is.null(value) || (is.data.frame(value) && identical(names(value), names(ref_df_row()))))
  mf$ref_fnote_df <- value
  mf
}


splice_fnote_info_in <- function(df, refdf, row = TRUE) {
  if (NROW(df) == 0) {
    return(df)
  }

  colnm <- ifelse(row, "row", "col")
  refdf <- refdf[!is.na(refdf[[colnm]]), ]

  refdf_spl <- split(refdf, refdf[[colnm]])
  df$ref_info_df <- replicate(nrow(df), list(ref_df_row()[0, ]))
  df$ref_info_df[as.integer(names(refdf_spl))] <- refdf_spl
  df
}


shove_refdf_into_rowinfo <- function(mform) {
  refdf <- mf_fnote_df(mform)
  rowinfo <- mf_rinfo(mform)
  mf_rinfo(mform) <- splice_fnote_info_in(rowinfo, refdf)
  mform
}

update_mf_nlines <- function(mform, colwidths, max_width) {
  mform <- update_mf_ref_nlines(mform, max_width = max_width)
  mform <- update_mf_rinfo_extents(mform)

  mform
}

update_mf_rinfo_extents <- function(mform) {
  rinfo <- mf_rinfo(mform)
  refdf_all <- mf_fnote_df(mform)
  refdf_rows <- refdf_all[!is.na(refdf_all$row), ]
  if (NROW(rinfo) == 0) {
    return(mform)
  }
  lgrp <- mf_lgrouping(mform) - mf_nrheader(mform)
  lgrp <- lgrp[lgrp > 0]
  rf_nlines <- vapply(seq_len(max(lgrp)), function(ii) {
    refdfii <- refdf_rows[refdf_rows$row == ii, ]
    refdfii <- refdfii[!duplicated(refdfii$symbol), ]
    if (NROW(refdfii) == 0L) {
      return(0L)
    }
    sum(refdfii$nlines)
  }, 1L)

  raw_self_exts <- vapply(split(lgrp, lgrp), length, 0L)
  stopifnot(length(raw_self_exts) == length(rf_nlines))
  new_exts <- raw_self_exts + rf_nlines

  mapdf <- data.frame(
    row_num = as.integer(names(new_exts)),
    raw_extent = raw_self_exts
  )
  stopifnot(all(mapdf$row_num == rinfo$abs_rownumber))


  new_par_exts <- vapply(rinfo$reprint_inds, function(idx) {
    sum(0L, mapdf$raw_extent[mapdf$row_num %in% idx])
  }, 1L)

  rinfo$self_extent <- new_exts
  rinfo$par_extent <- new_par_exts
  rinfo$nreflines <- rf_nlines
  mf_rinfo(mform) <- rinfo
  mform
}

update_mf_ref_nlines <- function(mform, max_width) {
  refdf <- mf_fnote_df(mform)
  if (NROW(refdf) == 0) {
    return(mform)
  }

  refdf$nlines <- vapply(
    paste0("{", refdf$symbol, "} - ", refdf$msg),
    nlines,
    max_width = max_width,
    1L
  )
  mf_fnote_df(mform) <- refdf
  shove_refdf_into_rowinfo(mform)
}



#' @export
#' @rdname mpf_accessors
`mf_strings<-` <- function(mf, value) {
  mf$strings <- value
  mf
}

.chkdim_and_replace <- function(mf, value, component) {
  strdim <- dim(mf_strings(mf))
  vdim <- dim(value)
  if (!is.null(strdim) && !identical(strdim, vdim)) {
    stop(
      "Dimensions of new '", component, "' value (",
      vdim[1], ", ", vdim[2], # nocov
      ") do not match dimensions of existing 'strings' component (", # nocov
      strdim[1], ", ", strdim[2], ")." # nocov
    )
  }
  mf[[component]] <- value
  mf
}


#' @export
#' @rdname mpf_accessors
`mf_spans<-` <- function(mf, value) {
  mf <- .chkdim_and_replace(mf, value, component = "spans")
  mf$display <- disp_from_spans(value)
  mf
}

#' @export
#' @rdname mpf_accessors
`mf_aligns<-` <- function(mf, value) {
  .chkdim_and_replace(mf, value, component = "aligns")
}


#' @export
#' @rdname mpf_accessors
`mf_display<-` <- function(mf, value) {
  stop("display is now a derived element of the matrix print form, modify it via `mf_spans<-`")
  .chkdim_and_replace(mf, value, component = "display")
}

#' @export
#' @rdname mpf_accessors
`mf_formats<-` <- function(mf, value) {
  .chkdim_and_replace(mf, value, component = "formats")
}


## NB NROW(v) == length(v) for atomic vectors so this is ok for lgrouping as wellas rinfo
.chknrow_and_replace <- function(mf, value, component, noheader = FALSE) {
  strdim <- NROW(mf_strings(mf)) - if (noheader) mf_nlheader(mf) else 0L
  vdim <- NROW(value)
  if (!is.null(strdim) && !identical(strdim, vdim)) {
    stop(
      "Number of rows/length of new '", component, "' value (",
      vdim[1],
      ") does not match existing 'strings' component (",
      strdim[1], ")."
    )
  }
  mf[[component]] <- value
  mf
}

#' @export
#' @rdname mpf_accessors
`mf_rinfo<-` <- function(mf, value) {
  ## this can someijtmes be called after expanding newlines so in general
  ## we should not expect it to match the number of rows in the strings matrix
  ## .chknrow_and_replace(mf, value, component = "row_info", noheader = TRUE)
  lgrps <- mf_lgrouping(mf)
  nrs <- length(unique(lgrps[-seq_len(mf_nlheader(mf))]))
  if (NROW(value) != nrs) {
    stop(
      "Rows in new row_info component (",
      NROW(value),
      ") does not match number of rows reflected in line_grouping component (",
      nrs, ")"
    )
  }
  mf$row_info <- value
  mf
}

#' @export
#' @rdname mpf_accessors
`mf_cinfo<-` <- function(mf, value) {
  if (NROW(value) > 0 && NROW(value) != ncol(mf)) {
    stop(
      "Number of rows in new cinfo (", NROW(value), ") does not match ",
      "number of columns (", ncol(mf), ")"
    )
  }
  mf$col_info <- value
  mf
}


#' @export
#' @rdname mpf_accessors
`mf_lgrouping<-` <- function(mf, value) {
  .chknrow_and_replace(mf, value, component = "line_grouping")
}


#' @export
#' @rdname mpf_accessors
`mf_rfnotes<-` <- function(mf, value) {
  mf$ref_footnotes <- value
  mf
}



#' @export
#' @rdname mpf_accessors
`mf_nrheader<-` <- function(mf, value) {
  attr(mf, "nrow_header") <- value
  mf
}

#' @export
#' @rdname mpf_accessors
`mf_colgap<-` <- function(mf, value) {
  mf$col_gap <- value
  mf
}

#' @export
#' @rdname mpf_accessors
mf_ncol <- function(mf) attr(mf, "ncols", exact = TRUE)

#' @export
#' @rdname mpf_accessors
mf_nrow <- function(mf) max(mf_lgrouping(mf)) - mf_nrheader(mf)



#' @export
#' @rdname mpf_accessors
`mf_ncol<-` <- function(mf, value) {
  stopifnot(is.numeric(value))
  attr(mf, "ncols") <- value
  mf
}

#' @param x `MatrixPrintForm`. The object.
#' @export
#' @rdname mpf_accessors
setMethod(
  "ncol", "MatrixPrintForm",
  function(x) mf_ncol(x)
)

#' @export
#' @rdname mpf_accessors
mpf_has_rlabels <- function(mf) {
  .Deprecated("mf_has_rlabels")
  mf_has_rlabels(mf)
}

#' @export
#' @rdname mpf_accessors
mf_has_rlabels <- function(mf) ncol(mf$strings) > ncol(mf)

#' Create spoof matrix form from a data.frame
#'
#' This is  useful primarily  for writing  testing/examples, and as a
#' starting point for more sophisticated custom `matrix_form` methods
#'
#' @param df data.frame
#' @param parent_path character. parent path that all rows should be "children of",
#' defaults to `"root"`, and generally should not matter to end users.
#'
#' @return A valid `MatrixPrintForm` object representing `df`,
#' ready for ASCII rendering
#'
#' @examples
#' mform <- basic_matrix_form(mtcars)
#' cat(toString(mform))
#' @export
basic_matrix_form <- function(df, parent_path = "root") {
  fmts <- lapply(df, function(x) if (is.null(obj_format(x))) "xx" else obj_format(x))

  bodystrs <- mapply(function(x, fmt) {
    sapply(x, format_value, format = fmt)
  }, x = df, fmt = fmts)

  rnms <- row.names(df)
  if (is.null(rnms)) {
    rnms <- as.character(seq_len(NROW(df)))
  }

  cnms <- names(df)

  strings <- rbind(
    c("", cnms),
    cbind(rnms, bodystrs)
  )

  fnr <- nrow(strings)
  fnc <- ncol(strings)

  ## center alignment for column labels, left alignment for everything else
  aligns <- rbind(
    "center",
    matrix("left", nrow = NROW(df), ncol = fnc)
  )


  ## build up fake pagination df
  charcols <- which(sapply(df, is.character))
  if (length(charcols) > 0) {
    exts <- apply(df[, charcols, drop = FALSE], 1, function(x) max(vapply(x, nlines, 1L)))
  } else {
    exts <- rep(1L, NROW(df))
  }
  rowdf <- basic_pagdf(row.names(df),
    extents = exts,
    parent_path = parent_path
  )
  formats <- cbind(
    "",
    rbind(
      "",
      matrix("xx", nrow = nrow(df), ncol = ncol(df))
    )
  )

  ret <- matrix_print_form(
    strings = strings,
    aligns = aligns,
    spans = matrix(1, nrow = fnr, ncol = fnc),
    formats = formats, ## matrix("xx", nrow = fnr, ncol = fnc),
    row_info = rowdf,
    has_topleft = FALSE,
    nlines_header = 1,
    nrow_header = 1,
    has_rowlabs = TRUE
  )
  mform_build_refdf(ret)
}


map_to_new <- function(old, map) {
  inds <- match(old, map$old_idx)
  map$new_idx[inds]
}


reconstruct_basic_fnote_list <- function(mf) {
  refdf <- mf_fnote_df(mf)
  if (NROW(refdf) == 0) {
    return(NULL)
  }
  refdf <- refdf[!duplicated(refdf$symbol), ]
  paste0("{", refdf$symbol, "} - ", refdf$msg)
}

.mf_subset_core_mats <- function(mf, i, row = TRUE) {
  fillnum <- if (row) nrow(mf_strings(mf)) - mf_nlheader(mf) else ncol(mf)
  if (is.logical(i) || all(i < 0)) {
    i <- seq_len(fillnum)[i]
  }

  if (row) {
    nlh <- mf_nlheader(mf)
    ncolrows <- mf_nrheader(mf)
    i_mat <- c(seq_len(nlh), which(mf_lgrouping(mf) %in% (i + ncolrows)))
    j_mat <- seq_len(ncol(mf_strings(mf)))
  } else {
    nlabcol <- as.integer(mf_has_rlabels(mf))
    i_mat <- seq_len(nrow(mf_strings(mf)))
    j_mat <- c(seq_len(nlabcol), i + nlabcol)
  }


  mf_strings(mf) <- mf_strings(mf)[i_mat, j_mat, drop = FALSE]
  mf_lgrouping(mf) <- as.integer(as.factor(mf_lgrouping(mf)[i_mat]))
  if (!row) {
    newspans <- truncate_spans(mf_spans(mf), j_mat) # 'i' is the columns here, b/c row is FALSE
  } else {
    newspans <- mf_spans(mf)[i_mat, j_mat, drop = FALSE]
  }
  mf_spans(mf) <- newspans
  mf_formats(mf) <- mf_formats(mf)[i_mat, j_mat, drop = FALSE]

  mf_aligns(mf) <- mf_aligns(mf)[i_mat, j_mat, drop = FALSE]
  if (!row) {
    mf_ncol(mf) <- length(i)
    if (!is.null(mf_col_widths(mf))) {
      mf_col_widths(mf) <- mf_col_widths(mf)[j_mat]
    }
  }
  mf
}

## ugh. spans are **way** more of a pain than I expected x.x
truncate_one_span <- function(spanrow, j) {
  i <- 1
  len <- length(spanrow)
  while (i < len) {
    spnlen <- spanrow[i]
    inds <- seq(i, i + spnlen - 1)
    newspnlen <- sum(inds %in% j)
    spanrow[inds] <- newspnlen
    i <- i + spnlen
  }
  spanrow[j]
}

truncate_spans <- function(spans, j) {
  if (length(spans[1, ]) == 1) {
    as.matrix(apply(spans, 1, truncate_one_span, j = j))
  } else {
    t(apply(spans, 1, truncate_one_span, j = j))
  }
}


mpf_subset_rows <- function(mf, i) {
  nlh <- mf_nlheader(mf)
  lgrps <- mf_lgrouping(mf)
  row_lgrps <- tail(lgrps, -1 * nlh)
  nrs <- length(unique(row_lgrps))
  ncolrows <- length(unique(lgrps[seq_len(nlh)]))

  ncs <- ncol(mf)
  mf <- .mf_subset_core_mats(mf, i, row = TRUE)
  map <- data.frame(
    old_idx = c(seq_len(ncolrows), i + ncolrows),
    new_idx = c(seq_len(ncolrows), ncolrows + order(i))
  )

  row_map <- data.frame(old_idx = i, new_idx = order(i))

  refdf <- mf_fnote_df(mf)

  old_nas <- is.na(refdf$row)
  refdf$row <- map_to_new(refdf$row, row_map)
  refdf <- refdf[old_nas | !is.na(refdf$row), ]
  mf_fnote_df(mf) <- refdf

  rinfo <- mf_rinfo(mf)

  rinfo <- rinfo[rinfo$abs_rownumber %in% i, ]

  rinfo$abs_rownumber <- map_to_new(rinfo$abs_rownumber, row_map)
  mf_rinfo(mf) <- rinfo

  mf <- shove_refdf_into_rowinfo(mf)
  mf_rfnotes(mf) <- reconstruct_basic_fnote_list(mf)
  mf
}



## we only care about referential footnotes, cause
## they are currently the only place we're tracking
## column information that will need to be touched up
## but lets be careful and do a bit more anyway
mpf_subset_cols <- function(mf, j) {
  nc <- ncol(mf)
  if (is.logical(j) || all(j < 0)) {
    j <- seq_len(nc)[j]
  }
  if (any(j < 0)) {
    stop("cannot mix negative and positive indices")
  }

  if (length(unique(j)) != length(j)) {
    stop("duplicated columns are not allowed when subsetting a matrix print form objects")
  }


  #    j_mat <- c(if(mf_has_topleft(mf)) seq_len(nlabcol), j + nlabcol)
  map <- data.frame(old_idx = j, new_idx = order(j))

  ## this has to happen before the remap inher
  refdf <- mf_fnote_df(mf)

  mf <- .mf_subset_core_mats(mf, j, row = FALSE)


  ## future proofing (pipe dreams)
  ## uncomment if we ever manage to have col info information on MPFs
  ## if(!is.null(mf_cinfo(mf))) {
  ##     cinfo <- mf_cinfo(mf)
  ##     cinfo <- cinfo[j, , drop = FALSE]
  ##     cinfo$abs_pos <- map_to_new(cinfo$abs_pos, map)
  ##     mf_cinfo(mf) <- mf
  ## }



  keep <- is.na(refdf$col) | refdf$col %in% j
  refdf <- refdf[keep, , drop = FALSE]

  refdf$col <- map_to_new(refdf$col, map)
  mf_fnote_df(mf) <- refdf
  mf <- shove_refdf_into_rowinfo(mf)
  mf_rfnotes(mf) <- reconstruct_basic_fnote_list(mf)
  mf_ncol(mf) <- length(j)
  mf
}

## credit: rlang, Henry and Wickham.
## this one tiny utility function is NOT worth a dependency.
## modified it so any length 0 x grabs y

#' `%||%` If length-0 alternative operator
#' @name ifnotlen0
#'
#' @param a ANY. Element to select only if it is not length 0
#' @param b ANY. Element to select if \code{a} is length 0
#' @export
#' @examples
#' 6 %||% 10
#'
#' character() %||% "hi"
#'
#' NULL %||% "hi"
#' @return `a`, unless it  is length 0, in which case  `b` (even in the
#'     case `b` is also length 0)
`%||%` <- function(a, b) {
  if (length(a) == 0) {
    b
  } else {
    a
  }
}

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		#' 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		.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		}

1		#' @import grid
2		#' @import grDevices
3		NULL
4		## https://www.ietf.org/rfc/rfc0678.txt
5
6		## This assumes fixed font size, monospaced font
7
8		std_cpi <- 10L
9		std_lpi <- 6L
10
11
12		std_full_pg_wd_in <- 8.5
13
14		std_full_pg_ht_in <- 11
15
16		std_log_pg_wd_chars <- 72
17
18		std_log_pg_ht_lines <- 60
19
20		std_marg_ht <- round((std_full_pg_ht_in - std_log_pg_ht_lines / std_lpi) / 2, 2)
21		std_marg_wd <- round((std_full_pg_wd_in - std_log_pg_wd_chars / std_cpi) / 2, 2)
22
23		std_margins <- list(
24		top = std_marg_ht,
25		bottom = std_marg_ht,
26		left = std_marg_wd,
27		right = std_marg_wd
28		)
29
30		## does not appear to be used anywhere
31		## to_inches_num <- function(x) {
32		## if (is(x, "unit")) {
33		## x <- unclass(convertUnit(x, "inches"))
34		## }
35		## x
36		## }
37
38		## Physical size, does not take margins into account
39		pg_dim_names <- list(
40		letter = c(8.5, 11),
41		a4 = c(8.27, 11.69),
42		legal = c(8.5, 14)
43		)
44
45
46		#'
47		#' Supported Named Page `TypesList` supported named page types
48		#'
49		#' @return for `page_types` a character vector of supported page types,
50		#' for `page_dim` the dimensions (width, then height) of the selected page type.
51		#'
52		#' @export
53		#' @examples
54		#' page_types()
55		#' page_dim("a4")
56		page_types <- function() {
57	36x	names(pg_dim_names)
58		}
59
60		#' @export
61		#' @param page_type character(1). The name of a page size specification. Call
62		#' `page_types` for supported values.
63		#' @rdname page_types
64		page_dim <- function(page_type) {
65	13x	if (is.null(page_type)) {
66	8x	return(NULL)
67		}
68	5x	if (!page_type %in% page_types()) {
69	1x	stop("Unrecognized page-size specification: ", page_type)
70		}
71	4x	pg_dim_names[[page_type]]
72		}
73
74
75
76		#' Calculate lines per inch and characters per inch for font
77		#'
78		#' @inheritParams page_lcpp
79		#'
80		#' @details This function creates opens pdf graphics device writing to an temporary file,
81		#' then utilizes [grid::convertWidth()] and [grid::convertHeight()] to calculate
82		#' lines per inch and characters per inch for the specified font family, size, and
83		#' line height.
84		#'
85		#' An error is thrown if the font is not monospaced (determined by comparing
86		#' the effective widths of the `M` and `.` glyphs).
87		#' @return named list with `cpi` and `lpi`, the characters and lines per
88		#' inch, respectively.
89		#'
90		#' @examples
91		#' \dontrun{
92		#' font_lcpi()
93		#'
94		#' font_lcpi(font_size = 8)
95		#'
96		#' font_lcpi(font_size = 8, lineheight = 1.1)
97		#' }
98		#'
99		#' @keywords internal
100		font_lcpi <- function(font_family = "Courier", font_size = 8, lineheight = 1) {
101	27x	tmppdf <- tempfile(fileext = ".pdf")
102	27x	pdf(tmppdf)
103	27x	on.exit(dev.off())
104	27x	grid.newpage()
105	27x	gp <- gpar(fontfamily = font_family, fontsize = font_size, lineheight = lineheight)
106	27x	pushViewport(plotViewport(gp = gp))
107	27x	if (convertWidth(unit(1, "strwidth", "."), "inches", valueOnly = TRUE) !=
108	27x	convertWidth(unit(1, "strwidth", "M"), "inches", valueOnly = TRUE)) { # nolint
109	1x	stop(
110	1x	"The font family you selected - ",
111	1x	font_family,
112	1x	" - does not appear to be monospaced. This is not supported."
113		)
114		}
115	26x	list(
116	26x	cpi = 1 / convertWidth(unit(1, "strwidth", "h"), "inches", valueOnly = TRUE),
117	26x	lpi = convertHeight(unit(1, "inches"), "lines", valueOnly = TRUE)
118		)
119		}
120
121		marg_order <- c("bottom", "left", "top", "right")
122
123		#' Determine lines per page (`LPP`) and characters per page (`CPP`) based on font and page type
124		#'
125		#' @param page_type character(1). Name of a page type. See
126		#' `page_types`. Ignored when `pg_width` and `pg_height`
127		#' are set directly.
128		#' @param landscape logical(1). Should the dimensions of `page_type`
129		#' be inverted for landscape? Defaults to `FALSE`, ignored when
130		#' `pg_width` and `pg_height` are set directly.
131		#' @param font_family character(1). Name of a font family. An error
132		#' will be thrown if the family named is not monospaced. Defaults
133		#' to Courier.
134		#' @param font_size numeric(1). Font size, defaults to 12.
135		#' @param lineheight numeric(1). Line height, defaults to 1.
136		#' @param margins numeric(4). Named numeric vector containing `'bottom'`,
137		#' `'left'`, `'top'`, and `'right'` margins in inches. Defaults
138		#' to `.5` inches for both vertical margins and `.75` for both
139		#' horizontal margins.
140		#' @param pg_width numeric(1). Page width in inches.
141		#' @param pg_height numeric(1). Page height in inches.
142		#'
143		#' @return a named list containing `LPP` (lines per page) and `CPP` (characters per page)
144		#' elements suitable for use by the pagination machinery.
145		#'
146		#' @export
147		#' @examples
148		#' page_lcpp()
149		#' page_lcpp(font_size = 10)
150		#' page_lcpp("a4", font_size = 10)
151		#'
152		#' page_lcpp(margins = c(top = 1, bottom = 1, left = 1, right = 1))
153		#' page_lcpp(pg_width = 10, pg_height = 15)
154		page_lcpp <- function(page_type = page_types(),
155		landscape = FALSE,
156		font_family = "Courier",
157		font_size = 8,
158		lineheight = 1,
159		margins = c(top = .5, bottom = .5, left = .75, right = .75),
160		pg_width = NULL,
161		pg_height = NULL) {
162	27x	if (is.null(page_type)) {
163	5x	page_type <- page_types()[1]
164		} else {
165	22x	page_type <- match.arg(page_type)
166		}
167
168	27x	if (is.null(names(margins))) {
169	6x	names(margins) <- marg_order
170		} else {
171	21x	margins <- margins[marg_order]
172		}
173	27x	if (any(is.na(margins))) {
174	!	stop("margins argument must have names 'bottom', 'left', 'top' and 'right'.")
175		}
176	27x	lcpi <- font_lcpi(
177	27x	font_family = font_family,
178	27x	font_size = font_size,
179	27x	lineheight = lineheight
180		)
181
182	26x	wdpos <- ifelse(landscape, 2, 1)
183	26x	pg_width <- pg_width %\|\|% pg_dim_names[[page_type]][wdpos]
184	26x	pg_height <- pg_height %\|\|% pg_dim_names[[page_type]][-wdpos]
185
186	26x	pg_width <- pg_width - sum(margins[c("left", "right")])
187	26x	pg_height <- pg_height - sum(margins[c("top", "bottom")])
188
189	26x	list(
190	26x	cpp = floor(lcpi[["cpi"]] * pg_width),
191	26x	lpp = floor(lcpi[["lpi"]] * pg_height)
192		)
193		}
194
195		## pg_types <- list(
196		## "fsrp" = c(cpp = 110, lpp = 66),
197		## "fsrp8" = c(cpp = 110, lpp = 66),
198		## "fsrp7" = c(cpp = 110, lpp = 75),
199		## "fsrl" = c(cpp = 149, lpp = 51),
200		## "fsrl8" = c(cpp = 149, lpp = 51),
201		## "fsrl7" = c(cpp = 150, lpp = 59),
202		## "erp" = c(cpp = 96, lpp = 66),
203		## "erp8" = c(cpp = 96, lpp = 66),
204		## "erl" = c(cpp = 149, lpp = 45),
205		## "erl8" = c(cpp = 149, lpp = 45),
206		## "sasp" = c(cpp = 93, lpp = 73),
207		## "sasp8" = c(cpp = 93, lpp = 73),
208		## "sasl" = c(cpp = 134, lpp = 52),
209		## "sasl8" = c(cpp = 134, lpp = 52),
210		## "sasp7" = c(cpp = 107, lpp = 92),
211		## "sasl7" = c(cpp = 154, lpp = 64),
212		## "sasp6" = c(cpp = 125, lpp = 108),
213		## "sasl6" = c(cpp = 180, lpp = 75),
214		## "sasp10" = c(cpp = 78, lpp = 64),
215		## "sasl10" = c(cpp = 108, lpp = 45),
216		## "sasp9" = c(cpp = 87, lpp = 71),
217		## "sasl9" = c(cpp = 120, lpp = 51),
218		## "rapidp10" = c(cpp = 78, lpp = 64),
219		## "rapidl10" = c(cpp = 108, lpp = 45),
220		## "rapidp9" = c(cpp = 87, lpp = 71),
221		## "rapidl9" = c(cpp = 120, lpp = 51),
222		## "rapidp" = c(cpp = 93, lpp = 73),
223		## "rapidp8" = c(cpp = 93, lpp = 73),
224		## "rapidl" = c(cpp = 134, lpp = 52),
225		## "rapidl8" = c(cpp = 134, lpp = 52),
226		## "rapidp7" = c(cpp = 107, lpp = 92),
227		## "rapidl7" = c(cpp = 154, lpp = 64),
228		## "rapidp6" = c(cpp = 125, lpp = 108),
229		## "rapidl6" = c(cpp = 180, lpp = 75),
230		## "shibal" = c(cpp = 170, lpp = 48),
231		## "shibal10" = c(cpp = 137, lpp = 39),
232		## "shibal8" = c(cpp = 170, lpp = 48),
233		## "shibal7" = c(cpp = 194, lpp = 56),
234		## "shibal6" = c(cpp = 225, lpp = 65),
235		## "shibap" = c(cpp = 112, lpp = 78),
236		## "shibap10" = c(cpp = 89, lpp = 64),
237		## "shibap8" = c(cpp = 112, lpp = 78),
238		## "shibap7" = c(cpp = 127, lpp = 92),
239		## "shibap6" = c(cpp = 148, lpp = 108))
240
241
242
243
244
245
246		## courier_fontsize_lcpi_df <- tribble(
247		## ~courier_size, ~cpi, ~lpi,
248		## 6, floor(129 / pg_dim_names[["letter"]][1]), floor(85 / pg_dim_names[["letter"]][2]),
249		## 7, floor(110 / pg_dim_names[["letter"]][1]), floor(76 / pg_dim_names[["letter"]][2]),
250		## 8, floor(95 / pg_dim_names[["letter"]][1]), floor(68 / pg_dim_names[["letter"]][2]),
251		## 9, floor(84 / pg_dim_names[["letter"]][1]), floor(61 / pg_dim_names[["letter"]][2]),
252		## 10, floor(75 / pg_dim_names[["letter"]][1]), floor(56 / pg_dim_names[["letter"]][2])
253		## )
254
255		## courier_lcpi <- function(size) {
256		## grid.newpage()
257		## gp <- gpar(fontfamily="Courier New", fontsize = size, lineheight = 1)
258		## pushViewport(plotViewport( gp = gp))
259		## list(cpi = round(1/convertWidth(unit(1, "strwidth", "h"), "inches", valueOnly = TRUE), 0),
260		## lpi = round(convertHeight(unit(1, "inches"), "lines", valueOnly = TRUE), 0))
261		## }

1		## credit: rlang, Henry and Wickham.
2		## this one tiny utility function is NOT worth a dependency.
3		## modified it so any length 0 x grabs y
4
5		#' `%\|\|%` If length-0 alternative operator
6		#' @name ifnotlen0
7		#'
8		#' @param a ANY. Element to select only if it is not length 0
9		#' @param b ANY. Element to select if \code{a} is length 0
10		#' @export
11		#' @examples
12		#' 6 %\|\|% 10
13		#'
14		#' character() %\|\|% "hi"
15		#'
16		#' NULL %\|\|% "hi"
17		#' @return `a`, unless it is length 0, in which case `b` (even in the
18		#' case `b` is also length 0)
19		`%\|\|%` <- function(a, b) {
20	229x	if (length(a) == 0) {
21	34x	b
22		} else {
23	195x	a
24		}
25		}