formatters coverage - 92.66%

Files
Source

## state completely sucks and I hate it, but
## we need a pdf device open to calculate the
## print width of strings, and we can't be opening
## a new one every time we want to
font_dev_state <- new.env()
font_dev_state$open <- FALSE
font_dev_state$fontspec <- list()
font_dev_state$spacewidth <- NA_real_
font_dev_state$ismonospace <- NA
font_dev_state$max_ratio <- NA_real_
font_dev_state$dev_num <- NA_integer_
font_dev_state$debug_active <- FALSE


cwidth_inches_unsafe <- function(x) {
  convertWidth(unit(1, "strwidth", x), "inches", valueOnly = TRUE)
}

## returns whether it opened a new device or not
#' Activate font state
#'
#' @param fontspec (`font_spec`)\cr a font_spec object specifying the font information to use for
#'   calculating string widths and heights, as returned by [font_spec()].
#' @param silent (`logical(1)`)\cr If `FALSE`, the default, a warning will be
#'   emitted if this function switches away from an active graphics device.
#'
#' @details The font device state is an environment with
#' four variables guaranteed to be set:
#'
#' \describe{
#'   \item{`open`}{(`logical(1)`)\cr whether a device is already open with font info}
#'   \item{`fontspec`}{(`font_spec`)\cr the font specification, if any, that is currently active (`list()` if none is).}
#'   \item{`spacewidth`}{(`numeric(1)`)\cr the width of the space character in the currently active font.}
#'   \item{`ismonospace`}{(`logical(1)`)\cr whether the specified font is monospaced.}
#' }
#'
#' `open_font_dev` opens a pdf device with the specified font
#' only if there is not one currently open with the same font.
#' If a new device is opened, it caches `spacewidth` and
#' `ismonospace` for use in `nchar_ttype`).
#'
#' `close_font_dev` closes any open font state device
#' and clears the cached values.
#'
#' `debug_font_dev` and `undebug_font_dev` activate and deactivate, respectively,
#' logging of where in the call stack font devices are being opened.
#'
#' @return
#' - `open_font_dev` returns a logical value indicating whether a *new* pdf device was opened.
#' - `close_font_dev`, `debug_font_dev` and `undebug_font_dev` return `NULL`.
#'
#' In all cases the value is returned invisibly.
#'
#' @examples
#' open_font_dev(font_spec("Times"))
#' nchar_ttype("Hiya there", font_spec("Times"))
#' close_font_dev()
#'
#' @export
open_font_dev <- function(fontspec, silent = FALSE) {
  if (is.null(fontspec)) {
    return(invisible(FALSE))
  } else if (font_dev_is_open()) {
    if (identical(font_dev_state$fontspec, fontspec)) {
      if (!silent && dev.cur() != font_dev_state$dev_num) {
        warning(
          "formatters is switching to the font state graphics device ",
          "to perform string width calculations. You may need to switch ",
          "to your currently open graphics device, depending on whether ",
          "the font device is closed and what other devices you have open."
        )
        dev.set(font_dev_state$dev_num)
      }
      return(invisible(FALSE))
    } else {
      close_font_dev()
    }
  }
  if (font_dev_state$debug_active && !font_dev_is_open()) { ## call debug_font_dev beforehand to get debugging info to helplocate places which aren't receiving/using the state properly # nolint
    ## dump the call stack any time we have cache misses
    ## and have to open a completely new font state device
    scalls <- sys.calls()
    msg <- sapply(
      scalls[2:length(scalls)],
      function(sci) {
        toret <- deparse(sci[[1]], nlines = 3)
        if (substr(toret[1], 1, 8) == "function") {
          toret <- "anon function"
        }
        toret
      }
    )
    message(paste("\n***** START font dev debugging dump *****\n",
      paste(msg, collapse = " -> "),
      paste(capture.output(print(fontspec)), collapse = "\n"),
      sep = "\n"
    ))
  }
  tmppdf <- tempfile(fileext = ".pdf")
  pdf(tmppdf)
  grid.newpage()
  gp <- gpar_from_fspec(fontspec)
  pushViewport(plotViewport(gp = gp))
  spcwidth <- cwidth_inches_unsafe(" ")
  assign("open", TRUE, envir = font_dev_state)
  assign("fontspec", fontspec, envir = font_dev_state)
  assign("spacewidth", spcwidth, envir = font_dev_state)
  assign("ismonospace", spcwidth == cwidth_inches_unsafe("W"),
    envir = font_dev_state
  )
  assign("dev_num", dev.cur(),
    envir = font_dev_state
  )
  invisible(TRUE)
}

#' @rdname open_font_dev
#' @export
close_font_dev <- function() {
  if (font_dev_state$open) {
    dev.off(font_dev_state$dev_num)
    assign("open", FALSE, envir = font_dev_state)
    assign("fontspec", list(), envir = font_dev_state)
    assign("spacewidth", NA_real_, envir = font_dev_state)
    assign("ismonospace", NA, envir = font_dev_state)
    assign("dev_num", NA_integer_, envir = font_dev_state)
  }
  invisible(NULL)
}

#' @rdname open_font_dev
#' @export
debug_font_dev <- function() {
  message("debugging font device swapping. call undebug_font_dev() to turn debugging back off.")
  font_dev_state$debug_active <- TRUE
  invisible(NULL)
}

#' @rdname open_font_dev
#' @export
undebug_font_dev <- function() {
  message("no longer debugging font device swapping.")
  font_dev_state$debug_active <- FALSE
  invisible(NULL)
}


## can only be called when font_dev_state$open is TRUE
get_space_width <- function() {
  if (!font_dev_is_open()) {
    stop(
      "get_space_width called when font dev state is not open. ",
      "This shouldn't happen, please contact the maintainers."
    )
  }
  font_dev_state$spacewidth
}

.open_fdev_is_monospace <- function() {
  if (!font_dev_is_open()) {
    stop(
      ".open_fdev_is_monospace called when font dev state is not open. ",
      "This shouldn't happen, please contact the maintainers."
    )
  }
  font_dev_state$ismonospace
}

## safe wrapper around .open_fdev_is_monospace
is_monospace <- function(fontspec = font_spec(font_family, font_size, lineheight),
                         font_family = "Courier",
                         font_size = 8,
                         lineheight = 1) {
  if (is.null(fontspec)) {
    return(TRUE)
  }
  new_dev <- open_font_dev(fontspec)
  if (new_dev) {
    on.exit(close_font_dev())
  }
  .open_fdev_is_monospace()
}

## get_max_wratio <- function() {
##   if (!font_dev_state$open) {
##     stop(
##       "get_space_width called when font dev state is not open. ",
##       "This shouldn't happen, please contact the maintainers."
##     )
##   }
##   if (.open_fdev_is_monospace()) {
##     1
##   } else {
##     font_dev_state$maxratio
##   }
## }

gpar_from_fspec <- function(fontspec) {
  gpar(
    fontfamily = fontspec$family,
    fontsize = fontspec$size,
    lineheight = fontspec$lineheight
  )
}

font_dev_is_open <- function() font_dev_state$open

#' 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_character(hsep_char, n.chars = 1, len = 1, null.ok = TRUE)
  options("formatters_default_hsep" = hsep_char)
}

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

  nr <- nrow(body)

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

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

# Main function that does the wrapping
do_cell_fnotes_wrap <- function(mat, widths, max_width, tf_wrap, fontspec, expand_newlines = TRUE) {
  col_gap <- mf_colgap(mat)
  ncchar <- sum(widths) + (length(widths) - as.integer(mf_has_rlabels(mat))) * 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",
      MoreArgs = list(fontspec = fontspec)
    )),
    ncol = ncol(mfs)
  )

  if (expand_newlines) {
    ## 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 already has fontspec on it so no need to pass that down
    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
}

## this gives the conversion from number of spaces to number of characters
## for use in, e.g., repping out divider lines.
calc_str_adj <- function(str, fontspec) {
  if (nchar(str) == 0) {
    return(0)
  }
  nchar(str) / nchar_ttype(str, fontspec, raw = TRUE)
}

