Home - News ( United States | United Kingdom | Italy | Germany ) - Football scores

Showing content from https://insightsengineering.github.io/formatters/main/coverage-report/ below:

## state completely sucks and I hate it, but

## we need a pdf device open to calculate the

## print width of strings, and we can't be opening

## a new one every time we want to

font_dev_state <- new.env()

font_dev_state$open <- FALSE

font_dev_state$fontspec <- list()

font_dev_state$spacewidth <- NA_real_

font_dev_state$ismonospace <- NA

font_dev_state$max_ratio <- NA_real_

font_dev_state$dev_num <- NA_integer_

font_dev_state$debug_active <- FALSE

cwidth_inches_unsafe <- function(x) {

  convertWidth(unit(1, "strwidth", x), "inches", valueOnly = TRUE)

}

## returns whether it opened a new device or not

#' Activate font state

#'

#' @param fontspec (`font_spec`)\cr a font_spec object specifying the font information to use for

#'   calculating string widths and heights, as returned by [font_spec()].

#' @param silent (`logical(1)`)\cr If `FALSE`, the default, a warning will be

#'   emitted if this function switches away from an active graphics device.

#'

#' @details The font device state is an environment with

#' four variables guaranteed to be set:

#'

#' \describe{

#'   \item{`open`}{(`logical(1)`)\cr whether a device is already open with font info}

#'   \item{`fontspec`}{(`font_spec`)\cr the font specification, if any, that is currently active (`list()` if none is).}

#'   \item{`spacewidth`}{(`numeric(1)`)\cr the width of the space character in the currently active font.}

#'   \item{`ismonospace`}{(`logical(1)`)\cr whether the specified font is monospaced.}

#' }

#'

#' `open_font_dev` opens a pdf device with the specified font

#' only if there is not one currently open with the same font.

#' If a new device is opened, it caches `spacewidth` and

#' `ismonospace` for use in `nchar_ttype`).

#'

#' `close_font_dev` closes any open font state device

#' and clears the cached values.

#'

#' `debug_font_dev` and `undebug_font_dev` activate and deactivate, respectively,

#' logging of where in the call stack font devices are being opened.

#'

#' @return

#' - `open_font_dev` returns a logical value indicating whether a *new* pdf device was opened.

#' - `close_font_dev`, `debug_font_dev` and `undebug_font_dev` return `NULL`.

#'

#' In all cases the value is returned invisibly.

#'

#' @examples

#' open_font_dev(font_spec("Times"))

#' nchar_ttype("Hiya there", font_spec("Times"))

#' close_font_dev()

#'

#' @export

open_font_dev <- function(fontspec, silent = FALSE) {

  if (is.null(fontspec)) {

    return(invisible(FALSE))

  } else if (font_dev_is_open()) {

    if (identical(font_dev_state$fontspec, fontspec)) {

      if (!silent && dev.cur() != font_dev_state$dev_num) {

        warning(

          "formatters is switching to the font state graphics device ",

          "to perform string width calculations. You may need to switch ",

          "to your currently open graphics device, depending on whether ",

          "the font device is closed and what other devices you have open."

        )

        dev.set(font_dev_state$dev_num)

      }

      return(invisible(FALSE))

    } else {

      close_font_dev()

    }

  }

  if (font_dev_state$debug_active && !font_dev_is_open()) { ## call debug_font_dev beforehand to get debugging info to helplocate places which aren't receiving/using the state properly # nolint

    ## dump the call stack any time we have cache misses

    ## and have to open a completely new font state device

    scalls <- sys.calls()

    msg <- sapply(

      scalls[2:length(scalls)],

      function(sci) {

        toret <- deparse(sci[[1]], nlines = 3)

        if (substr(toret[1], 1, 8) == "function") {

          toret <- "anon function"

        }

        toret

      }

    )

    message(paste("\n***** START font dev debugging dump *****\n",

      paste(msg, collapse = " -> "),

      paste(capture.output(print(fontspec)), collapse = "\n"),

      sep = "\n"

    ))

  }

  tmppdf <- tempfile(fileext = ".pdf")

  pdf(tmppdf)

  grid.newpage()

  gp <- gpar_from_fspec(fontspec)

  pushViewport(plotViewport(gp = gp))

  spcwidth <- cwidth_inches_unsafe(" ")

  assign("open", TRUE, envir = font_dev_state)

  assign("fontspec", fontspec, envir = font_dev_state)

  assign("spacewidth", spcwidth, envir = font_dev_state)

  assign("ismonospace", spcwidth == cwidth_inches_unsafe("W"),

    envir = font_dev_state

  )

  assign("dev_num", dev.cur(),

    envir = font_dev_state

  )

  invisible(TRUE)

}

#' @rdname open_font_dev

#' @export

close_font_dev <- function() {

  if (font_dev_state$open) {

    dev.off(font_dev_state$dev_num)

    assign("open", FALSE, envir = font_dev_state)

    assign("fontspec", list(), envir = font_dev_state)

    assign("spacewidth", NA_real_, envir = font_dev_state)

    assign("ismonospace", NA, envir = font_dev_state)

    assign("dev_num", NA_integer_, envir = font_dev_state)

  }

  invisible(NULL)

}

#' @rdname open_font_dev

#' @export

debug_font_dev <- function() {

  message("debugging font device swapping. call undebug_font_dev() to turn debugging back off.")

  font_dev_state$debug_active <- TRUE

  invisible(NULL)

}

#' @rdname open_font_dev

#' @export

undebug_font_dev <- function() {

  message("no longer debugging font device swapping.")

  font_dev_state$debug_active <- FALSE

  invisible(NULL)

}

## can only be called when font_dev_state$open is TRUE

get_space_width <- function() {

  if (!font_dev_is_open()) {

    stop(

      "get_space_width called when font dev state is not open. ",

      "This shouldn't happen, please contact the maintainers."

    )

  }

  font_dev_state$spacewidth

}

.open_fdev_is_monospace <- function() {

  if (!font_dev_is_open()) {

    stop(

      ".open_fdev_is_monospace called when font dev state is not open. ",

      "This shouldn't happen, please contact the maintainers."

    )

  }

  font_dev_state$ismonospace

}

## safe wrapper around .open_fdev_is_monospace

is_monospace <- function(fontspec = font_spec(font_family, font_size, lineheight),

                         font_family = "Courier",

                         font_size = 8,

                         lineheight = 1) {

  if (is.null(fontspec)) {

    return(TRUE)

  }

  new_dev <- open_font_dev(fontspec)

  if (new_dev) {

    on.exit(close_font_dev())

  }

  .open_fdev_is_monospace()

}

## get_max_wratio <- function() {

##   if (!font_dev_state$open) {

##     stop(

##       "get_space_width called when font dev state is not open. ",

##       "This shouldn't happen, please contact the maintainers."

##     )

##   }

##   if (.open_fdev_is_monospace()) {

##     1

##   } else {

##     font_dev_state$maxratio

##   }

## }

gpar_from_fspec <- function(fontspec) {

  gpar(

    fontfamily = fontspec$family,

    fontsize = fontspec$size,

    lineheight = fontspec$lineheight

  )

}

font_dev_is_open <- function() font_dev_state$open

#' Default horizontal separator

#'

#' The default horizontal separator character which can be displayed in the current

#' charset for use in rendering table-like objects.

#'

#' @param hsep_char (`string`)\cr character that will be set in the R environment

#'   options as the default horizontal separator. Must be a single character. Use

#'   `getOption("formatters_default_hsep")` to get its current value (`NULL` if not set).

#'

#' @return unicode 2014 (long dash for generating solid horizontal line) if in a

#'   locale that uses a UTF character set, otherwise an ASCII hyphen with a

#'   once-per-session warning.

#'

#' @examples

#' default_hsep()

