formatters coverage - 94.10%

Files
Source

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


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

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

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


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


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


## Generics for `toString` and helper functions


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

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

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

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

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

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

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

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



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

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

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










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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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



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

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

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

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

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

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

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

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



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

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

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



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


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

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

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

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




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

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


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

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


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

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




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

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

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

## until we do it for real

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


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

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

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

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

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

  # There is something to change
  if (any(row_nlines > 1) || topleft_has_nl_char) {

    # False: Padder should be bottom aligned if no topleft (case of rlistings)
    # It is always bottom: tl_padder <- ifelse(has_topleft, pad_vert_top, pad_vert_bottom)

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

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

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

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

  matform
}

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

disp_from_spans <- function(spans) {

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

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

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

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

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

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


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


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


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


    hasrlbs <- mf_has_rlabels(mform)

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

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

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

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



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




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


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

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









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


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

#' @export
#' @rdname mpf_accessors

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

mf_aligns <- function(mf) mf$aligns

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

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

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

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


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

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

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

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

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


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




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


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

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

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

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


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

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

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


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

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

    mform
}

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

        refdfii <- refdf_rows[refdf_rows$row == ii,]
        refdfii <- refdfii[!duplicated(refdfii$symbol), ]
        if(NROW(refdfii) == 0L)
            return(0L)
        sum(refdfii$nlines)
    }, 1L)

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

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


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

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

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

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



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

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


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

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


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

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


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

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

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


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


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



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

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

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

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



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

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

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

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

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

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

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

  cnms <- names(df)

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

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

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


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

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


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

}


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


fix_fnote_df <- function(df) {
    ind_symb <- df$symbol == as.character(df$ref_index)
    df$ref_index <- seq_len(nrow(df))
    df$symbol[ind_symb] <- as.character(df$ref_index[ind_symb])
    df
}







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

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


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

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

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

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


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

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

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

    refdf <- mf_fnote_df(mf)

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

    rinfo <- mf_rinfo(mf)

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

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

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

}



## we only care about referential footnotes, cause
## they are currently the only place we're tracking
## column information that will need to be touched up
## but lets be careful and do a bit more anyway
mpf_subset_cols <- function(mf, j) {

    nc <- ncol(mf)
    if(is.logical(j) || all(j < 0))
        j <- seq_len(nc)[j]
    if(any(j < 0))
        stop("cannot mix negative and positive indices")

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


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

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

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


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



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

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

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

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

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

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


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


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

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


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

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

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

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

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

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


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


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

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

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

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

mpf_infer_cinfo <- function(mf, colwidths = NULL, rep_cols = num_rep_cols(mf)) {

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

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

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


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




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


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


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


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

    pg_lcpp <- page_lcpp(page_type = page_type,
                      landscape = landscape,
                      font_family = font_family,
                      font_size = font_size,
                      lineheight = lineheight,
                      margins = margins,
                      pg_width = pg_width,
                      pg_height = pg_height)

    if (non_null_na(lpp)) {
        lpp <- pg_lcpp$lpp
    }
    if(non_null_na(cpp)) {
        cpp <- pg_lcpp$cpp
    }
    stopifnot(!is.na(cpp))
    if(!tf_wrap && !is.null(max_width)) {
        warning("tf_wrap is FALSE - ignoring non-null max_width value.")
        max_width <- NULL
    } else if(tf_wrap && is.null(max_width))
        max_width <- cpp

    if(is.character(max_width) && identical(max_width, "auto")) {
        max_width <- inset + sum(colwidths) + (length(colwidths) - 1) * col_gap
    }
    page_size_spec(lpp = lpp, cpp = cpp, max_width = max_width)
}


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

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

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

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

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

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

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

    ret <- lpp - flines - tlines - cinfo_lines

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


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

    cpp <- pg_size_spec$cpp

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


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

}



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

#' @param pg_size_spec page_size_spec. A pre-calculated page
#'     size specification. Typically this is not set in end user code.
#' @param col_gap numeric(1). Currently unused.
#' @return for `paginate_indices` a list with two elements of the same
#'     length:   `pag_row_indices`,    and   `pag_col_indices`.    For
#'     `paginate_to_mpfs`,   a  list   of  `MatrixPrintForm` objects
#'     representing each individual page after pagination (including
#'     forced pagination if necessary).
#' @export
#' @aliases paginate pagination
#' @examples
#' mpf <- basic_matrix_form(mtcars)
#'
#' paginate_indices(mpf, pg_width = 5, pg_height = 3)
#'
#' paginate_to_mpfs(mpf, pg_width = 5, pg_height = 3)
paginate_indices <- function(obj,
                     page_type = "letter",
                     font_family = "Courier",
                     font_size = 8,
                     lineheight = 1,
                     landscape = FALSE,
                     pg_width = NULL,
                     pg_height = NULL,
                     margins = c(top = .5, bottom = .5, left = .75, right = .75),
                     lpp = NA_integer_,
                     cpp = NA_integer_,
                     min_siblings = 2,
                     nosplitin = character(),
                     colwidths = NULL,
                     tf_wrap = FALSE,
                     max_width = NULL,
                     indent_size = 2,
                     pg_size_spec = NULL,
                     rep_cols = num_rep_cols(obj),
                     col_gap = 3,
                     verbose = FALSE) {


    ## this MUST alsways return a list, inluding list(obj) when
    ## no forced pagination is needed! otherwise stuff breaks for things
    ## based on s3 classes that are lists underneath!!!
    fpags <- do_forced_paginate(obj)

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


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


    if(is.null(pg_size_spec)) {
        pg_size_spec <- calc_lcpp(page_type = page_type,
                        font_family = font_family,
                        font_size = font_size,
                        lineheight = lineheight,
                        landscape = landscape,
                        pg_width = pg_width,
                        pg_height = pg_height,
                        margins = margins,
                        lpp = lpp,
                        cpp = cpp,
                        tf_wrap = tf_wrap,
                        max_width = max_width,
                        colwidths = colwidths,
                        inset = table_inset(mpf),
                        col_gap = col_gap)
    }

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





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

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

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

    list(pag_row_indices = pag_row_indices,
         pag_col_indices = pag_col_indices)
}

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

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