# toString ---------------------------------------------------------------------
# main printing code 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
#' @inheritParams open_font_dev
#' @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`.
#' @param ttype_ok (`logical(1)`)\cr should truetype (non-monospace) fonts be
#'   allowed via `fontspec`. Defaults to `FALSE`. This parameter is primarily
#'   for internal testing and generally should not be set by end users.
#'
#' @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,
                                                  fontspec = font_spec(),
                                                  ttype_ok = FALSE) {
  checkmate::assert_flag(tf_wrap)

  ## we are going to use the pdf device and grid to understand the actual
  ## print width of things given our font family and font size
  new_dev <- open_font_dev(fontspec)
  if (new_dev) {
    on.exit(close_font_dev())
  }

  if (!is_monospace(fontspec = fontspec) && !ttype_ok) {
    stop(
      "non-monospace font specified in toString call; this would result in cells contents not lining up exactly. ",
      "If you truly want this behavior please set ttype_ok = TRUE in the call to toString/export_as_txt/export_as_pdf"
    )
  }
  mat <- matrix_form(x, indent_rownames = TRUE, fontspec = fontspec)

  # 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, fontspec = fontspec)

    # 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, fontspec = fontspec)
  } else {
    mf_col_widths(x) <- widths
  }

  ## Total number of characters for the table
  ## col_gap (and table inset) are in number of spaces
  ## so we're ok here even in the truetype case
  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, fontspec = fontspec)

  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, MoreArgs = list(fontspec = fontspec)),
    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)
  }
  adj_hsep <- calc_str_adj(hsep, fontspec)
  div <- substr(strrep(hsep, ceiling(ncchar * adj_hsep)), 1, ceiling(ncchar * adj_hsep))
  hsd <- header_section_div(mat)
  if (!is.na(hsd)) {
    adj_hsd <- calc_str_adj(hsd, fontspec)
    hsd <- substr(strrep(hsd, ceiling(ncchar * adj_hsd)), 1, ceiling(ncchar * adj_hsd))
  } 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) {
          adj_i <- calc_str_adj(sec_seps_df$trailing_sep[i], fontspec)
          substr(
            strrep(sec_seps_df$trailing_sep[i], ceiling(ncchar * adj_i)), 1,
            ceiling((ncchar - inset) * adj_i)
          )
        }
      )
      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, fontspec = fontspec)
  }
  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, fontspec = fontspec)
    allfoots$ref_footnotes <- wrap_txt(allfoots$ref_footnotes, max_width - inset, fontspec = fontspec)
    ## no - inset here because the prov_footer is not inset
    allfoots$prov_footer <- wrap_txt(allfoots$prov_footer, max_width, fontspec = fontspec)
  }

  # 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.
#'
#' @inheritParams open_font_dev
#' @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, fontspec = font_spec()) {
  if (length(str) > 1) {
    return(
      unlist(
        lapply(str, wrap_string, width = width, collapse = collapse, fontspec = fontspec),
        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."
    )
  }

  if (!is_monospace(fontspec)) {
    return(wrap_string_ttype(str, width, fontspec, collapse = collapse))
  }

  # 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_ttype(ret, fontspec) > width)) {
    which_exceeded <- which(nchar_ttype(ret, fontspec) > 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_ttype(ret[we_i - 1], fontspec) + 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_ttype(ori_wrapped_txt_v, fontspec) > width) # how many issues there were
      broken_char_cur <- sum(nchar_ttype(cur_wrapped_txt_v, fontspec) > 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_ttype(ret, fontspec) > 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) {
  if (w < 1) {
    return(str)
  }
  stringi::stri_wrap(str,
    width = w,
    normalize = FALSE, # keeps spaces
    simplify = TRUE, # If FALSE makes it a list with str elements
    indent = 0,
    use_length = FALSE # incase the defaul changes, use actual char widths
  )
}

#' @rdname wrap_string_ttype
#' @export
split_word_ttype <- function(str, width, fontspec, min_ok_chars) {
  chrs <- strsplit(str, "")[[1]]
  nctt_chars <- nchar_ttype(chrs, fontspec, raw = TRUE)
  ok <- which(cumsum(nctt_chars) <= width)
  if (length(ok) < min_ok_chars || length(chrs) - length(ok) < min_ok_chars) {
    list(
      ok = character(),
      remainder = str
    )
  } else {
    list(
      ok = substr(str, 1, length(ok)),
      remainder = substr(str, length(ok) + 1, nchar(str))
    )
  }
}

## need a separate path here because **the number of characters**
## in each part is no longer going to be constant the way it
## was for monospace
## this is much slower but still shouldn't be a bottleneck, if it is we'll
## have to do something else
#' wrap string given a Truetype font
#'
#' @inheritParams wrap_string
#' @param min_ok_chars (`numeric(1)`)\cr number of minimum characters that remain
#'   on either side when a word is split.
#' @param wordbreak_ok (`logical(1)`)\cr should breaking within a word be allowed? If, `FALSE`,
#'   attempts to wrap a string to a width narrower than its widest word will result
#'   in an error.
#' @return `str`, broken up into a word-wrapped vector
#' @export
wrap_string_ttype <- function(str,
                              width,
                              fontspec,
                              collapse = NULL,
                              min_ok_chars = min(floor(nchar(str) / 2), 4, floor(width / 2)),
                              wordbreak_ok = TRUE) {
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }

  rawspls <- strsplit(str, "[[:space:]](?=[^[:space:]])", perl = TRUE)[[1]] # preserve all but one space
  nctt <- nchar_ttype(rawspls, fontspec, raw = TRUE)
  pts <- which(cumsum(nctt) <= width)
  if (length(pts) == length(rawspls)) { ## no splitting needed
    return(str)
  } else if (length(pts) == 0) { ## no spaces, all one word, split it and keep going
    if (wordbreak_ok) {
      inner_res <- list()
      min_ok_inner <- min_ok_chars
      while (length(inner_res$ok) == 0) {
        inner_res <- split_word_ttype(rawspls[1], width, fontspec, min_ok_inner) # min_ok_chars)
        min_ok_inner <- floor(min_ok_inner / 2)
      }
      done <- inner_res$ok
      remainder <- paste(c(inner_res$remainder, rawspls[-1]), collapse = " ")
    } else {
      stop(
        "Unable to find word wrapping solution without breaking word: ",
        rawspls[[1]], " [requires  ", nchar_ttype(rawspls[[1]], fontspec), " spaces of width, out of ",
        width, " available]."
      )
    }
  } else { ## some words fit, and some words don't
    done_tmp <- paste(rawspls[pts], collapse = " ")
    tospl_tmp <- rawspls[length(pts) + 1]
    width_tmp <- width - sum(nctt[pts])
    if (wordbreak_ok && width_tmp / width > .33) {
      inner_res <- split_word_ttype(tospl_tmp, width_tmp, fontspec,
        min_ok_chars = min_ok_chars
      )
    } else {
      inner_res <- list(done = "", remainder = tospl_tmp)
    }
    done <- paste(c(rawspls[pts], inner_res$ok),
      collapse = " "
    )
    remainder <- paste(
      c(
        inner_res$remainder,
        if (length(rawspls) > length(pts) + 1) tail(rawspls, -(length(pts) + 1))
      ),
      collapse = " "
    )
  }
  ret <- c(
    done,
    wrap_string_ttype(remainder, width, fontspec)
  )
  if (!is.null(collapse)) {
    ret <- paste(ret, collapse = collapse)
  }
  ret
}

# 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, fontspec = font_spec()) {
  new_dev <- open_font_dev(fontspec)
  if (new_dev) {
    on.exit(close_font_dev())
  }

  unlist(wrap_string(str, width, collapse, fontspec = fontspec), 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.
#'
#' @inheritParams open_font_dev
#' @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,
                                  fontspec = font_spec()) {
  new_dev <- open_font_dev(fontspec)
  if (new_dev) {
    on.exit(close_font_dev())
  }

  if (!is(x, "MatrixPrintForm")) {
    x <- matrix_form(x, indent_rownames = TRUE, indent_size = indent_size, fontspec = fontspec)
  }
  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) #old monospace assumption
  ## we now use widths in terms of the printwidth of the space (" ")
  ## character. This collapses to the same thing in the monospace
  ## case but allows us to reasonably support truetype fonts
  chars <- nchar_ttype(body, fontspec)

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

## "number of characters" width in terms of
## width of " " for the chosen font family

## pdf device with font specification MUST already be open