#' set_default_hsep("o")

#' default_hsep()

#'

#' @name default_horizontal_sep

#' @export

default_hsep <- function() {

  system_default_hsep <- getOption("formatters_default_hsep")

  if (is.null(system_default_hsep)) {

    if (any(grepl("^UTF", utils::localeToCharset()))) {

      hsep <- "\u2014"

    } else {

      if (interactive()) {

        warning(

          "Detected non-UTF charset. Falling back to '-' ",

          "as default header/body separator. This warning ",

          "will only be shown once per R session."

        ) # nocov

      } # nocov

      hsep <- "-" # nocov

    }

  } else {

    hsep <- system_default_hsep

  }

  hsep

}

#' @name default_horizontal_sep

#' @export

set_default_hsep <- function(hsep_char) {

  checkmate::assert_character(hsep_char, n.chars = 1, len = 1, null.ok = TRUE)

  options("formatters_default_hsep" = hsep_char)

}

.calc_cell_widths <- function(mat, colwidths, col_gap) {

  spans <- mat$spans

  keep_mat <- mat$display

  body <- mat$strings

  nr <- nrow(body)

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

  nc <- ncol(cell_widths_mat)

  for (i in seq_len(nrow(body))) {

    if (any(!keep_mat[i, ])) { # any spans?

      j <- 1

      while (j <= nc) {

        nj <- spans[i, j]

        j <- if (nj > 1) {

          js <- seq(j, j + nj - 1)

          cell_widths_mat[i, js] <- sum(cell_widths_mat[i, js]) + col_gap * (nj - 1)

          j + nj

        } else {

          j + 1

        }

      }

    }

  }

  cell_widths_mat

}

# Main function that does the wrapping

do_cell_fnotes_wrap <- function(mat, widths, max_width, tf_wrap, fontspec, expand_newlines = TRUE) {

  col_gap <- mf_colgap(mat)

  ncchar <- sum(widths) + (length(widths) - as.integer(mf_has_rlabels(mat))) * col_gap

  inset <- table_inset(mat)

  ## Text wrapping checks

  if (tf_wrap) {

    if (is.null(max_width)) {

      max_width <- getOption("width", 80L)

    } else if (is.character(max_width) && identical(max_width, "auto")) {

      max_width <- ncchar + inset

    }

    assert_number(max_width, lower = 0)

  }

  ## Check for having the right number of widths

  stopifnot(length(widths) == ncol(mat$strings))

  ## format the to ASCII

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

  # Check that indentation is correct (it works only for body)

  .check_indentation(mat, row_col_width = cell_widths_mat[, 1, drop = TRUE])

  mod_ind_list <- .modify_indentation(mat, cell_widths_mat, do_what = "remove")

  mfs <- mod_ind_list[["mfs"]]

  cell_widths_mat <- mod_ind_list[["cell_widths_mat"]]

  # Main wrapper

  mf_strings(mat) <- matrix(

    unlist(mapply(wrap_string,

      str = mfs,

      width = cell_widths_mat,

      collapse = "\n",

      MoreArgs = list(fontspec = fontspec)

    )),

    ncol = ncol(mfs)

  )

  if (expand_newlines) {

    ## XXXXX this is wrong and will break for listings cause we don't know when

    ## we need has_topleft to be FALSE!!!!!!!!!!

    mat <- mform_handle_newlines(mat)

    ## this updates extents in rinfo AND nlines in ref_fnotes_df

    ## mat already has fontspec on it so no need to pass that down

    mat <- update_mf_nlines(mat, max_width = max_width)

    # Re-indenting

    mf_strings(mat) <- .modify_indentation(mat, cell_widths_mat, do_what = "add")[["mfs"]]

    .check_indentation(mat) # all went well

  }

  mat

}

# Helper function to see if body indentation matches (minimum)

# It sees if there is AT LEAST the indentation contained in rinfo

.check_indentation <- function(mat, row_col_width = NULL) {

  # mf_nrheader(mat) # not useful

  mf_nlh <- mf_nlheader(mat)

  mf_lgrp <- mf_lgrouping(mat)

  mf_str <- mf_strings(mat)

  # we base everything on the groupings -> unique indentation identifiers

  if (!is.null(mf_rinfo(mat))) { # this happens in rare cases with rtables::rtable()

    mf_ind <- c(rep(0, mf_nrheader(mat)), mf_rinfo(mat)$indent) # XXX to fix with topleft

  } else {

    mf_ind <- rep(0, mf_nrheader(mat))

  }

  ind_std <- paste0(rep(" ", mat$indent_size), collapse = "")

  # Expected indent (-x negative numbers should not appear at this stage)

  stopifnot(all(mf_ind >= 0))

  real_indent <- vapply(mf_ind, function(ii) {

    paste0(rep(ind_std, ii), collapse = "")

  }, character(1))

  if (!is.null(row_col_width) && any(row_col_width > 0) && !is.null(mf_rinfo(mat))) { # third is rare case

    # Self consistency test for row_col_width (same groups should have same width)

    # This should not be necessary (nocov)

    consistency_check <- vapply(unique(mf_lgrp), function(ii) {

      width_per_grp <- row_col_width[which(mf_lgrp == ii)]

      all(width_per_grp == width_per_grp[1])

    }, logical(1))

    stopifnot(all(consistency_check))

    # Taking only one width for each indentation grouping

    unique_row_col_width <- row_col_width[match(unique(mf_lgrp), mf_lgrp)]

    # Exception for check: case with summarize_row_groups and (hence) content_rows

    nchar_real_indent <- nchar(real_indent)

    body_rows <- seq(mf_nrheader(mat) + 1, length(nchar_real_indent))

    nchar_real_indent[body_rows] <- nchar_real_indent[body_rows] +

      as.numeric(mf_rinfo(mat)$node_class != "ContentRow")

    # xxx I think all of the above is a bit buggy honestly (check ContentRows!!!)

    if (any(nchar_real_indent > unique_row_col_width)) {

      stop(

        "Inserted width for row label column is not wide enough. ",

        "We found the following rows that do not have at least indentation * ind_size + 1",

        " characters to allow text to be shown after indentation: ",

        paste0(which(nchar(real_indent) + 1 > unique_row_col_width), collapse = " ")

      )

    }

  }

  # Main detector

  correct_indentation <- vapply(seq_along(mf_lgrp), function(xx) {

    grouping <- mf_lgrp[xx]

    if (nzchar(real_indent[grouping])) {

      has_correct_indentation <- stringi::stri_detect(

        mf_str[xx, 1],

        regex = paste0("^", real_indent[grouping])

      )

      return(has_correct_indentation || !nzchar(mf_str[xx, 1])) # "" is still an ok indentation

    }

    # Cases where no indent are true by definition

    TRUE

  }, logical(1))

  if (any(!correct_indentation)) {

    stop(

      "We discovered indentation mismatches between the matrix_form and the indentation",

      " predefined in mf_rinfo. This should not happen. Contact the maintainer."

    ) # nocov

  }

}

# Helper function that takes out or adds the proper indentation

