formatters coverage - 94.50%

Files
Source

## #' 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) {
  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) {
    stop("Unable to find any valid pagination between ", start, " and ", origuess)
  }
  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) && 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)

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

## 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)
  # nlines detects if there is a newline character
  row_nlines <- apply(strmat, 1, function(x) max(vapply(x, nlines, 1L), 1L))
  nr_header <- mf_nrheader(matform)

  # There is something to change
  if (any(row_nlines > 1)) {
    # Header indices
    hdr_inds <- 1:nr_header
    ## groundwork for sad haxx to get tl to not be messed up
    if (has_topleft) {
        tl <- strmat[hdr_inds, 1]
        strmat[hdr_inds, 1] <- ""
        ## recalc them without topleft cause thats handled separately
        row_nlines <- apply(strmat, 1, function(x) max(vapply(x, nlines, 1L), 1L))
    } else {
      tl <- character()
    }
    ## used below even though we don't store it on the resulting object
    new_nlines_hdr <- sum(row_nlines[hdr_inds])
    newstrmat <- rbind(
      expand_mat_rows(strmat[hdr_inds, , drop = FALSE],
        row_nlines[hdr_inds],
        cpadder = pad_vert_bottom
      ),
      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])
    )
    ## sad haxx :(
    if (has_topleft) {
      newtl <- unlist(strsplit(tl, "\n"))
      if (length(newtl) > new_nlines_hdr) {
        stop("Expanding top-left material resulted in more lines (", length(newtl), # nocov
             "than fit in the header.") # nocov
      }
      newstrmat[1:new_nlines_hdr, 1] <- c(newtl, rep("", new_nlines_hdr - length(newtl)))
      newfrmmat[1:new_nlines_hdr, 1] <- "xx"
    }
    mf_strings(matform) <- newstrmat
    mf_formats(matform) <- newfrmmat
    mf_spans(matform) <- expand_mat_rows(mf_spans(matform), row_nlines, rep_vec_to_len)
    mf_aligns(matform) <- expand_mat_rows(mf_aligns(matform), 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(mf_lgrouping(matform), times = row_nlines)
  }

  matform
}

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
}

### 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 and column layout summary data.frames for use during pagination
#' @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}, as it is simply the
#' row/column structure of \code{tt} and thus not useful for pathing or pagination.
#' @export
#' @return a data.frame of row/column-structure information used by the pagination machinery.
#' @rdname make_row_df
#'
## 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")
})
## 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`, `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)