#' Calculate font-specific string width
#'
#' This function returns the width of each element `x`
#' *as a multiple of the width of the space character
#' for in declared font*, rounded up to the nearest
#' integer. This is used extensively in the text rendering
#' ([toString()]) and pagination machinery for
#' calculating word wrapping, default column widths,
#' lines per page, etc.
#'
#' @param x (`character`)\cr the string(s) to calculate width(s) for.
#' @param fontspec (`font_spec` or `NULL`)\cr if non-NULL, the font to use for
#'   the calculations (as returned by [font_spec()]). Defaults to "Courier",
#'   which is a monospace font. If NULL, the width will be returned
#'   in number of characters by calling `nchar` directly.
#' @param tol (`numeric(1)`)\cr the tolerance to use when determining
#'   if a multiple needs to be rounded up to the next integer. See
#'   Details.
#' @param raw (`logical(1)`)\cr whether unrounded widths should be returned. Defaults to `FALSE`.
#'
#' @details String width is defined in terms of spaces within
#' the specified font. For monospace fonts, this definition
#' collapses to the number of characters in the string
#' ([nchar()]), but for truetype fonts it does not.
#'
#' For `raw = FALSE`, non-integer values (the norm in a truetype
#' setting) for the number of spaces a string takes up is rounded
#' up, *unless the multiple is less than `tol` above the last integer
#' before it*. E.g., if `k - num_spaces < tol` for an integer
#' `k`, `k` is returned instead of `k+1`.
#'
#' @seealso [font_spec()]
#'
#' @examples
#' nchar_ttype("hi there!")
#'
#' nchar_ttype("hi there!", font_spec("Times"))
#'
#' @export
nchar_ttype <- function(x, fontspec = font_spec(), tol = sqrt(.Machine$double.eps), raw = FALSE) {
  ## escape hatch because sometimes we need to call, e.g. make_row_df
  ## but we dont' care about getting the word wrapping right and the
  ## performance penalty was KILLING us. Looking at you
  ## rtables::update_ref_indexing @.@
  if (is.null(fontspec)) {
    return(nchar(x))
  }
  new_dev <- open_font_dev(fontspec)
  if (new_dev) {
    on.exit(close_font_dev())
  }
  if (font_dev_state$ismonospace) { ## WAY faster if we can do it
    return(nchar(x))
  }
  space_width <- get_space_width()
  ## cwidth_inches_unsafe is ok here because if we don't
  ## have a successfully opened state (somehow), get_space_width
  ## above will error.
  num_inches_raw <- vapply(x, cwidth_inches_unsafe, 1.0)
  num_spaces_raw <- num_inches_raw / space_width
  if (!raw) {
    num_spaces_ceil <- ceiling(num_spaces_raw)
    ## we don't want to add one when the answer is e.g, 3.0000000000000953
    within_tol <- which(num_spaces_raw + 1 - num_spaces_ceil <= tol)
    ret <- num_spaces_ceil
    if (length(within_tol) == 0L) {
      ret[within_tol] <- floor(num_spaces_raw[within_tol])
    }
  } else {
    ret <- num_spaces_raw
  }
  if (!is.null(dim(x))) {
    dim(ret) <- dim(x)
  } else {
    names(ret) <- NULL
  }
  ret
}

#' Pad a string and align within string
#'
#' @inheritParams open_font_dev
#' @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(), fontspec = font_spec()) {
  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_ttype(x, fontspec)
  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
#'
#' @inheritParams open_font_dev
#' @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, fontspec = fontspec),
                     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_,
                     fontspec) {
  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"
    raw_ncol <- guess - start + 1
    tot_ncol <- raw_ncol + n_reprint
    rep_ext <- rep_ext
    sprintf(
      paste0(
        "  FAIL: selected %d columns require %d %s, while only %d are available. \n",
        "        details: [raw: %d %s (%d %s), rep. cols: %d %s (%d %s), tot. colgap: %d %s]."
      ),
      guess - start + 1,
      lines + rep_ext + sectlines,
      spacetype,
      lpp,
      lines,
      spacetype_abr,
      raw_ncol,
      structtype_abr,
      rep_ext,
      spacetype_abr,
      n_reprint,
      structtype_abr,
      sectlines,
      spacetype
    )
  }
}

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,
                      col_gap,
                      has_rowlabels) {
  # 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
  }


  rowlines <- raw_rowlines + reflines ## sum(pagdf[start:guess, "self_extent"]) - reflines
  ## self extent includes reflines
  ## self extent does ***not*** currently include trailing sep for rows
  ## self extent does ***not*** currently include col_gap for columns
  ## we don't include the trailing_sep for guess because if we paginate here it won't be printed
  ncols <- 0L
  if (row) {
    sectlines <- if (start == guess) 0L else sum(!is.na(pagdf[start:(guess - 1), "trailing_sep"]))
  } else { ## columns
    ncols <- guess - start + 1 + length(pagdf$reprint_inds[[start]]) ## +1 because its inclusive, 5-6 is 2 columns
    sectlines <- col_gap * (ncols - as.integer(!has_rowlabels)) ## -1 if no row labels
  }
  lines <- rowlines + sectlines
  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,
                     col_gap,
                     has_rowlabels) {
  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,
    col_gap = col_gap,
    has_rowlabels = has_rowlabels
  )) {
    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
        col_gap = col_gap,
        has_rowlabels = has_rowlabels
      )
    }
    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`.
#' @param col_gap (`numeric(1)`)\cr width of gap between columns, in same units as extent in `pagdf` (spaces
#'   under a particular font specification).
#' @param has_rowlabels (`logical(1)`)\cr whether the object being paginated has row labels.
#'
#' @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,
                              col_gap = 3L,
                              has_rowlabels) {
  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,
      col_gap = col_gap,
      has_rowlabels = has_rowlabels
    )
    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
#' @inheritParams open_font_dev
#' @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, fontspec = font_spec())
#' lapply(colpaginds, function(j) mtcars[, j, drop = FALSE])
#'
#' @export
vert_pag_indices <- function(obj,
                             cpp = 40,
                             colwidths = NULL,
                             verbose = FALSE,
                             rep_cols = 0L,
                             fontspec,
                             nosplitin = character()) {
  if (is.list(nosplitin)) {
    nosplitin <- nosplitin[["cols"]]
  }
  mf <- matrix_form(obj, indent_rownames = TRUE, fontspec = fontspec)
  clwds <- colwidths %||% propose_column_widths(mf, fontspec = fontspec)
  if (is.null(mf_cinfo(mf))) { ## like always, ugh.
    mf <- mpf_infer_cinfo(mf, colwidths = clwds, rep_cols = rep_cols, fontspec = fontspec)
  }

  num_rep_cols(mf) <- 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,
    nosplitin = nosplitin,
    row = FALSE,
    col_gap = mf_colgap(mf),
    has_rowlabels = mf_has_rlabels(mf)
  )
  res
}

mpf_infer_cinfo <- function(mf, colwidths = NULL, rep_cols = num_rep_cols(mf), fontspec, colpaths = NULL) {
  if (!is.null(mf_cinfo(mf))) {
    return(mf_update_cinfo(mf, colwidths = colwidths))
  }
  new_dev <- open_font_dev(fontspec)
  if (new_dev) {
    on.exit(close_font_dev())
  }
  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, fontspec = fontspec)
  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]
      ) ## colwidths
      pagdfrow(
        row = NA,
        nm = rownum,
        lab = rownum,
        rnum = rownum,
        pth = NA,
        extent = clwds[i],
        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,
        fontspec = fontspec
      )
    }
  )
  pdf <- do.call(rbind, pdfrows)

  refdf <- mf_fnote_df(mf)
  pdf <- splice_fnote_info_in(pdf, refdf, row = FALSE)
  if (!is.null(colpaths)) {
    if (length(colpaths) != NROW(pdf)) {
      ## nocov start
      stop(
        "Got non-null colpaths with length not equal to number of columns (",
        length(colpaths),
        "!=",
        NROW(pdf),
        ") during MatrixPrintForm construction. Please contact the maintainers."
      )
      ## nocov end
    }
    pdf[["path"]] <- colpaths
  }
  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
#' @inheritParams open_font_dev
#' @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)),
                        fontspec = font_spec()) {
  rws <- mapply(pagdfrow,
    nm = rnames, lab = labs, extent = extents,
    rclass = rclass, rnum = rnums, pth = paths,
    MoreArgs = list(fontspec = fontspec),
    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,
                           font_family,
                           font_size,
                           lineheight,
                           fontspec = font_spec(
                             font_family = font_family,
                             font_size = font_size,
                             lineheight = lineheight
                           )) {
  structure(list(
    lpp = lpp,
    cpp = cpp,
    max_width = max_width,
    font_spec = fontspec
  ), class = "page_size_spec")
}

get_font_spec <- function(obj) {
  if (!is(obj, "page_size_spec")) {
    stop("get_font_spec is only currently defined for page_size_spec objects")
  }
  obj$font_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],
                      fontspec = font_spec(),
                      ## 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,
    fontspec = fontspec,
    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,
    ## font_family = font_family,
    ## font_size = font_size,
    ## lineheight = lineheight
    fontspec = fontspec
  )
}

calc_rlpp <- function(pg_size_spec, mf, colwidths, tf_wrap, verbose) {
  lpp <- pg_size_spec$lpp
  max_width <- pg_size_spec$max_width
  fontspec <- get_font_spec(pg_size_spec)
  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, fontspec = fontspec))
    }
    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),
      fontspec = fontspec
    )
  }
  prfoot <- prov_footer(mf)
  if (length(prfoot) && any(nzchar(prfoot))) {
    flines <- flines + nlines(prov_footer(mf), colwidths = colwidths, max_width = max_width, fontspec = fontspec)
    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
}

## this is ok to be unchanged because by this point
## all of these are in terms of space widths
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 The number of spaces to be placed between columns
#'   in the rendered table (and assumed for horizontal pagination).
#' @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 = list(
                               rows = character(),
                               cols = 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,
                             fontspec = font_spec(font_family, font_size, lineheight),
                             verbose = FALSE) {
  ## this preserves backwards compatibility
  ## could start deprecation cycle of char input
  if (is.character(nosplitin)) {
    nosplitin <- list(
      rows = nosplitin,
      cols = character()
    )
  }
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }
  ## 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."
    )
  }

  ## 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, fontspec = fontspec)
  if (is.null(colwidths)) {
    colwidths <- mf_col_widths(mpf) %||% propose_column_widths(mpf, fontspec = fontspec)
  } else {
    mf_col_widths(mpf) <- colwidths
  }

  mf_colgap(mpf) <- col_gap
  if (!is.null(rep_cols) && rep_cols != num_rep_cols(obj)) {
    num_rep_cols(mpf) <- rep_cols
  }
  if (NROW(mf_cinfo(mpf)) == 0) {
    mpf <- mpf_infer_cinfo(mpf, colwidths, rep_cols, fontspec = fontspec)
  }

  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,
      fontspec = fontspec,
      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 into mf_rinfo(mpf)
  mpf <- do_cell_fnotes_wrap(mpf, colwidths, max_width, tf_wrap = tf_wrap, fontspec = fontspec)

  # 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[["rows"]],
      col_gap = col_gap,
      has_rowlabels = mf_has_rlabels(mpf)
    )
  }

  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, fontspec = fontspec,
      nosplitin = nosplitin[["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,
                             # rep_cols = num_rep_cols(obj),
                             # col_gap = 3, # this could be change in default - breaking change
                             col_gap = 3,
                             fontspec = font_spec(font_family, font_size, lineheight),
                             verbose = FALSE) {
  newdev <- open_font_dev(fontspec)
  if (newdev) {
    on.exit(close_font_dev())
  }

  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, fontspec = fontspec)
  # For listings, keycols are mandatory rep_num_cols
  if (is.null(rep_cols)) {
    rep_cols <- num_rep_cols(obj)
  }
  num_rep_cols(mpf) <- rep_cols

  # 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, fontspec = fontspec)
  } 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
  }

  if (NROW(mf_cinfo(mpf)) == 0) {
    mpf <- mpf_infer_cinfo(mpf, colwidths, rep_cols, fontspec = fontspec)
  }

  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,
      fontspec = fontspec,
      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 always return a list, including 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) {
    # Correction for case we are entering here (page_by)
    if (!is.null(page_num)) {
      prov_footer(obj) <- head(prov_footer(obj), -1)
      fpags <- lapply(fpags, function(x) {
        prov_footer(x) <- head(prov_footer(x), -1)
        x
      })
    }
    # XXX to merge with listings and avoid recursive (after PR #296)
    deep_pag <- paginate_to_mpfs( # what about the other parameters?
      fpags,
      pg_size_spec = pg_size_spec,
      colwidths = colwidths,
      min_siblings = min_siblings,
      nosplitin = nosplitin,
      fontspec = fontspec,
      verbose = verbose,
      rep_cols = rep_cols,
      page_num = page_num
    )
    return(deep_pag)
  } 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, fontspec = fontspec)
  num_rep_cols(mpf) <- rep_cols
  if (is.null(colwidths)) {
    colwidths <- mf_col_widths(mpf) %||% propose_column_widths(mpf, fontspec = fontspec)
  }
  mf_col_widths(mpf) <- colwidths
  mf_colgap(mpf) <- col_gap

  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,
    col_gap = col_gap,
    fontspec = fontspec
  )

  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), fontspec = fontspec),
                                tf_wrap = FALSE,
                                max_width = NULL,
                                indent_size = 2,
                                pg_size_spec = NULL,
                                rep_cols = num_rep_cols(obj),
                                col_gap = 3,
                                verbose = FALSE,
                                fontspec = font_spec(
                                  font_family,
                                  font_size,
                                  lineheight
                                ),
                                ...) {
  new_dev <- open_font_dev(fontspec)
  if (new_dev) {
    on.exit(close_font_dev())
  }
  fpag <- do_forced_paginate(obj)
  if (length(fpag) > 1) {
    return(lapply(
      fpag,
      diagnose_pagination,
      page_type = page_type,
      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,
      fontspec = fontspec
    ))
  }

  mpf <- matrix_form(obj, TRUE, fontspec = fontspec)
  msgres <- capture.output(
    {
      tmp <- try(
        paginate_to_mpfs(
          obj,
          page_type = page_type,
          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,
          fontspec = fontspec,
          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,
    fontspec = font_spec(font_family, font_size, lineheight)
  )
  mpf <- mpf_infer_cinfo(mpf, colwidths = colwidths, fontspec = fontspec)

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

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

#' 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`]).
#'
#' @inheritParams open_font_dev
#' @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.
#' @param col_gap (`numeric(1)`)\cr the gap to be assumed between columns, in number of spaces with
#'   font specified by `fontspec`.
#'
#' @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 relevant functions in`rtables`), as it is the
#'   row/column structure of `tt` and thus not useful for pathing or pagination.
#'
#' @examples
#' # Expected error with matrix_form. For real case examples consult {rtables} documentation
#' mf <- basic_matrix_form(iris)
#' # make_row_df(mf) # Use table obj instead
#'
#' @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,
                                   fontspec = font_spec(),
                                   col_gap = 3L) {
  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,
                                                     fontspec = font_spec(),
                                                     col_gap = mf_colgap(tt) %||% 3L) {
  msg <- paste0(
    "make_row_df can be used only on {rtables} table objects, and not on `matrix_form`-",
    "generated objects (MatrixPrintForm)."
  )
  stop(msg)
})

