formatters coverage - 92.98%

Files
Source

## until we do it for real

#' Class for Matrix Print Form
#'
#' The `MatrixPrintForm` class, an intermediate representation for ASCII table printing.
#'
#' @name MatrixPrintForm-class
#' @rdname 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 top-left is bottom aligned (default)
  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))

  # Correction for the case where there are more lines for topleft material than for cols
  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)
  }

  # Solve \n in titles
  if (any(grepl("\n", all_titles(matform)))) {
    if (any(grepl("\n", main_title(matform)))) {
      tmp_title_vec <- .quick_handle_nl(main_title(matform))
      main_title(matform) <- tmp_title_vec[1]
      subtitles(matform) <- c(tmp_title_vec[-1], .quick_handle_nl(subtitles(matform)))
    } else {
      subtitles(matform) <- .quick_handle_nl(subtitles(matform))
    }
  }

  # Solve \n in footers
  main_footer(matform) <- .quick_handle_nl(main_footer(matform))
  prov_footer(matform) <- .quick_handle_nl(prov_footer(matform))

  # xxx \n in page titles are not working atm (I think)

  matform
}

.quick_handle_nl <- function(str_v) {
  if (any(grepl("\n", str_v))) {
    return(unlist(strsplit(str_v, "\n", fixed = TRUE)))
  } else {
    return(str_v)
  }
}

# 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 for Matrix Print Form
#'
#' Constructor for `MatrixPrintForm`, an intermediate representation for ASCII table printing.
#'
#' @param strings (`character matrix`)\cr 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`)\cr matrix of same dimension as `strings` giving the
#'   spanning information for each element. Must be repeated to match placeholders in `strings`.
#' @param aligns (`character matrix`)\cr matrix of same dimension as `strings` giving the text
#'   alignment information for each element. Must be repeated to match placeholders in `strings`.
#'   Must be a supported text alignment. See [decimal_align] for allowed values.
#' @param formats (`matrix`)\cr matrix of same dimension as `strings` giving the text format
#'   information for each element. Must be repeated to match placeholders in `strings`.
#' @param row_info (`data.frame`)\cr data frame with row-information necessary for pagination (see
#'   [basic_pagdf()] for more details).
#' @param line_grouping (`integer`)\cr sequence of integers indicating how print lines correspond
#'   to semantic rows in the object. Typically this should not be set manually unless
#'   `expand_newlines` is set to `FALSE`.
#' @param ref_fnotes (`list`)\cr referential footnote information, if applicable.
#' @param nlines_header (`numeric(1)`)\cr number of lines taken up by the values of the header
#'   (i.e. not including the divider).
#' @param nrow_header (`numeric(1)`)\cr number of *rows* corresponding to the header.
#' @param has_topleft (`flag`)\cr does the corresponding table have "top left information"
#'   which should be treated differently when expanding newlines. Ignored if `expand_newlines`
#'   is `FALSE`.
#' @param has_rowlabs (`flag`)\cr do the matrices (`strings`, `spans`, `aligns`) each contain a
#'   column that corresponds with row labels (rather than with table cell values). Defaults to `TRUE`.
#' @param main_title (`string`)\cr main title as a string.
#' @param subtitles (`character`)\cr subtitles, as a character vector.
#' @param page_titles (`character`)\cr page-specific titles, as a character vector.
#' @param main_footer (`character`)\cr main footer, as a character vector.
#' @param prov_footer (`character`)\cr provenance footer information, as a character vector.
#' @param listing_keycols (`character`)\cr. if matrix form of a listing, this contains
#'   the key columns as a character vector.
#' @param header_section_div (`string`)\cr divider to be used between header and body sections.
#' @param horizontal_sep (`string`)\cr horizontal separator to be used for printing divisors
#'   between header and table body and between different footers.
#' @param expand_newlines (`flag`)\cr whether the matrix form generated should expand rows whose
#'   values contain newlines into multiple 'physical' rows (as they will appear when rendered into
#'   ASCII). Defaults to `TRUE`.
#' @param col_gap (`numeric(1)`)\cr space (in characters) between columns.
#' @param table_inset (`numeric(1)`)\cr table inset. See [table_inset()].
#' @param colwidths (`numeric` or `NULL`)\cr column rendering widths. If non-`NULL`, must have length
#'   equal to `ncol(strings)`.
#' @param indent_size (`numeric(1)`)\cr number of spaces to be used per level of indent (if supported by
#'   the relevant method). Defaults to 2.
#'
#' @return An object of class `MatrixPrintForm`. Currently this is implemented as an S3 class inheriting
#'   from list with the following elements:
#'   \describe{
#'     \item{`strings`}{see argument.}
#'     \item{`spans`}{see argument.}
#'     \item{`aligns`}{see argument.}
#'     \item{`display`}{logical matrix of same dimension as `strings` that specifies whether an element
#'       in `strings` will be displayed when the table is rendered.}
#'     \item{`formats`}{see argument.}
#'     \item{`row_info`}{see argument.}
#'     \item{`line_grouping`}{see argument.}
#'     \item{`ref_footnotes`}{see argument.}
#'     \item{`main_title`}{see argument.}
#'     \item{`subtitles`}{see argument.}
#'     \item{`page_titles`}{see argument.}
#'     \item{`main_footer`}{see argument.}
#'     \item{`prov_footer`}{see argument.}
#'     \item{`header_section_div`}{see argument.}
#'     \item{`horizontal_sep`}{see argument.}
#'     \item{`col_gap`}{see argument.}
#'     \item{`table_inset`}{see argument.}
#'   }
#'
#'   as well as the following attributes:
#'
#'   \describe{
#'     \item{`nlines_header`}{see argument.}
#'     \item{`nrow_header`}{see argument.}
#'     \item{`ncols`}{number of columns *of the table*, not including any row names/row labels}
#'   }
#'
#' @note The bare constructor for the `MatrixPrintForm` should generally
#'   only be called by `matrix_form` custom methods, and almost never from other code.
#'
#' @examples
#' basic_matrix_form(iris) # calls matrix_form which calls this constructor
#'
#' @export
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(),
                            listing_keycols = NULL,
                            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,
      listing_keycols = listing_keycols,
      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 data frame
#'
#' @inheritParams nlines
#' @param row_path (`character`)\cr row path (or `NA_character_` for none).
#' @param col_path (`character`)\cr column path (or `NA_character_` for none).
#' @param row (`integer(1)`)\cr integer position of the row.
#' @param col (`integer(1)`)\cr integer position of the column.
#' @param symbol (`string`)\cr symbol for the reference. `NA_character_` to use the
#'   `ref_index` automatically.
#' @param ref_index (`integer(1)`)\cr index of the footnote, used for ordering even when
#'   symbol is not `NA`.
#' @param msg (`string`)\cr 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)
}

## hide the implementation behind abstraction in case we decide we want a real class someday
#' Getters and setters for aspects of `MatrixPrintForm` objects
#'
#' Most of these functions, particularly the setters, 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`)\cr a `MatrixPrintForm` object.
#' @param value (`ANY`)\cr the new value for the component in question.
#'
#' @return
#' * Getters return the associated element of `mf`.
#' * Setters return the modified `mf` object.
#'
#' @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) != mf_ncol(mf)) {
    stop(
      "Number of rows in new cinfo (", NROW(value), ") does not match ",
      "number of columns (", mf_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) > mf_ncol(mf)