.modify_indentation <- function(mat, cell_widths_mat, do_what = c("remove", "add")) {

  # Extract info

  mfs <- mf_strings(mat) # we work on mfs

  mf_nlh <- mf_nlheader(mat)

  mf_l <- mf_lgrouping(mat)

  if (!is.null(mf_rinfo(mat))) { # this happens in rare cases with rtables::rtable()

    mf_ind <- c(rep(0, mf_nrheader(mat)), mf_rinfo(mat)$indent) # XXX to fix with topleft

  } else {

    mf_ind <- rep(0, mf_nrheader(mat))

  }

  stopifnot(length(mf_ind) == length(unique(mf_l))) # Check for indentation and grouping

  ind_std <- paste0(rep(" ", mat$indent_size), collapse = "") # standard size of indent 1

  # Create real indentation

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

  # Use groupings to add or remove proper indentation

  lbl_row <- mfs[, 1, drop = TRUE]

  for (ii in seq_along(lbl_row)) {

    grp <- mf_l[ii]

    if (nzchar(real_indent[grp])) {

      # Update also the widths!!

      if (do_what[1] == "remove") {

        cell_widths_mat[ii, 1] <- cell_widths_mat[ii, 1] - nchar(real_indent[grp])

        mfs[ii, 1] <- stringi::stri_replace(lbl_row[ii], "", regex = paste0("^", real_indent[grp]))

      } else if (do_what[1] == "add") {

        mfs[ii, 1] <- paste0(real_indent[grp], lbl_row[ii])

      } else {

        stop("do_what needs to be remove or add.") # nocov

      }

    } else {

      mfs[ii, 1] <- lbl_row[ii]

    }

  }

  # Final return

  return(list("mfs" = mfs, "cell_widths_mat" = cell_widths_mat))

}

## take a character vector and return whether the value is

## a string version of a number or not

is_number_str <- function(vec) {

  is.na(as.numeric(vec))

}

is_dec_align <- function(vec) {

  # "c" is not an alignment method we define in `formatters`,

  # but the reverse dependency package `tables` will need

  sdiff <- setdiff(vec, c(list_valid_aligns(), "c"))

  if (length(sdiff) > 0) {

    stop("Invalid text-alignment(s): ", paste(sdiff, collapse = ", "))

  }

  grepl("dec", vec)

}

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

#' Decimal alignment

#'

#' Aligning decimal values of string matrix. Allowed alignments are: `dec_left`, `dec_right`,

#' and `decimal`.

#'

#' @param string_mat (`character matrix`)\cr "string" matrix component of `MatrixPrintForm` object.

#' @param align_mat (`character matrix`)\cr "aligns" matrix component of `MatrixPrintForm` object.

#'   Should contain either `dec_left`, `dec_right`, or `decimal` for values to be decimal aligned.

#'

#' @details Left and right decimal alignment (`dec_left` and `dec_right`) differ from center decimal

#'   alignment (`decimal`) only when there is padding present. This may occur if column widths are

#'   set wider via parameters `widths` in `toString` or `colwidths` in `paginate_*`. More commonly,

#'   it also occurs when column names are wider. Cell wrapping is not supported when decimal

#'   alignment is used.

#'

#' @return A processed string matrix of class `MatrixPrintForm` with decimal-aligned values.

#'

#' @seealso [toString()], [MatrixPrintForm()]

#'

#' @examples

#' dfmf <- basic_matrix_form(mtcars[1:5, ])

#' aligns <- mf_aligns(dfmf)

#' aligns[, -c(1)] <- "dec_left"

#' decimal_align(mf_strings(dfmf), aligns)

#'

#' @export

decimal_align <- function(string_mat, align_mat) {

  ## Evaluate if any values are to be decimal aligned

  if (!any_dec_align(align_mat)) {

    return(string_mat)

  }

  for (i in seq(1, ncol(string_mat))) {

    ## Take a column and its decimal alignments

    col_i <- as.character(string_mat[, i])

    align_col_i <- is_dec_align(align_mat[, i])

    ## !( A || B) -> !A && !B  DeMorgan's Law

    ## Are there any values to be decimal aligned? safe if

    if (any(align_col_i) && any(!grepl("^[0-9]\\.", col_i))) {

      ## Extract values not to be aligned (NAs, non-numbers,

      ##  doesn't say "decimal" in alignment matrix)

      ## XXX FIXME because this happens after formatting, we can't tell the difference between

      ## non-number strings which come from na_str+ NA  value and strings which just aren't numbers.

      ## this is a problem that should eventually be fixed.

      nas <- vapply(col_i, is.na, FUN.VALUE = logical(1))

      nonnum <- !grepl("[0-9]", col_i)

      ## No grepl("[a-zA-Z]", col_i) because this excludes N=xx, e.g.

      nonalign <- nas | nonnum | !align_col_i

      col_ia <- col_i[!nonalign]

      ## Do decimal alignment

      if (length(col_ia) > 0) {

        # Special case: scientific notation

        has_sc_not <- grepl("\\d+[e|E][\\+|\\-]\\d+", col_ia)

        if (any(has_sc_not)) {

          stop(

            "Found values using scientific notation between the ones that",

            " needs to be decimal aligned (aligns is decimal, dec_left or dec_right).",

            " Please consider using format functions to get a complete decimal ",

            "(e.g. formatC)."

          )

        }

        ## Count the number of numbers in the string

        matches <- gregexpr("\\d+\\.\\d+|\\d+", col_ia)

        more_than_one <- vapply(matches, function(x) {

          sum(attr(x, "match.length") > 0) > 1

        }, logical(1))

        ## Throw error in case any have more than 1 numbers

        if (any(more_than_one)) {

          stop(

            "Decimal alignment is not supported for multiple values. ",

            "Found the following string with multiple numbers ",

            "(first 3 selected from column ", col_i[1], "): '",

            paste0(col_ia[more_than_one][seq(1, 3)], collapse = "', '"),

            "'"

          )

        }

        ## General split (only one match -> the first)

        main_regexp <- regexpr("\\d+", col_ia)

        left <- regmatches(col_ia, main_regexp, invert = FALSE)

        right <- regmatches(col_ia, main_regexp, invert = TRUE)

        right <- sapply(right, "[[", 2)

        something_left <- sapply(strsplit(col_ia, "\\d+"), "[[", 1)

        left <- paste0(something_left, left)

        if (!checkmate::test_set_equal(paste0(left, right), col_ia)) {

          stop(

            "Split string list lost some piece along the way. This ",

            "should not have happened. Please contact the maintainer."

          )

        } # nocov

        separator <- sapply(right, function(x) {

          if (nzchar(x)) {

            substr(x, 1, 1)

          } else {

            c(" ")

          }

        }, USE.NAMES = FALSE)

        right <- sapply(right, function(x) {

          if (nchar(x) > 1) {

            substr(x, 2, nchar(x))

          } else {

            c("")

          }

        }, USE.NAMES = FALSE)

        ## figure out whether we need space separators (at least one had a "." or not)

        if (!any(grepl("[^[:space:]]", separator))) {

          separator <- gsub("[[:space:]]*", "", separator)

        }

        ## modify the piece with spaces

        left_mod <- paste0(spaces(max(nchar(left), na.rm = TRUE) - nchar(left)), left)

        right_mod <- paste0(right, spaces(max(nchar(right), na.rm = TRUE) - nchar(right)))

        # Put everything together

        aligned <- paste(left_mod, separator, right_mod, sep = "")

        string_mat[!nonalign, i] <- aligned

      }

    }

  }

  string_mat

}

## this gives the conversion from number of spaces to number of characters

## for use in, e.g., repping out divider lines.

calc_str_adj <- function(str, fontspec) {

  if (nchar(str) == 0) {

    return(0)

  }

  nchar(str) / nchar_ttype(str, fontspec, raw = TRUE)

}

# toString ---------------------------------------------------------------------

# main printing code for MatrixPrintForm

#' @description

#' All objects that are printed to console pass via `toString`. This function allows

#' fundamental formatting specifications to be applied to final output, like column widths

#' and relative wrapping (`width`), title and footer wrapping (`tf_wrap = TRUE` and

#' `max_width`), and horizontal separator character (e.g. `hsep = "+"`).

#'

#' @inheritParams MatrixPrintForm

#' @inheritParams open_font_dev

#' @inheritParams format_value

#' @param widths (`numeric` or  `NULL`)\cr Proposed widths for the columns of `x`. The expected

#'   length of this numeric vector can be retrieved with `ncol(x) + 1` as the column of row names