#' 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.
#'
#' @inheritParams make_row_df
#' @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,
                                   fontspec = NULL,
                                   col_gap = NULL) {
  standardGeneric("matrix_form")
})


#' @rdname matrix_form
#' @export
setMethod("matrix_form", "MatrixPrintForm", function(obj,
                                                     indent_rownames = FALSE,
                                                     expand_newlines = TRUE,
                                                     indent_size = 2,
                                                     fontspec = NULL,
                                                     col_gap = NULL) {
  if (!is.null(fontspec)) {
    mf_fontspec(obj) <- fontspec
  }
  if (!is.null(col_gap) && !isTRUE(all.equal(col_gap, mf_colgap(obj)))) {
    mf_colgap(obj) <- col_gap
  }
  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
#'
#' @inheritParams open_font_dev
#' @param x (`ANY`)\cr the object to be printed.
#' @param colwidths (`numeric`)\cr column widths (if necessary). Principally used in `rtables`'
#'   method.
#' @param max_width (`numeric(1)`)\cr width that strings should be wrapped to when
#'   determining how many lines they require.
#' @param col_gap (`numeric(1)`)\cr width of gap between columns in number of spaces.
#'   Only used by methods which must calculate span widths after wrapping.
#'
#' @return The number of lines needed to render the object `x`.
#'
#' @export
setGeneric(
  "nlines",
  ## XXX TODO come back and add fontspec default value once not having
  ## it has found all the disconnection breakages
  function(x, colwidths = NULL, max_width = NULL, fontspec, col_gap = NULL) standardGeneric("nlines")
)

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

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

#' @export
#' @rdname nlines
setMethod("nlines", "character", function(x, colwidths, max_width, fontspec, col_gap = NULL) {
  splstr <- strsplit(x, "\n", fixed = TRUE)
  if (length(x) == 0) {
    return(0L)
  }

  sum(vapply(splstr,
    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, fontspec = fontspec))
      }
    }, 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)

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

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

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

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

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

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

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

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

#' @export
#' @param value (`numeric(1)`)\cr the new number of columns to repeat.
#' @rdname num_rep_cols
setGeneric("num_rep_cols<-", function(obj, value) standardGeneric("num_rep_cols<-"))

#' @export
#' @rdname num_rep_cols
setMethod("num_rep_cols<-", "ANY", function(obj, value) stop("No num_rep_cols<- method for class ", class(obj)))

#' @export
#' @rdname num_rep_cols
setMethod("num_rep_cols<-", "MatrixPrintForm", function(obj, value) {
  obj <- mf_update_cinfo(obj, colwidths = NULL, rep_cols = value)
  obj
})

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

## 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
  # colwidths = NULL, max_width = NULL, fontspec = NULL
  # because we don't care about wrapping here we're counting lines
  # TODO probably better if we had a nlines_nowrap fun to be more explicit

  row_nlines <- apply(
    strmat,
    1,
    function(x) {
      max(
        vapply(x,
          nlines,
          colwidths = NULL,
          max_width = NULL,
          fontspec = NULL, 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.
#'
#' @inheritParams open_font_dev
#' @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 colpaths (`list` or `NULL`)\cr `NULL`, or a list of paths to each leaf column,
#'   for use during horizontal pagination.
#' @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.
#' @param rep_cols (`numeric(1)`)\cr number of columns to be repeated as context during horizontal pagination.
#'
#' @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,
                            colpaths = NULL,
                            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,
                            fontspec = font_spec(),
                            rep_cols = 0L) {
  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,
      fontspec = fontspec,
      num_rep_cols = rep_cols
    ),
    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, fontspec = fontspec)
  }
  mf_col_widths(ret) <- colwidths
  ret <- mform_build_refdf(ret)
  ret <- mpf_infer_cinfo(ret, colpaths = colpaths, fontspec = fontspec)

  ret
}

mf_update_cinfo <- function(mf, colwidths = NULL, rep_cols = NULL) {
  need_update <- FALSE
  if (!is.null(colwidths)) {
    mf$col_widths <- colwidths
    need_update <- TRUE
  }

  if (!is.null(rep_cols)) {
    mf$num_rep_cols <- rep_cols
    need_update <- TRUE
  }

  if (need_update && !is.null(mf_cinfo(mf))) {
    cinfo <- mf_cinfo(mf)
    r_colwidths <- mf_col_widths(mf)
    has_rlabs <- mf_has_rlabels(mf)
    if (has_rlabs) {
      r_colwidths <- r_colwidths[-1] ## row label widths
    }
    cinfo$self_extent <- r_colwidths
    nrepcols <- num_rep_cols(mf)
    rep_seq <- seq_len(nrepcols)
    cinfo$par_extent <- cumsum(c(0, cinfo$self_extent[seq_len(nrepcols)], rep(0, length(r_colwidths) - nrepcols - 1)))
    cinfo$reprint_inds <- I(lapply(seq_len(NROW(cinfo)), function(i) rep_seq[rep_seq < i]))
    mf_cinfo(mf) <- cinfo
  }
  mf
}

#' 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
  ## include space in front of { so we don't catch \{ when
  ## rtfs want to pass markup through
  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

#' @export
#' @rdname mpf_accessors
mf_fontspec <- function(mf) mf$fontspec

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

## 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 <- mf_update_cinfo(mf, colwidths = value, rep_cols = NULL)
  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,
    fontspec = mf_fontspec(mform),
    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.
#'
#' @inheritParams open_font_dev
#' @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.
#' @param num_rep_cols (`numeric(1)`)\cr Number of columns to be treated as repeating columns.
#'   Defaults to `0` for `basic_matrix_form` and `length(keycols)` for
#'   `basic_listing_mf`. Note repeating columns are separate from row labels if present.
#'
#' @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))
#'
#' @examplesIf require("dplyr")
#' # 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,
                              fontspec = font_spec(),
                              split_labels = NULL,
                              data_labels = NULL,
                              num_rep_cols = 0L) {
  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, fontspec = fontspec, 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),
    fontspec = fontspec,
    col_gap = 3,
    indent_size = indent_size,
    rep_cols = num_rep_cols
  )

  # 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,
                             fontspec = font_spec()) {
  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,
    num_rep_cols = length(keycols),
    fontspec = fontspec
  )

  # 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_cinfo(mf))) {
      mf_cinfo(mf) <- mf_cinfo(mf)[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 || length(j) == 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
}

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