#' Create spoof matrix form from a data frame
#'
#' Useful functions for writing tests and examples, and a starting point for
#' more sophisticated custom `matrix_form` methods.
#'
#' @param df (`data.frame`)\cr a data frame.
#' @param indent_rownames (`flag`)\cr whether row names should be indented. Being this
#'   used for testing purposes, it defaults to `FALSE`. If `TRUE`, it assigns label rows
#'   on even lines (also format is `"-"` and value strings are `""`). Indentation works
#'   only if split labels are used (see parameters `split_labels` and `data_labels`).
#' @param parent_path (`string`)\cr parent path that all rows should be "children of".
#'   Defaults to `NULL`, as usually this is not needed. It may be necessary to use `"root"`,
#'   for some specific scenarios.
#' @param ignore_rownames (`flag`)\cr whether row names should be ignored.
#' @param add_decoration (`flag`)\cr whether adds title and footer decorations should
#'   be added to the matrix form.
#' @param split_labels (`string`)\cr indicates which column to use as split labels. If
#'   `NULL`, no split labels are used.
#' @param data_labels (`string`)\cr indicates which column to use as data labels. It is
#'   ignored if no `split_labels` is present and is automatically assigned to
#'   `"Analysis method"` when `split_labels` is present, but `data_labels` is `NULL`.
#'   Its direct column name is used as node name in `"DataRow"` pathing. See [mf_rinfo()]
#'   for more information.
#'
#' @return A valid `MatrixPrintForm` object representing `df` that is ready for
#'   ASCII rendering.
#'
#' @details
#' If some of the column has a [obj_format] assigned, it will be respected for all column
#' values except for label rows, if present (see parameter `split_labels`).
#'
#' @examples
#' mform <- basic_matrix_form(mtcars)
#' cat(toString(mform))
#'
#' # Advanced test case with label rows
#' library(dplyr)
#' iris_output <- iris %>%
#'   group_by(Species) %>%
#'   summarize("all obs" = round(mean(Petal.Length), 2)) %>%
#'   mutate("DataRow_label" = "Mean")
#' mf <- basic_matrix_form(iris_output,
#'   indent_rownames = TRUE,
#'   split_labels = "Species", data_labels = "DataRow_label"
#' )
#' cat(toString(mf))
#'
#' @name test_matrix_form
#' @export
basic_matrix_form <- function(df,
                              indent_rownames = FALSE,
                              parent_path = NULL,
                              ignore_rownames = FALSE,
                              add_decoration = FALSE,
                              split_labels = NULL,
                              data_labels = NULL) {
  checkmate::assert_data_frame(df)
  checkmate::assert_flag(indent_rownames)
  checkmate::assert_character(parent_path, null.ok = TRUE)
  checkmate::assert_flag(ignore_rownames)
  checkmate::assert_flag(add_decoration)
  checkmate::assert_character(split_labels, null.ok = TRUE)
  checkmate::assert_character(data_labels, null.ok = TRUE)

  # Some defaults
  row_classes <- "DataRow" # Default for all rows
  data_row_format <- "xx" # Default if no labels are used
  indent_size <- 2
  indent_space <- paste0(rep(" ", indent_size), collapse = "")

  # Pre-processing the fake split
  if (!is.null(split_labels)) {
    checkmate::assert_choice(split_labels, colnames(df))
    label_rows <- as.character(df[[split_labels]])
    if (is.null(data_labels)) {
      data_rows <- rep("Analysis Method", nrow(df))
      data_labels <- "Analyzed Variable"
    } else {
      checkmate::assert_choice(data_labels, colnames(df))
      data_rows <- as.character(df[[data_labels]])
    }
    rnms_special <- c(rbind(label_rows, data_rows))
    row_classes <- c(rbind(
      rep("LabelRow", length(label_rows)),
      rep("DataRow", length(data_rows))
    ))
    data_colnm <- setdiff(colnames(df), c(split_labels, data_labels))
    tmp_df <- NULL
    for (col_i in seq_along(data_colnm)) {
      lbl_and_dt <- c(rbind(rep("", length(label_rows)), df[[data_colnm[col_i]]]))
      tmp_df <- cbind(tmp_df, lbl_and_dt)
    }
    colnames(tmp_df) <- data_colnm
    rownames(tmp_df) <- NULL
    df <- as.data.frame(tmp_df)
    ignore_rownames <- FALSE
  }

  # Formats
  fmts <- lapply(df, function(x) {
    if (is.null(obj_format(x))) {
      fmt_tmp <- data_row_format
    } else {
      fmt_tmp <- obj_format(x) # Can be assigned for each column
    }
    out <- rep(fmt_tmp, NROW(df))
    if (!is.null(split_labels)) {
      out[row_classes == "LabelRow"] <- "-"
    }
    out
  })

  formats <- rbind("", data.frame(fmts))
  if (!ignore_rownames) {
    formats <- cbind("rnms" = "", formats)
  }

  # Strings
  bodystrs <- mapply(function(x, coli_fmt) {
    coli_fmt[coli_fmt == "-"] <- "xx"
    sapply(seq_along(x), function(y) {
      format_value(x[y], format = coli_fmt[y])
    })
  }, x = df, coli_fmt = fmts)

  if (!ignore_rownames) {
    rnms <- row.names(df)
    if (!is.null(split_labels)) {
      # This overload is done because identical rownames not allowed (e.g. Mean.1 Mean.2)
      rnms <- rnms_special
    } else if (is.null(rnms)) {
      rnms <- as.character(seq_len(NROW(df)))
    }
  }

  strings <- rbind(colnames(df), bodystrs)
  rownames(strings) <- NULL
  if (!ignore_rownames) {
    strings <- cbind("rnms" = c("", rnms), strings)
  }
  # colnames(strings) <- NULL # to add after fixing basic_mf for listings

  # Spans
  spans <- matrix(1, nrow = nrow(strings), ncol = ncol(strings))

  # Aligns
  # Default alignment is left for rownames column and center for the rest
  aligns <- matrix("center",
    nrow = NROW(strings),
    ncol = NCOL(strings) - as.numeric(!ignore_rownames)
  )
  if (!ignore_rownames) {
    aligns <- cbind("left", aligns)
  }

  # Row Info: 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))
  }
  # Constructing path roughly
  if (!is.null(split_labels)) {
    paths <- lapply(
      seq_along(rnms),
      function(row_path_i) {
        if (row_classes[row_path_i] == "DataRow") {
          c(
            split_labels,
            rnms[row_path_i - 1], # LabelRow before
            data_labels,
            rnms[row_path_i]
          )
        } else {
          c(split_labels, rnms[row_path_i])
        }
      }
    )
  } else {
    rnms <- row.names(df)
    if (is.null(rnms)) {
      rnms <- as.character(seq_len(NROW(df)))
    }
    paths <- lapply(rnms, function(x) c(parent_path, x))
  }
  rowdf <- basic_pagdf(
    rnames = rnms,
    extents = exts,
    rclass = row_classes,
    parent_path = NULL, # Overloaded by above parent_path lapply
    paths = paths
  )

  # Indentation happens last so to be sure we have all ready (only strings and formats change)
  if (indent_rownames && !is.null(split_labels)) {
    where_to_indent <- which(row_classes == "DataRow") + 1 # +1 because of colnames
    strings[where_to_indent, 1] <- paste0(indent_space, strings[where_to_indent, 1])
    formats[where_to_indent, 1] <- paste0(indent_space, formats[where_to_indent, 1]) # Needs fixing
    rowdf$indent[where_to_indent - 1] <- 1 # -1 because only rows
  }

  ret <- MatrixPrintForm(
    strings = strings,
    aligns = aligns,
    spans = spans,
    formats = formats, ## matrix("xx", nrow = fnr, ncol = fnc),
    row_info = rowdf,
    has_topleft = FALSE,
    nlines_header = 1,
    nrow_header = 1,
    has_rowlabs = isFALSE(ignore_rownames),
    indent_size = indent_size,
  )

  # Check for ncols
  stopifnot(mf_has_rlabels(ret) == isFALSE(ignore_rownames))

  ret <- mform_build_refdf(ret)

  if (add_decoration) {
    main_title(ret) <- "main title"
    main_footer(ret) <- c("main", "  footer")
    prov_footer(ret) <- "prov footer"
    subtitles(ret) <- c("sub", "titles")
  }

  ret
}