#'   must also be considered.

#' @param hsep (`string`)\cr character to repeat to create header/body separator line. If

#'   `NULL`, the object value will be used. If `" "`, an empty separator will be printed. See

#'   [default_hsep()] for more information.

#' @param tf_wrap (`flag`)\cr whether the text for title, subtitles, and footnotes should be wrapped.

#' @param max_width (`integer(1)`, `string` or `NULL`)\cr width that title and footer (including

#'   footnotes) materials should be word-wrapped to. If `NULL`, it is set to the current print width of the

#'   session (`getOption("width")`). If set to `"auto"`, the width of the table (plus any table inset) is

#'   used. Parameter is ignored if `tf_wrap = FALSE`.

#' @param ttype_ok (`logical(1)`)\cr should truetype (non-monospace) fonts be

#'   allowed via `fontspec`. Defaults to `FALSE`. This parameter is primarily

#'   for internal testing and generally should not be set by end users.

#'

#' @details

#' Manual insertion of newlines is not supported when `tf_wrap = TRUE` and will result in a warning and

#' undefined wrapping behavior. Passing vectors of already split strings remains supported, however in this

#' case each string is word-wrapped separately with the behavior described above.

#'

#' @return A character string containing the ASCII rendering of the table-like object represented by `x`.

#'

#' @seealso [wrap_string()]

#'

#' @examples

#' mform <- basic_matrix_form(mtcars)

#' cat(toString(mform))

#'

#' @rdname tostring

#' @exportMethod toString

setMethod("toString", "MatrixPrintForm", function(x,

                                                  widths = NULL,

                                                  tf_wrap = FALSE,

                                                  max_width = NULL,

                                                  col_gap = mf_colgap(x),

                                                  hsep = NULL,

                                                  fontspec = font_spec(),

                                                  ttype_ok = FALSE,

                                                  round_type = c("iec", "sas")) {

  checkmate::assert_flag(tf_wrap)

  ## we are going to use the pdf device and grid to understand the actual

  ## print width of things given our font family and font size

  new_dev <- open_font_dev(fontspec)

  if (new_dev) {

    on.exit(close_font_dev())

  }

  if (!is_monospace(fontspec = fontspec) && !ttype_ok) {

    stop(

      "non-monospace font specified in toString call; this would result in cells contents not lining up exactly. ",

      "If you truly want this behavior please set ttype_ok = TRUE in the call to toString/export_as_txt/export_as_pdf"

    )

  }

  mat <- matrix_form(x, indent_rownames = TRUE, fontspec = fontspec, round_type = round_type)

  # Check for \n in mat strings -> if there are any, matrix_form did not work

  if (any(grepl("\n", mf_strings(mat)))) {

    stop(

      "Found newline characters (\\n) in string matrix produced by matrix_form. ",

      "This is not supported and implies missbehavior on the first parsing (in matrix_form). ",

      "Please contact the maintainer or file an issue."

    ) # nocov

  }

  if (any(grepl("\r", mf_strings(mat)))) {

    stop(

      "Found recursive special characters (\\r) in string matrix produced by matrix_form. ",

      "This special character is not supported and should be removed."

    ) # nocov

  }

  # Check that expansion worked for header -> should not happen

  if (!is.null(mf_rinfo(mat)) && # rare case of rtables::rtable()

    (length(mf_lgrouping(mat)) != nrow(mf_strings(mat)) || # non-unique grouping test # nolint

      mf_nrheader(mat) + nrow(mf_rinfo(mat)) != length(unique(mf_lgrouping(mat))))) { # nolint

    stop(

      "The sum of the expected nrows header and nrows of content table does ",

      "not match the number of rows in the string matrix. To our knowledge, ",

      "this is usually of a problem in solving newline characters (\\n) in the header. ",

      "Please contact the maintaner or file an issue."

    ) # nocov

  }

  inset <- table_inset(mat)

  # if cells are decimal aligned, run propose column widths

  # if the provided widths is less than proposed width, return an error

  if (any_dec_align(mf_aligns(mat))) {

    aligned <- propose_column_widths(x, fontspec = fontspec, round_type = round_type)

    # catch any columns that require widths more than what is provided

    if (!is.null(widths)) {

      how_wide <- sapply(seq_along(widths), function(i) c(widths[i] - aligned[i]))

      too_wide <- how_wide < 0

      if (any(too_wide)) {

        desc_width <- paste(paste(

          names(which(too_wide)),

          paste0("(", how_wide[too_wide], ")")

        ), collapse = ", ")

        stop(

          "Inserted width(s) for column(s) ", desc_width,

          " is(are) not wide enough for the desired alignment."

        )

      }

    }

  }

  # Column widths are fixed here

  if (is.null(widths)) {

    # if mf does not have widths -> propose them

    widths <- mf_col_widths(x) %||% propose_column_widths(x, fontspec = fontspec, round_type = round_type)

  } else {

    mf_col_widths(x) <- widths

  }

  ## Total number of characters for the table

  ## col_gap (and table inset) are in number of spaces

  ## so we're ok here even in the truetype case

  ncchar <- sum(widths) + (length(widths) - 1) * col_gap

  ## max_width for wrapping titles and footers (not related to ncchar if not indirectly)

  max_width <- .handle_max_width(

    tf_wrap = tf_wrap,

    max_width = max_width,

    colwidths = widths,

    col_gap = col_gap,

    inset = inset

  )

  # Main wrapper function for table core

  mat <- do_cell_fnotes_wrap(mat, widths, max_width = max_width, tf_wrap = tf_wrap, fontspec = fontspec)

  body <- mf_strings(mat)

  aligns <- mf_aligns(mat)

  keep_mat <- mf_display(mat)

  ## spans <- mat$spans

  mf_ri <- mf_rinfo(mat)

  ref_fnotes <- mf_rfnotes(mat)

  nl_header <- mf_nlheader(mat)

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

  # decimal alignment

  if (any_dec_align(aligns)) {

    body <- decimal_align(body, aligns)

  }

  # Content is a matrix of cells with the right amount of spaces

  content <- matrix(

    mapply(padstr, body, cell_widths_mat, aligns, MoreArgs = list(fontspec = fontspec)),

    ncol = ncol(body)

  )

  content[!keep_mat] <- NA

  # Define gap string and divisor string

  gap_str <- strrep(" ", col_gap)

  if (is.null(hsep)) {

    hsep <- horizontal_sep(mat)

  }

  adj_hsep <- calc_str_adj(hsep, fontspec)

  div <- substr(strrep(hsep, ceiling(ncchar * adj_hsep)), 1, ceiling(ncchar * adj_hsep))

  hsd <- header_section_div(mat)

  if (!is.na(hsd)) {

    adj_hsd <- calc_str_adj(hsd, fontspec)

    hsd <- substr(strrep(hsd, ceiling(ncchar * adj_hsd)), 1, ceiling(ncchar * adj_hsd))

  } else {

    hsd <- NULL # no divisor

  }

  # text head (paste w/o NA content header and gap string)

  txt_head <- apply(head(content, nl_header), 1, .paste_no_na, collapse = gap_str)

  # txt body

  sec_seps_df <- mf_ri[, c("abs_rownumber", "trailing_sep"), drop = FALSE]

  if (!is.null(sec_seps_df) && any(!is.na(sec_seps_df$trailing_sep))) {

    bdy_cont <- tail(content, -nl_header)

    ## unfortunately we count "header rows" wrt line grouping so it

    ## doesn't match the real (i.e. body) rows as is

    row_grouping <- tail(mf_lgrouping(mat), -nl_header) - mf_nrheader(mat)

    nrbody <- NROW(bdy_cont)

    stopifnot(length(row_grouping) == nrbody)

    ## all rows with non-NA section divs and the final row (regardless of NA status)

    ## fixes #77

    sec_seps_df <- sec_seps_df[unique(c(

      which(!is.na(sec_seps_df$trailing_sep)),

      NROW(sec_seps_df)

    )), ]

    txt_body <- character()

    sec_strt <- 1

    section_rws <- sec_seps_df$abs_rownumber

    for (i in seq_len(NROW(section_rws))) {

      cur_rownum <- section_rws[i]

      sec_end <- max(which(row_grouping == cur_rownum))

      txt_body <- c(

        txt_body,

        apply(bdy_cont[seq(sec_strt, sec_end), , drop = FALSE],

          1,

          .paste_no_na,

          collapse = gap_str

        ),

        ## don't print section dividers if they would be the last thing before the

        ## footer divider

        ## this also ensures an extraneous sec div won't be printed if we have non-sec-div

        ## rows after the last sec div row (#77)

        if (sec_end < nrbody) {

          adj_i <- calc_str_adj(sec_seps_df$trailing_sep[i], fontspec)

          substr(

            strrep(sec_seps_df$trailing_sep[i], ceiling(ncchar * adj_i)), 1,

            ceiling((ncchar - inset) * adj_i)

          )

        }

      )

      sec_strt <- sec_end + 1

    }

  } else {

    # This is the usual default pasting

    txt_body <- apply(tail(content, -nl_header), 1, .paste_no_na, collapse = gap_str)

  }

  # retrieving titles and footers

  allts <- all_titles(mat)

  ref_fnotes <- reorder_ref_fnotes(ref_fnotes)

  # Fix for ref_fnotes with \n characters XXX this does not count in the pagination

  if (any(grepl("\\n", ref_fnotes))) {

    ref_fnotes <- unlist(strsplit(ref_fnotes, "\n", fixed = TRUE))

  }

  allfoots <- list(

    "main_footer" = main_footer(mat),

    "prov_footer" = prov_footer(mat),

    "ref_footnotes" = ref_fnotes

  )

  allfoots <- allfoots[!sapply(allfoots, is.null)]

  ## Wrapping titles if they go beyond the horizontally allowed space

  if (tf_wrap) {

    new_line_warning(allts)

    allts <- wrap_txt(allts, max_width, fontspec = fontspec)

  }

  titles_txt <- if (any(nzchar(allts))) c(allts, "", .do_inset(div, inset)) else NULL

  # Wrapping footers if they go beyond the horizontally allowed space

  if (tf_wrap) {

    new_line_warning(allfoots)

    allfoots$main_footer <- wrap_txt(allfoots$main_footer, max_width - inset, fontspec = fontspec)

    allfoots$ref_footnotes <- wrap_txt(allfoots$ref_footnotes, max_width - inset, fontspec = fontspec)

    ## no - inset here because the prov_footer is not inset

    allfoots$prov_footer <- wrap_txt(allfoots$prov_footer, max_width, fontspec = fontspec)

  }

  # Final return

  paste0(

    paste(c(

      titles_txt, # .do_inset(div, inset) happens if there are any titles

      .do_inset(txt_head, inset),

      .do_inset(div, inset),

      .do_inset(hsd, inset), # header_section_div if present

      .do_inset(txt_body, inset),

      .footer_inset_helper(allfoots, div, inset)

    ), collapse = "\n"),

    "\n"

  )

})