times_font_name <- function() {
  ## I thought this was going to be OS specific
  ## but it seems like it's not...
  "Times"
}

#' Font size specification
#'
#' @param font_family (`character(1)`)\cr font family to use during
#'   string width and lines-per-page calculations. You can specify
#'   "Times New Roman" as "Times" or "serif", regardless of OS.
#'   Beyond that, see `family` entry in [graphics::par()]
#'   for details.
#' @param font_size (`numeric(1)`)\cr font size to use during string width
#'   calculations and lines-per-page calculations.
#' @param lineheight (`numeric(1)`)\cr line height to use during
#'   lines-per-page calculations.
#'
#' @details Passing the output of this constructor
#' to the rendering or pagination machinery defines
#' a font for use when calculating word wrapping and pagination.
#'
#' @note Specifying font in this way to, e.g., [export_as_txt()] or
#' [toString()] will not affect the font size of the output, as these
#' are both raw text formats. [export_as_pdf()] will use the specified font.
#'
#' @seealso [nchar_ttype()], [toString()], [`pagination_algo`], [export_as_pdf()]
#'
#' @examples
#' fspec <- font_spec("Courier", 8, 1)
#'
#' lets <- paste(letters, collapse = "")
#'
#' nchar_ttype(lets, fspec)
#'
#' fspec2 <- font_spec("Times", 8, 1)
#'
#' nchar_ttype(lets, fspec2)
#'
#' @export
font_spec <- function(font_family = "Courier",
                      font_size = 8,
                      lineheight = 1) {
  if (font_family %in% c("Times New Roman", "Times", "serif")) {
    font_family <- times_font_name()
  }
  structure(
    list(
      family = font_family,
      size = font_size,
      lineheight = lineheight
    ),
    class = c("font_spec", "list")
  )
}
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,
                      fontspec = font_spec(font_family, font_size, lineheight)) {
  new_dev <- open_font_dev(fontspec)
  if (new_dev) {
    on.exit(close_font_dev())
  }
  list(
    cpi = 1 / convertWidth(unit(1, "strwidth", " "), "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
#'
#' @inheritParams open_font_dev
#' @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,
                      fontspec = font_spec(font_family, font_size, lineheight)) {
  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(fontspec = fontspec)

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

.open_fdev_is_monospace <- function() {
  if (!font_dev_state$open) {
    stop(
      ".open_fdev_is_monospace called when font dev state is not open. ",
      "This shouldn't happen, please contact the maintainers."
    )
  }
  font_dev_state$ismonospace
}

## safe wrapper around .open_fdev_is_monospace
is_monospace <- function(font_family = "Courier",
                         font_size = 8,
                         lineheight = 1,
                         fontspec = font_spec(
                           font_family,
                           font_size,
                           lineheight
                         )) {
  if (is.null(fontspec)) {
    return(TRUE)
  }
  new_dev <- open_font_dev(fontspec)
  if (new_dev) {
    on.exit(close_font_dev())
  }
  .open_fdev_is_monospace()
}

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

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 currently 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 (`character`)\cr character vector to display when the values of `x` are missing.
#'   If only one string is provided, it is applied for all missing values. Defaults to `"NA"`.
#' @param output (`string`)\cr output type.
#'
#' @details A length-zero value for `na_str` will be interpreted as `"NA"`.
#'
#' @return Formatted text representing the cell `x`.
#'
#' @seealso [round_fmt()]
#'
#' @examples
#' x <- format_value(pi, format = "xx.xx")
#' x
#'
#' format_value(x, output = "ascii")
#'
#' # na_str works with multiple values
#' format_value(c(NA, 1, NA), format = "xx.x (xx.x - xx.x)", na_str = c("NE", "<missing>"))
#'
#' @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)

  # Checks for NAs in the input
  if (length(na_str) == 0) {
    na_str <- "NA"
  }
  if (any(is.na(na_str))) {
    na_str[is.na(na_str)] <- "NA"
  }
  if (length(na_str) == 1) {
    if (!all(is.na(x))) {
      na_str <- array(na_str, dim = length(x))
    }
  } else { # length(na_str) > 1
    tmp_na_str <- array("NA", dim = length(x))
    tmp_na_str[is.na(x)] <- na_str[seq(sum(is.na(x)))]
    na_str <- tmp_na_str
  }
  # if (length(na_str) < sum(is.na(x))) { # not a fun of vec recycling
  #   na_str <- rep(na_str, length.out = sum(is.na(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,
        "'. Run `list_valid_format_labels()` to get a list of all available formats."
      )
    }
    if (format != "xx" && length(x) != l) {
      stop(
        "Cell contents <", paste(x, collapse = ", "), "> and format '",
        format, "' are of different lengths (", length(x), " vs ", l, ")."
      )
    }
    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")
    )
  }
  # Check that probably never happens as it is almost always already text
  txt[is.na(txt)] <- na_str[1]


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

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

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

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