#' @rdname paginate_indices
#' @export
paginate_to_mpfs <- function(obj,
                     page_type = "letter",
                     font_family = "Courier",
                     font_size = 8,
                     lineheight = 1,
                     landscape = FALSE,
                     pg_width = NULL,
                     pg_height = NULL,
                     margins = c(top = .5, bottom = .5, left = .75, right = .75),
                     lpp = NA_integer_,
                     cpp = NA_integer_,
                     min_siblings = 2,
                     nosplitin = character(),
                     colwidths = NULL,
                     tf_wrap = FALSE,
                     max_width = NULL,
                     indent_size = 2,
                     pg_size_spec = NULL,
                     rep_cols = num_rep_cols(obj),
                     col_gap = 2,
                     verbose = FALSE) {
    mpf <- matrix_form(obj, TRUE, TRUE, indent_size = indent_size)
    if(is.null(colwidths))
        colwidths <- mf_col_widths(mpf) %||% propose_column_widths(mpf)
    else
        mf_col_widths(mpf) <- colwidths
    if(NROW(mf_cinfo(mpf)) == 0)
        mpf <- mpf_infer_cinfo(mpf, colwidths, rep_cols)


    if(is.null(pg_size_spec)) {
        pg_size_spec <- calc_lcpp(page_type = page_type,
                        font_family = font_family,
                        font_size = font_size,
                        lineheight = lineheight,
                        landscape = landscape,
                        pg_width = pg_width,
                        pg_height = pg_height,
                        margins = margins,
                        lpp = lpp,
                        cpp = cpp,
                        tf_wrap = tf_wrap,
                        max_width = max_width,
                        colwidths = colwidths,
                        inset = table_inset(mpf),
                        col_gap = col_gap)
    }
    ## this MUST alsways return a list, inluding list(obj) when
    ## no forced pagination is needed! otherwise stuff breaks for things
    ## based on s3 classes that are lists underneath!!!
    fpags <- do_forced_paginate(obj)

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


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

    page_indices <- paginate_indices(obj = obj,
                                     ## page_type = page_type,
                                     ## font_family = font_family,
                                     ## font_size = font_size,
                                     ## lineheight = lineheight,
                                     ## landscape = landscape,
                                     ## pg_width = pg_width,
                                     ## pg_height = pg_height,
                                     ## margins = margins,
                                     pg_size_spec = pg_size_spec,
                                     ## lpp = lpp,
                                     ## cpp = cpp,
                                     min_siblings = min_siblings,
                                     nosplitin = nosplitin,
                                     colwidths = colwidths,
                                     tf_wrap = tf_wrap,
                                     ## max_width = max_width,
                                     rep_cols = rep_cols,
                                     verbose = verbose)

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

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

    unlist(res, recursive = FALSE)
}


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


    fpag <- do_forced_paginate(obj)
    if(length(fpag) > 1) {
        return(lapply(fpag,
                      diagnose_pagination,
                      page_type = page_type,
                      font_family = font_family,
                      font_size = font_size,
                      lineheight = lineheight,
                      landscape = landscape,
                      pg_width = pg_width,
                      pg_height = pg_height,
                      margins = margins,
                      lpp = lpp,
                      cpp = cpp,
                      tf_wrap = tf_wrap,
                      max_width = max_width,
                      colwidths = colwidths,
                      col_gap = col_gap,
                      min_siblings = min_siblings,
                      nosplitin = nosplitin))
    }

    mpf <- matrix_form(obj, TRUE)
    msgres <- capture.output({tmp <- try(paginate_to_mpfs(obj, page_type = page_type,
                     font_family = font_family,
                     font_size = font_size,
                     lineheight = lineheight,
                     landscape = landscape,
                     pg_width = pg_width,
                     pg_height = pg_height,
                     margins = margins,
                     lpp = lpp,
                     cpp = cpp,
                     tf_wrap = tf_wrap,
                     max_width = max_width,
                     colwidths = colwidths,
                     col_gap = col_gap,
                     min_siblings = min_siblings,
                     nosplitin = nosplitin,
                     verbose = TRUE))},
                     type = "message")
    if(is(tmp, "try-error") && grepl("Width of row labels equal to or larger", tmp)) {
        cond <- attr(tmp, "condition")
        stop(conditionMessage(cond), call. = conditionCall(cond))
    }

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

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

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

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

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

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


#' @importFrom htmltools tags tagList

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

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

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

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

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

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

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

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


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



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

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

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

## }

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

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

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


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

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

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

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

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

## This assumes fixed font size, monospaced font

std_cpi <- 10L
std_lpi <- 6L


std_full_pg_wd_in <- 8.5

std_full_pg_ht_in <- 11

std_log_pg_wd_chars <- 72

std_log_pg_ht_lines <- 60

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

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

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

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


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

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



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

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

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

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

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

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

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

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






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

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

## this can't be tested from within R
# nocov start
#' @importFrom stats na.omit
#' @importFrom utils head tail localeToCharset
#' @import checkmate

d_hsep_factory <- function() {
  warn_sent <- FALSE
  function() {
    if (any(grepl("^UTF", localeToCharset()))) {
      "\u2014"
    } else {
      if (!warn_sent && interactive()) {
        message(
          "Detected non-UTF charset. Falling back to '-' ",
          "as default header/body separator. This warning ",
          "will only be shown once per R session."
        )
        warn_sent <<- TRUE
      }
      "-"
    }
  }
}

#' Default horizontal Separator
#'
#' The default horizontal separator character which can be
#' displayed in the current `charset` for use in rendering table-likes.
#'
#' @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.
#'
#' @export
#' @examples
#' default_hsep()
default_hsep <- d_hsep_factory()

# nocov end

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

  nr <- nrow(body)

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

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


# Main function that does the wrapping
do_cell_fnotes_wrap <- function(mat, widths, max_width, tf_wrap) {

    col_gap <- mf_colgap(mat)
    ncchar <- sum(widths) + (length(widths) - 1) * col_gap
    inset <- table_inset(mat)

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

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

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

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

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

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

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

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

    mat
}

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

    mat <- matrix_form(x, indent_rownames = TRUE)

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

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

    inset <- table_inset(mat)

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

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

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

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

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

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

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

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

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

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

    # Define gap string and divisor string
    gap_str <- strrep(" ", col_gap)
    div <- substr(strrep(hsep, ncchar), 1, ncchar)

    # 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 <- x$row_info[, 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(x$line_grouping, -nl_header) - mf_nrheader(x)
        nrbody <- NROW(bdy_cont)
        stopifnot(length(row_grouping) == nrbody)
        ## all rows with non-NA section divs and the final row (regardless of NA status)
        ## fixes #77
        sec_seps_df <- sec_seps_df[unique(c(
            which(!is.na(sec_seps_df$trailing_sep)),
            NROW(sec_seps_df)
        )), ]
        txt_body <- character()
        sec_strt <- 1
        section_rws <- sec_seps_df$abs_rownumber
        for (i in seq_len(NROW(section_rws))) {
            cur_rownum <- section_rws[i]
            sec_end <- max(which(row_grouping == cur_rownum))
            txt_body <- c(
                txt_body,
                apply(bdy_cont[seq(sec_strt, sec_end), , drop = FALSE],
                      1,
                      .paste_no_na,
                      collapse = gap_str
                      ),
                ## don't print section dividers if they would be the last thing before the
                ## footer divider
                ## this also ensures an extraneous sec div won't be printed if we have non-sec-div
                ## rows after the last sec div row (#77)
                if (sec_end < nrbody) {
                    substr(
                        strrep(sec_seps_df$trailing_sep[i], ncchar), 1,
                        ncchar - inset
                    )
                }
            )
            sec_strt <- sec_end + 1
        }
    } else {
        # This is the usual default pasting
        txt_body <- apply(tail(content, -nl_header), 1, .paste_no_na, collapse = gap_str)
    }

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

    # 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(x),
        "prov_footer" = prov_footer(x),
        "ref_footnotes" = ref_fnotes
    )
    allfoots <- allfoots[!sapply(allfoots, is.null)]

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

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

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

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


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

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

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


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

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

  # str can be also a vector or list. In this case simplify manages the output
  ret <- .go_stri_wrap(str, width)

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

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

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

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

  return(ret)
}

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

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

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

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

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

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

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

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

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


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

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

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


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


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

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

  chars <- nchar(body)

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

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

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

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

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

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




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

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

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

  nc <- nchar(x)

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

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

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


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


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


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



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





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


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

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

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

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

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

  labels
}


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

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

  x
}


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

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

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

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

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

  x
}


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

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

  x
}

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

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