# Switcher for the 3 options for max_width (NULL, numeric, "auto"))

.handle_max_width <- function(tf_wrap, max_width,

                              cpp = NULL, # Defaults to getOption("width", 80L)

                              # Things for auto

                              inset = NULL, colwidths = NULL, col_gap = NULL) {

  max_width <- if (!tf_wrap) {

    if (!is.null(max_width)) {

      warning("tf_wrap is FALSE - ignoring non-null max_width value.")

    }

    NULL

  } else if (tf_wrap) {

    if (is.null(max_width)) {

      if (is.null(cpp) || is.na(cpp)) {

        getOption("width", 80L)

      } else {

        cpp

      }

    } else if (is.numeric(max_width)) {

      max_width

    } else if (is.character(max_width) && identical(max_width, "auto")) {

      # This should not happen, but just in case

      if (any(sapply(list(inset, colwidths, col_gap), is.null))) {

        stop("inset, colwidths, and col_gap must all be non-null when max_width is \"auto\".")

      }

      inset + sum(colwidths) + (length(colwidths) - 1) * col_gap

    } else {

      stop("max_width must be NULL, a numeric value, or \"auto\".")

    }

  }

  return(max_width)

}

.do_inset <- function(x, inset) {

  if (inset == 0 || !any(nzchar(x))) {

    return(x)

  }

  padding <- strrep(" ", inset)

  if (is.character(x)) {

    x <- paste0(padding, x)

  } else if (is(x, "matrix")) {

    x[, 1] <- .do_inset(x[, 1, drop = TRUE], inset)

  }

  x

}

.inset_div <- function(txt, div, inset) {

  c(.do_inset(div, inset), "", txt)

}

.footer_inset_helper <- function(footers_v, div, inset) {

  div_done <- FALSE # nolint

  fter <- footers_v$main_footer

  prvf <- footers_v$prov_footer

  rfn <- footers_v$ref_footnotes

  footer_txt <- .do_inset(rfn, inset)

  if (any(nzchar(footer_txt))) {

    footer_txt <- .inset_div(footer_txt, div, inset)

  }

  if (any(vapply(

    footers_v, function(x) any(nzchar(x)),

    TRUE

  ))) {

    if (any(nzchar(prvf))) {

      provtxt <- c(

        if (any(nzchar(fter))) "",

        prvf

      )

    } else {

      provtxt <- character()

    }

    footer_txt <- c(

      footer_txt,

      .inset_div(

        c(

          .do_inset(fter, inset),

          provtxt

        ),

        div,

        inset

      )

    )

  }

  footer_txt

}

reorder_ref_fnotes <- function(fns) {

  ind <- gsub("\\{(.*)\\}.*", "\\1", fns)

  ind_num <- suppressWarnings(as.numeric(ind))

  is_num <- !is.na(ind_num)

  is_asis <- ind == fns

  if (all(is_num)) {

    ord_num <- order(ind_num)

    ord_char <- NULL

    ord_other <- NULL

  } else {

    ord_num <- order(ind_num[is_num])

    ord_char <- order(ind[!is_num & !is_asis])

    ord_other <- order(ind[is_asis])

  }

  c(fns[is_num][ord_num], fns[!is_num & !is_asis][ord_char], ind[is_asis][ord_other])

}

new_line_warning <- function(str_v) {

  if (any(unlist(sapply(str_v, grepl, pattern = "\n")))) {

    msg <- c(

      "Detected manual newlines when automatic title/footer word-wrapping is on.",

      "This is unsupported and will result in undefined behavior. Please either ",

      "utilize automatic word-wrapping with newline characters inserted, or ",

      "turn off automatic wrapping and wordwrap all contents manually by inserting ",

      "newlines."

    )

    warning(paste0(msg, collapse = ""))

  }

}

#' Wrap a string to a precise width

#'

#' Core wrapping functionality that preserves whitespace. Newline character `"\n"` is not supported

#' by core functionality [stringi::stri_wrap()]. This is usually solved beforehand by [matrix_form()].

#' If the width is smaller than any large word, these will be truncated after `width` characters. If

#' the split leaves trailing groups of empty spaces, they will be dropped.

#'

#' @inheritParams open_font_dev

#' @param str (`string`, `character`, or `list`)\cr string to be wrapped. If it is a `vector` or

#'   a `list`, it will be looped as a `list` and returned with `unlist(use.names = FALSE)`.

#' @param width (`numeric(1)`)\cr width, in characters, that the text should be wrapped to.

#' @param collapse (`string` or `NULL`)\cr collapse character used to separate segments of words that