1		#' @import grid
2		#' @import grDevices
3		NULL
4		## https://www.ietf.org/rfc/rfc0678.txt
5
6		times_font_name <- function() {
7		## I thought this was going to be OS specific
8		## but it seems like it's not...
9	4x	"Times"
10		}
11
12		#' Font size specification
13		#'
14		#' @param font_family (`character(1)`)\cr font family to use during
15		#' string width and lines-per-page calculations. You can specify
16		#' "Times New Roman" as "Times" or "serif", regardless of OS.
17		#' Beyond that, see `family` entry in [graphics::par()]
18		#' for details.
19		#' @param font_size (`numeric(1)`)\cr font size to use during string width
20		#' calculations and lines-per-page calculations.
21		#' @param lineheight (`numeric(1)`)\cr line height to use during
22		#' lines-per-page calculations.
23		#'
24		#' @details Passing the output of this constructor
25		#' to the rendering or pagination machinery defines
26		#' a font for use when calculating word wrapping and pagination.
27		#'
28		#' @note Specifying font in this way to, e.g., [export_as_txt()] or
29		#' [toString()] will not affect the font size of the output, as these
30		#' are both raw text formats. [export_as_pdf()] will use the specified font.
31		#'
32		#' @seealso [nchar_ttype()], [toString()], [`pagination_algo`], [export_as_pdf()]
33		#'
34		#' @examples
35		#' fspec <- font_spec("Courier", 8, 1)
36		#'
37		#' lets <- paste(letters, collapse = "")
38		#'
39		#' nchar_ttype(lets, fspec)
40		#'
41		#' fspec2 <- font_spec("Times", 8, 1)
42		#'
43		#' nchar_ttype(lets, fspec2)
44		#'
45		#' @export
46		font_spec <- function(font_family = "Courier",
47		font_size = 8,
48		lineheight = 1) {
49	408x	if (font_family %in% c("Times New Roman", "Times", "serif")) {
50	4x	font_family <- times_font_name()
51		}
52	408x	structure(
53	408x	list(
54	408x	family = font_family,
55	408x	size = font_size,
56	408x	lineheight = lineheight
57		),
58	408x	class = c("font_spec", "list")
59		)
60		}
61		std_cpi <- 10L
62		std_lpi <- 6L
63
64		std_full_pg_wd_in <- 8.5
65
66		std_full_pg_ht_in <- 11
67
68		std_log_pg_wd_chars <- 72
69
70		std_log_pg_ht_lines <- 60
71
72		std_marg_ht <- round((std_full_pg_ht_in - std_log_pg_ht_lines / std_lpi) / 2, 2)
73		std_marg_wd <- round((std_full_pg_wd_in - std_log_pg_wd_chars / std_cpi) / 2, 2)
74
75		std_margins <- list(
76		top = std_marg_ht,
77		bottom = std_marg_ht,
78		left = std_marg_wd,
79		right = std_marg_wd
80		)
81
82		## does not appear to be used anywhere
83		## to_inches_num <- function(x) {
84		## if (is(x, "unit")) {
85		## x <- unclass(convertUnit(x, "inches"))
86		## }
87		## x
88		## }
89
90		## Physical size, does not take margins into account
91		pg_dim_names <- list(
92		letter = c(8.5, 11),
93		a4 = c(8.27, 11.69),
94		legal = c(8.5, 14)
95		)
96
97		#' Supported named page types
98		#'
99		#' List supported named page types.
100		#'
101		#' @return
102		#' * `page_types` returns a character vector of supported page types
103		#' * `page_dim` returns the dimensions (width, then height) of the selected page type.
104		#'
105		#' @export
106		#' @examples
107		#' page_types()
108		#' page_dim("a4")
109		page_types <- function() {
110	74x	names(pg_dim_names)
111		}
112
113		#' @param page_type (`string`)\cr the name of a page size specification. Call
114		#' [page_types()] for supported values.
115		#'
116		#' @export
117		#' @rdname page_types
118		page_dim <- function(page_type) {
119	45x	if (is.null(page_type)) {
120	28x	return(NULL)
121		}
122	17x	if (!page_type %in% page_types()) {
123	1x	stop("Unrecognized page-size specification: ", page_type)
124		}
125	16x	pg_dim_names[[page_type]]
126		}
127
128		#' Calculate lines per inch and characters per inch for font
129		#'
130		#' @inheritParams page_lcpp
131		#'
132		#' @details
133		#' This function opens a PDF graphics device, writes to a temporary file, then
134		#' utilizes [grid::convertWidth()] and [grid::convertHeight()] to calculate lines
135		#' per inch and characters per inch for the specified font family, size, and
136		#' line height.
137		#'
138		#' An error is thrown if the font is not monospaced (determined by comparing
139		#' the effective widths of the `M` and `.` glyphs).
140		#'
141		#' @return A named list with `cpi` and `lpi`, the characters and lines per
142		#' inch, respectively.
143		#'
144		#' @examples
145		#' font_lcpi <- getFromNamespace("font_lcpi", "formatters")
146		#'
147		#' font_lcpi()
148		#' font_lcpi(font_size = 8)
149		#' font_lcpi(font_size = 8, lineheight = 1.1)
150		#'
151		#' @keywords internal
152		font_lcpi <- function(font_family = "Courier",
153		font_size = 8,
154		lineheight = 1,
155		fontspec = font_spec(font_family, font_size, lineheight)) {
156	58x	new_dev <- open_font_dev(fontspec)
157	58x	if (new_dev) {
158	10x	on.exit(close_font_dev())
159		}
160	58x	list(
161	58x	cpi = 1 / convertWidth(unit(1, "strwidth", " "), "inches", valueOnly = TRUE),
162	58x	lpi = convertHeight(unit(1, "inches"), "lines", valueOnly = TRUE)
163		)
164		}
165
166		marg_order <- c("bottom", "left", "top", "right")
167
168		#' Determine lines per page (LPP) and characters per page (CPP) based on font and page type
169		#'
170		#' @inheritParams open_font_dev
171		#' @param page_type (`string`)\cr name of a page type. See [`page_types`]. Ignored
172		#' when `pg_width` and `pg_height` are set directly.
173		#' @param landscape (`flag`)\cr whether the dimensions of `page_type` should be
174		#' inverted for landscape orientation. Defaults to `FALSE`, ignored when `pg_width` and
175		#' `pg_height` are set directly.
176		#' @param font_family (`string`)\cr name of a font family. An error will be thrown
177		#' if the family named is not monospaced. Defaults to `"Courier"`.
178		#' @param font_size (`numeric(1)`)\cr font size. Defaults to `12`.
179		#' @param lineheight (`numeric(1)`)\cr line height. Defaults to `1`.
180		#' @param margins (`numeric(4)`)\cr named numeric vector containing `"bottom"`, `"left"`,
181		#' `"top"`, and `"right"` margins in inches. Defaults to `.5` inches for both vertical
182		#' margins and `.75` for both horizontal margins.
183		#' @param pg_width (`numeric(1)`)\cr page width in inches.
184		#' @param pg_height (`numeric(1)`)\cr page height in inches.
185		#'
186		#' @return A named list containing LPP (lines per page) and CPP (characters per page)
187		#' elements suitable for use by the pagination machinery.
188		#'
189		#' @examples
190		#' page_lcpp()
191		#' page_lcpp(font_size = 10)
192		#' page_lcpp("a4", font_size = 10)
193		#'
194		#' page_lcpp(margins = c(top = 1, bottom = 1, left = 1, right = 1))
195		#' page_lcpp(pg_width = 10, pg_height = 15)
196		#'
197		#' @export
198		page_lcpp <- function(page_type = page_types(),
199		landscape = FALSE,
200		font_family = "Courier",
201		font_size = 8,
202		lineheight = 1,
203		margins = c(top = .5, bottom = .5, left = .75, right = .75),
204		pg_width = NULL,
205		pg_height = NULL,
206		fontspec = font_spec(font_family, font_size, lineheight)) {
207	54x	if (is.null(page_type)) {
208	19x	page_type <- page_types()[1]
209		} else {
210	35x	page_type <- match.arg(page_type)
211		}
212
213	54x	if (is.null(names(margins))) {
214	12x	names(margins) <- marg_order
215		} else {
216	42x	margins <- margins[marg_order]
217		}
218	54x	if (any(is.na(margins))) {
219	!	stop("margins argument must have names 'bottom', 'left', 'top' and 'right'.")
220		}
221	54x	lcpi <- font_lcpi(fontspec = fontspec)
222
223	54x	wdpos <- ifelse(landscape, 2, 1)
224	54x	pg_width <- pg_width %\|\|% pg_dim_names[[page_type]][wdpos]
225	54x	pg_height <- pg_height %\|\|% pg_dim_names[[page_type]][-wdpos]
226
227	54x	pg_width <- pg_width - sum(margins[c("left", "right")])
228	54x	pg_height <- pg_height - sum(margins[c("top", "bottom")])
229
230	54x	list(
231	54x	cpp = floor(lcpi[["cpi"]] * pg_width),
232	54x	lpp = floor(lcpi[["lpi"]] * pg_height)
233		)
234		}
235
236		.open_fdev_is_monospace <- function() {
237		if (!font_dev_state$open) {
238		stop(
239		".open_fdev_is_monospace called when font dev state is not open. ",
240		"This shouldn't happen, please contact the maintainers."
241		)
242		}
243		font_dev_state$ismonospace
244		}
245
246		## safe wrapper around .open_fdev_is_monospace
247		is_monospace <- function(font_family = "Courier",
248		font_size = 8,
249		lineheight = 1,
250		fontspec = font_spec(
251		font_family,
252		font_size,
253		lineheight
254		)) {
255		if (is.null(fontspec)) {
256		return(TRUE)
257		}
258		new_dev <- open_font_dev(fontspec)
259		if (new_dev) {
260		on.exit(close_font_dev())
261		}
262		.open_fdev_is_monospace()
263		}
264
265		## pg_types <- list(
266		## "fsrp" = c(cpp = 110, lpp = 66),
267		## "fsrp8" = c(cpp = 110, lpp = 66),
268		## "fsrp7" = c(cpp = 110, lpp = 75),
269		## "fsrl" = c(cpp = 149, lpp = 51),
270		## "fsrl8" = c(cpp = 149, lpp = 51),
271		## "fsrl7" = c(cpp = 150, lpp = 59),
272		## "erp" = c(cpp = 96, lpp = 66),
273		## "erp8" = c(cpp = 96, lpp = 66),
274		## "erl" = c(cpp = 149, lpp = 45),
275		## "erl8" = c(cpp = 149, lpp = 45),
276		## "sasp" = c(cpp = 93, lpp = 73),
277		## "sasp8" = c(cpp = 93, lpp = 73),
278		## "sasl" = c(cpp = 134, lpp = 52),
279		## "sasl8" = c(cpp = 134, lpp = 52),
280		## "sasp7" = c(cpp = 107, lpp = 92),
281		## "sasl7" = c(cpp = 154, lpp = 64),
282		## "sasp6" = c(cpp = 125, lpp = 108),
283		## "sasl6" = c(cpp = 180, lpp = 75),
284		## "sasp10" = c(cpp = 78, lpp = 64),
285		## "sasl10" = c(cpp = 108, lpp = 45),
286		## "sasp9" = c(cpp = 87, lpp = 71),
287		## "sasl9" = c(cpp = 120, lpp = 51),
288		## "rapidp10" = c(cpp = 78, lpp = 64),
289		## "rapidl10" = c(cpp = 108, lpp = 45),
290		## "rapidp9" = c(cpp = 87, lpp = 71),
291		## "rapidl9" = c(cpp = 120, lpp = 51),
292		## "rapidp" = c(cpp = 93, lpp = 73),
293		## "rapidp8" = c(cpp = 93, lpp = 73),
294		## "rapidl" = c(cpp = 134, lpp = 52),
295		## "rapidl8" = c(cpp = 134, lpp = 52),
296		## "rapidp7" = c(cpp = 107, lpp = 92),
297		## "rapidl7" = c(cpp = 154, lpp = 64),
298		## "rapidp6" = c(cpp = 125, lpp = 108),
299		## "rapidl6" = c(cpp = 180, lpp = 75),
300		## "shibal" = c(cpp = 170, lpp = 48),
301		## "shibal10" = c(cpp = 137, lpp = 39),
302		## "shibal8" = c(cpp = 170, lpp = 48),
303		## "shibal7" = c(cpp = 194, lpp = 56),
304		## "shibal6" = c(cpp = 225, lpp = 65),
305		## "shibap" = c(cpp = 112, lpp = 78),
306		## "shibap10" = c(cpp = 89, lpp = 64),
307		## "shibap8" = c(cpp = 112, lpp = 78),
308		## "shibap7" = c(cpp = 127, lpp = 92),
309		## "shibap6" = c(cpp = 148, lpp = 108))
310
311		## ~courier_size, ~cpi, ~lpi,
312		## 6, floor(129 / pg_dim_names[["letter"]][1]), floor(85 / pg_dim_names[["letter"]][2]),
313		## 7, floor(110 / pg_dim_names[["letter"]][1]), floor(76 / pg_dim_names[["letter"]][2]),
314		## 8, floor(95 / pg_dim_names[["letter"]][1]), floor(68 / pg_dim_names[["letter"]][2]),
315		## 9, floor(84 / pg_dim_names[["letter"]][1]), floor(61 / pg_dim_names[["letter"]][2]),
316		## 10, floor(75 / pg_dim_names[["letter"]][1]), floor(56 / pg_dim_names[["letter"]][2])
317		## )
318
319		## courier_lcpi <- function(size) {
320		## grid.newpage()
321		## gp <- gpar(fontfamily="Courier New", fontsize = size, lineheight = 1)
322		## pushViewport(plotViewport( gp = gp))
323		## list(cpi = round(1/convertWidth(unit(1, "strwidth", "h"), "inches", valueOnly = TRUE), 0),
324		## lpi = round(convertHeight(unit(1, "inches"), "lines", valueOnly = TRUE), 0))
325		## }

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	16205x	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	208x	if (!is.na(digits) && digits < 0) {
187	!	stop("round_fmt currently does not support non-missing values of digits < 0")
188		}
189	208x	if (is.na(x)) {
190	11x	na_str
191	197x	} else if (is.na(digits)) {
192	44x	paste0(x)
193		} else {
194	153x	sprfmt <- paste0("%.", digits, "f")
195	153x	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	!	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	47x	ret <- paste(mapply(round_fmt, x = x, digits = c(dig1, dig2), na_str = na_str),
216	47x	collapse = sep
217		)
218	47x	if (!is.null(wrap)) {
219	24x	ret <- paste(c(wrap[1], ret, wrap[2]), collapse = "")
220		}
221	47x	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 (`character`)\cr character vector to display when the values of `x` are missing.
237		#' If only one string is provided, it is applied for all missing values. Defaults to `"NA"`.
238		#' @param output (`string`)\cr output type.
239		#'
240		#' @details A length-zero value for `na_str` will be interpreted as `"NA"`.
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		#' # na_str works with multiple values
253		#' format_value(c(NA, 1, NA), format = "xx.x (xx.x - xx.x)", na_str = c("NE", "<missing>"))
254		#'
255		#' @export
256		format_value <- function(x, format = NULL, output = c("ascii", "html"), na_str = "NA") {
257		## if(is(x, "CellValue"))
258		## x = x[[1]]
259
260	9137x	if (length(x) == 0) {
261	1x	return("")
262		}
263
264	9136x	output <- match.arg(output)
265
266		# Checks for NAs in the input
267	9136x	if (length(na_str) == 0) {
268	1x	na_str <- "NA"
269		}
270	9136x	if (any(is.na(na_str))) {
271	1x	na_str[is.na(na_str)] <- "NA"
272		}
273	9136x	if (length(na_str) == 1) {
274	9132x	if (!all(is.na(x))) {
275	9110x	na_str <- array(na_str, dim = length(x))
276		}
277		} else { # length(na_str) > 1
278	4x	tmp_na_str <- array("NA", dim = length(x))
279	4x	tmp_na_str[is.na(x)] <- na_str[seq(sum(is.na(x)))]
280	4x	na_str <- tmp_na_str
281		}
282		# if (length(na_str) < sum(is.na(x))) { # not a fun of vec recycling
283		# na_str <- rep(na_str, length.out = sum(is.na(x)))
284		# }
285
286	9136x	txt <- if (all(is.na(x)) && length(na_str) == 1L) {
287	22x	na_str
288	9136x	} else if (is.null(format)) {
289	302x	toString(x)
290	9136x	} else if (is.function(format)) {
291	1x	format(x, output = output)
292	9136x	} else if (is.character(format)) {
293	8811x	l <- if (format %in% formats_1d) {
294	8729x	1
295	8811x	} else if (format %in% formats_2d) {
296	69x	2
297	8811x	} else if (format %in% formats_3d) {
298	12x	3
299		} else {
300	1x	stop(
301	1x	"Unknown format label: '", format,
302	1x	"'. Run `list_valid_format_labels()` to get a list of all available formats."
303		)
304		}
305	8810x	if (format != "xx" && length(x) != l) {
306	2x	stop(
307	2x	"Cell contents <", paste(x, collapse = ", "), "> and format '",
308	2x	format, "' are of different lengths (", length(x), " vs ", l, ")."
309		)
310		}
311	8808x	switch(format,
312	8688x	"xx" = as.character(x),
313	3x	"xx." = round_fmt(x, digits = 0, na_str = na_str),
314	6x	"xx.x" = round_fmt(x, digits = 1, na_str = na_str),
315	3x	"xx.xx" = round_fmt(x, digits = 2, na_str = na_str),
316	3x	"xx.xxx" = round_fmt(x, digits = 3, na_str = na_str),
317	3x	"xx.xxxx" = round_fmt(x, digits = 4, na_str = na_str),
318	2x	"xx%" = paste0(round_fmt(x * 100, digits = NA, na_str = na_str), "%"),
319	2x	"xx.%" = paste0(round_fmt(x * 100, digits = 0, na_str = na_str), "%"),
320	2x	"xx.x%" = paste0(round_fmt(x * 100, digits = 1, na_str = na_str), "%"),
321	2x	"xx.xx%" = paste0(round_fmt(x * 100, digits = 2, na_str = na_str), "%"),
322	2x	"xx.xxx%" = paste0(round_fmt(x * 100, digits = 3, na_str = na_str), "%"),
323	2x	"(N=xx)" = paste0("(N=", round_fmt(x, digits = NA, na_str = na_str), ")"),
324	2x	"N=xx" = paste0("N=", round_fmt(x, digits = NA, na_str = na_str)),
325	3x	">999.9" = ifelse(x > 999.9, ">999.9", round_fmt(x, digits = 1, na_str = na_str)),
326	3x	">999.99" = ifelse(x > 999.99, ">999.99", round_fmt(x, digits = 2, na_str = na_str)),
327	3x	"x.xxxx \| (<0.0001)" = ifelse(x < 0.0001, "<0.0001", round_fmt(x, digits = 4, na_str = na_str)),
328	2x	"xx / xx" = sep_2d_helper(x, dig1 = NA, dig2 = NA, sep = " / ", na_str = na_str),
329	2x	"xx. / xx." = sep_2d_helper(x, dig1 = 0, dig2 = 0, sep = " / ", na_str = na_str),
330	2x	"xx.x / xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " / ", na_str = na_str),
331	2x	"xx.xx / xx.xx" = sep_2d_helper(x, dig1 = 2, dig2 = 2, sep = " / ", na_str = na_str),
332	2x	"xx.xxx / xx.xxx" = sep_2d_helper(x, dig1 = 3, dig2 = 3, sep = " / ", na_str = na_str),
333	2x	"N=xx (xx%)" = paste0("N=", val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str)),
334	3x	"xx (xx%)" = val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str),
335	2x	"xx (xx.%)" = val_pct_helper(x, dig1 = NA, dig2 = 0, na_str = na_str),
336	2x	"xx (xx.x%)" = val_pct_helper(x, dig1 = NA, dig2 = 1, na_str = na_str),
337	2x	"xx (xx.xx%)" = val_pct_helper(x, dig1 = NA, dig2 = 2, na_str = na_str),
338	2x	"xx. (xx.%)" = val_pct_helper(x, dig1 = 0, dig2 = 0, na_str = na_str),
339	3x	"xx.x (xx.x%)" = val_pct_helper(x, dig1 = 1, dig2 = 1, na_str = na_str),
340	2x	"xx.xx (xx.xx%)" = val_pct_helper(x, dig1 = 2, dig2 = 2, na_str = na_str),
341	2x	"(xx, xx)" = sep_2d_helper(x,
342	2x	dig1 = NA, dig2 = NA, sep = ", ",
343	2x	na_str = na_str, wrap = c("(", ")")
344		),
345	2x	"(xx., xx.)" = sep_2d_helper(x,
346	2x	dig1 = 0, dig2 = 0, sep = ", ",
347	2x	na_str = na_str, wrap = c("(", ")")
348		),
349	2x	"(xx.x, xx.x)" = sep_2d_helper(x,
350	2x	dig1 = 1, dig2 = 1, sep = ", ",
351	2x	na_str = na_str, wrap = c("(", ")")
352		),
353	2x	"(xx.xx, xx.xx)" = sep_2d_helper(x,
354	2x	dig1 = 2, dig2 = 2, sep = ", ",
355	2x	na_str = na_str, wrap = c("(", ")")
356		),
357	2x	"(xx.xxx, xx.xxx)" = sep_2d_helper(x,
358	2x	dig1 = 3, dig2 = 3, sep = ", ",
359	2x	na_str = na_str, wrap = c("(", ")")
360		),
361	2x	"(xx.xxxx, xx.xxxx)" = sep_2d_helper(x,
362	2x	dig1 = 4, dig2 = 4, sep = ", ",
363	2x	na_str = na_str, wrap = c("(", ")")
364		),
365	2x	"xx - xx" = sep_2d_helper(x, dig1 = NA, dig2 = NA, sep = " - ", na_str = na_str),
366	5x	"xx.x - xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " - ", na_str = na_str),
367	2x	"xx.xx - xx.xx" = sep_2d_helper(x, dig1 = 2, dig2 = 2, sep = " - ", na_str = na_str),
368	2x	"xx (xx)" = val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str, pct = FALSE),
369	2x	"xx. (xx.)" = val_pct_helper(x, dig1 = 0, dig2 = 0, na_str = na_str, pct = FALSE),
370	2x	"xx.x (xx.x)" = val_pct_helper(x, dig1 = 1, dig2 = 1, na_str = na_str, pct = FALSE),
371	2x	"xx.xx (xx.xx)" = val_pct_helper(x, dig1 = 2, dig2 = 2, na_str = na_str, pct = FALSE),
372	2x	"xx (xx.)" = val_pct_helper(x, dig1 = NA, dig2 = 0, na_str = na_str, pct = FALSE),
373	2x	"xx (xx.x)" = val_pct_helper(x, dig1 = NA, dig2 = 1, na_str = na_str, pct = FALSE),
374	2x	"xx (xx.xx)" = val_pct_helper(x, dig1 = NA, dig2 = 2, na_str = na_str, pct = FALSE),
375	2x	"xx.x, xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = ", ", na_str = na_str),
376	2x	"xx.x to xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " to ", na_str = na_str),
377	2x	"xx.xx (xx.xx - xx.xx)" = paste0(
378	2x	round_fmt(x[1], digits = 2, na_str = na_str[1]), " ",
379	2x	sep_2d_helper(x[2:3],
380	2x	dig1 = 2, dig2 = 2,
381	2x	sep = " - ", na_str = na_str[2:3],
382	2x	wrap = c("(", ")")
383		)
384		),
385	2x	"xx. (xx. - xx.)" = paste0(
386	2x	round_fmt(x[1], digits = 0, na_str = na_str[1]), " ",
387	2x	sep_2d_helper(x[2:3],
388	2x	dig1 = 0, dig2 = 0,
389	2x	sep = " - ", na_str = na_str[2:3],
390	2x	wrap = c("(", ")")
391		)
392		),
393	6x	"xx.x (xx.x - xx.x)" = paste0(
394	6x	round_fmt(x[1], digits = 1, na_str = na_str[1]), " ",
395	6x	sep_2d_helper(x[2:3],
396	6x	dig1 = 1, dig2 = 1,
397	6x	sep = " - ", na_str = na_str[2:3],
398	6x	wrap = c("(", ")")
399		)
400		),
401	2x	"xx.xxx (xx.xxx - xx.xxx)" = paste0(
402	2x	round_fmt(x[1], digits = 3, na_str = na_str[1]), " ",
403	2x	sep_2d_helper(x[2:3],
404	2x	dig1 = 3, dig2 = 3,
405	2x	sep = " - ", na_str = na_str[2:3],
406	2x	wrap = c("(", ")")
407		)
408		),
409	!	paste("format string", format, "not found")
410		)
411		}
412		# Check that probably never happens as it is almost always already text
413	9133x	txt[is.na(txt)] <- na_str[1]
414
415
416	9133x	if (output == "ascii") {
417	9132x	txt
418	1x	} else if (output == "html") {
419		## convert to tagList
420		## convert \n to <br/>
421
422	1x	if (identical(txt, "")) {
423	!	txt
424		} else {
425	1x	els <- unlist(strsplit(txt, "\n", fixed = TRUE))
426	1x	Map(function(el, is.last) {
427	1x	tagList(el, if (!is.last) tags$br() else NULL)
428	1x	}, els, c(rep(FALSE, length(els) - 1), TRUE))
429		}
430		} else {
431	!	txt
432		}
433		}
434
435		setClassUnion("FormatSpec", c("NULL", "character", "function", "list"))
436		setClassUnion("characterOrNULL", c("NULL", "character"))
437		setClass("fmt_config",
438		slots = c(
439		format = "FormatSpec",
440		format_na_str = "characterOrNULL",
441		align = "characterOrNULL"
442		)
443		)
444
445		#' Format configuration
446		#'
447		#' @param format (`string` or `function`)\cr a format label (string) or formatter function.
448		#' @param na_str (`string`)\cr string that should be displayed in place of missing values.
449		#' @param align (`string`)\cr alignment values should be rendered with.
450		#'
451		#' @return An object of class `fmt_config` which contains the following elements:
452		#' * `format`
453		#' * `na_str`
454		#' * `align`
455		#'
456		#' @examples
457		#' fmt_config(format = "xx.xx", na_str = "-", align = "left")
458		#' fmt_config(format = "xx.xx - xx.xx", align = "right")
459		#'
460		#' @export
461		fmt_config <- function(format = NULL, na_str = "NA", align = "center") {
462	2x	new("fmt_config", format = format, format_na_str = na_str, align = align)
463		}

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	420x	if (length(a) == 0) {
23	128x	b
24		} else {
25	292x	a
26		}
27		}

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		#' 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	52x	system_default_hsep <- getOption("formatters_default_hsep")
23
24	52x	if (is.null(system_default_hsep)) {
25	51x	if (any(grepl("^UTF", utils::localeToCharset()))) {
26	51x	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	52x	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	35x	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	6x	checkmate::assert_string(page_number, null.ok = TRUE)
77	6x	options("formatter_default_page_number" = page_number)
78		}