1		### This file defines the generics which make up the interface `formatters` offers.
2		### Defining methods for these generics for a new table-like class should be fully
3		### sufficient for hooking that class up to the `formatters` pagination and rendering
4		### machinery.
5
6
7		#' @import methods
8		#' @include matrix_form.R
9		#'
10		#' @title Make row layout summary data.frames for use during pagination
11		#'
12		#' @description
13		#' All relevant information about table rows (e.g. indentations) is summarized in a data.frames.
14		#' This function works ONLY on `rtables` and `rlistings` objects, and not on their print counterparts
15		#' (like `MatrixPrintForm`).
16		#'
17		#' @name make_row_df
18		#'
19		#' @param tt ANY. Object representing the table-like object to be summarized.
20		#' @param visible_only logical(1). Should only visible aspects of the table structure be reflected in this summary.
21		#' Defaults to \code{TRUE}. May not be supported by all methods.
22		#' @param incontent logical(1). Internal detail do not set manually.
23		#' @param repr_ext integer(1). Internal detail do not set manually.
24		#' @param repr_inds integer. Internal detail do not set manually.
25		#' @param sibpos integer(1). Internal detail do not set manually.
26		#' @param nsibs integer(1). Internal detail do not set manually.
27		#' @param rownum numeric(1). Internal detail do not set manually.
28		#' @param indent integer(1). Internal detail do not set manually.
29
30		#' @param colwidths numeric. Internal detail do not set manually.
31		#' @param path character. Path to the (sub)table represented by
32		#' \code{tt}. Defaults to \code{character()}
33		#' @param max_width numeric(1) or NULL. Maximum width for title/footer
34		#' materials.
35		#'
36		#' @details When \code{visible_only} is \code{TRUE} (the default),
37		#' methods should return a data.frame with exactly one row per
38		#' visible row in the table-like object. This is useful when
39		#' reasoning about how a table will print, but does not reflect
40		#' the full pathing space of the structure (though the paths which
41		#' are given will all work as is).
42		#'
43		#' If supported, when \code{visible_only} is \code{FALSE}, every
44		#' structural element of the table (in row-space) will be reflected in
45		#' the returned data.frame, meaning the full pathing-space will be
46		#' represented but some rows in the layout summary will not represent
47		#' printed rows in the table as it is displayed.
48		#'
49		#' Most arguments beyond \code{tt} and \code{visible_only} are present so that
50		#' `make_row_df` methods can call `make_row_df` recursively and retain information,
51		#' and should not be set during a top-level call
52		#'
53		#' @note the technically present root tree node is excluded from the summary returned by
54		#' both \code{make_row_df} and \code{make_col_df} (see `rtables::make_col_df`), as it is simply the
55		#' row/column structure of \code{tt} and thus not useful for pathing or pagination.
56		#' @return a data.frame of row/column-structure information used by the pagination machinery.
57		#'
58		#' @rdname make_row_df
59		#' @export
60		## nocov start
61		setGeneric("make_row_df", function(tt, colwidths = NULL, visible_only = TRUE,
62		rownum = 0,
63		indent = 0L,
64		path = character(),
65		incontent = FALSE,
66		repr_ext = 0L,
67		repr_inds = integer(),
68		sibpos = NA_integer_,
69		nsibs = NA_integer_,
70		max_width = NULL) {
71		standardGeneric("make_row_df")
72		})
73
74		#' @rdname make_row_df
75		setMethod("make_row_df", "MatrixPrintForm", function(tt, colwidths = NULL, visible_only = TRUE,
76		rownum = 0,
77		indent = 0L,
78		path = character(),
79		incontent = FALSE,
80		repr_ext = 0L,
81		repr_inds = integer(),
82		sibpos = NA_integer_,
83		nsibs = NA_integer_,
84		max_width = NULL) {
85		stop("make_row_df can be used only on {rtables} table objects, and not on `matrix_form`-",
86		"generated objects (MatrixPrintForm).")
87		})
88		## nocov end
89
90
91		#' Transform `rtable` to a list of matrices which can be used for outputting
92		#'
93		#' Although `rtables` are represented as a tree data structure when outputting the table to ASCII or HTML it is useful to
94		#' map the `rtable` to an in between state with the formatted cells in a matrix form.
95		#'
96		#' @param obj ANY. Object to be transformed into a ready-to-render form (a `MatrixPrintForm` object)
97		#' @param indent_rownames logical(1), if TRUE the column with the row names in the `strings` matrix of has indented row
98		#' names (strings pre-fixed)
99		#' @param expand_newlines logical(1). Should the matrix form generated
100		#' expand rows whose values contain newlines into multiple
101		#' 'physical' rows (as they will appear when rendered into
102		#' ASCII). Defaults to \code{TRUE}
103		#' @param indent_size numeric(1). Number of spaces to be used per level of indent (if supported by
104		#' the relevant method). Defaults to 2.
105		#' @export
106		#'
107		#' @details
108		#'
109		#' The strings in the return object are defined as follows: row labels are those determined by \code{summarize_rows} and
110		#' cell values are determined using \code{get_formatted_cells}.
111		#' (Column labels are calculated using a non-exported internal function.
112		#'
113		#' @return A `MatrixPrintForm` classed list with the following elements:
114		#' \describe{
115		#' \item{strings}{The content, as it should be printed, of the top-left material, column headers, row labels, and
116		#' cell values of \code{tt}}
117		#' \item{spans}{The column-span information for each print-string in the strings matrix}
118		#' \item{aligns}{The text alignment for each print-string in the strings matrix}
119		#' \item{display}{Whether each print-string in the strings matrix should be printed or not}.
120		#' \item{row_info}{the data.frame generated by \code{summarize_rows(tt)}}
121		#' }
122		#'
123		#' With an additional \code{nrow_header} attribute indicating the number of pseudo "rows" the
124		#' column structure defines.
125		setGeneric("matrix_form", function(obj,
126		indent_rownames = FALSE,
127		expand_newlines = TRUE,
128		indent_size = 2) {
129	155x	standardGeneric("matrix_form")
130		})
131
132
133		#' @rdname matrix_form
134		#' @export
135		setMethod("matrix_form", "MatrixPrintForm", function(obj,
136		indent_rownames = FALSE,
137		expand_newlines = TRUE,
138		indent_size = 2) {
139	155x	obj
140		})
141
142
143		## Generics for `toString` and helper functions
144
145
146		## this is where we will take word wrapping
147		## into account when it is added
148		##
149		## ALL calculations of vertical space for pagination
150		## purposes must go through nlines and divider_height!!!!!!!!
151
152		## this will be customizable someday. I have foreseen it (spooky noises)
153		#' Divider Height
154		#'
155		#' @param obj ANY. Object.
156		#' @return The height, in lines of text, of the divider between
157		#' header and body. Currently returns \code{1L} for the default method.
158		#' @export
159		#' @examples
160		#' divider_height(mtcars)
161	20x	setGeneric("divider_height", function(obj) standardGeneric("divider_height"))
162
163		#' @rdname divider_height
164		#' @export
165		setMethod(
166		"divider_height", "ANY",
167	20x	function(obj) 1L
168		)
169
170		#' Number of lines required to print a value
171		#' @param x ANY. The object to be printed
172		#' @param colwidths numeric. Column widths (if necessary).
173		#' @param max_width numeric(1). Width strings should be wrapped to
174		#' when determining how many lines they require.
175		#' @return A scalar numeric indicating the number of lines needed
176		#' to render the object \code{x}.
177		#' @export
178		setGeneric(
179		"nlines",
180	23433x	function(x, colwidths = NULL, max_width = NULL) standardGeneric("nlines")
181		)
182
183		## XXX beware. I think it is dangerous
184		#' @export
185		#' @rdname nlines
186		setMethod(
187		"nlines", "list",
188		function(x, colwidths, max_width) {
189	2x	if (length(x) == 0) {
190	1x	0L
191		} else {
192	1x	sum(unlist(vapply(x, nlines, NA_integer_,
193	1x	colwidths = colwidths,
194	1x	max_width = max_width
195		)))
196		}
197		}
198		)
199
200		#' @export
201		#' @rdname nlines
202		setMethod("nlines", "NULL", function(x, colwidths, max_width) 0L)
203
204		#' @export
205		#' @rdname nlines
206		setMethod("nlines", "character", function(x, colwidths, max_width) {
207	23430x	if (length(x) == 0) {
208	1x	return(0L)
209		}
210
211	23429x	sum(vapply(strsplit(x, "\n", fixed = TRUE),
212	23429x	function(xi, max_width) {
213	23435x	if (length(xi) == 0) {
214	111x	1L
215	23324x	} else if (length(max_width) == 0) { ## this happens with strsplit("", "\n")
216	23275x	length(xi)
217		} else {
218	49x	length(wrap_txt(xi, max_width))
219		}
220	23429x	}, 1L,
221	23429x	max_width = max_width
222		))
223		})
224
225
226
227		#' @title `toString`
228		#'
229		#' @description Transform a complex object into a string representation ready
230		#' to be printed or written to a plain-text file
231		#'
232		#' @param x ANY. Object to be prepared for rendering.
233		#' @param ... Passed to individual methods.
234		#' @rdname tostring
235		#' @export
236		setGeneric("toString", function(x, ...) standardGeneric("toString"))
237
238		## preserve S3 behavior
239		setMethod("toString", "ANY", base::toString) ## nocov
240
241		#' @title Print
242		#'
243		#' @description Print an R object. see \code{[base::print()]}
244		#' @inheritParams base::print
245		#' @rdname basemethods
246		setMethod("print", "ANY", base::print) ## nocov
247
248
249
250
251
252
253
254
255
256
257		## General/"universal" property `getter` and `setter` generics and stubs
258
259		#' @title Label, Name and Format accessor generics
260		#'
261		#' @description `Getters` and `setters` for basic, relatively universal attributes
262		#' of "table-like" objects"
263		#'
264		#' @name lab_name
265		#' @param obj ANY. The object.
266		#' @param value character(1)/FormatSpec. The new value of the attribute.
267		#' @return the name, format or label of \code{obj} for `getters`, or \code{obj} after modification
268		#' for setters.
269		#' @aliases obj_name
270		#' @export
271
272		## no exported methods so we do nocov
273		# nocov start
274		setGeneric("obj_name", function(obj) standardGeneric("obj_name"))
275
276
277		#' @rdname lab_name
278		#' @export
279		setGeneric("obj_name<-", function(obj, value) standardGeneric("obj_name<-"))
280		# nocov end
281
282		#' @seealso with_label
283		#' @rdname lab_name
284		#' @export
285	3x	setGeneric("obj_label", function(obj) standardGeneric("obj_label"))
286
287		#' @rdname lab_name
288		#' @param value character(1). The new label
289		#' @export
290	2x	setGeneric("obj_label<-", function(obj, value) standardGeneric("obj_label<-"))
291
292		#' @rdname lab_name
293		#' @exportMethod obj_label
294	3x	setMethod("obj_label", "ANY", function(obj) attr(obj, "label"))
295
296		#' @rdname lab_name
297		#' @exportMethod obj_label<-
298		setMethod(
299		"obj_label<-", "ANY",
300		function(obj, value) {
301	2x	attr(obj, "label") <- value
302	2x	obj
303		}
304		)
305
306		#' @rdname lab_name
307		#' @export
308	133x	setGeneric("obj_format", function(obj) standardGeneric("obj_format"))
309		## this covers rcell, etc
310		#' @rdname lab_name
311		#' @exportMethod obj_format
312	131x	setMethod("obj_format", "ANY", function(obj) attr(obj, "format", exact = TRUE))
313		#' @rdname lab_name
314		#' @export
315	2x	setMethod("obj_format", "fmt_config", function(obj) obj@format)
316
317		#' @export
318		#' @rdname lab_name
319	3x	setGeneric("obj_format<-", function(obj, value) standardGeneric("obj_format<-"))
320		## this covers rcell, etc
321		#' @exportMethod obj_format<-
322		#' @rdname lab_name
323		setMethod("obj_format<-", "ANY", function(obj, value) {
324	2x	attr(obj, "format") <- value
325	2x	obj
326		})
327		#' @rdname lab_name
328		#' @export
329		setMethod("obj_format<-", "fmt_config", function(obj, value) {
330	1x	obj@format <- value
331	1x	obj
332		})
333
334		#' @rdname lab_name
335		#' @export
336	3x	setGeneric("obj_na_str", function(obj) standardGeneric("obj_na_str"))
337		#' @rdname lab_name
338		#' @exportMethod obj_na_str
339	1x	setMethod("obj_na_str", "ANY", function(obj) attr(obj, "format_na_str", exact = TRUE))
340		#' @rdname lab_name
341		#' @export
342	2x	setMethod("obj_na_str", "fmt_config", function(obj) obj@format_na_str)
343
344		#' @rdname lab_name
345		#' @export
346	2x	setGeneric("obj_na_str<-", function(obj, value) standardGeneric("obj_na_str<-"))
347		#' @exportMethod obj_na_str<-
348		#' @rdname lab_name
349		setMethod("obj_na_str<-", "ANY", function(obj, value) {
350	1x	attr(obj, "format_na_str") <- value
351	1x	obj
352		})
353		#' @rdname lab_name
354		#' @export
355		setMethod("obj_na_str<-", "fmt_config", function(obj, value) {
356	1x	obj@format_na_str <- value
357	1x	obj
358		})
359
360		#' @rdname lab_name
361		#' @export
362	3x	setGeneric("obj_align", function(obj) standardGeneric("obj_align"))
363		#' @rdname lab_name
364		#' @exportMethod obj_align
365	1x	setMethod("obj_align", "ANY", function(obj) attr(obj, "align", exact = TRUE))
366		#' @rdname lab_name
367		#' @export
368	2x	setMethod("obj_align", "fmt_config", function(obj) obj@align)
369
370		#' @rdname lab_name
371		#' @export
372	2x	setGeneric("obj_align<-", function(obj, value) standardGeneric("obj_align<-"))
373		#' @exportMethod obj_align<-
374		#' @rdname lab_name
375		setMethod("obj_align<-", "ANY", function(obj, value) {
376	1x	attr(obj, "align") <- value
377	1x	obj
378		})
379		#' @rdname lab_name
380		#' @export
381		setMethod("obj_align<-", "fmt_config", function(obj, value) {
382	1x	obj@align <- value
383	1x	obj
384		})
385
386		#' General title/footer accessors
387		#'
388		#' @param obj ANY. Object to extract information from.
389		#' @export
390		#' @rdname title_footer
391		#' @return A character scalar (`main_title`), a character vector (`main_footer`), or
392		#' vector of length zero or more (`subtitles`, `page_titles`,
393		#' `prov_footer`) containing the relevant title/footer contents
394	92x	setGeneric("main_title", function(obj) standardGeneric("main_title"))
395
396		#' @export
397		#' @rdname title_footer
398		setMethod(
399		"main_title", "MatrixPrintForm",
400	92x	function(obj) obj$main_title
401		)
402
403		##' @rdname title_footer
404		##' @export
405	6x	setGeneric("main_title<-", function(obj, value) standardGeneric("main_title<-"))
406		##' @rdname title_footer
407		##' @export
408		setMethod(
409		"main_title<-", "MatrixPrintForm",
410		function(obj, value) {
411	6x	obj$main_title <- value
412	6x	obj
413		}
414		)
415
416
417
418		#' @export
419		#' @rdname title_footer
420		setGeneric("subtitles", function(obj) standardGeneric("subtitles")) ## nocov
421
422		#' @export
423		#' @rdname title_footer
424		setMethod(
425		"subtitles", "MatrixPrintForm",
426	93x	function(obj) obj$subtitles
427		)
428
429		##' @rdname title_footer
430		##' @export
431		setGeneric("subtitles<-", function(obj, value) standardGeneric("subtitles<-")) ## nocov
432
433		##' @rdname title_footer
434		##' @export
435		setMethod(
436		"subtitles<-", "MatrixPrintForm",
437		function(obj, value) {
438	5x	obj$subtitles <- value
439	5x	obj
440		}
441		)
442
443		#' @export
444		#' @rdname title_footer
445	109x	setGeneric("page_titles", function(obj) standardGeneric("page_titles"))
446
447		#' @export
448		#' @rdname title_footer
449		setMethod(
450		"page_titles", "MatrixPrintForm",
451	109x	function(obj) obj$page_titles
452		)
453		#' @rdname title_footer
454		#' @export
455	!	setMethod("page_titles", "ANY", function(obj) NULL)
456
457		##' @rdname title_footer
458		##' @export
459	2x	setGeneric("page_titles<-", function(obj, value) standardGeneric("page_titles<-"))
460
461		#' @export
462		#' @rdname title_footer
463		setMethod(
464		"page_titles<-", "MatrixPrintForm",
465		function(obj, value) {
466	2x	if (!is.character(value)) {
467	!	stop("page titles must be in the form of a character vector, got object of class ", class(value))
468		}
469	2x	obj$page_titles <- value
470	2x	obj
471		}
472		)
473
474
475
476		#' @export
477		#' @rdname title_footer
478	87x	setGeneric("main_footer", function(obj) standardGeneric("main_footer"))
479
480		#' @export
481		#' @rdname title_footer
482		setMethod(
483		"main_footer", "MatrixPrintForm",
484	87x	function(obj) obj$main_footer
485		)
486
487		#' @rdname title_footer
488		#' @param value character. New value.
489		#' @export
490	6x	setGeneric("main_footer<-", function(obj, value) standardGeneric("main_footer<-"))
491
492
493
494		#' @export
495		#' @rdname title_footer
496		setMethod(
497		"main_footer<-", "MatrixPrintForm",
498		function(obj, value) {
499	6x	if (!is.character(value)) {
500	!	stop("main footer must be a character vector. Got object of class ", class(value))
501		}
502	6x	obj$main_footer <- value
503	6x	obj
504		}
505		)
506
507
508		#' @export
509		#' @rdname title_footer
510	97x	setGeneric("prov_footer", function(obj) standardGeneric("prov_footer"))
511
512		#' @export
513		#' @rdname title_footer
514		setMethod(
515		"prov_footer", "MatrixPrintForm",
516	97x	function(obj) obj$prov_footer
517		)
518
519		#' @rdname title_footer
520		#' @export
521	7x	setGeneric("prov_footer<-", function(obj, value) standardGeneric("prov_footer<-"))
522
523		#' @export
524		#' @rdname title_footer
525		setMethod(
526		"prov_footer<-", "MatrixPrintForm",
527		function(obj, value) {
528	7x	if (!is.character(value)) {
529	!	stop("provenance footer must be a character vector. Got object of class ", class(value))
530		}
531	7x	obj$prov_footer <- value
532	7x	obj
533		}
534		)
535
536
537
538
539		#' @rdname title_footer
540		#' @export
541	1x	all_footers <- function(obj) c(main_footer(obj), prov_footer(obj))
542
543		#' @rdname title_footer
544		#' @export
545	90x	all_titles <- function(obj) c(main_title(obj), subtitles(obj), page_titles(obj))
546
547
548		#' Access or (recursively) set table inset.
549		#'
550		#' Table inset is the amount of characters that the body of
551		#' a table, referential footnotes, and main footer material
552		#' are inset from the left-alignment of the titles and provenance
553		#' footer materials.
554		#'
555		#' @param obj ANY. Object to get or (recursively if necessary) set
556		#' table inset for.
557		#' @param value character(1). String to use as new header/body separator.
558		#'
559		#' @return for `table_inset` the integer value that the table body
560		#' (including column heading information and section dividers),
561		#' referential footnotes, and main footer should be inset from the
562		#' left alignment of the titles and provenance footers during rendering.
563		#' For `table_inset<-`, the `obj`, with the new table_inset value
564		#' applied recursively to it and all its subtables.
565		#'
566		#' @export
567	193x	setGeneric("table_inset", function(obj) standardGeneric("table_inset"))
568
569		#' @rdname table_inset
570		#' @export
571		setMethod(
572		"table_inset", "MatrixPrintForm",
573	193x	function(obj) obj$table_inset
574		)
575
576
577		#' @rdname table_inset
578		#' @export
579	4x	setGeneric("table_inset<-", function(obj, value) standardGeneric("table_inset<-"))
580
581		#' @rdname table_inset
582		#' @export
583		setMethod(
584		"table_inset<-", "MatrixPrintForm",
585		function(obj, value) {
586	4x	newval <- as.integer(value)
587	4x	if (is.na(newval) \|\| newval < 0) {
588	1x	stop("Got invalid value for table_inset: ", newval)
589		}
590	3x	obj$table_inset <- newval
591	3x	obj
592		}
593		)
594
595
596
597
598		#' Generic for Performing "Forced Pagination"
599		#'
600		#' Forced pagination is pagination which happens regardless of
601		#' position on page. The object is expected to have all information
602		#' necessary to locate such page breaks, and the `do_forced_pag`
603		#' method is expected to fully perform those paginations.
604		#'
605		#' @param obj The object to be paginated.
606		#'
607		#' The `ANY` method simply returns a list of length one, containing
608		#' `obj`.
609		#'
610		#' @return a list of subobjects, which will be further paginated
611		#' by the standard pagination algorithm.
612		#'
613		#'
614		#' @export
615	46x	setGeneric("do_forced_paginate", function(obj) standardGeneric("do_forced_paginate"))
616
617		#' @export
618		#' @rdname do_forced_paginate
619	43x	setMethod("do_forced_paginate", "ANY", function(obj) list(obj))
620
621		#' Number of repeated columns
622		#'
623		#' When called on a table-like object using the formatters framework,
624		#' this method should return the number of columns which are mandatorily
625		#' repeated after each horizontal pagination.
626		#'
627		#' Absent a class-specific method, this function returns 0, indicating
628		#' no always-repeated columns.
629		#'
630		#' @param obj ANY. A table-like object.
631		#' @note This number \emph{does not include row labels}, the repetition
632		#' of which is handled separately.
633		#'
634		#' @return an integer.
635		#' @export
636		#' @examples
637		#' mpf <- basic_matrix_form(mtcars)
638		#' num_rep_cols(mpf)
639	25x	setGeneric("num_rep_cols", function(obj) standardGeneric("num_rep_cols"))
640		#' @export
641		#' @rdname num_rep_cols
642	25x	setMethod("num_rep_cols", "ANY", function(obj) 0L)