# `toString` ----

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



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)
    ## wrap_string calls strwrap, which destroys whitespace so we need to make
    ## sure to put the indents back in

    ## See if indentation is properly set
    ind_from_mf <- mf_rinfo(mat)$indent > 0
    nlh <- mf_nlheader(mat)
    ind_std <- paste0(rep(" ", mat$indent_size), collapse = "")
    ## Body indentation
    old_indent <- sapply(mf_rinfo(mat)$indent, function(i) paste0(rep(ind_std, i), collapse = ""))
    ## Header indentation (it happens with toplefts, not \n in titles, dealt afterwards)
    ## NB: what about \n in topleft? -> not supported
    header_indent <- gsub("^([[:space:]]*).*", "\\1", mat$strings[1:nlh, 1]) # Supposedly never with empty strings " "
    old_indent <- c(header_indent, old_indent)
    need_reindent <- nzchar(old_indent)
    ## Check for which row has indent
    ind_from_strings <- nchar(old_indent)[-seq_len(nlh)] > 0
    if (!all(ind_from_strings == ind_from_mf)) {
        stop("Row-info and string indentations are different.", # nocov
             " Please contact the maintainer, this should not happen.") # nocov
    }
    ori_mflg <- mf_lgrouping(mat) # Original groups
    reindent_old_idx <- ori_mflg[need_reindent] # Indent groups bf wrap

    ## Taking care in advance of indented word wrappings
    cell_widths_mat[need_reindent, 1] <- cell_widths_mat[need_reindent, 1] - nchar(old_indent)[need_reindent]

    ## Case in which the indentation is taking too much space vs desired wrapping
    if (any(cell_widths_mat < 0)) {
        col_culprits <- apply(cell_widths_mat, 2, function(i) any(i < 0))
        stop(
            "Inserted width(s) for column(s) ", which(col_culprits),
            " is(are) not wide enough for the desired indentation."
        )
    }

    new_strings <- matrix(
        unlist(mapply(wrap_string,
                      str = mat$strings,
                      max_width = cell_widths_mat,
                      hard = TRUE
                      )),
        ncol = ncol(mat$strings)
    )
    mat$strings <- new_strings

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

    ## Indent groups after newline
    reindent_new_idx <- mf_lgrouping(mat) %in% reindent_old_idx
    if (anyNA(reindent_new_idx)) {
        stop("Unable to remap indenting after cell content text wrapping. ", # nocov
             "Please contact the maintainer, this should not happen.") # nocov
    }

    ## Adding the indentation back in
    ind_v <- NULL
    for (i in mf_lgrouping(mat)[reindent_new_idx]) {
        ind_v <- c(ind_v, which(i == ori_mflg)[1])
    }
    new_indent <- old_indent[ind_v]

    ## Additional safety check
    if (length(new_indent) > 0 && !all(nzchar(new_indent))) {
        stop("Recovered indentation contains empty strings. This is an", # nocov
             " indexing problem, please contact the maintainer, this should not happen.") # nocov
    }

    ## Indentation is different for topleft material
    if (isTRUE(mf_has_topleft(mat))) {
        ## mf_nlheader counts actual header lines while mf_nrheader is 'virtual'
        ## A bit of an hack, but unforeseen behavior, related to \n in topleft is not supported
        ## Therefore, this still suppose that we dealt with \n in the cols before
        indx_topleft <- which(reindent_new_idx[1:nlh])
        new_indent[seq_along(indx_topleft)] <- old_indent[indx_topleft]
    }

    ## Main addition of the 'saved' indentation to strings
    mf_strings(mat)[reindent_new_idx, 1] <- paste0(
        new_indent,
        mat$strings[reindent_new_idx, 1]
    )
    ## this updates extents in rinfo AND nlines in ref_fnotes_df
    mat <- update_mf_nlines(mat, max_width = max_width)
    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) {
    sdiff <- setdiff(vec, list_valid_aligns())
    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])
        ## If no values are to be decimal aligned in the column (according
        ##  to the aligns matrix), or there are no numerical values, strings
        ##  remain as is
        ## if (sum(align_col_i) == 0 ||
        ##     all(grepl("^[0-9]\\.", col_i))) {
        ##     string_mat[, i] <- string_mat[, i]
        ## }

        ## !( A || B) -> !A && !B  DeMorgan's Law
        ## Values to be decimal aligned
        if (any(align_col_i) &&
            ## I do not understand this condition what is it doing???
            ## I guess the assumption is this means they are already decimal aligned?
            ## not sure that's true with padding... ~GB
            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)
            ## Why not? grepl("[a-zA-Z]", col_i) # This excludes N=xx, e.g.
            nonalign <- nas | nonnum | !align_col_i
            ## Do decimal alignment
            if (length(col_i[!nonalign]) > 0) {
                ## Count the number of numbers in the string
                matches <- gregexpr("\\d+\\.\\d+|\\d+", col_i[!nonalign])
                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_i[!nonalign][more_than_one][seq(1, 3)],
                                collapse = "', '"), "'")
                }
                ## General split (only one match -> the first)
                main_regexp <- regexpr("\\d+", col_i[!nonalign])
                left <- regmatches(col_i[!nonalign], main_regexp, invert = FALSE)
                right <- regmatches(col_i[!nonalign], main_regexp, invert = TRUE)
                right <- sapply(right, "[[", 2)
                something_left <- sapply(strsplit(col_i[!nonalign], "\\d+"), "[[", 1)
                left <- paste0(something_left, left)
                if (!checkmate::test_set_equal(paste0(left, right), col_i[!nonalign]))
                    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
}