#' @describeIn test_matrix_form Create a `MatrixPrintForm` object from data frame `df` that
#'   respects the default formats for a listing object.
#'
#' @param keycols (`character`)\cr a vector of `df` column names that are printed first and for which
#'   repeated values are assigned `""`. This format is characteristic of a listing matrix form.
#'
#' @return A valid `MatrixPrintForm` object representing `df` as a listing that is ready for ASCII
#'   rendering.
#'
#' @examples
#' mform <- basic_listing_mf(mtcars)
#' cat(toString(mform))
#'
#' @export
basic_listing_mf <- function(df,
                             keycols = names(df)[1],
                             add_decoration = TRUE) {
  checkmate::assert_data_frame(df)
  checkmate::assert_subset(keycols, colnames(df))

  dfmf <- basic_matrix_form(
    df = df,
    indent_rownames = FALSE,
    ignore_rownames = TRUE,
    add_decoration = add_decoration
  )

  # keycols addition to MatrixPrintForm (should happen in the constructor)
  dfmf$listing_keycols <- keycols

  # Modifications needed for making it a listings
  mf_strings(dfmf)[1, ] <- colnames(mf_strings(dfmf)) # set colnames

  if (!is.null(keycols)) {
    str_dfmf <- mf_strings(dfmf)[-1, ]
    # Ordering
    ord <- do.call(
      order,
      as.list(
        data.frame(
          str_dfmf[, keycols]
        )
      )
    )
    str_dfmf <- str_dfmf[ord, ]
    # Making keycols with empties
    curkey <- ""
    for (i in seq_along(keycols)) {
      kcol <- keycols[i]
      kcolvec <- str_dfmf[, kcol] # -1 is col label row
      str_dfmf[, kcol] <- ""
      kcolvec <- vapply(kcolvec, format_value, "", format = NULL, na_str = "NA")
      curkey <- paste0(curkey, kcolvec)
      disp <- c(TRUE, tail(curkey, -1) != head(curkey, -1))
      str_dfmf[disp, kcol] <- kcolvec[disp]
    }
    mf_strings(dfmf)[-1, ] <- str_dfmf
    # keycols as first
    mf_strings(dfmf) <- cbind(
      mf_strings(dfmf)[, keycols, drop = FALSE],
      mf_strings(dfmf)[, !colnames(mf_strings(dfmf)) %in% keycols, drop = FALSE]
    )
  }

  dfmf$aligns[seq(2, nrow(dfmf$aligns)), ] <- "center" # the default for listings

  # the default for listings is a 1 double??
  dfmf$formats <- matrix(1, nrow = nrow(dfmf$formats), ncol = ncol(dfmf$formats))

  # row info
  ri <- dfmf$row_info
  rownames(ri) <- ri$abs_rownumber
  ri$label <- ri$name <- ""
  ri$path <- as.list(NA_character_) # same format of listings
  ri$node_class <- "listing_df"
  # l_ri$pos_in_siblings # why is it like this in rlistings?? also n_siblings
  class(ri$path) <- "AsIs" # Artifact from I()
  dfmf$row_info <- ri

  # colwidths need to be sorted too!!
  dfmf$col_widths <- dfmf$col_widths[colnames(mf_strings(dfmf))]

  if (!add_decoration) {
    # This is probably a forced behavior in the original matrix_form in rlistings
    main_title(dfmf) <- character()
    main_footer(dfmf) <- character()
  }

  dfmf
}

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, keycols = NULL, row = TRUE) {
  fillnum <- if (row) nrow(mf_strings(mf)) - mf_nlheader(mf) else mf_ncol(mf)
  if (is.logical(i) || all(i < 0)) {
    i <- seq_len(fillnum)[i]
  }
  nlh <- mf_nlheader(mf)

  if (row) {
    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)
  }

  tmp_strmat <- mf_strings(mf)[i_mat, j_mat, drop = FALSE]

  # Only for listings - Fix pagination with empty values in key columns
  if (nrow(tmp_strmat) > 0 && .is_listing_mf(mf)) { # safe check for empty listings
    ind_keycols <- which(colnames(tmp_strmat) %in% keycols)

    # Fix for missing labels in key columns (only for rlistings)
    empty_keycols <- !nzchar(tmp_strmat[-seq_len(nlh), ind_keycols, drop = FALSE][1, ])

    if (any(empty_keycols)) { # only if there are missing keycol labels
      # find the first non-empty label in the key columns
      keycols_needed <- mf_strings(mf)[, empty_keycols, drop = FALSE]
      first_nonempty <- apply(keycols_needed, 2, function(x) {
        section_ind <- i_mat[-seq_len(nlh)][1]
        sec_ind_no_header <- seq_len(section_ind)[-seq_len(nlh)]
        tail(x[sec_ind_no_header][nzchar(x[sec_ind_no_header])], 1)
      })

      # if there are only "" the previous returns character()
      any_chr_empty <- if (length(first_nonempty) > 1) {
        vapply(first_nonempty, length, numeric(1))
      } else {
        length(first_nonempty)
      }
      if (any(any_chr_empty == 0L)) {
        warning(
          "There are empty key columns in the listing. ",
          "We keep empty strings for each page."
        )
        first_nonempty[any_chr_empty == 0L] <- ""
      }

      # replace the empty labels with the first non-empty label
      tmp_strmat[nlh + 1, empty_keycols] <- unlist(first_nonempty)
    }
  }

  mf_strings(mf) <- tmp_strmat

  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, bc 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, keycols = NULL) {
  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 <- mf_ncol(mf)
  mf <- .mf_subset_core_mats(mf, i, keycols = keycols, 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, keycols = NULL) {
  nc <- mf_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, keycols = keycols, 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
}

.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
#'
#' Aligning decimal values of string matrix. Allowed alignments are: `dec_left`, `dec_right`,
#' and `decimal`.
#'
#' @param string_mat (`character matrix`)\cr "string" matrix component of `MatrixPrintForm` object.
#' @param align_mat (`character matrix`)\cr "aligns" matrix component of `MatrixPrintForm` object.
#'   Should contain either `dec_left`, `dec_right`, or `decimal` for values to be decimal aligned.
#'
#' @details Left and right decimal alignment (`dec_left` and `dec_right`) differ from center decimal
#'   alignment (`decimal`) only when there is padding present. This may occur if column widths are
#'   set wider via parameters `widths` in `toString` or `colwidths` in `paginate_*`. More commonly,
#'   it also occurs when column names are wider. Cell wrapping is not supported when decimal
#'   alignment is used.
#'
#' @return A processed string matrix of class `MatrixPrintForm` with decimal-aligned values.
#'
#' @seealso [toString()], [MatrixPrintForm()]
#'
#' @examples
#' dfmf <- basic_matrix_form(mtcars[1:5, ])
#' aligns <- mf_aligns(dfmf)
#' aligns[, -c(1)] <- "dec_left"
#' decimal_align(mf_strings(dfmf), aligns)
#'
#' @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 method for MatrixPrintForm

#' @description
#' All objects that are printed to console pass via `toString`. This function allows
#' fundamental formatting specifications to be applied to final output, like column widths
#' and relative wrapping (`width`), title and footer wrapping (`tf_wrap = TRUE` and
#' `max_width`), and horizontal separator character (e.g. `hsep = "+"`).
#'
#' @inheritParams MatrixPrintForm
#' @param widths (`numeric` or  `NULL`)\cr Proposed widths for the columns of `x`. The expected
#'   length of this numeric vector can be retrieved with `ncol(x) + 1` as the column of row names
#'   must also be considered.
#' @param hsep (`string`)\cr character to repeat to create header/body separator line. If
#'   `NULL`, the object value will be used. If `" "`, an empty separator will be printed. See
#'   [default_hsep()] for more information.
#' @param tf_wrap (`flag`)\cr whether the text for title, subtitles, and footnotes should be wrapped.
#' @param max_width (`integer(1)`, `string` or `NULL`)\cr 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. Parameter is ignored if `tf_wrap = FALSE`.
#'
#' @details
#' Manual insertion of newlines is not supported when `tf_wrap = TRUE` 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.
#'
#' @return A character string containing the ASCII rendering of the table-like object represented by `x`.
#'
#' @seealso [wrap_string()]
#'
#' @examples
#' mform <- basic_matrix_form(mtcars)
#' cat(toString(mform))
#'
#' @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
  }
  if (any(grepl("\r", mf_strings(mat)))) {
    stop(
      "Found recursive special characters (\\r) in string matrix produced by matrix_form. ",
      "This special character is not supported and should be removed."
    ) # 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

  ## max_width for wrapping titles and footers (not related to ncchar if not indirectly)
  max_width <- .handle_max_width(
    tf_wrap = tf_wrap,
    max_width = max_width,
    colwidths = widths,
    col_gap = col_gap,
    inset = inset
  )

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

# Switcher for the 3 options for max_width (NULL, numeric, "auto"))
.handle_max_width <- function(tf_wrap, max_width,
                              cpp = NULL, # Defaults to getOption("width", 80L)
                              # Things for auto
                              inset = NULL, colwidths = NULL, col_gap = NULL) {
  max_width <- if (!tf_wrap) {
    if (!is.null(max_width)) {
      warning("tf_wrap is FALSE - ignoring non-null max_width value.")
    }
    NULL
  } else if (tf_wrap) {
    if (is.null(max_width)) {
      if (is.null(cpp) || is.na(cpp)) {
        getOption("width", 80L)
      } else {
        cpp
      }
    } else if (is.numeric(max_width)) {
      max_width
    } else if (is.character(max_width) && identical(max_width, "auto")) {
      # This should not happen, but just in case
      if (any(sapply(list(inset, colwidths, col_gap), is.null))) {
        stop("inset, colwidths, and col_gap must all be non-null when max_width is \"auto\".")
      }
      inset + sum(colwidths) + (length(colwidths) - 1) * col_gap
    } else {
      stop("max_width must be NULL, a numeric value, or \"auto\".")
    }
  }
  return(max_width)
}

.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 a precise width
#'
#' Core wrapping functionality that preserves whitespace. Newline character `"\n"` is not supported
#' by core functionality [stringi::stri_wrap()]. This is usually solved beforehand 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 (`string`, `character`, or `list`)\cr string to be wrapped. If it is a `vector` or
#'   a `list`, it will be looped as a `list` and returned with `unlist(use.names = FALSE)`.
#' @param width (`numeric(1)`)\cr width, in characters, that the text should be wrapped to.
#' @param collapse (`string` or `NULL`)\cr collapse character used to separate segments of words that
#'   have been split and should be pasted together. This is usually done internally with `"\n"` to update
#'   the wrapping along with other internal values.
#'
#' @details Word wrapping happens similarly to [stringi::stri_wrap()] with the following difference: individual
#'   words which are longer than `max_width` are broken up in a way that fits with other word wrapping.
#'
#' @return A string if `str` is one element and if `collapse = NULL`. Otherwise, a list of elements
#'   (if `length(str) > 1`) that can contain strings or vectors 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")
#'
#' @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 still broken, we did not solve the current issue!
      if (setequal(ori_wrapped_txt_v, cur_wrapped_txt_v) || broken_char_cur >= broken_char_ori) {
        # 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 Deprecated function. Please 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 a vector of spans (with duplication) into a visibility vector
#'
#' @param spans (`numeric`)\cr a vector of spans, with each span value repeated
#'   for the cells it covers.
#'
#' @details
#' The values of `spans` are assumed to be repeated such that each individual position covered by the
#' span has the repeated value.
#'
#' This means that each block of values in `spans` 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 spans two individual cells.
#'
#' @return A logical vector the same length as `spans` indicating whether the contents of a string vector
#'   with those spans is valid.
#'
#' @note
#' Currently no checking or enforcement is done to verify that the vector of spans is valid according to
#' the specifications described in the Details section above.
#'
#' @examples
#' spans_to_viscell(c(2, 2, 2, 2, 1, 3, 3, 3))
#'
#' @export
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 the `MatrixPrintForm` of an object
#'
#' Row names are also considered a column for the output.
#'
#' @param x (`ANY`)\cr a `MatrixPrintForm` object, or an object with a `matrix_form` method.
#' @param indent_size (`numeric(1)`)\cr indent size, in characters. Ignored when `x` is already
#'   a `MatrixPrintForm` object in favor of information there.
#'
#' @return A vector of column widths based on the content of `x` for use in printing and pagination.
#'
#' @examples
#' mf <- basic_matrix_form(mtcars)
#' propose_column_widths(mf)
#'
#' @export
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`)\cr a string.
#' @param n (`integer(1)`)\cr number of characters in the output string. If `n < nchar(x)`, an error is thrown.
#' @param just (`string`)\cr text alignment justification to use. Defaults to `"center"`. Must be one of
#'   `"center"`, `"right"`, `"left"`, `"dec_right"`, `"dec_left"`, or `"decimal"`.
#'
#' @return `x`, padded to be a string of length `n`.
#'
#' @examples
#' padstr("abc", 3)
#' padstr("abc", 4)
#' padstr("abc", 5)
#' padstr("abc", 5, "left")
#' padstr("abc", 5, "right")
#'
#' \dontrun{
#' # Expect error: "abc" has more than 1 characters
#' padstr("abc", 1)
#' }
#'
#' @export
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 an integer to a given length
#'
#' @param x (`integer(1)`)\cr number to spread.
#' @param len (`integer(1)`)\cr number of times to repeat `x`.
#'
#' @return If `x` is a scalar whole number value (see [is.wholenumber()]), the value `x` is repeated `len` times.
#'   Otherwise, 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)
#'
#' @export
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
  }
}

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

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

#' 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`) is already adjusted for rendered elements which
#' are not rows/columns and a data frame of pagination information,
#' pagination is performed via the following algorithm with `start = 1`.
#'
#' Core Pagination Algorithm:
#'
#' 1. Initial guess for pagination position 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 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`
#'
#' @name pagination_algo
NULL

#' Create a row of a pagination data frame
#'
#' @param nm (`string`)\cr name.
#' @param lab (`string`)\cr label.
#' @param rnum (`numeric(1)`)\cr absolute row number.
#' @param pth (`character` or `NULL`)\cr path within larger table.
#' @param sibpos (`integer(1)`)\cr position among sibling rows.
#' @param nsibs (`integer(1)`)\cr number of siblings (including self).
#' @param extent (`numeric(1)`)\cr number of lines required to print the row.
#' @param colwidths (`numeric`)\cr column widths.
#' @param repext (`integer(1)`)\cr number of lines required to reprint all context for this row if it appears directly
#'   after pagination.
#' @param repind (`integer`)\cr vector of row numbers to be reprinted if this row appears directly after pagination.
#' @param indent (`integer`)\cr indent.
#' @param rclass (`string`)\cr class of row object.
#' @param nrowrefs (`integer(1)`)\cr number of row referential footnotes for this row.
#' @param ncellrefs (`integer(1)`)\cr number of cell referential footnotes for the cells in this row.
#' @param nreflines (`integer(1)`)\cr total number of lines required by all referential footnotes.
#' @param force_page (`flag`)\cr currently ignored.
#' @param page_title (`flag`)\cr currently ignored.
#' @param trailing_sep (`string`)\cr the string to use as a separator below this row during printing.
#'   If `NA_character_`, no separator is used.
#' @param row (`ANY`)\cr object representing the row, which is used for default values of `nm`, `lab`,
#'   `extent`, and `rclass` if provided. Must have methods for `obj_name`, `obj_label`, and `nlines`, to retrieve
#'   default values of `nm`, `lab`, and `extent`, respectively.
#'
#' @return A single row `data.frame` with the appropriate columns 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,
                           allowed_lines, lpp, decoration_lines,
                           start, guess, rep_ext, n_reprint,
                           reflines, n_refs, sectlines) {
  if (row) {
    spacetype <- "lines"
    spacetype_abr <- "lns"
    structtype_abr <- "rws"
    sprintf(
      paste0(
        "  FAIL: rows selected for pagination require %d %s while only %d are available from ",
        "lpp = %d and %d header/footers lines.\n",
        "        details: [raw: %d %s (%d %s), rep. context: %d %s (%d %s), ",
        "refs: %d %s (%d) sect. divs: %d %s]."
      ),
      lines,
      spacetype,
      allowed_lines,
      lpp,
      decoration_lines, # header + footers
      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(
      "  FAIL: selected columns require %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,
                      lpp, # for informational purposes only
                      context_lpp, # for informational purposes only (headers/footers)
                      min_sibs,
                      nosplit = NULL,
                      div_height = 1L,
                      verbose = FALSE,
                      row = TRUE,
                      have_col_fnotes = FALSE) {
  # FALSE output from this function means that another guess is taken till success or failure
  rw <- pagdf[guess, ]

  if (verbose) {
    message(
      "-> Attempting pagination between ", start, " and ", guess, " ",
      paste(ifelse(row, "row", "column"))
    )
  }

  # Fix for counting the right number of lines when there is wrapping on a keycols
  if (.is_listing_mf(pagdf) && !is.null(pagdf$self_extent_page_break)) {
    pagdf$self_extent[start] <- pagdf$self_extent_page_break[start]
  }

  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,
        allowed_lines = rlpp, lpp = lpp, decoration_lines = context_lpp,
        start, guess, rep_ext, length(pagdf$reprint_inds[[start]]),
        reflines, NROW(refdf_ii), sectlines
      )
      message(msg)
    }
    return(FALSE)
  }

  # Special cases: is it a label or content row?
  if (rw[["node_class"]] %in% c("LabelRow", "ContentRow")) {
    # check if it has children; if no children then valid
    has_children <- rw$abs_rownumber %in% unlist(pagdf$reprint_inds)
    if (rw$abs_rownumber == nrow(pagdf)) {
      if (verbose) {
        message("  EXCEPTION: last row is a label or content row but in lpp")
      }
    } else if (!any(has_children)) {
      if (verbose) {
        message(
          "  EXCEPTION: last row is a label or content row\n",
          "but does not have rows and row groups depending on it"
        )
      }
    } else {
      if (verbose) {
        message("  FAIL: last row is a label or content row")
      }
      return(FALSE)
    }
  }

  # Siblings handling
  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(
          "  FAIL: last row had only ", sibpos - 1,
          " preceding siblings, needed ", min_sibs
        )
      }
    } else if (nsib - sibpos < min_sibs + 1) {
      retfalse <- TRUE
      if (verbose) {
        message(
          "  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(
            "  FAIL: nosplit variable [",
            inplay[min(which(!ok_split))], "] would be constant [",
            curvals, "] across this pagebreak."
          )
        }
        return(FALSE)
      }
    }
  }

  # Usual output when found
  if (verbose) {
    message("  OK [", lines + rep_ext, if (row) " lines]" else " chars]")
  }
  TRUE
}