1		.need_pag <- function(page_type, pg_width, pg_height, cpp, lpp) {
2	!	!(is.null(page_type) && is.null(pg_width) && is.null(pg_height) && is.null(cpp) && is.null(lpp))
3
4		}
5
6		#' Export a table-like object to plain (ASCII) text with page break
7		#'
8		#' This function converts \code{x} to a \code{MatrixPrintForm} object via
9		#' \code{matrix_form}, paginates it via \code{paginate}, converts each
10		#' page to ASCII text via \code{toString}, and emits the strings to \code{file},
11		#' separated by \code{page_break}.
12		#'
13		#' @inheritParams paginate_indices
14		#' @inheritParams toString
15		#' @inheritParams propose_column_widths
16		#' @param x ANY. The table-like object to export. Must have an
17		#' applicable \code{matrix_form} method.
18		#' @param file character(1) or NULL. If non-NULL, the path to write a
19		#' text file to containing the \code{x} rendered as ASCII text,
20		#' @param page_break character(1). Page break symbol (defaults to
21		#' outputting \code{"\\n\\s"}).
22		#' @param paginate logical(1). Whether pagination should be performed,
23		#' defaults to \code{TRUE} if page size is specified (including
24		#' the default).
25		#' @details if \code{x} has an \code{num_rep_cols} method, the value
26		#' returned by it will be used for \code{rep_cols} by default, if
27		#' not, 0 will be used.
28		#'
29		#' If \code{x} has an applicable \code{do_mand_paginate} method, it will be invoked
30		#' during the pagination process.
31		#'
32		#' @return if \code{file} is NULL, the total paginated and then concatenated
33		#' string value, otherwise the file that was written.
34		#' @export
35		#' @examples
36		#' export_as_txt(basic_matrix_form(mtcars), pg_height = 5, pg_width = 4)
37
38		export_as_txt <- function(x,
39		file = NULL,
40		page_type = NULL,
41		landscape = FALSE,
42		pg_width = page_dim(page_type)[if(landscape) 2 else 1],
43		pg_height = page_dim(page_type)[if(landscape) 1 else 2],
44		font_family = "Courier",
45		font_size = 8, # grid parameters
46		lineheight = 1L,
47		margins = c(top = .5, bottom = .5, left = .75, right = .75),
48		paginate = TRUE,
49		cpp = NA_integer_,
50		lpp = NA_integer_,
51		...,
52		hsep = default_hsep(),
53		indent_size = 2,
54		tf_wrap = paginate,
55		max_width = NULL,
56		colwidths = NULL,
57		min_siblings = 2,
58		nosplitin = character(),
59		rep_cols = num_rep_cols(x),
60		verbose = FALSE,
61		page_break = "\\s\\n") {
62
63	3x	if(paginate) {
64	3x	pages <- paginate_to_mpfs(x,
65	3x	page_type = page_type,
66	3x	font_family = font_family,
67	3x	font_size = font_size,
68	3x	lineheight = lineheight,
69	3x	landscape = landscape,
70	3x	pg_width = pg_width,
71	3x	pg_height = pg_height,
72	3x	margins = margins,
73	3x	lpp = lpp,
74	3x	cpp = cpp,
75	3x	min_siblings = min_siblings,
76	3x	nosplitin = nosplitin,
77	3x	colwidths = colwidths,
78	3x	tf_wrap = tf_wrap,
79	3x	max_width = max_width,
80	3x	indent_size = indent_size,
81	3x	verbose = verbose,
82	3x	rep_cols = rep_cols)
83		} else {
84	!	mf <- matrix_form(x, TRUE, TRUE, indent_size = indent_size)
85	!	mf_col_widths(mf) <- colwidths %\|\|% propose_column_widths(mf)
86	!	pages <- list(mf)
87		}
88		## we dont' set widths here because we already but that info on mpf
89		## so its on each of the pages.
90	3x	strings <- vapply(pages, toString, "", widths = NULL,
91	3x	hsep = hsep, tf_wrap = tf_wrap, max_width = max_width)
92	3x	res <- paste(strings, collapse = page_break)
93
94	3x	if(is.null(file))
95	1x	res
96		else
97	2x	cat(res, file = file)
98		}
99
100
101
102		## ## TODO this needs to be in terms of a MPF, so ncol(tt) needs to change
103
104		## ## if(!is.null(colwidths) && length(colwidths) != ncol(tt) + 1)
105		## ## stop("non-null colwidths argument must have length ncol(tt) + 1 [",
106		## ## ncol(tt) + 1, "], got length ", length(colwidths))
107
108		## mpf <- matrix_form(x, indent_rownames = TRUE)
109
110		## ps_spec <- calc_lcpp(page_type = page_type,
111		## landscape = landscape,
112		## pg_width = pg_width,
113		## pg_height = pg_height,
114		## font_family = font_family,
115		## cpp = cpp,
116		## lpp = lpp)
117
118		## ## This needs to return list(x) in cases where no pagination was necessary
119		## idx_lst <- paginate(mpf, .page_size_spec = ps_spec, colwidths = colwidths,
120		## tf_wrap = tf_wrap, ## XXX I think we don't need this
121		## ...)
122
123		## tbls <- lapply(idx_lst, function(ii)
124		## ## XXX how do we partition the colwidths ???
125		## ## Also this is gross make it a function!!!
126		## res <- paste(mapply(function(tb, cwidths, ...) {
127		## ## 1 and +1 are because cwidths includes rowlabel 'column'
128		## cinds <- c(1, .figure_out_colinds(tb, tt) + 1L)
129		## toString(tb, widths = cwidths[cinds], ...)
130		## },
131		## MoreArgs = list(hsep = hsep,
132		## indent_size = indent_size,
133		## tf_wrap = tf_wrap,
134		## max_width = max_width,
135		## cwidths = colwidths),
136		## SIMPLIFY = FALSE,
137		## tb = tbls),
138		## collapse = page_break)
139
140		## if(!is.null(file))
141		## cat(res, file = file)
142		## else
143		## res
144		## }
145
146
147
148
149		## In use, must be tested
150		prep_header_line <- function(mf, i) {
151	2x	ret <- mf$strings[i, mf$display[i, , drop = TRUE], drop = TRUE]
152	2x	ret
153		}
154
155		## margin_lines_to_in <- function(margins, font_size, font_family) {
156		## tmpfile <- tempfile(fileext = ".pdf")
157		## gp_plot <- gpar(fontsize = font_size, fontfamily = font_family)
158		## pdf(file = tmpfile, width = 20, height = 20)
159		## on.exit({
160		## dev.off()
161		## file.remove(tmpfile)
162		## })
163		## grid.newpage()
164		## pushViewport(plotViewport(margins = margins, gp = gp_plot))
165		## c(
166		## bottom = convertHeight(unit(margins["bottom"], "lines"), "inches", valueOnly = TRUE),
167		## left = convertWidth(unit(1, "strwidth", strrep("m", margins["left"])), "inches", valueOnly = TRUE),
168		## top = convertHeight(unit(margins["top"], "lines"), "inches", valueOnly = TRUE),
169		## right = convertWidth(unit(1, "strwidth", strrep("m", margins["right"])), "inches", valueOnly = TRUE)
170		## )
171		## }
172
173
174
175
176		mpf_to_dfbody <- function(mpf, colwidths) {
177	2x	mf <- matrix_form(mpf, indent_rownames = TRUE)
178	2x	nlr <- mf_nlheader(mf)
179	2x	if (is.null(colwidths)) {
180	!	colwidths <- propose_column_widths(mf)
181		}
182	2x	mf$strings[1:nlr, 1] <- ifelse(nzchar(mf$strings[1:nlr, 1, drop = TRUE]),
183	2x	mf$strings[1:nlr, 1, drop = TRUE],
184	2x	strrep(" ", colwidths)
185		)
186
187
188	2x	myfakedf <- as.data.frame(tail(mf$strings, -nlr))
189	2x	myfakedf
190		}
191
192
193		#' Transform `MPF` to `RTF`
194		#'
195		#' Experimental export to `RTF` via the `r2rtf` package
196		#'
197		#' @inheritParams page_lcpp
198		#' @inheritParams toString
199		#' @inheritParams grid::plotViewport
200		#' @param mpf `MatrixPrintForm`. `MatrixPrintForm` object.
201		#' @param colwidths character(1). Column widths.
202		#' @details This function provides a low-level coercion of a
203		#' `MatrixPrintForm` object into text containing the corresponding
204		#' table in `RTF`. Currently, no pagination is done at this level,
205		#' and should be done prior to calling this function, though that
206		#' may change in the future.
207		#'
208		#' @return An `RTF` object
209		#' @export
210		mpf_to_rtf <- function(mpf,
211		colwidths = NULL,
212		page_type = "letter",
213		pg_width = page_dim(page_type)[if (landscape) 2 else 1],
214		pg_height = page_dim(page_type)[if (landscape) 1 else 2],
215		landscape = FALSE,
216		margins = c(4, 4, 4, 4),
217		font_size = 8,
218		...) {
219	2x	if (!requireNamespace("r2rtf")) {
220	!	stop("RTF export requires the 'r2rtf' package, please install it.")
221		}
222	2x	mpf <- matrix_form(mpf, indent_rownames = TRUE)
223	2x	nlr <- mf_nlheader(mpf)
224	2x	if (is.null(colwidths)) {
225	!	colwidths <- propose_column_widths(mpf)
226		}
227	2x	mpf$strings[1:nlr, 1] <- ifelse(nzchar(mpf$strings[1:nlr, 1, drop = TRUE]),
228	2x	mpf$strings[1:nlr, 1, drop = TRUE],
229	2x	strrep(" ", colwidths)
230		)
231
232	2x	myfakedf <- mpf_to_dfbody(mpf, colwidths)
233
234	2x	rtfpg <- r2rtf::rtf_page(myfakedf,
235	2x	width = pg_width,
236	2x	height = pg_height,
237	2x	orientation = if (landscape) "landscape" else "portrait",
238	2x	margin = c(0.1, 0.1, 0.1, 0.1, 0.1, 0.1),
239	2x	nrow = 10000L
240	2x	) ## dont allow r2rtf to restrict lines per page beyond actual real eastate
241	2x	rtfpg <- r2rtf::rtf_title(rtfpg, main_title(mpf), subtitles(mpf), text_font = 1)
242	2x	for (i in seq_len(nlr)) {
243	2x	hdrlndat <- prep_header_line(mpf, i)
244	2x	rtfpg <- r2rtf::rtf_colheader(rtfpg,
245	2x	paste(hdrlndat, collapse = " \| "),
246	2x	col_rel_width = unlist(tapply(colwidths,
247	2x	cumsum(mpf$display[i, , drop = TRUE]),
248	2x	sum,
249	2x	simplify = FALSE
250		)),
251	2x	border_top = c("", rep(if (i > 1) "single" else "", length(hdrlndat) - 1)),
252	2x	text_font = 9, ## this means Courier New for some insane reason
253	2x	text_font_size = font_size
254		)
255		}
256
257	2x	rtfpg <- r2rtf::rtf_body(rtfpg,
258	2x	col_rel_width = colwidths,
259	2x	text_justification = c("l", rep("c", ncol(myfakedf) - 1)),
260	2x	text_format = "",
261	2x	text_font = 9,
262	2x	text_font_size = font_size
263		)
264
265	2x	for (i in seq_along(mpf$ref_footnotes)) {
266	4x	rtfpg <- r2rtf::rtf_footnote(rtfpg,
267	4x	mpf$ref_footnotes[i],
268	4x	border_top = if (i == 1) "single" else "",
269	4x	border_bottom = if (i == length(mpf$ref_footnotes)) "single" else "",
270	4x	text_font = 9
271		)
272		}
273
274	2x	if (length(main_footer(mpf)) > 0) {
275	2x	rtfpg <- r2rtf::rtf_footnote(rtfpg, main_footer(mpf), text_font = 9)
276		}
277	2x	if (length(prov_footer(mpf)) > 0) {
278	2x	rtfpg <- r2rtf::rtf_source(rtfpg, prov_footer(mpf), text_font = 9)
279		}
280
281	2x	rtfpg
282		}
283
284		## Not currently in use, previous alternate ways to get to RTF
285
286		## ## XXX Experimental. Not to be exported without approval
287		## mpf_to_huxtable <- function(obj) {
288		## if (!requireNamespace("huxtable")) {
289		## stop("mpf_to_huxtable requires the huxtable package")
290		## }
291		## mf <- matrix_form(obj, indent_rownames = TRUE)
292		## nlr <- mf_nlheader(mf)
293		## myfakedf <- as.data.frame(tail(mf$strings, -nlr))
294		## ret <- huxtable::as_hux(myfakedf, add_colnames = FALSE)
295		## mf$strings[!mf$display] <- ""
296		## for (i in seq_len(nlr)) {
297		## arglist <- c(
298		## list(ht = ret, after = i - 1),
299		## as.list(mf$strings[i, ])
300		## )
301		## ret <- do.call(huxtable::insert_row, arglist)
302
303		## spanspl <- split(
304		## seq_len(ncol(mf$strings)),
305		## cumsum(mf$display[i, ])
306		## )
307
308
309		## for (j in seq_along(spanspl)) {
310		## if (length(spanspl[[j]]) > 1) {
311		## ret <- huxtable::merge_cells(ret, row = i, col = spanspl[[j]])
312		## }
313		## }
314		## }
315		## ret <- huxtable::set_header_rows(ret, seq_len(nlr), TRUE)
316		## huxtable::font(ret) <- "courier"
317		## huxtable::font_size(ret) <- 6
318		## huxtable::align(ret)[
319		## seq_len(nrow(ret)),
320		## seq_len(ncol(ret))
321		## ] <- mf$aligns
322		## ret
323		## }
324
325		## ## XXX Experimental. Not to be exported without approval
326		## mpf_to_rtf <- function(obj, ..., file) {
327		## huxt <- mpf_to_huxtable(obj)
328		## ## a bunch more stuff here
329		## huxtable::quick_rtf(huxt, ..., file = file)
330		## }
331
332
333
334
335		## ## XXX Experimental. Not to be exported without approval
336		## mpf_to_gt <- function(obj) {
337		## requireNamespace("gt")
338		## mf <- matrix_form(obj, indent_rownames = TRUE)
339		## nlh <- mf_nlheader(mf)
340		## body_df <- as.data.frame(mf$strings[-1 * seq_len(nlh), ])
341		## varnamerow <- mf_nrheader(mf)
342		## ## detect if we have counts
343		## if (any(nzchar(mf$formats[seq_len(nlh), ]))) {
344		## varnamerow <- varnamerow - 1
345		## }
346
347		## rlbl_lst <- as.list(mf$strings[nlh, , drop = TRUE])
348		## names(rlbl_lst) <- names(body_df)
349
350		## ret <- gt::gt(body_df, rowname_col = "V1")
351		## ret <- gt::cols_label(ret, .list = rlbl_lst)
352		## if (nlh > 1) {
353		## for (i in 1:(nlh - 1)) {
354		## linedat <- mf$strings[i, , drop = TRUE]
355		## splvec <- cumsum(mf$display[i, , drop = TRUE])
356		## spl <- split(seq_along(linedat), splvec)
357		## for (j in seq_along(spl)) {
358		## vns <- names(body_df)[spl[[j]]]
359		## labval <- linedat[spl[[j]][1]]
360		## ret <- gt::tab_spanner(ret,
361		## label = labval,
362		## columns = {{ vns }},
363		## level = nlh - i,
364		## id = paste0(labval, j)
365		## )
366		## }
367		## }
368		## }
369
370		## ret <- gt::opt_css(ret, css = "th.gt_left { white-space:pre;}")
371
372		## ret
373		## }
374
375
376
377		#' Export table to `RTF`
378		#'
379		#' Experimental export to the `RTF` format.
380		#'
381		#' @details `RTF` export occurs by via the following steps
382		#'
383		#' \itemize{
384		#' \item{the table is paginated to the page size (Vertically and horizontally)}
385		#' \item{Each separate page is converted to a `MatrixPrintForm` and from there to `RTF`-encoded text}
386		#' \item{Separate `RTFs` text chunks are combined and written out as a single `RTF` file}
387		#' }
388		#'
389		#' Conversion of `MatrixPrintForm` objects to `RTF` is done via [formatters::mpf_to_rtf()].
390		#' @inheritParams export_as_txt
391		#' @inheritParams toString
392		#' @inheritParams grid::plotViewport
393		#' @inheritParams paginate_to_mpfs
394		#' @export
395
396		export_as_rtf <- function(x,
397		file = NULL,
398		colwidths = propose_column_widths(matrix_form(x, TRUE)),
399		page_type = "letter",
400		pg_width = page_dim(page_type)[if(landscape) 2 else 1],
401		pg_height = page_dim(page_type)[if(landscape) 1 else 2],
402		landscape = FALSE,
403		margins = c(bottom = .5, left = .75, top=.5, right = .75),
404		font_size = 8,
405		font_family = "Courier",
406		...) {
407	1x	if(!requireNamespace("r2rtf"))
408	!	stop("RTF export requires the r2rtf package, please install it.")
409	1x	if(is.null(names(margins)))
410	!	names(margins) <- marg_order
411
412	1x	fullmf <- matrix_form(x, indent_rownames = TRUE)
413	1x	req_ncols <- ncol(fullmf) + as.numeric(mf_has_rlabels(fullmf))
414	1x	if(!is.null(colwidths) && length(colwidths) != req_ncols)
415	!	stop("non-null colwidths argument must have length ncol(x) (+ 1 if row labels are present) [",
416	!	req_ncols, "], got length ", length(colwidths))
417
418	1x	true_width <- pg_width - sum(margins[c("left", "right")])
419	1x	true_height <- pg_height - sum(margins[c("top", "bottom")])
420
421	1x	mpfs <- paginate_to_mpfs(fullmf, font_family = font_family, font_size = font_size,
422	1x	pg_width = true_width,
423	1x	pg_height = true_height,
424	1x	margins = c(bottom = 0, left = 0, top = 0, right = 0),
425	1x	lineheight = 1.25,
426	1x	colwidths = colwidths,
427		...)
428
429	1x	rtftxts <- lapply(mpfs, function(mf) r2rtf::rtf_encode(mpf_to_rtf(mf,
430	1x	colwidths = mf_col_widths(mf),
431	1x	page_type = page_type,
432	1x	pg_width = pg_width,
433	1x	pg_height = pg_height,
434	1x	font_size = font_size,
435	1x	margins = c(top = 0, left = 0, bottom = 0, right = 0))))
436	1x	restxt <- paste(rtftxts[[1]]$start,
437	1x	paste(sapply(rtftxts, function(x) x$body), collapse = "\n{\\pard\\fs2\\par}\\page{\\pard\\fs2\\par}\n"),
438	1x	rtftxts[[1]]$end)
439	1x	if(!is.null(file))
440	1x	cat(restxt, file = file)
441		else
442	!	restxt
443		}

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

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

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

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