#' @rdname tostring
#'
#' @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.
#'
#' @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`
#'
#' @exportMethod toString
setMethod("toString", "MatrixPrintForm", function(x,
                                                  widths = NULL,
                                                  tf_wrap = FALSE,
                                                  max_width = NULL,
                                                  col_gap = mf_colgap(x),
                                                  hsep = default_hsep()) {
    assert_flag(tf_wrap)

    mat <- matrix_form(x, indent_rownames = TRUE)
    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."
          )
        }
      }
    }

    if (is.null(widths)) {
        widths <- mf_col_widths(x) %||% propose_column_widths(x)
    } else {
        mf_col_widths(x) <- widths
    }
    ncchar <- sum(widths) + (length(widths) - 1) * col_gap

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

    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 <- matrix(mapply(padstr, body, cell_widths_mat, aligns), ncol = ncol(body))
    content[!keep_mat] <- NA
                                        # apply(content, 1, function(x) sum(nchar(x), na.rm = TRUE))

    gap_str <- strrep(" ", col_gap)

    div <- substr(strrep(hsep, ncchar), 1, ncchar)
    txt_head <- apply(head(content, nl_header), 1, .paste_no_na, collapse = gap_str)
    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 {
        txt_body <- apply(tail(content, -nl_header), 1, .paste_no_na, collapse = gap_str)
    }


    allts <- all_titles(x)

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

    paste0(paste(
        c(
            titles_txt,
            .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 maximum width
#' @param str character(1). String to be wrapped
#' @param max_width numeric(1). Maximum width, in characters, that the
#' text should be wrapped at.
#' @param hard logical(1). Should hard wrapping (embedding newlines in
#' the incoming strings) or soft (breaking wrapped strings into vectors
#' of length >1) be used. Defaults to `FALSE` (i.e. soft wrapping).
#'
#' @details Word wrapping happens as with \link[base:strwrap]{base::strwrap}
#'   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 (`wrap_string` or character vector (`wrap_txt`) containing
#'   the hard or soft word-wrapped content.
#'
#' @export
wrap_string <- function(str, max_width, hard = FALSE) {
  stopifnot(is.character(str) && length(str) == 1)
  naive <- strwrap(str, max_width + 1)
  while (any(nchar(naive) > max_width)) {
    good <- character()
    bwi <- which(nchar(naive) > max_width)[1]
    curbw <- naive[bwi]
    if (bwi > 2) {
      good <- c(good, naive[1:(bwi - 2)])
    }
    if (bwi > 1) {
      str_before <- naive[bwi - 1]
    } else {
      str_before <- ""
    }
    room <- max_width - nchar(str_before) - (bwi > 1)
    if (room <= 0) {
      toadd <- c(str_before, substr(curbw, 1, max_width))
      room <- 0
      leftover <- substr(curbw, max_width + 1, nchar(curbw))
    } else {
      goodpart <- substr(curbw, 1, room)
      if (nzchar(str_before)) {
        toadd <- paste(str_before, goodpart)
      } else {
        toadd <- goodpart
      }
      leftover <- substr(curbw, room + 1, nchar(curbw))
    }
    good <- c(good, toadd)
    if (bwi == length(naive)) {
      good <- c(good, leftover)
    } else {
      good <- c(
        good,
        paste(leftover, naive[bwi + 1]),
        if (bwi < length(naive) - 1) naive[seq(bwi + 2, length(naive))]
      )
    }
    str <- paste(good, collapse = " ")
    naive <- strwrap(str, max_width + 1)
  }
  if (hard) {
    naive <- paste(naive, collapse = "\n")
  }
  naive
}

#' @param txt character. A vector of strings that should be (independently)
#' text-wrapped.
#' @rdname wrap_string
#' @export
wrap_txt <- function(txt, max_width, hard = FALSE) {
  unlist(lapply(txt, wrap_string, max_width = max_width, hard = hard), use.names = FALSE)
}

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

pad_vert_bottom <- function(x, len) {
  c(rep("", 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
}


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

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

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

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		## 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		#'
9		#'
10		#' @param a ANY. Element to select only if it is not length 0
11		#' @param b ANY. Element to select if \code{a} is length 0
12		#' @export
13		#' @examples
14		#' 6 %\|\|% 10
15		#'
16		#' character() %\|\|% "hi"
17		#'
18		#' NULL %\|\|% "hi"
19		#' @return `a`, unless it is length 0, in which case `b` (even in the
20		#' case `b` is also length 0)
21	218x	`%\|\|%` <- function(a, b) if (length(a) == 0) b else a