find_pag <- function(pagdf,
                     current_page,
                     start,
                     guess,
                     rlpp,
                     lpp_or_cpp,
                     context_lpp_or_cpp,
                     min_siblings,
                     nosplitin = character(),
                     verbose = FALSE,
                     row = TRUE,
                     have_col_fnotes = FALSE,
                     div_height = 1L,
                     do_error = FALSE) {
  if (verbose) {
    if (row) {
      message("--------- ROW-WISE: Checking possible pagination for page ", current_page)
    } else {
      message("========= COLUMN-WISE: Checking possible pagination for page ", current_page)
    }
  }

  origuess <- guess
  while (guess >= start && !valid_pag(
    pagdf, guess,
    start = start,
    rlpp = rlpp, lpp = lpp_or_cpp, context_lpp = context_lpp_or_cpp, # only lpp goes to row pagination
    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) {
    # Repeat pagination process to see what went wrong with verbose on
    if (isFALSE(do_error) && isFALSE(verbose)) {
      find_pag(
        pagdf = pagdf,
        current_page = current_page,
        start = start,
        guess = origuess,
        rlpp = rlpp, lpp_or_cpp = lpp_or_cpp, context_lpp_or_cpp = context_lpp_or_cpp,
        min_siblings = min_siblings,
        nosplitin = nosplitin,
        verbose = TRUE,
        row = row,
        have_col_fnotes = have_col_fnotes,
        div_height = div_height,
        do_error = TRUE # only used to avoid loop
      )
    }
    stop(
      "-------------------------------------- Error Summary ----------------------------------------\n",
      "Unable to find any valid pagination split for page ", current_page, " between ",
      ifelse(row, "rows ", "columns "), start, " and ", origuess, ". \n",
      "Inserted ", ifelse(row, "lpp (row-space, lines per page) ", "cpp (column-space, content per page) "),
      ": ", lpp_or_cpp, "\n",
      "Context-relevant additional ", ifelse(row, "header/footers lines", "fixed column characters"),
      ": ", context_lpp_or_cpp, "\n",
      ifelse(row,
        paste("Limit of allowed row lines per page:", rlpp, "\n"),
        paste("Check the minimum allowed column characters per page in the last FAIL(ed) attempt. \n")
      ),
      "Note: take a look at the last FAIL(ed) attempt above to see what went wrong. It could be, for example, ",
      "that the inserted column width induces some wrapping, hence the inserted number of lines (lpp) is not enough."
    )
  }
  guess
}

#' Find pagination indices from pagination info data frame
#'
#' 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`.
#'
#' @param pagdf (`data.frame`)\cr a pagination info `data.frame` as created by
#'   either `make_rows_df` or `make_cols_df`.
#' @param rlpp (`numeric`)\cr maximum number of *row* lines per page (not including header materials), including
#'   (re)printed header and context rows.
#' @param lpp_or_cpp (`numeric`)\cr total maximum number of *row* lines or content (column-wise characters) per page
#'   (including header materials and context rows). This is only for informative results with `verbose = TRUE`.
#'   It will print `NA` if not specified by the pagination machinery.
#' @param context_lpp_or_cpp (`numeric`)\cr total number of context *row* lines or content (column-wise characters)
#'   per page (including header materials). Uses `NA` if not specified by the pagination machinery and is only
#'   for informative results with `verbose = TRUE`.
#' @param min_siblings (`numeric`)\cr minimum sibling rows which must appear on either side of pagination row for a
#'   mid-subtable split to be valid. Defaults to 2 for tables. It is automatically turned off (set to 0) for listings.
#' @param nosplitin (`character`)\cr list of names of subtables where page breaks are not allowed, regardless of other
#'   considerations. Defaults to none.
#' @param verbose (`flag`)\cr whether additional informative messages about the search for
#'   pagination breaks should be shown. Defaults to `FALSE`.
#' @param row (`flag`)\cr whether pagination is happening in row space (`TRUE`, the default) or column
#'   space (`FALSE`).
#' @param have_col_fnotes (`flag`)\cr whether the table-like object being rendered has column-associated
#'   referential footnotes.
#' @param div_height (`numeric(1)`)\cr the height of the divider line when the associated object is rendered.
#'   Defaults to `1`.
#'
#' @details `pab_indices_inner` implements the core pagination algorithm (see below)
#' for a single direction (vertical if `row = TRUE` (the default), horizontal otherwise)
#' based on the pagination data frame and (already adjusted for non-body rows/columns)
#' lines (or characters) per page.
#'
#' @inheritSection pagination_algo Pagination Algorithm
#'
#' @return A `list` containing a 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,
                              lpp_or_cpp = NA_integer_, context_lpp_or_cpp = NA_integer_, # Context number of lines
                              min_siblings,
                              nosplitin = character(),
                              verbose = FALSE,
                              row = TRUE,
                              have_col_fnotes = FALSE,
                              div_height = 1L) {
  start <- 1
  current_page <- 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 = pagdf,
      current_page = current_page, start = start, guess = guess,
      rlpp = adjrlpp, lpp_or_cpp = lpp_or_cpp, context_lpp_or_cpp = context_lpp_or_cpp,
      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
    current_page <- current_page + 1
  }
  ret
}