#'   have been split and should be pasted together. This is usually done internally with `"\n"` to update

#'   the wrapping along with other internal values.

#'

#' @details Word wrapping happens similarly to [stringi::stri_wrap()] with the following difference: individual

#'   words which are longer than `max_width` are broken up in a way that fits with other word wrapping.

#'

#' @return A string if `str` is one element and if `collapse = NULL`. Otherwise, a list of elements

#'   (if `length(str) > 1`) that can contain strings or vectors of characters (if `collapse = NULL`).

#'

#' @examples

#' str <- list(

#'   "  , something really  \\tnot  very good", # \t needs to be escaped

#'   "  but I keep it12   "

#' )

#' wrap_string(str, 5, collapse = "\n")

#'

#' @export

wrap_string <- function(str, width, collapse = NULL, fontspec = font_spec()) {

  if (length(str) > 1) {

    return(

      unlist(

        lapply(str, wrap_string, width = width, collapse = collapse, fontspec = fontspec),

        use.names = FALSE

      )

    )

  }

  str <- unlist(str, use.names = FALSE) # it happens is one list element

  if (!length(str) || !nzchar(str) || is.na(str)) {

    return(str)

  }

  checkmate::assert_character(str)

  checkmate::assert_int(width, lower = 1)

  if (any(grepl("\\n", str))) {

    stop(

      "Found \\n in a string that was meant to be wrapped. This should not happen ",

      "because matrix_form should take care of them before this step (toString, ",

      "i.e. the printing machinery). Please contact the maintaner or file an issue."

    )

  }

  if (!is_monospace(fontspec)) {

    return(wrap_string_ttype(str, width, fontspec, collapse = collapse))

  }

  # str can be also a vector or list. In this case simplify manages the output

  ret <- .go_stri_wrap(str, width)

  # Check if it went fine

  if (any(nchar_ttype(ret, fontspec) > width)) {

    which_exceeded <- which(nchar_ttype(ret, fontspec) > width)

    # Recursive for loop to take word interval

    while (length(which_exceeded) > 0) {

      we_i <- which_exceeded[1]

      # Is there space for some part of the next word?

      char_threshold <- width * (2 / 3) + 0.01 # if too little space -> no previous word

      smart_condition <- nchar_ttype(ret[we_i - 1], fontspec) + 1 < char_threshold # +1 is for spaces

      if (we_i - 1 > 0 && smart_condition) {

        we_interval <- unique(c(we_i - 1, we_i))

        we_interval <- we_interval[

          (we_interval < (length(ret) + 1)) &

            (we_interval > 0)

        ]

      } else {

        we_interval <- we_i

      }

      # Split words and collapse (needs unique afterwards)

      ret[we_interval] <- split_words_by(

        paste0(ret[we_interval], collapse = " "),

        width

      )

      # Taking out repetitions if there are more than one

      if (length(we_interval) > 1) {

        ret <- ret[-we_interval[-1]]

        we_interval <- we_interval[1]

      }

      # Paste together and rerun if it is not the same as original ret

      ret_collapse <- paste0(ret, collapse = " ")

      # Checking if we are stuck in a loop

      ori_wrapped_txt_v <- .go_stri_wrap(str, width)

      cur_wrapped_txt_v <- .go_stri_wrap(ret_collapse, width)

      broken_char_ori <- sum(nchar_ttype(ori_wrapped_txt_v, fontspec) > width) # how many issues there were

      broken_char_cur <- sum(nchar_ttype(cur_wrapped_txt_v, fontspec) > width) # how many issues there are

      # if still broken, we did not solve the current issue!

      if (setequal(ori_wrapped_txt_v, cur_wrapped_txt_v) || broken_char_cur >= broken_char_ori) {

        # help function: Very rare case where the recursion is stuck in a loop

        ret_tmp <- force_split_words_by(ret[we_interval], width) # here we_interval is only one ind

        ret <- append(ret, ret_tmp, we_interval)[-we_interval]

        which_exceeded <- which(nchar_ttype(ret, fontspec) > width)

      } else {

        return(wrap_string(str = ret_collapse, width = width, collapse = collapse))

      }

    }

  }

  if (!is.null(collapse)) {

    return(paste0(ret, collapse = collapse))

  }

  return(ret)

}

.go_stri_wrap <- function(str, w) {

  if (w < 1) {

    return(str)

  }

  stringi::stri_wrap(str,

    width = w,

    normalize = FALSE, # keeps spaces

    simplify = TRUE, # If FALSE makes it a list with str elements

    indent = 0,

    use_length = FALSE # incase the defaul changes, use actual char widths

  )

}

#' @rdname wrap_string_ttype

#' @export

split_word_ttype <- function(str, width, fontspec, min_ok_chars) {

  chrs <- strsplit(str, "")[[1]]

  nctt_chars <- nchar_ttype(chrs, fontspec, raw = TRUE)

  ok <- which(cumsum(nctt_chars) <= width)

  if (length(ok) < min_ok_chars || length(chrs) - length(ok) < min_ok_chars) {

    list(

      ok = character(),

      remainder = str

    )

  } else {

    list(

      ok = substr(str, 1, length(ok)),

      remainder = substr(str, length(ok) + 1, nchar(str))

    )

  }

}

## need a separate path here because **the number of characters**

## in each part is no longer going to be constant the way it

## was for monospace

## this is much slower but still shouldn't be a bottleneck, if it is we'll

## have to do something else

#' wrap string given a Truetype font

#'

#' @inheritParams wrap_string

#' @param min_ok_chars (`numeric(1)`)\cr number of minimum characters that remain

#'   on either side when a word is split.

#' @param wordbreak_ok (`logical(1)`)\cr should breaking within a word be allowed? If, `FALSE`,

#'   attempts to wrap a string to a width narrower than its widest word will result

#'   in an error.

#' @return `str`, broken up into a word-wrapped vector

#' @export

wrap_string_ttype <- function(str,

                              width,

                              fontspec,

                              collapse = NULL,

                              min_ok_chars = min(floor(nchar(str) / 2), 4, floor(width / 2)),

                              wordbreak_ok = TRUE) {

  newdev <- open_font_dev(fontspec)

  if (newdev) {

    on.exit(close_font_dev())

  }

  rawspls <- strsplit(str, "[[:space:]](?=[^[:space:]])", perl = TRUE)[[1]] # preserve all but one space

  nctt <- nchar_ttype(rawspls, fontspec, raw = TRUE)

  pts <- which(cumsum(nctt) <= width)

  if (length(pts) == length(rawspls)) { ## no splitting needed

    return(str)

  } else if (length(pts) == 0) { ## no spaces, all one word, split it and keep going

    if (wordbreak_ok) {

      inner_res <- list()

      min_ok_inner <- min_ok_chars

      while (length(inner_res$ok) == 0) {

        inner_res <- split_word_ttype(rawspls[1], width, fontspec, min_ok_inner) # min_ok_chars)

        min_ok_inner <- floor(min_ok_inner / 2)

      }

      done <- inner_res$ok

      remainder <- paste(c(inner_res$remainder, rawspls[-1]), collapse = " ")

    } else {

      stop(

        "Unable to find word wrapping solution without breaking word: ",

        rawspls[[1]], " [requires  ", nchar_ttype(rawspls[[1]], fontspec), " spaces of width, out of ",

        width, " available]."

      )

    }

  } else { ## some words fit, and some words don't

    done_tmp <- paste(rawspls[pts], collapse = " ")

    tospl_tmp <- rawspls[length(pts) + 1]

    width_tmp <- width - sum(nctt[pts])

    if (wordbreak_ok && width_tmp / width > .33) {

      inner_res <- split_word_ttype(tospl_tmp, width_tmp, fontspec,

        min_ok_chars = min_ok_chars

      )

    } else {

      inner_res <- list(done = "", remainder = tospl_tmp)

    }

    done <- paste(c(rawspls[pts], inner_res$ok),

      collapse = " "

    )

    remainder <- paste(

      c(

        inner_res$remainder,

        if (length(rawspls) > length(pts) + 1) tail(rawspls, -(length(pts) + 1))

      ),

      collapse = " "

    )

  }

  ret <- c(

    done,

    wrap_string_ttype(remainder, width, fontspec)

  )

  if (!is.null(collapse)) {

    ret <- paste(ret, collapse = collapse)

  }

  ret

}