#' Find column indices for vertical pagination
#'
#' @inheritParams pag_indices_inner
#' @param obj (`ANY`)\cr object to be paginated. Must have a [matrix_form()] method.
#' @param cpp (`numeric(1)`)\cr number of characters per page (width).
#' @param colwidths (`numeric`)\cr vector of column widths (in characters) for use in vertical pagination.
#' @param rep_cols (`numeric(1)`)\cr number of *columns* (not including row labels) to be repeated on every page.
#'   Defaults to 0.
#'
#' @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, lpp_or_cpp = cpp, context_lpp_or_cpp = cpp - 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 data frame
#'
#' Returns a minimal pagination info `data.frame` (with no info on siblings, footnotes, etc.).
#'
#' @inheritParams test_matrix_form
#' @param rnames (`character`)\cr vector of row names.
#' @param labs (`character`)\cr vector of row labels. Defaults to `rnames`.
#' @param rnums (`integer`)\cr vector of row numbers. Defaults to `seq_along(rnames)`.
#' @param extents (`integer`)\cr number of lines each row requires to print. Defaults to 1 for all rows.
#' @param rclass (`character`)\cr class(es) for the rows. Defaults to `"DataRow"`.
#' @param paths (`list`)\cr list of paths to the rows. Defaults to `lapply(rnames, function(x) c(parent_path, x))`.
#'
#' @return A `data.frame` suitable for use in both the `MatrixPrintForm` 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 = "DataRow",
                        parent_path = NULL,
                        paths = lapply(rnames, function(x) c(parent_path, x))) {
  rws <- mapply(pagdfrow,
    nm = rnames, lab = labs, extent = extents,
    rclass = rclass, rnum = rnums, pth = paths,
    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)

  if (!all(rclass == "DataRow")) {
    # These things are used in the simple case of a split, hence having labels.
    # To improve and extend to other cases
    res$pos_in_siblings <- NA
    res$pos_in_siblings[rclass == "DataRow"] <- 1
    res$par_extent[rclass == "DataRow"] <- 1 # the rest is 0
    res$n_siblings <- res$pos_in_siblings
    res$reprint_inds[which(rclass == "DataRow")] <- res$abs_rownumber[which(rclass == "DataRow") - 1]
  }
  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))

  max_width <- .handle_max_width(tf_wrap, max_width, cpp, colwidths, col_gap, inset)

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

#' Paginate a table-like object for rendering
#'
#' These functions perform or diagnose bi-directional pagination on an object.
#'
#' `paginate_indices` renders `obj` into a `MatrixPrintForm` (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 `obj` itself (see Details for an important caveat).
#'
#' `paginate_to_mpfs` renders `obj` into its MPF intermediate representation, then paginates that MPF into
#' component MPFs each corresponding to an individual page and returns those in a `list`.
#'
#' `diagnose_pagination` attempts pagination via `paginate_to_mpfs`, then returns diagnostic information
#' which explains why page breaks were positioned where they were, or alternatively why no valid pagination
#' 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
#' is 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_paginate()] 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_paginate()] method.
#'
#' `paginate_indices`, on the other hand, *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 larger 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`)\cr 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`)\cr 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`)\cr. a pre-calculated page size specification. Typically this is not set by
#'   end users.
#' @param col_gap (`numeric(1)`)\cr currently ignored.
#' @param page_num (`string`)\cr placeholder string for page numbers. See [default_page_number] for more
#'   information. Defaults to `NULL`.
#'
#' @return
#' * `paginate_indices` returns a `list` with two elements of the same length: `pag_row_indices` and `pag_col_indices`.
#' * `paginate_to_mpfs` returns a `list` of  `MatrixPrintForm` objects representing each individual page after
#'   pagination (including forced pagination if necessary).
#'
#' @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)
#'
#' @aliases paginate pagination
#' @export
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 occurred.

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

  # rlistings note: if there is a wrapping in a keycol, it is not calculated correctly
  #                 in the above call, so we need to keep this information in mf_rinfo
  #                 and use it here.
  mfri <- mf_rinfo(mpf)
  keycols <- .get_keycols_from_listing(obj)
  if (NROW(mfri) > 1 && .is_listing_mf(mpf) && length(keycols) > 0) {
    # Lets determine the groupings created by keycols
    keycols_grouping_df <- NULL
    for (i in seq_along(keycols)) {
      kcol <- keycols[i]
      if (is(obj, "MatrixPrintForm")) {
        # This makes the function work also in the case we have only matrix form (mainly for testing purposes)
        kcolvec <- mf_strings(obj)[, mf_strings(obj)[1, , drop = TRUE] == kcol][-1]
        while (any(kcolvec == "")) {
          kcolvec[which(kcolvec == "")] <- kcolvec[which(kcolvec == "") - 1]
        }
      } else {
        kcolvec <- obj[[kcol]]
        kcolvec <- vapply(kcolvec, format_value, "", format = obj_format(kcolvec), na_str = obj_na_str(kcolvec))
      }
      groupings <- as.numeric(factor(kcolvec, levels = unique(kcolvec)))
      where_they_start <- which(c(1, diff(groupings)) > 0)
      keycols_grouping_df <- cbind(
        keycols_grouping_df,
        where_they_start[groupings]
      ) # take the groupings
    }

    # Creating the real self_extend for mf_rinfo (if the line is chosen for pagination start)
    self_extent_df <- apply(keycols_grouping_df, 2, function(x) mfri$self_extent[x])
    mf_rinfo(mpf) <- cbind(mfri, "self_extent_page_break" = apply(self_extent_df, 1, max))
  }

  if (is.null(pg_size_spec$lpp)) {
    pag_row_indices <- list(seq_len(mf_nrow(mpf)))
  } else {
    rlpp <- calc_rlpp(
      pg_size_spec, mpf,
      colwidths = colwidths,
      tf_wrap = tf_wrap, verbose = verbose
    )
    pag_row_indices <- pag_indices_inner(
      pagdf = mf_rinfo(mpf),
      rlpp = rlpp,
      lpp_or_cpp = pg_size_spec$lpp,
      context_lpp_or_cpp = pg_size_spec$lpp - rlpp,
      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,
                             page_num = default_page_number(),
                             rep_cols = NULL,
                             col_gap = 2,
                             verbose = FALSE) {
  if (isTRUE(page_num)) {
    page_num <- "page {i}/{n}"
  }
  checkmate::assert_string(page_num, null.ok = TRUE, min.chars = 1)

  # We can return a list of paginated tables and listings
  if (.is_list_of_tables_or_listings(obj)) {
    cur_call <- match.call(expand.dots = FALSE)
    mpfs <- unlist(
      lapply(obj, function(obj_i) {
        cur_call[["obj"]] <- obj_i
        eval(cur_call, envir = parent.frame(3L))
      }),
      recursive = FALSE
    )

    if (!is.null(page_num)) {
      extracted_cpp <- max(
        sapply(mpfs, function(mpf) {
          pf <- prov_footer(mpf)
          nchar(pf[length(pf)])
        })
      )
      mpfs <- .modify_footer_for_page_nums(mpfs, page_num, extracted_cpp)
    }

    return(mpfs)
  }

  if (!is.null(page_num)) {
    # Only adding a line for pagination -> lpp - 1 would have worked too
    prov_footer(obj) <- c(prov_footer(obj), page_num)
  }

  mpf <- matrix_form(obj, TRUE, TRUE, indent_size = indent_size)

  # Turning off min_siblings for listings
  if (.is_listing_mf(mpf)) {
    min_siblings <- 0
  }

  # Checking colwidths
  if (is.null(colwidths)) {
    colwidths <- mf_col_widths(mpf) %||% propose_column_widths(mpf)
  } else {
    cur_ncol <- ncol(mpf)
    if (!.is_listing_mf(mpf)) {
      cur_ncol <- cur_ncol + as.numeric(mf_has_rlabels(mpf))
    }
    if (length(colwidths) != cur_ncol) {
      stop(
        "non-null colwidths argument must have length ncol(x) (+ 1 if row labels are present and if it is a table) [",
        cur_ncol, "], got length ", length(colwidths)
      )
    }
    mf_col_widths(mpf) <- colwidths
  }

  # For listings, keycols are mandatory rep_num_cols
  if (is.null(rep_cols)) {
    rep_cols <- num_rep_cols(obj)
  }

  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
  )

  pagmats <- lapply(page_indices$pag_row_indices, function(ii) {
    mpf_subset_rows(mpf, ii, keycols = .get_keycols_from_listing(obj))
  })
  ## 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, keycols = .get_keycols_from_listing(obj))
    })
  })

  res <- unlist(res, recursive = FALSE)

  # Adding page numbers if needed
  if (!is.null(page_num)) {
    res <- .modify_footer_for_page_nums(
      mf_list = res,
      page_num_format = page_num,
      current_cpp = pg_size_spec$cpp
    )
  }

  res
}