# help function: Very rare case where the recursion is stuck in a loop

force_split_words_by <- function(ret, width) {

  which_exceeded <- which(nchar(ret) > width)

  ret_tmp <- NULL

  for (ii in seq_along(ret)) {

    if (ii %in% which_exceeded) {

      wrd_i <- ret[ii]

      init_v <- seq(1, nchar(wrd_i), by = width)

      end_v <- c(init_v[-1] - 1, nchar(wrd_i))

      str_v_tmp <- stringi::stri_sub(wrd_i, from = init_v, to = end_v)

      ret_tmp <- c(ret_tmp, str_v_tmp[!grepl("^\\s+$", str_v_tmp) & nzchar(str_v_tmp)])

    } else {

      ret_tmp <- c(ret_tmp, ret[ii])

    }

  }

  ret_tmp

}

# Helper fnc to split the words and collapse them with space

split_words_by <- function(wrd, width) {

  vapply(wrd, function(wrd_i) {

    init_v <- seq(1, nchar(wrd_i), by = width)

    end_v <- c(init_v[-1] - 1, nchar(wrd_i))

    fin_str_v <- substring(wrd_i, init_v, end_v)

    is_only_spaces <- grepl("^\\s+$", fin_str_v)

    # We pop only spaces at this point

    if (all(is_only_spaces)) {

      fin_str_v <- fin_str_v[1] # keep only one width-sized empty

    } else {

      fin_str_v <- fin_str_v[!is_only_spaces] # hybrid text + \s

    }

    # Collapse the string

    paste0(fin_str_v, collapse = " ")

  }, character(1), USE.NAMES = FALSE)

}

#' @describeIn wrap_string Deprecated function. Please use [wrap_string()] instead.

#'

#' @examples

#' wrap_txt(str, 5, collapse = NULL)

#'

#' @export

wrap_txt <- function(str, width, collapse = NULL, fontspec = font_spec()) {

  new_dev <- open_font_dev(fontspec)

  if (new_dev) {

    on.exit(close_font_dev())

  }

  unlist(wrap_string(str, width, collapse, fontspec = fontspec), use.names = FALSE)

}

pad_vert_top <- function(x, len, default = "") {

  c(x, rep(default, len - length(x)))

}

pad_vert_bottom <- function(x, len, default = "") {

  c(rep(default, len - length(x)), x)

}

pad_vec_to_len <- function(vec, len, cpadder = pad_vert_top, rlpadder = cpadder) {

  dat <- unlist(lapply(vec[-1], cpadder, len = len))

  dat <- c(rlpadder(vec[[1]], len = len), dat)

  matrix(dat, nrow = len)

}

rep_vec_to_len <- function(vec, len, ...) {

  matrix(unlist(lapply(vec, rep, times = len)),

    nrow = len

  )

}

safe_strsplit <- function(x, split, ...) {

  ret <- strsplit(x, split, ...)

  lapply(ret, function(reti) if (length(reti) == 0) "" else reti)

}

.expand_mat_rows_inner <- function(i, mat, row_nlines, expfun, ...) {

  leni <- row_nlines[i]

  rw <- mat[i, ]

  if (is.character(rw)) {

    rw <- safe_strsplit(rw, "\n", fixed = TRUE)

  }

  expfun(rw, len = leni, ...)

}

expand_mat_rows <- function(mat, row_nlines = apply(mat, 1, nlines), expfun = pad_vec_to_len, ...) {

  rinds <- seq_len(nrow(mat))

  exprows <- lapply(rinds, .expand_mat_rows_inner,

    mat = mat,

    row_nlines = row_nlines,

    expfun = expfun,

    ...

  )

  do.call(rbind, exprows)

}

#' Transform a vector of spans (with duplication) into a visibility vector

#'

#' @param spans (`numeric`)\cr a vector of spans, with each span value repeated

#'   for the cells it covers.

#'

#' @details

#' The values of `spans` are assumed to be repeated such that each individual position covered by the

#' span has the repeated value.

#'

#' This means that each block of values in `spans` must be of a length at least equal to its value

#' (i.e. two 2s, three 3s, etc).

#'

#' This function correctly handles cases where two spans of the same size are next to each other;

#' i.e., a block of four 2s represents two large cells each of which spans two individual cells.

#'

#' @return A logical vector the same length as `spans` indicating whether the contents of a string vector

#'   with those spans is valid.

#'

#' @note

#' Currently no checking or enforcement is done to verify that the vector of spans is valid according to

#' the specifications described in the Details section above.

#'

#' @examples

#' spans_to_viscell(c(2, 2, 2, 2, 1, 3, 3, 3))

#'

#' @export

spans_to_viscell <- function(spans) {

  if (!is.vector(spans)) {

    spans <- as.vector(spans)

  }

  myrle <- rle(spans)

  unlist(

    mapply(

      function(vl, ln) {

        rep(c(TRUE, rep(FALSE, vl - 1L)), times = ln / vl)

      },

      SIMPLIFY = FALSE,

      vl = myrle$values,

      ln = myrle$lengths

    ),

    recursive = FALSE

  )

}

#' Propose column widths based on the `MatrixPrintForm` of an object

#'

#' Row names are also considered a column for the output.

#'

#' @inheritParams open_font_dev

#' @inheritParams format_value

#' @param x (`ANY`)\cr a `MatrixPrintForm` object, or an object with a `matrix_form` method.

#' @param indent_size (`numeric(1)`)\cr indent size, in characters. Ignored when `x` is already

#'   a `MatrixPrintForm` object in favor of information there.

#'

#' @return A vector of column widths based on the content of `x` for use in printing and pagination.

#'

#' @examples

#' mf <- basic_matrix_form(mtcars)

#' propose_column_widths(mf)

#'

#' @export

propose_column_widths <- function(x,

                                  indent_size = 2,

                                  fontspec = font_spec(),

                                  round_type = c("iec", "sas")) {

  new_dev <- open_font_dev(fontspec)

  if (new_dev) {

    on.exit(close_font_dev())

  }

  if (!is(x, "MatrixPrintForm")) {

    x <- matrix_form(x, indent_rownames = TRUE, indent_size = indent_size, fontspec = fontspec, round_type = round_type)

  }

  body <- mf_strings(x)

  spans <- mf_spans(x)

  aligns <- mf_aligns(x)

  display <- mf_display(x)

  # compute decimal alignment if asked in alignment matrix

  if (any_dec_align(aligns)) {

    body <- decimal_align(body, aligns)

  }

  ## chars <- nchar(body) #old monospace assumption

  ## we now use widths in terms of the printwidth of the space (" ")

  ## character. This collapses to the same thing in the monospace

  ## case but allows us to reasonably support truetype fonts

  chars <- nchar_ttype(body, fontspec)

  # first check column widths without colspan

  has_spans <- spans != 1

  chars_ns <- chars

  chars_ns[has_spans] <- 0

  widths <- apply(chars_ns, 2, max)

  # now check if the colspans require extra width

  if (any(has_spans)) {

    has_row_spans <- apply(has_spans, 1, any)

    chars_sp <- chars[has_row_spans, , drop = FALSE]

    spans_sp <- spans[has_row_spans, , drop = FALSE]

    disp_sp <- display[has_row_spans, , drop = FALSE]

    nc <- ncol(spans)

    for (i in seq_len(nrow(chars_sp))) {

      for (j in seq_len(nc)) {

        if (disp_sp[i, j] && spans_sp[i, j] != 1) {

          i_cols <- seq(j, j + spans_sp[i, j] - 1)

          nchar_i <- chars_sp[i, j]

          cw_i <- widths[i_cols]

          available_width <- sum(cw_i)

          if (nchar_i > available_width) {

            # need to update widths to fit content with colspans

            # spread width among columns

            widths[i_cols] <- cw_i + spread_integer(nchar_i - available_width, length(cw_i))

          }

        }

      }

    }

  }

  widths

}