.modify_footer_for_page_nums <- function(mf_list, page_num_format, current_cpp) {
  total_pages <- length(mf_list)
  page_str <- gsub("\\{n\\}", total_pages, page_num_format)
  page_nums <- vapply(
    seq_len(total_pages),
    function(x) {
      gsub("\\{i\\}", x, page_str)
    },
    FUN.VALUE = character(1)
  )
  page_footer <- sprintf(paste0("%", current_cpp, "s"), page_nums)
  if (any(nchar(page_footer) > current_cpp)) {
    stop("Page numbering string (page_num) is too wide to fit the desired page size width (cpp).")
  }

  lapply(seq_along(mf_list), function(pg_i) {
    prov_footer(mf_list[[pg_i]]) <- c(head(prov_footer(mf_list[[pg_i]]), -1), page_footer[pg_i])
    mf_list[[pg_i]]
  })
}

# This works only with matrix_form objects
.is_listing_mf <- function(mf) {
  all(mf_rinfo(mf)$node_class == "listing_df")
}

# Extended copy of get_keycols
.get_keycols_from_listing <- function(obj) {
  if (is(obj, "listing_df")) {
    names(which(sapply(obj, is, class2 = "listing_keycol")))
  } else if (is(obj, "MatrixPrintForm") && .is_listing_mf(obj)) {
    obj$listing_keycols
  } else {
    NULL # table case
  }
}

#' @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 in total.
#'
#' To get information about intermediate attempts, perform pagination with `verbose = TRUE` and inspect
#' the messages in order.
#'
#' @importFrom utils capture.output
#'
#' @return
#' * `diagnose_pagination` returns 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.
#'
#' `diagnose_pagination` is intended for interactive debugging use and *should not be programmed against*,
#' as the exact content and form of the verbose messages it captures and returns is subject to change.
#'
#' 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.
#'
#' @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
#'
#' @rdname paginate_indices
#' @export
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 (`ANY`)\cr an object.
#' @param label (`string`)\cr label attribute to attach to `x`.
#'
#' @return `x` labeled by `label`. Note that the exact mechanism of labeling should be considered
#'   an internal implementation detail, but the label can always be retrieved via `obj_label`.
#'
#' @examples
#' x <- with_label(c(1, 2, 3), label = "Test")
#' obj_label(x)
#'
#' @export
with_label <- function(x, label) {
  obj_label(x) <- label
  x
}

#' Get label attributes of variables in a `data.frame`
#'
#' Variable labels can be stored as a `label` attribute for each variable.
#' This functions returns a named character vector with the variable labels
#' (or empty strings if not specified).
#'
#' @param x (`data.frame`)\cr a data frame object.
#' @param fill (`flag`)\cr whether variable names should be returned for variables for
#'   which the `label` attribute does not exist. If `FALSE`, these variables are filled with
#'   `NA`s instead.
#'
#' @return a named character vector of variable labels from `x`, with names corresponding
#'   to variable names.
#'
#' @examples
#' x <- iris
#' var_labels(x)
#' var_labels(x) <- paste("label for", names(iris))
#' var_labels(x)
#'
#' @export
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 `data.frame`
#'
#' Variable labels can be stored as the `label` attribute for each variable.
#' This functions sets all non-missing (non-`NA`) variable labels in a `data.frame`.
#'
#' @inheritParams var_labels
#' @param value (`character`)\cr a vector of new variable labels. If any values are `NA`,
#'   the label for that variable is removed.
#'
#' @return `x` with modified variable labels.
#'
#' @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
#' }
#'
#' @export
`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])) {
      unname(value[j])
    } else {
      NULL
    }
  }

  x
}

#' Copy and change variable labels of a `data.frame`
#'
#' Relabel a subset of the variables.
#'
#' @inheritParams var_labels<-
#' @param ... name-value pairs, where each name corresponds to a variable name in
#'   `x` and the value to the new variable label.
#'
#' @return A copy of `x` with labels modified according to `...`
#'
#' @examples
#' x <- var_relabel(iris, Sepal.Length = "Sepal Length of iris flower")
#' var_labels(x)
#'
#' @export
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 `data.frame`
#'
#' Remove `label` attribute from all variables in a data frame.
#'
#' @param x (`data.frame`)\cr a `data.frame` object.
#'
#' @return `x` with its variable labels stripped.
#'
#' @examples
#' x <- var_labels_remove(iris)
#'
#' @export
var_labels_remove <- function(x) {
  stopifnot(is.data.frame(x))

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

  x
}

formats_1d <- c(
  "xx", "xx.", "xx.x", "xx.xx", "xx.xxx", "xx.xxxx",
  "xx%", "xx.%", "xx.x%", "xx.xx%", "xx.xxx%", "(N=xx)", "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)"
)

#' List of currently supported formats and vertical alignments
#'
#' @description We support `xx` style format labels grouped by 1d, 2d, and 3d.
#' Currently valid format labels cannot be added dynamically. Format functions
#' must be used for special cases.
#'
#' @return
#' * `list_valid_format_labels()` returns 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()` returns 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")
}