## "number of characters" width in terms of

## width of " " for the chosen font family

## pdf device with font specification MUST already be open

#' Calculate font-specific string width

#'

#' This function returns the width of each element `x`

#' *as a multiple of the width of the space character

#' for in declared font*, rounded up to the nearest

#' integer. This is used extensively in the text rendering

#' ([toString()]) and pagination machinery for

#' calculating word wrapping, default column widths,

#' lines per page, etc.

#'

#' @param x (`character`)\cr the string(s) to calculate width(s) for.

#' @param fontspec (`font_spec` or `NULL`)\cr if non-NULL, the font to use for

#'   the calculations (as returned by [font_spec()]). Defaults to "Courier",

#'   which is a monospace font. If NULL, the width will be returned

#'   in number of characters by calling `nchar` directly.

#' @param tol (`numeric(1)`)\cr the tolerance to use when determining

#'   if a multiple needs to be rounded up to the next integer. See

#'   Details.

#' @param raw (`logical(1)`)\cr whether unrounded widths should be returned. Defaults to `FALSE`.

#'

#' @details String width is defined in terms of spaces within

#' the specified font. For monospace fonts, this definition

#' collapses to the number of characters in the string

#' ([nchar()]), but for truetype fonts it does not.

#'

#' For `raw = FALSE`, non-integer values (the norm in a truetype

#' setting) for the number of spaces a string takes up is rounded

#' up, *unless the multiple is less than `tol` above the last integer

#' before it*. E.g., if `k - num_spaces < tol` for an integer

#' `k`, `k` is returned instead of `k+1`.

#'

#' @seealso [font_spec()]

#'

#' @examples

#' nchar_ttype("hi there!")

#'

#' nchar_ttype("hi there!", font_spec("Times"))

#'

#' @export

nchar_ttype <- function(x, fontspec = font_spec(), tol = sqrt(.Machine$double.eps), raw = FALSE) {

  ## escape hatch because sometimes we need to call, e.g. make_row_df

  ## but we dont' care about getting the word wrapping right and the

  ## performance penalty was KILLING us. Looking at you

  ## rtables::update_ref_indexing @.@

  if (is.null(fontspec)) {

    return(nchar(x))

  }

  new_dev <- open_font_dev(fontspec)

  if (new_dev) {

    on.exit(close_font_dev())

  }

  if (font_dev_state$ismonospace) { ## WAY faster if we can do it

    return(nchar(x))

  }

  space_width <- get_space_width()

  ## cwidth_inches_unsafe is ok here because if we don't

  ## have a successfully opened state (somehow), get_space_width

  ## above will error.

  num_inches_raw <- vapply(x, cwidth_inches_unsafe, 1.0)

  num_spaces_raw <- num_inches_raw / space_width

  if (!raw) {

    num_spaces_ceil <- ceiling(num_spaces_raw)

    ## we don't want to add one when the answer is e.g, 3.0000000000000953

    within_tol <- which(num_spaces_raw + 1 - num_spaces_ceil <= tol)

    ret <- num_spaces_ceil

    if (length(within_tol) == 0L) {

      ret[within_tol] <- floor(num_spaces_raw[within_tol])

    }

  } else {

    ret <- num_spaces_raw

  }

  if (!is.null(dim(x))) {

    dim(ret) <- dim(x)

  } else {

    names(ret) <- NULL

  }

  ret

}

#' Pad a string and align within string

#'

#' @inheritParams open_font_dev

#' @param x (`string`)\cr a string.

#' @param n (`integer(1)`)\cr number of characters in the output string. If `n < nchar(x)`, an error is thrown.

#' @param just (`string`)\cr text alignment justification to use. Defaults to `"center"`. Must be one of

#'   `"center"`, `"right"`, `"left"`, `"dec_right"`, `"dec_left"`, or `"decimal"`.

#'

#' @return `x`, padded to be a string of length `n`.

#'

#' @examples

#' padstr("abc", 3)

#' padstr("abc", 4)

#' padstr("abc", 5)

#' padstr("abc", 5, "left")

#' padstr("abc", 5, "right")

#'

#' \dontrun{

#' # Expect error: "abc" has more than 1 characters

#' padstr("abc", 1)

#' }

#'

#' @export

padstr <- function(x, n, just = list_valid_aligns(), fontspec = font_spec()) {

  just <- match.arg(just)

  if (length(x) != 1) stop("length of x needs to be 1 and not", length(x))

  if (is.na(n) || !is.numeric(n) || n < 0) stop("n needs to be numeric and > 0")

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

  nc <- nchar_ttype(x, fontspec)

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

  switch(just,

    center = {

      pad <- (n - nc) / 2

      paste0(spaces(floor(pad)), x, spaces(ceiling(pad)))

    },

    left = paste0(x, spaces(n - nc)),

    right = paste0(spaces(n - nc), x),

    decimal = {

      pad <- (n - nc) / 2

      paste0(spaces(floor(pad)), x, spaces(ceiling(pad)))

    },

    dec_left = paste0(x, spaces(n - nc)),

    dec_right = paste0(spaces(n - nc), x)

  )

}

spaces <- function(n) {

  strrep(" ", n)

}

.paste_no_na <- function(x, ...) {

  paste(na.omit(x), ...)

}

#' Spread an integer to a given length

#'

#' @param x (`integer(1)`)\cr number to spread.

#' @param len (`integer(1)`)\cr number of times to repeat `x`.

#'

#' @return If `x` is a scalar whole number value (see [is.wholenumber()]), the value `x` is repeated `len` times.

#'   Otherwise, an error is thrown.

#'

#' @examples

#' spread_integer(3, 1)

#' spread_integer(0, 3)

#' spread_integer(1, 3)

#' spread_integer(2, 3)

#' spread_integer(3, 3)

#' spread_integer(4, 3)

#' spread_integer(5, 3)

#' spread_integer(6, 3)

#' spread_integer(7, 3)

#'

#' @export

spread_integer <- function(x, len) {

  stopifnot(

    is.wholenumber(x), length(x) == 1, x >= 0,

    is.wholenumber(len), length(len) == 1, len >= 0,

    !(len == 0 && x > 0)

  )

  if (len == 0) {

    integer(0)

  } else {

    y <- rep(floor(x / len), len)

    i <- 1

    while (sum(y) < x) {

      y[i] <- y[i] + 1

      if (i == len) {

        i <- 1

      } else {

        i <- i + 1

      }

    }

    y

  }

}

#' Check if a value is a whole number

#'

#' @param x (`numeric(1)`)\cr a numeric value.

#' @param tol (`numeric(1)`)\cr a precision tolerance.

#'

#' @return `TRUE` if `x` is within `tol` of zero, `FALSE` otherwise.

#'

#' @examples

#' is.wholenumber(5)

#' is.wholenumber(5.00000000000000001)

#' is.wholenumber(.5)

#'

#' @export

is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) {

  abs(x - round(x)) < tol

}

RetroSearch is an open source project built by @garambo | Open a GitHub Issue

Search and Browse the WWW like it's 1997 | Search results from DuckDuckGo

HTML: 3.2 | Encoding: UTF-8 | Version: 0.7.4