#' Check if a format or alignment is supported
#'
#' @description Utility functions for checking formats and alignments.
#'
#' @param x (`string` or `function`)\cr format string or an object returned by [sprintf_format()]
#' @param stop_otherwise (`flag`)\cr whether an error should be thrown if `x` is not a valid format.
#'
#' @return
#' * `is_valid_format` returns `TRUE` if `x` is `NULL`, a supported format string, or a function, and
#'   `FALSE` otherwise.
#'
#' @note If `x` is a function, no check is performed to verify that it returns a valid format.
#'
#' @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 (`character`)\cr a character vector that indicates the requested cell alignments.
#'
#' @return
#'  * `check_aligns` returns `TRUE` if the provided alignments are supported, otherwise, an error is thrown.
#'
#' @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 (`string`)\cr a format string passed to [sprintf()].
#'
#' @return A formatting function which wraps and applies the specified `sprintf`-style format
#'   to string `format`.
#'
#' @seealso [sprintf()]
#'
#' @examples
#' fmtfun <- sprintf_format("(N=%i")
#' format_value(100, format = fmtfun)
#'
#' fmtfun2 <- sprintf_format("%.4f - %.2f")
#' format_value(list(12.23456, 2.724))
#'
#' @export
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 [format_value()] to prepare numeric values within
#' cells for formatting and display.
#'
#' @param x (`numeric(1)`)\cr value to format.
#' @param digits (`numeric(1)`)\cr number of digits to round to, or `NA` to convert to a
#'   character value with no rounding.
#' @param na_str (`string`)\cr the value to return if `x` is `NA`.
#'
#' @details
#' This function combines the rounding behavior of R's standards-compliant [round()]
#' function (see the Details section of that documentation) with the strict decimal display
#' of [sprintf()]. The exact behavior is as follows:
#'
#' \enumerate{
#'   \item{If `x` is `NA`, the value of `na_str` is returned.}
#'   \item{If `x` is non-`NA` but `digits` is `NA`, `x` is converted to a character and returned.}
#'   \item{If `x` and `digits` are both non-NA, [round()] is called first, and then [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 any trailing zeros
#'   required to display *exactly* `digits` elements.
#'
#' @note
#' This differs from the base R [round()] function in that `NA` digits indicate `x` should be converted
#' to character and returned unchanged whereas `round(x, digits=NA)` returns `NA` for all values of `x`.
#'
#' This behavior will differ from `as.character(round(x, digits = digits))` in the case where there are
#' not at least `digits` significant digits after the decimal that remain after rounding. It *may* differ from
#' `sprintf("\%.Nf", x)` for values ending in `5` after the decimal place on many popular operating systems
#' due to `round`'s stricter adherence to the IEC 60559 standard, particularly for R versions > 4.0.0 (see
#' warning in [round()] documentation).
#'
#' @seealso [format_value()], [round()], [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)
#'
#' @export
#' @aliases rounding
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 `format` information
#'
#' @param x (`ANY`)\cr the value to be formatted.
#' @param format (`string` or `function`)\cr the format label (string) or formatter function to
#'   apply to `x`.
#' @param na_str (`string`)\cr string to display when the value of `x` is missing. Defaults to `"NA"`.
#' @param output (`string`)\cr output type.
#'
#' @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.
#'
#' @return Formatted text representing the cell `x`.
#'
#' @seealso [round_fmt()]
#'
#' @examples
#' x <- format_value(pi, format = "xx.xx")
#' x
#'
#' format_value(x, output = "ascii")
#'
#' @export
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) < sum(is.na(x))) {
      na_str <- rep(na_str, length.out = sum(is.na(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), ")"),
      "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 (`string` or `function`)\cr a format label (string) or formatter function.
#' @param na_str (`string`)\cr string that should be displayed in place of missing values.
#' @param align (`string`)\cr 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)
}

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

## nocov start
#' Make row layout summary data frames for use during pagination
#'
#' All relevant information about table rows (e.g. indentations) is summarized in a `data.frame`.
#' This function works **only** on `rtables` and `rlistings` objects, and not on their `print` counterparts
#' (like [`MatrixPrintForm`]).
#'
#' @param tt (`ANY`)\cr object representing the table-like object to be summarized.
#' @param visible_only (`flag`)\cr should only visible aspects of the table structure be reflected
#'   in this summary. Defaults to `TRUE`. May not be supported by all methods.
#' @param incontent (`flag`)\cr internal detail, do not set manually.
#' @param repr_ext (`integer(1)`)\cr internal detail, do not set manually.
#' @param repr_inds (`integer`)\cr internal detail, do not set manually.
#' @param sibpos (`integer(1)`)\cr internal detail, do not set manually.
#' @param nsibs (`integer(1)`)\cr internal detail, do not set manually.
#' @param rownum (`numeric(1)`)\cr internal detail, do not set manually.
#' @param indent (`integer(1)`)\cr internal detail, do not set manually.
#' @param colwidths (`numeric`)\cr internal detail, do not set manually.
#' @param path (`character`)\cr path to the (sub)table represented by `tt`. Defaults to `character()`.
#' @param max_width (`numeric(1)` or `NULL`)\cr maximum width for title/footer materials.
#'
#' @import methods
#' @include matrix_form.R
#'
#' @details
#' When `visible_only` is `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 `visible_only` is `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 `tt` and `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.
#'
#' @return A `data.frame` of row/column-structure information used by the pagination machinery.
#'
#' @note The technically present root tree node is excluded from the summary returned by
#'   both `make_row_df` and `make_col_df` (see [rtables::make_col_df()]), as it is simply the
#'   row/column structure of `tt` and thus not useful for pathing or pagination.
#'
#' @export
#' @name make_row_df
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 `rtable`s 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`)\cr object to be transformed into a ready-to-render form (a [`MatrixPrintForm`] object).
#' @param indent_rownames (`flag`)\cr if `TRUE`, the row names column in the `strings` matrix of `obj`
#'   will have indented row names (strings pre-fixed).
#' @param expand_newlines (`flag`)\cr whether the generated matrix form should expand rows whose values
#'   contain newlines into multiple 'physical' rows (as they will appear when rendered into ASCII). Defaults
#'   to `TRUE`.
#' @param indent_size (`numeric(1)`)\cr number of spaces to be used per level of indent (if supported by
#'   the relevant method). Defaults to 2.
#'
#' @return A [`MatrixPrintForm`] classed list with an additional `nrow_header` attribute indicating the
#'   number of pseudo "rows" the column structure defines, 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 `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 [basic_pagdf()].}
#'   }
#'
#' @export
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`)\cr object.
#'
#' @return The height, in lines of text, of the divider between header and body. Currently
#'   returns `1L` for the default method.
#'
#' @examples
#' divider_height(mtcars)
#'
#' @export
setGeneric("divider_height", function(obj) standardGeneric("divider_height"))

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

# nlines ---------------------------------------------------------------

#' Number of lines required to print a value
#'
#' @param x (`ANY`)\cr the object to be printed.
#' @param colwidths (`numeric`)\cr column widths (if necessary).
#' @param max_width (`numeric(1)`)\cr width that strings should be wrapped to when
#'   determining how many lines they require.
#'
#' @return The number of lines needed to render the object `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
  ))
})

#' Transform objects into string representations
#'
#' Transform a complex object into a string representation ready to be printed or written
#' to a plain-text file.
#'
#' @param x (`ANY`)\cr object to be prepared for rendering.
#' @param ... additional parameters passed to individual methods.
#'
#' @export
#' @rdname tostring
setGeneric("toString", function(x, ...) standardGeneric("toString"))

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

#' Print
#'
#' Print an R object. See [print()].
#'
#' @inheritParams base::print
#'
#' @rdname basemethods
setMethod("print", "ANY", base::print) ## nocov

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

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

# obj_name ---------------------------------------------------------------

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

# obj_label ---------------------------------------------------------------

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

# obj_format ---------------------------------------------------------------

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

# obj_na_str ---------------------------------------------------------------

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

# obj_align ---------------------------------------------------------------

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

# main_title ---------------------------------------------------------------

#' General title and footer accessors
#'
#' @param obj (`ANY`)\cr object to extract information from.
#'
#' @return A character scalar (`main_title`), character vector (`main_footer`), or
#'   vector of length zero or more (`subtitles`, `page_titles`, `prov_footer`) containing
#'   the relevant title/footer contents.
#'
#' @export
#' @rdname title_footer
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
  }
)

# subtitles ---------------------------------------------------------------

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

# page_titles ---------------------------------------------------------------

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

# main_footer ---------------------------------------------------------------

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

# prov_footer ---------------------------------------------------------------

#' @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))

# table_inset ---------------------------------------------------------------

#' 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`)\cr object to get or (recursively if necessary) set table inset for.
#' @param value (`string`)\cr string to use as new header/body separator.
#'
#' @return
#' * `table_inset` returns 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.
#' * `table_inset<-` returns `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
  }
)

# do_forced_paginate ---------------------------------------------------------------

#' 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 (`ANY`)\cr object to be paginated. The `ANY` method simply returns a list of
#'   length one, containing `obj`.
#'
#' @return A list of sub-objects, 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))

# num_rep_cols ---------------------------------------------------------------

#' Number of repeated columns
#'
#' When called on a table-like object using the formatters framework, this method returns 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`)\cr a table-like object.
#'
#' @return An integer.
#'
#' @note This number *does not* include row labels, the repetition of which is handled separately.
#'
#' @examples
#' mpf <- basic_matrix_form(mtcars)
#' num_rep_cols(mpf)
#' lmpf <- basic_listing_mf(mtcars)
#' num_rep_cols(lmpf)
#'
#' @export
setGeneric("num_rep_cols", function(obj) standardGeneric("num_rep_cols"))

#' @export
#' @rdname num_rep_cols
setMethod("num_rep_cols", "ANY", function(obj) 0L)

#' @export
#' @rdname num_rep_cols
setMethod("num_rep_cols", "MatrixPrintForm", function(obj) {
  if (.is_listing_mf(obj)) {
    return(length(.get_keycols_from_listing(obj)))
  } else {
    return(0L) # same as ANY for non-listing objects
  }
})

# 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 types
#'
#' List supported named page types.
#'
#' @return
#' * `page_types` returns a character vector of supported page types
#' * `page_dim` returns the dimensions (width, then height) of the selected page type.
#'
#' @export
#' @examples
#' page_types()
#' page_dim("a4")
page_types <- function() {
  names(pg_dim_names)
}

#' @param page_type (`string`)\cr the name of a page size specification. Call
#'   [page_types()] for supported values.
#'
#' @export
#' @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 opens a PDF graphics device, writes to a 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 A named list with `cpi` and `lpi`, the characters and lines per
#' inch, respectively.
#'
#' @examples
#' font_lcpi <- getFromNamespace("font_lcpi", "formatters")
#'
#' 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 (`string`)\cr name of a page type. See [`page_types`]. Ignored
#'   when `pg_width` and `pg_height` are set directly.
#' @param landscape (`flag`)\cr whether the dimensions of `page_type` should be
#'   inverted for landscape orientation. Defaults to `FALSE`, ignored when `pg_width` and
#'   `pg_height` are set directly.
#' @param font_family (`string`)\cr 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)`)\cr font size. Defaults to `12`.
#' @param lineheight (`numeric(1)`)\cr line height. Defaults to `1`.
#' @param margins (`numeric(4)`)\cr 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)`)\cr page width in inches.
#' @param pg_height (`numeric(1)`)\cr 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.
#'
#' @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)
#'
#' @export
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_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))
## }

#' Default horizontal separator
#'
#' The default horizontal separator character which can be displayed in the current
#' charset for use in rendering table-like objects.
#'
#' @param hsep_char (`string`)\cr character that will be set in the R environment
#'   options as the default horizontal separator. Must be a 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_string(hsep_char, n.chars = 1, null.ok = TRUE)
  options("formatters_default_hsep" = hsep_char)
}

#' Default page number format
#'
#' If set, the default page number string will appear on the bottom right of
#' every page of a paginated table. The current `cpp` is used to position the string.
#'
#' @param page_number (`string`)\cr single string value to set the page number format.
#'   It should be formatted similarly to the following format: `"page {i}/{n}"`.
#'   `{i}` will be replaced with the current page number, and `{n}` will be replaced with the
#'   total page number. Current `cpp` is used to position the string in the bottom right corner.
#'
#' @return The page number format string (`NULL` if not set).
#'
#' @examples
#' default_page_number()
#' set_default_page_number("page {i} of {n}")
#' default_page_number()
#'
#' @name default_page_number
#' @export
default_page_number <- function() {
  getOption("formatter_default_page_number", default = NULL)
}

#' @name default_page_number
#' @export
set_default_page_number <- function(page_number) {
  checkmate::assert_string(page_number, null.ok = TRUE)
  options("formatter_default_page_number" = page_number)
}

## 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
#'
#' @param a (`ANY`)\cr element to select *only* if it is not of length 0.
#' @param b (`ANY`)\cr element to select if `a` has length 0.
#'
#' @return `a` if it is not of length 0, otherwise `b`.
#'
#' @examples
#' 6 %||% 10
#'
#' character() %||% "hi"
#'
#' NULL %||% "hi"
#'
#' @export
#' @name ifnotlen0
`%||%` <- function(a, b) {
  if (length(a) == 0) {
    b
  } else {
    a
  }
}

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

1		#' Return an object with a label attribute
2		#'
3		#' @param x (`ANY`)\cr an object.
4		#' @param label (`string`)\cr label attribute to attach to `x`.
5		#'
6		#' @return `x` labeled by `label`. Note that the exact mechanism of labeling should be considered
7		#' an internal implementation detail, but the label can always be retrieved via `obj_label`.
8		#'
9		#' @examples
10		#' x <- with_label(c(1, 2, 3), label = "Test")
11		#' obj_label(x)
12		#'
13		#' @export
14		with_label <- function(x, label) {
15	1x	obj_label(x) <- label
16	1x	x
17		}
18
19		#' Get label attributes of variables in a `data.frame`
20		#'
21		#' Variable labels can be stored as a `label` attribute for each variable.
22		#' This functions returns a named character vector with the variable labels
23		#' (or empty strings if not specified).
24		#'
25		#' @param x (`data.frame`)\cr a data frame object.
26		#' @param fill (`flag`)\cr whether variable names should be returned for variables for
27		#' which the `label` attribute does not exist. If `FALSE`, these variables are filled with
28		#' `NA`s instead.
29		#'
30		#' @return a named character vector of variable labels from `x`, with names corresponding
31		#' to variable names.
32		#'
33		#' @examples
34		#' x <- iris
35		#' var_labels(x)
36		#' var_labels(x) <- paste("label for", names(iris))
37		#' var_labels(x)
38		#'
39		#' @export
40		var_labels <- function(x, fill = FALSE) {
41	5x	stopifnot(is.data.frame(x))
42	5x	if (NCOL(x) == 0) {
43	1x	return(character())
44		}
45
46	4x	y <- Map(function(col, colname) {
47	38x	label <- attr(col, "label")
48
49	38x	if (is.null(label)) {
50	11x	if (fill) {
51	!	colname
52		} else {
53	4x	NA_character_
54		}
55		} else {
56	27x	if (!is.character(label) && !(length(label) == 1)) {
57	!	stop("label for variable ", colname, "is not a character string")
58		}
59	27x	as.vector(label)
60		}
61	4x	}, x, colnames(x))
62
63	4x	labels <- unlist(y, recursive = FALSE, use.names = TRUE)
64
65	4x	if (!is.character(labels)) {
66	!	stop("label extraction failed")
67		}
68
69	4x	labels
70		}
71
72		#' Set label attributes of all variables in a `data.frame`
73		#'
74		#' Variable labels can be stored as the `label` attribute for each variable.
75		#' This functions sets all non-missing (non-`NA`) variable labels in a `data.frame`.
76		#'
77		#' @inheritParams var_labels
78		#' @param value (`character`)\cr a vector of new variable labels. If any values are `NA`,
79		#' the label for that variable is removed.
80		#'
81		#' @return `x` with modified variable labels.
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		#'
93		#' @export
94		`var_labels<-` <- function(x, value) {
95	3x	stopifnot(
96	3x	is.data.frame(x),
97	3x	is.character(value),
98	3x	ncol(x) == length(value)
99		)
100
101	3x	theseq <- if (!is.null(names(value))) names(value) else seq_along(x)
102		# across columns of x
103	3x	for (j in theseq) {
104	21x	attr(x[[j]], "label") <- if (!is.na(value[j])) {
105	21x	unname(value[j])
106		} else {
107	!	NULL
108		}
109		}
110
111	3x	x
112		}
113
114		#' Copy and change variable labels of a `data.frame`
115		#'
116		#' Relabel a subset of the variables.
117		#'
118		#' @inheritParams var_labels<-
119		#' @param ... name-value pairs, where each name corresponds to a variable name in
120		#' `x` and the value to the new variable label.
121		#'
122		#' @return A copy of `x` with labels modified according to `...`
123		#'
124		#' @examples
125		#' x <- var_relabel(iris, Sepal.Length = "Sepal Length of iris flower")
126		#' var_labels(x)
127		#'
128		#' @export
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		#' Remove variable labels of a `data.frame`
157		#'
158		#' Remove `label` attribute from all variables in a data frame.
159		#'
160		#' @param x (`data.frame`)\cr a `data.frame` object.
161		#'
162		#' @return `x` with its variable labels stripped.
163		#'
164		#' @examples
165		#' x <- var_labels_remove(iris)
166		#'
167		#' @export
168		var_labels_remove <- function(x) {
169	1x	stopifnot(is.data.frame(x))
170
171	1x	for (i in seq_len(ncol(x))) {
172	11x	attr(x[[i]], "label") <- NULL
173		}
174
175	1x	x
176		}

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

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

1		#' Default horizontal separator
2		#'
3		#' The default horizontal separator character which can be displayed in the current
4		#' charset for use in rendering table-like objects.
5		#'
6		#' @param hsep_char (`string`)\cr character that will be set in the R environment
7		#' options as the default horizontal separator. Must be a single character. Use
8		#' `getOption("formatters_default_hsep")` to get its current value (`NULL` if not set).
9		#'
10		#' @return unicode 2014 (long dash for generating solid horizontal line) if in a
11		#' locale that uses a UTF character set, otherwise an ASCII hyphen with a
12		#' once-per-session warning.
13		#'
14		#' @examples
15		#' default_hsep()
16		#' set_default_hsep("o")
17		#' default_hsep()
18		#'
19		#' @name default_horizontal_sep
20		#' @export
21		default_hsep <- function() {
22	51x	system_default_hsep <- getOption("formatters_default_hsep")
23
24	51x	if (is.null(system_default_hsep)) {
25	50x	if (any(grepl("^UTF", utils::localeToCharset()))) {
26	50x	hsep <- "\u2014"
27		} else {
28	!	if (interactive()) {
29	!	warning(
30	!	"Detected non-UTF charset. Falling back to '-' ",
31	!	"as default header/body separator. This warning ",
32	!	"will only be shown once per R session."
33	!	) # nocov
34		} # nocov
35		hsep <- "-" # nocov
36		}
37		} else {
38	1x	hsep <- system_default_hsep
39		}
40	51x	hsep
41		}
42
43		#' @name default_horizontal_sep
44		#' @export
45		set_default_hsep <- function(hsep_char) {
46	3x	checkmate::assert_string(hsep_char, n.chars = 1, null.ok = TRUE)
47	2x	options("formatters_default_hsep" = hsep_char)
48		}
49
50		#' Default page number format
51		#'
52		#' If set, the default page number string will appear on the bottom right of
53		#' every page of a paginated table. The current `cpp` is used to position the string.
54		#'
55		#' @param page_number (`string`)\cr single string value to set the page number format.
56		#' It should be formatted similarly to the following format: `"page {i}/{n}"`.
57		#' `{i}` will be replaced with the current page number, and `{n}` will be replaced with the
58		#' total page number. Current `cpp` is used to position the string in the bottom right corner.
59		#'
60		#' @return The page number format string (`NULL` if not set).
61		#'
62		#' @examples
63		#' default_page_number()
64		#' set_default_page_number("page {i} of {n}")
65		#' default_page_number()
66		#'
67		#' @name default_page_number
68		#' @export
69		default_page_number <- function() {
70	36x	getOption("formatter_default_page_number", default = NULL)
71		}
72
73		#' @name default_page_number
74		#' @export
75		set_default_page_number <- function(page_number) {
76	4x	checkmate::assert_string(page_number, null.ok = TRUE)
77	4x	options("formatter_default_page_number" = page_number)
78		}

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		#'
7		#' @param a (`ANY`)\cr element to select only if it is not of length 0.
8		#' @param b (`ANY`)\cr element to select if `a` has length 0.
9		#'
10		#' @return `a` if it is not of length 0, otherwise `b`.
11		#'
12		#' @examples
13		#' 6 %\|\|% 10
14		#'
15		#' character() %\|\|% "hi"
16		#'
17		#' NULL %\|\|% "hi"
18		#'
19		#' @export
20		#' @name ifnotlen0
21		`%\|\|%` <- function(a, b) {
22	518x	if (length(a) == 0) {
23	76x	b
24		} else {
25	442x	a
26		}
27		}