- | 1168 |
+ 1172 |
|
}
@@ -15110,511 +15138,511 @@ formatters coverage - 94.52%
-
+
| 1 |
|
- # `toString` ----
+ ### 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 |
|
- ## this can't be tested from within R
+ ### sufficient for hooking that class up to the `formatters` pagination and rendering
|
| 4 |
|
- # nocov start
+ ### machinery.
|
| 5 |
|
- #' @importFrom stats na.omit
+
|
| 6 |
|
- #' @importFrom utils head tail localeToCharset
+
|
| 7 |
|
- #' @import checkmate
+ #' @import methods
|
| 8 |
|
-
+ #' @include matrix_form.R
|
| 9 |
|
- d_hsep_factory <- function() {
+ #'
|
| 10 |
|
- warn_sent <- FALSE
+ #' @title Make row layout summary data.frames for use during pagination
|
| 11 |
|
- function() {
+ #'
|
| 12 |
|
- if (any(grepl("^UTF", localeToCharset()))) {
+ #' @description
|
| 13 |
|
- "\u2014"
+ #' All relevant information about table rows (e.g. indentations) is summarized in a data.frames.
|
| 14 |
|
- } else {
+ #' This function works ONLY on `rtables` and `rlistings` objects, and not on their print counterparts
|
| 15 |
|
- if (!warn_sent && interactive()) {
+ #' (like `MatrixPrintForm`).
|
| 16 |
|
- message(
+ #'
|
| 17 |
|
- "Detected non-UTF charset. Falling back to '-' ",
+ #' @name make_row_df
|
| 18 |
|
- "as default header/body separator. This warning ",
+ #'
|
| 19 |
|
- "will only be shown once per R session."
+ #' @param tt ANY. Object representing the table-like object to be summarized.
|
| 20 |
|
- )
+ #' @param visible_only logical(1). Should only visible aspects of the table structure be reflected in this summary.
|
| 21 |
|
- warn_sent <<- TRUE
+ #' Defaults to \code{TRUE}. May not be supported by all methods.
|
| 22 |
|
- }
+ #' @param incontent logical(1). Internal detail do not set manually.
|
| 23 |
|
- "-"
+ #' @param repr_ext integer(1). Internal detail do not set manually.
|
| 24 |
|
- }
+ #' @param repr_inds integer. Internal detail do not set manually.
|
| 25 |
|
- }
+ #' @param sibpos integer(1). Internal detail do not set manually.
|
| 26 |
|
- }
+ #' @param nsibs integer(1). Internal detail do not set manually.
|
| 27 |
|
-
+ #' @param rownum numeric(1). Internal detail do not set manually.
|
| 28 |
|
- #' Default horizontal Separator
+ #' @param indent integer(1). Internal detail do not set manually.
|
| 29 |
|
- #'
+
|
| 30 |
|
- #' The default horizontal separator character which can be
+ #' @param colwidths numeric. Internal detail do not set manually.
|
| 31 |
|
- #' displayed in the current `charset` for use in rendering table-likes.
+ #' @param path character. Path to the (sub)table represented by
|
| 32 |
|
- #'
+ #' \code{tt}. Defaults to \code{character()}
|
| 33 |
|
- #' @return `unicode` 2014 (long dash for generating solid horizontal line)
+ #' @param max_width numeric(1) or NULL. Maximum width for title/footer
|
| 34 |
|
- #' if in a locale that uses a UTF character set, otherwise an ASCII hyphen
+ #' materials.
|
| 35 |
|
- #' with a once-per-session warning.
+ #'
|
| 36 |
|
- #'
+ #' @details When \code{visible_only} is \code{TRUE} (the default),
|
| 37 |
|
- #' @export
+ #' methods should return a data.frame with exactly one row per
|
| 38 |
|
- #' @examples
+ #' visible row in the table-like object. This is useful when
|
| 39 |
|
- #' default_hsep()
+ #' reasoning about how a table will print, but does not reflect
|
| 40 |
|
- default_hsep <- d_hsep_factory()
+ #' the full pathing space of the structure (though the paths which
|
| 41 |
|
-
+ #' are given will all work as is).
|
| 42 |
|
- # nocov end
+ #'
|
| 43 |
|
-
+ #' If supported, when \code{visible_only} is \code{FALSE}, every
|
| 44 |
|
- .calc_cell_widths <- function(mat, colwidths, col_gap) {
+ #' structural element of the table (in row-space) will be reflected in
|
-
+
| 45 |
- 142x |
+ |
- spans <- mat$spans
+ #' the returned data.frame, meaning the full pathing-space will be
|
-
+
| 46 |
- 142x |
+ |
- keep_mat <- mat$display
+ #' represented but some rows in the layout summary will not represent
|
-
+
| 47 |
- 142x |
+ |
- body <- mat$strings
+ #' printed rows in the table as it is displayed.
|
| 48 |
|
-
+ #'
|
-
+
| 49 |
- 142x |
+ |
- nr <- nrow(body)
+ #' Most arguments beyond \code{tt} and \code{visible_only} are present so that
|
| 50 |
|
-
+ #' `make_row_df` methods can call `make_row_df` recursively and retain information,
|
-
+
| 51 |
- 142x |
+ |
- cell_widths_mat <- matrix(rep(colwidths, nr), nrow = nr, byrow = TRUE)
+ #' and should not be set during a top-level call
|
-
+
| 52 |
- 142x |
+ |
- nc <- ncol(cell_widths_mat)
+ #'
|
| 53 |
|
-
+ #' @note the technically present root tree node is excluded from the summary returned by
|
-
+
| 54 |
- 142x |
+ |
- for (i in seq_len(nrow(body))) {
+ #' both \code{make_row_df} and \code{make_col_df} (see `rtables::make_col_df`), as it is simply the
|
-
+
| 55 |
- 2691x |
+ |
- if (any(!keep_mat[i, ])) { # any spans?
+ #' row/column structure of \code{tt} and thus not useful for pathing or pagination.
|
-
+
| 56 |
- 6x |
+ |
- j <- 1
+ #' @return a data.frame of row/column-structure information used by the pagination machinery.
|
-
+
| 57 |
- 6x |
+ |
- while (j <= nc) {
+ #'
|
-
+
| 58 |
- 10x |
+ |
- nj <- spans[i, j]
+ #' @rdname make_row_df
|
-
+
| 59 |
- 10x |
+ |
- j <- if (nj > 1) {
+ #' @export
|
-
+
| 60 |
- 6x |
+ |
- js <- seq(j, j + nj - 1)
+ ## nocov start
|
-
+
| 61 |
- 6x |
+ |
- cell_widths_mat[i, js] <- sum(cell_widths_mat[i, js]) + col_gap * (nj - 1)
+ setGeneric("make_row_df", function(tt, colwidths = NULL, visible_only = TRUE,
|
-
+
| 62 |
- 6x |
+ |
- j + nj
+ rownum = 0,
|
| 63 |
|
- } else {
+ indent = 0L,
|
-
+
| 64 |
- 4x |
+ |
- j + 1
+ path = character(),
|
| 65 |
|
- }
+ incontent = FALSE,
|
| 66 |
|
- }
+ repr_ext = 0L,
|
| 67 |
|
- }
+ repr_inds = integer(),
|
| 68 |
|
- }
+ sibpos = NA_integer_,
|
-
+
| 69 |
- 142x |
+ |
- cell_widths_mat
+ nsibs = NA_integer_,
|
| 70 |
|
- }
+ max_width = NULL) {
|
| 71 |
|
-
+ standardGeneric("make_row_df")
|
| 72 |
|
-
+ })
|
@@ -15628,105 +15656,105 @@ formatters coverage - 94.52%
74 |
|
- do_cell_fnotes_wrap <- function(mat, widths, max_width, tf_wrap) {
+ #' @rdname make_row_df
|
| 75 |
|
-
+ setMethod("make_row_df", "MatrixPrintForm", function(tt, colwidths = NULL, visible_only = TRUE,
|
-
+
| 76 |
- 84x |
+ |
- col_gap <- mf_colgap(mat)
+ rownum = 0,
|
-
+
| 77 |
- 84x |
+ |
- ncchar <- sum(widths) + (length(widths) - 1) * col_gap
+ indent = 0L,
|
-
+
| 78 |
- 84x |
+ |
- inset <- table_inset(mat)
+ path = character(),
|
| 79 |
|
-
+ incontent = FALSE,
|
| 80 |
|
- ## Text wrapping checks
+ repr_ext = 0L,
|
-
+
| 81 |
- 84x |
+ |
- if (tf_wrap) {
+ repr_inds = integer(),
|
-
+
| 82 |
- 19x |
+ |
- if (is.null(max_width)) {
+ sibpos = NA_integer_,
|
-
+
| 83 |
- 3x |
+ |
- max_width <- getOption("width", 80L)
+ nsibs = NA_integer_,
|
-
+
| 84 |
- 16x |
+ |
- } else if (is.character(max_width) && identical(max_width, "auto")) {
+ max_width = NULL) {
|
-
+
| 85 |
- ! |
+ |
- max_width <- ncchar + inset
+ stop("make_row_df can be used only on {rtables} table objects, and not on `matrix_form`-",
|
| 86 |
|
- }
+ "generated objects (MatrixPrintForm).")
|
-
+
| 87 |
- 19x |
+ |
- assert_number(max_width, lower = 0)
+ })
|
| 88 |
|
- }
+ ## nocov end
|
@@ -15740,644 +15768,644 @@ formatters coverage - 94.52%
90 |
|
- ## Check for having the right number of widths
+
|
-
+
| 91 |
- 84x |
+ |
- stopifnot(length(widths) == ncol(mat$strings))
+ #' Transform `rtable` to a list of matrices which can be used for outputting
|
| 92 |
|
-
+ #'
|
| 93 |
|
- ## format the to ASCII
+ #' Although `rtables` are represented as a tree data structure when outputting the table to ASCII or HTML it is useful to
|
-
+
| 94 |
- 84x |
+ |
- cell_widths_mat <- .calc_cell_widths(mat, widths, col_gap)
+ #' map the `rtable` to an in between state with the formatted cells in a matrix form.
|
| 95 |
|
- ## wrap_string calls strwrap, which destroys whitespace so we need to make
+ #'
|
| 96 |
|
- ## sure to put the indents back in
+ #' @param obj ANY. Object to be transformed into a ready-to-render form (a `MatrixPrintForm` object)
|
| 97 |
|
-
+ #' @param indent_rownames logical(1), if TRUE the column with the row names in the `strings` matrix of has indented row
|
| 98 |
|
- ## See if indentation is properly set
+ #' names (strings pre-fixed)
|
-
+
| 99 |
- 84x |
+ |
- ind_from_mf <- mf_rinfo(mat)$indent > 0
+ #' @param expand_newlines logical(1). Should the matrix form generated
|
-
+
| 100 |
- 84x |
+ |
- nlh <- mf_nlheader(mat)
+ #' expand rows whose values contain newlines into multiple
|
-
+
| 101 |
- 84x |
+ |
- ind_std <- paste0(rep(" ", mat$indent_size), collapse = "")
+ #' 'physical' rows (as they will appear when rendered into
|
| 102 |
|
- ## Body indentation
+ #' ASCII). Defaults to \code{TRUE}
|
-
+
| 103 |
- 84x |
+ |
- old_indent <- sapply(mf_rinfo(mat)$indent, function(i) paste0(rep(ind_std, i), collapse = ""))
+ #' @param indent_size numeric(1). Number of spaces to be used per level of indent (if supported by
|
| 104 |
|
- ## Header indentation (it happens with toplefts, not \n in titles, dealt afterwards)
+ #' the relevant method). Defaults to 2.
|
| 105 |
|
- ## NB: what about \n in topleft? -> not supported
+ #' @export
|
-
+
| 106 |
- 84x |
+ |
- header_indent <- gsub("^([[:space:]]*).*", "\\1", mat$strings[1:nlh, 1]) # Supposedly never with empty strings " "
+ #'
|
-
+
| 107 |
- 84x |
+ |
- old_indent <- c(header_indent, old_indent)
+ #' @details
|
-
+
| 108 |
- 84x |
+ |
- need_reindent <- nzchar(old_indent)
+ #'
|
| 109 |
|
- ## Check for which row has indent
+ #' The strings in the return object are defined as follows: row labels are those determined by \code{summarize_rows} and
|
-
+
| 110 |
- 84x |
+ |
- ind_from_strings <- nchar(old_indent)[-seq_len(nlh)] > 0
+ #' cell values are determined using \code{get_formatted_cells}.
|
-
+
| 111 |
- 84x |
+ |
- if (!all(ind_from_strings == ind_from_mf)) {
+ #' (Column labels are calculated using a non-exported internal function.
|
| 112 |
|
- stop("Row-info and string indentations are different.", # nocov
+ #'
|
| 113 |
|
- " Please contact the maintainer, this should not happen.") # nocov
+ #' @return A `MatrixPrintForm` classed list with the following elements:
|
| 114 |
|
- }
+ #' \describe{
|
-
+
| 115 |
- 84x |
+ |
- ori_mflg <- mf_lgrouping(mat) # Original groups
+ #' \item{strings}{The content, as it should be printed, of the top-left material, column headers, row labels, and
|
-
+
| 116 |
- 84x |
+ |
- reindent_old_idx <- ori_mflg[need_reindent] # Indent groups bf wrap
+ #' cell values of \code{tt}}
|
| 117 |
|
-
+ #' \item{spans}{The column-span information for each print-string in the strings matrix}
|
| 118 |
|
- ## Taking care in advance of indented word wrappings
+ #' \item{aligns}{The text alignment for each print-string in the strings matrix}
|
-
+
| 119 |
- 84x |
+ |
- cell_widths_mat[need_reindent, 1] <- cell_widths_mat[need_reindent, 1] - nchar(old_indent)[need_reindent]
+ #' \item{display}{Whether each print-string in the strings matrix should be printed or not}.
|
| 120 |
|
-
+ #' \item{row_info}{the data.frame generated by \code{summarize_rows(tt)}}
|
| 121 |
|
- ## Case in which the indentation is taking too much space vs desired wrapping
+ #' }
|
-
+
| 122 |
- 84x |
+ |
- if (any(cell_widths_mat < 0)) {
+ #'
|
-
+
| 123 |
- 1x |
+ |
- col_culprits <- apply(cell_widths_mat, 2, function(i) any(i < 0))
+ #' With an additional \code{nrow_header} attribute indicating the number of pseudo "rows" the
|
-
+
| 124 |
- 1x |
+ |
- stop(
+ #' column structure defines.
|
-
+
| 125 |
- 1x |
+ |
- "Inserted width(s) for column(s) ", which(col_culprits),
+ setGeneric("matrix_form", function(obj,
|
-
+
| 126 |
- 1x |
+ |
- " is(are) not wide enough for the desired indentation."
+ indent_rownames = FALSE,
|
| 127 |
|
- )
+ expand_newlines = TRUE,
|
| 128 |
|
- }
+ indent_size = 2) {
|
-
+
| 129 |
- |
+ 152x |
-
+ standardGeneric("matrix_form")
|
-
+
| 130 |
- 83x |
+ |
- new_strings <- matrix(
+ })
|
-
+
| 131 |
- 83x |
+ |
- unlist(mapply(wrap_string,
+
|
-
+
| 132 |
- 83x |
+ |
- str = mat$strings,
+
|
-
+
| 133 |
- 83x |
+ |
- max_width = cell_widths_mat,
+ #' @rdname matrix_form
|
-
+
| 134 |
- 83x |
+ |
- hard = TRUE
+ #' @export
|
| 135 |
|
- )),
+ setMethod("matrix_form", "MatrixPrintForm", function(obj,
|
-
+
| 136 |
- 83x |
+ |
- ncol = ncol(mat$strings)
+ indent_rownames = FALSE,
|
| 137 |
|
- )
+ expand_newlines = TRUE,
|
-
+
| 138 |
- 83x |
+ |
- mat$strings <- new_strings
+ indent_size = 2) {
|
-
+
| 139 |
- |
+ 152x |
-
+ obj
|
| 140 |
|
- ## XXXXX this is wrong and will break for listings cause we don't know when
+ })
|
| 141 |
|
- ## we need has_topleft to be FALSE!!!!!!!!!!
+
|
-
+
| 142 |
- 83x |
+ |
- mat <- mform_handle_newlines(mat)
+
|
| 143 |
|
-
+ ## Generics for `toString` and helper functions
|
| 144 |
|
- ## Indent groups after newline
+
|
-
+
| 145 |
- 83x |
+ |
- reindent_new_idx <- mf_lgrouping(mat) %in% reindent_old_idx
+
|
-
+
| 146 |
- 83x |
+ |
- if (anyNA(reindent_new_idx)) {
+ ## this is where we will take word wrapping
|
| 147 |
|
- stop("Unable to remap indenting after cell content text wrapping. ", # nocov
+ ## into account when it is added
|
| 148 |
|
- "Please contact the maintainer, this should not happen.") # nocov
+ ##
|
| 149 |
|
- }
+ ## ALL calculations of vertical space for pagination
|
| 150 |
|
-
+ ## purposes must go through nlines and divider_height!!!!!!!!
|
| 151 |
|
- ## Adding the indentation back in
+
|
-
+
| 152 |
- 83x |
+ |
- ind_v <- NULL
+ ## this will be customizable someday. I have foreseen it (spooky noises)
|
-
+
| 153 |
- 83x |
+ |
- for (i in mf_lgrouping(mat)[reindent_new_idx]) {
+ #' Divider Height
|
-
+
| 154 |
- 4x |
+ |
- ind_v <- c(ind_v, which(i == ori_mflg)[1])
+ #'
|
| 155 |
|
- }
+ #' @param obj ANY. Object.
|
-
+
| 156 |
- 83x |
+ |
- new_indent <- old_indent[ind_v]
+ #' @return The height, in lines of text, of the divider between
|
| 157 |
|
-
+ #' header and body. Currently returns \code{1L} for the default method.
|
| 158 |
|
- ## Additional safety check
+ #' @export
|
-
+
| 159 |
- 83x |
+ |
- if (length(new_indent) > 0 && !all(nzchar(new_indent))) {
+ #' @examples
|
| 160 |
|
- stop("Recovered indentation contains empty strings. This is an", # nocov
+ #' divider_height(mtcars)
|
-
+
| 161 |
- |
+ 20x |
- " indexing problem, please contact the maintainer, this should not happen.") # nocov
+ setGeneric("divider_height", function(obj) standardGeneric("divider_height"))
|
| 162 |
|
- }
+
|
| 163 |
|
-
+ #' @rdname divider_height
|
| 164 |
|
- ## Indentation is different for topleft material
+ #' @export
|
-
+
| 165 |
- 83x |
+ |
- if (isTRUE(mf_has_topleft(mat))) {
+ setMethod(
|
| 166 |
|
- ## mf_nlheader counts actual header lines while mf_nrheader is 'virtual'
+ "divider_height", "ANY",
|
-
+
| 167 |
- |
+ 20x |
- ## A bit of an hack, but unforeseen behavior, related to \n in topleft is not supported
+ function(obj) 1L
|
| 168 |
|
- ## Therefore, this still suppose that we dealt with \n in the cols before
+ )
|
-
+
| 169 |
- 2x |
+ |
- indx_topleft <- which(reindent_new_idx[1:nlh])
+
|
-
+
| 170 |
- 2x |
+ |
- new_indent[seq_along(indx_topleft)] <- old_indent[indx_topleft]
+ #' Number of lines required to print a value
|
| 171 |
|
- }
+ #' @param x ANY. The object to be printed
|
| 172 |
|
-
+ #' @param colwidths numeric. Column widths (if necessary).
|
| 173 |
|
- ## Main addition of the 'saved' indentation to strings
+ #' @param max_width numeric(1). Width strings should be wrapped to
|
-
+
| 174 |
- 83x |
+ |
- mf_strings(mat)[reindent_new_idx, 1] <- paste0(
+ #' when determining how many lines they require.
|
-
+
| 175 |
- 83x |
+ |
- new_indent,
+ #' @return A scalar numeric indicating the number of lines needed
|
-
+
| 176 |
- 83x |
+ |
- mat$strings[reindent_new_idx, 1]
+ #' to render the object \code{x}.
|
| 177 |
|
- )
+ #' @export
|
| 178 |
|
- ## this updates extents in rinfo AND nlines in ref_fnotes_df
+ setGeneric(
|
-
+
| 179 |
- 83x |
+ |
- mat <- update_mf_nlines(mat, max_width = max_width)
+ "nlines",
|
| 180 |
- 83x |
+ 26621x |
- mat
+ function(x, colwidths = NULL, max_width = NULL) standardGeneric("nlines")
|
| 181 |
|
- }
+ )
|
@@ -16391,469 +16419,469 @@ formatters coverage - 94.52%
183 |
|
- ## take a character vector and return whether the value is
+ ## XXX beware. I think it is dangerous
|
| 184 |
|
- ## a string version of a number or not
+ #' @export
|
| 185 |
|
- is_number_str <- function(vec) {
+ #' @rdname nlines
|
-
+
| 186 |
- ! |
+ |
- is.na(as.numeric(vec))
+ setMethod(
|
| 187 |
|
- }
+ "nlines", "list",
|
| 188 |
|
-
+ function(x, colwidths, max_width) {
|
-
+
| 189 |
- |
+ 2x |
- is_dec_align <- function(vec) {
+ if (length(x) == 0) {
|
-
+
| 190 |
- |
+ 1x |
- # "c" is not an alignment method we define in `formatters`,
+ 0L
|
| 191 |
|
- # but the reverse dependency package `tables` will need
+ } else {
|
| 192 |
- 378x |
+ 1x |
- sdiff <- setdiff(vec, c(list_valid_aligns(), "c"))
+ sum(unlist(vapply(x, nlines, NA_integer_,
|
| 193 |
- 378x |
+ 1x |
- if(length(sdiff) > 0)
+ colwidths = colwidths,
|
-
+
| 194 |
- ! |
+ 1x |
- stop("Invalid text-alignment(s): ",
+ max_width = max_width
|
-
+
| 195 |
- ! |
+ |
- paste(sdiff, collapse = ", "))
+ )))
|
-
+
| 196 |
- 378x |
+ |
- grepl("dec", vec)
+ }
|
| 197 |
|
- }
+ }
|
| 198 |
|
-
+ )
|
-
+
| 199 |
- 233x |
+ |
- any_dec_align <- function(vec) any(is_dec_align(vec))
+
|
| 200 |
|
-
+ #' @export
|
| 201 |
|
- #' Decimal Alignment
+ #' @rdname nlines
|
| 202 |
|
- #'
+ setMethod("nlines", "NULL", function(x, colwidths, max_width) 0L)
|
| 203 |
|
- #' @description Aligning decimal values of string matrix. Allowed alignments are: `dec_left`,
+
|
| 204 |
|
- #' `dec_right` and `decimal`.
+ #' @export
|
| 205 |
|
- #'
+ #' @rdname nlines
|
| 206 |
|
- #' @param string_mat character matrix. String matrix component of matrix print form object.
+ setMethod("nlines", "character", function(x, colwidths, max_width) {
|
-
+
| 207 |
- |
+ 26618x |
- #' @param align_mat character matrix. Aligns matrix component of matrix print form object.
+ if (length(x) == 0) {
|
-
+
| 208 |
- |
+ 1x |
- #' Should contain either `dec_left`, `dec_right` or `decimal` for values to be decimal aligned.
+ return(0L)
|
| 209 |
|
- #'
+ }
|
| 210 |
|
- #' @details Decimal alignment left and right (`dec_left` and `dec_right`) are different to
+
|
-
+
| 211 |
- |
+ 26617x |
- #' center decimal alignment `decimal` only in the case some padding is present. This may
+ sum(vapply(strsplit(x, "\n", fixed = TRUE),
|
-
+
| 212 |
- |
+ 26617x |
- #' happen if column widths are wider by setting parameters `widths` in `toString` or
+ function(xi, max_width) {
|
-
+
| 213 |
- |
+ 26623x |
- #' `colwidths` in `paginate_*` accordingly. It will be also the case (more common) of
+ if (length(xi) == 0) {
|
-
+
| 214 |
- |
+ 2415x |
- #' wider column names. Decimal alignment is not supported along with cell wrapping.
+ 1L
|
-
+
| 215 |
- |
+ 24208x |
- #'
+ } else if (length(max_width) == 0) { ## this happens with strsplit("", "\n")
|
-
+
| 216 |
- |
+ 24159x |
- #' @examples
+ length(xi)
|
| 217 |
|
- #' dfmf <- basic_matrix_form(mtcars[1:5,])
+ } else {
|
-
+
| 218 |
- |
+ 49x |
- #' aligns <- mf_aligns(dfmf)
+ length(wrap_txt(xi, max_width))
|
| 219 |
|
- #' aligns[, -c(1)] <- "dec_left"
+ }
|
-
+
| 220 |
- |
+ 26617x |
- #' decimal_align(mf_strings(dfmf), aligns)
+ }, 1L,
|
-
+
| 221 |
- |
+ 26617x |
- #'
+ max_width = max_width
|
| 222 |
|
- #' @return Processed string matrix of matrix print form with decimal aligned values.
+ ))
|
| 223 |
|
- #'
+ })
|
| 224 |
|
- #' @seealso [toString] and [MatrixPrintForm]
+
|
| 225 |
|
- #'
+
|
| 226 |
|
- #' @export
+
|
| 227 |
|
- decimal_align <- function(string_mat, align_mat) {
+ #' @title `toString`
|
| 228 |
|
- ## Evaluate if any values are to be decimal aligned
+ #'
|
-
+
| 229 |
- 45x |
+ |
- if (!any_dec_align(align_mat)) {
+ #' @description Transform a complex object into a string representation ready
|
-
+
| 230 |
- ! |
+ |
- return(string_mat)
+ #' to be printed or written to a plain-text file
|
| 231 |
|
- }
+ #'
|
-
+
| 232 |
- 45x |
+ |
- for (i in seq(1, ncol(string_mat))) {
+ #' @param x ANY. Object to be prepared for rendering.
|
| 233 |
|
- ## Take a column and its decimal alignments
+ #' @param ... Passed to individual methods.
|
-
+
| 234 |
- 145x |
+ |
- col_i <- as.character(string_mat[, i])
+ #' @rdname tostring
|
-
+
| 235 |
- 145x |
+ |
- align_col_i <- is_dec_align(align_mat[, i])
+ #' @export
|
| 236 |
|
-
+ setGeneric("toString", function(x, ...) standardGeneric("toString"))
|
| 237 |
|
- ## !( A || B) -> !A && !B DeMorgan's Law
+
|
| 238 |
|
- ## Are there any values to be decimal aligned? safe if
+ ## preserve S3 behavior
|
-
+
| 239 |
- 145x |
+ |
- if (any(align_col_i) && any(!grepl("^[0-9]\\.", col_i))) {
+ setMethod("toString", "ANY", base::toString) ## nocov
|
| 240 |
|
- ## Extract values not to be aligned (NAs, non-numbers,
+
|
| 241 |
|
- ## doesn't say "decimal" in alignment matrix)
+ #' @title Print
|
| 242 |
|
- ## XXX FIXME because this happens after formatting, we can't tell the difference between
+ #'
|
| 243 |
|
- ## non-number strings which come from na_str+ NA value and strings which just aren't numbers.
+ #' @description Print an R object. see \code{[base::print()]}
|
| 244 |
|
- ## this is a problem that should eventually be fixed.
+ #' @inheritParams base::print
|
-
+
| 245 |
- 82x |
+ |
- nas <- vapply(col_i, is.na, FUN.VALUE = logical(1))
+ #' @rdname basemethods
|
-
+
| 246 |
- 82x |
+ |
- nonnum <- !grepl("[0-9]", col_i)
+ setMethod("print", "ANY", base::print) ## nocov
|
| 247 |
|
- ## No grepl("[a-zA-Z]", col_i) because this excludes N=xx, e.g.
+
|
-
+
| 248 |
- 82x |
+ |
- nonalign <- nas | nonnum | !align_col_i
+
|
-
+
| 249 |
- 82x |
+ |
- col_ia <- col_i[!nonalign]
+
|
@@ -16867,1785 +16895,1785 @@ formatters coverage - 94.52%
251 |
|
- ## Do decimal alignment
+
|
-
+
| 252 |
- 82x |
+ |
- if (length(col_ia) > 0) {
+
|
| 253 |
|
- # Special case: scientific notation
+
|
-
+
| 254 |
- 82x |
+ |
- has_sc_not <- grepl("\\d+[e|E][\\+|\\-]\\d+", col_ia)
+
|
-
+
| 255 |
- 82x |
+ |
- if(any(has_sc_not)) {
+
|
-
+
| 256 |
- 1x |
+ |
- stop("Found values using scientific notation between the ones that",
+
|
-
+
| 257 |
- 1x |
+ |
- " needs to be decimal aligned (aligns is decimal, dec_left or dec_right).",
+ ## General/"universal" property `getter` and `setter` generics and stubs
|
-
+
| 258 |
- 1x |
+ |
- " Please consider using format functions to get a complete decimal ",
+
|
-
+
| 259 |
- 1x |
+ |
- "(e.g. formatC).")
+ #' @title Label, Name and Format accessor generics
|
| 260 |
|
- }
+ #'
|
| 261 |
|
-
+ #' @description `Getters` and `setters` for basic, relatively universal attributes
|
| 262 |
|
- ## Count the number of numbers in the string
+ #' of "table-like" objects"
|
-
+
| 263 |
- 81x |
+ |
- matches <- gregexpr("\\d+\\.\\d+|\\d+", col_ia)
+ #'
|
-
+
| 264 |
- 81x |
+ |
- more_than_one <- vapply(matches, function(x) {
+ #' @name lab_name
|
-
+
| 265 |
- 685x |
+ |
- sum(attr(x, "match.length") > 0) > 1
+ #' @param obj ANY. The object.
|
-
+
| 266 |
- 81x |
+ |
- }, logical(1))
+ #' @param value character(1)/FormatSpec. The new value of the attribute.
|
| 267 |
|
- ## Throw error in case any have more than 1 numbers
+ #' @return the name, format or label of \code{obj} for `getters`, or \code{obj} after modification
|
-
+
| 268 |
- 81x |
+ |
- if (any(more_than_one)) {
+ #' for setters.
|
-
+
| 269 |
- 2x |
+ |
- stop("Decimal alignment is not supported for multiple values. ",
+ #' @aliases obj_name
|
-
+
| 270 |
- 2x |
+ |
- "Found the following string with multiple numbers ",
+ #' @export
|
-
+
| 271 |
- 2x |
+ |
- "(first 3 selected from column ", col_i[1],"): '",
+
|
-
+
| 272 |
- 2x |
+ |
- paste0(col_ia[more_than_one][seq(1, 3)],
+ ## no exported methods so we do nocov
|
-
+
| 273 |
- 2x |
+ |
- collapse = "', '"), "'")
+ # nocov start
|
| 274 |
|
- }
+ setGeneric("obj_name", function(obj) standardGeneric("obj_name"))
|
| 275 |
|
- ## General split (only one match -> the first)
+
|
-
+
| 276 |
- 79x |
+ |
- main_regexp <- regexpr("\\d+", col_ia)
+
|
-
+
| 277 |
- 79x |
+ |
- left <- regmatches(col_ia, main_regexp, invert = FALSE)
+ #' @rdname lab_name
|
-
+
| 278 |
- 79x |
+ |
- right <- regmatches(col_ia, main_regexp, invert = TRUE)
+ #' @export
|
-
+
| 279 |
- 79x |
+ |
- right <- sapply(right, "[[", 2)
+ setGeneric("obj_name<-", function(obj, value) standardGeneric("obj_name<-"))
|
-
+
| 280 |
- 79x |
+ |
- something_left <- sapply(strsplit(col_ia, "\\d+"), "[[", 1)
+ # nocov end
|
-
+
| 281 |
- 79x |
+ |
- left <- paste0(something_left, left)
+
|
-
+
| 282 |
- 79x |
+ |
- if (!checkmate::test_set_equal(paste0(left, right), col_ia))
+ #' @seealso with_label
|
-
+
| 283 |
- ! |
+ |
- stop("Split string list lost some piece along the way. This ",
+ #' @rdname lab_name
|
-
+
| 284 |
- ! |
+ |
- "should not have happened. Please contact the maintainer.") # nocov
+ #' @export
|
| 285 |
- 79x |
+ 3x |
- separator <- sapply(right, function(x) {
+ setGeneric("obj_label", function(obj) standardGeneric("obj_label"))
|
-
+
| 286 |
- 639x |
+ |
- if (nzchar(x)) {
+
|
-
+
| 287 |
- 346x |
+ |
- substr(x, 1, 1)
+ #' @rdname lab_name
|
| 288 |
|
- } else {
+ #' @param value character(1). The new label
|
-
+
| 289 |
- 293x |
+ |
- c(" ")
+ #' @export
|
-
+
| 290 |
- |
+ 2x |
- }
+ setGeneric("obj_label<-", function(obj, value) standardGeneric("obj_label<-"))
|
-
+
| 291 |
- 79x |
+ |
- }, USE.NAMES = FALSE)
+
|
-
+
| 292 |
- 79x |
+ |
- right <- sapply(right, function(x) {
+ #' @rdname lab_name
|
-
+
| 293 |
- 639x |
+ |
- if (nchar(x) > 1) {
+ #' @exportMethod obj_label
|
| 294 |
- 314x |
+ 3x |
- substr(x, 2, nchar(x))
+ setMethod("obj_label", "ANY", function(obj) attr(obj, "label"))
|
| 295 |
|
- } else {
+
|
-
+
| 296 |
- 325x |
+ |
- c("")
+ #' @rdname lab_name
|
| 297 |
|
- }
+ #' @exportMethod obj_label<-
|
-
+
| 298 |
- 79x |
+ |
- }, USE.NAMES = FALSE)
+ setMethod(
|
| 299 |
|
- ## figure out whether we need space separators (at least one had a "." or not)
+ "obj_label<-", "ANY",
|
-
+
| 300 |
- 79x |
+ |
- if(!any(grepl("[^[:space:]]", separator)))
+ function(obj, value) {
|
| 301 |
- 26x |
+ 2x |
- separator <- gsub("[[:space:]]*", "", separator)
+ attr(obj, "label") <- value
|
-
+
| 302 |
- |
+ 2x |
- ## modify the piece with spaces
+ obj
|
-
+
| 303 |
- 79x |
+ |
- left_mod <- paste0(spaces(max(nchar(left), na.rm = TRUE) - nchar(left)), left)
+ }
|
-
+
| 304 |
- 79x |
+ |
- right_mod <- paste0(right, spaces(max(nchar(right), na.rm = TRUE) - nchar(right)))
+ )
|
| 305 |
|
- # Put everything together
+
|
-
+
| 306 |
- 79x |
+ |
- aligned <- paste(left_mod, separator, right_mod, sep = "")
+ #' @rdname lab_name
|
-
+
| 307 |
- 79x |
+ |
- string_mat[!nonalign, i] <- aligned
+ #' @export
|
-
+
| 308 |
- |
+ 131x |
- }
+ setGeneric("obj_format", function(obj) standardGeneric("obj_format"))
|
| 309 |
|
- }
+ ## this covers rcell, etc
|
| 310 |
|
- }
+ #' @rdname lab_name
|
-
+
| 311 |
- 42x |
+ |
- string_mat
+ #' @exportMethod obj_format
|
-
+
| 312 |
- |
+ 129x |
- }
+ setMethod("obj_format", "ANY", function(obj) attr(obj, "format", exact = TRUE))
|
| 313 |
|
-
+ #' @rdname lab_name
|
| 314 |
|
- #' @rdname tostring
+ #' @export
|
-
+
| 315 |
- |
+ 2x |
- #'
+ setMethod("obj_format", "fmt_config", function(obj) obj@format)
|
| 316 |
|
- #' @inheritParams MatrixPrintForm
+
|
| 317 |
|
- #' @param widths numeric (or NULL). (proposed) widths for the columns
+ #' @export
|
| 318 |
|
- #' of \code{x}. The expected length of this numeric vector can be
+ #' @rdname lab_name
|
-
+
| 319 |
- |
+ 3x |
- #' retrieved with `ncol() + 1` as the column of row names must
+ setGeneric("obj_format<-", function(obj, value) standardGeneric("obj_format<-"))
|
| 320 |
|
- #' also be considered.
+ ## this covers rcell, etc
|
| 321 |
|
- #' @param hsep character(1). Characters to repeat to create
+ #' @exportMethod obj_format<-
|
| 322 |
|
- #' header/body separator line.
+ #' @rdname lab_name
|
| 323 |
|
- #' @param tf_wrap logical(1). Should the texts for title, subtitle,
+ setMethod("obj_format<-", "ANY", function(obj, value) {
|
-
+
| 324 |
- |
+ 2x |
- #' and footnotes be wrapped?
+ attr(obj, "format") <- value
|
-
+
| 325 |
- |
+ 2x |
- #' @param max_width integer(1), character(1) or NULL. Width that title
+ obj
|
| 326 |
|
- #' and footer (including footnotes) materials should be
+ })
|
| 327 |
|
- #' word-wrapped to. If NULL, it is set to the current print width
+ #' @rdname lab_name
|
| 328 |
|
- #' of the session (`getOption("width")`). If set to `"auto"`,
+ #' @export
|
| 329 |
|
- #' the width of the table (plus any table inset) is used. Ignored
+ setMethod("obj_format<-", "fmt_config", function(obj, value) {
|
-
+
| 330 |
- |
+ 1x |
- #' completely if `tf_wrap` is `FALSE`.
+ obj@format <- value
|
-
+
| 331 |
- |
+ 1x |
- #'
+ obj
|
| 332 |
|
- #' @details
+ })
|
| 333 |
|
- #'
+
|
| 334 |
|
- #' Manual insertion of newlines is not supported when `tf_wrap` is on
+ #' @rdname lab_name
|
| 335 |
|
- #' and will result in a warning and undefined wrapping behavior. Passing
+ #' @export
|
-
+
| 336 |
- |
+ 3x |
- #' vectors of already split strings remains supported, however in this
+ setGeneric("obj_na_str", function(obj) standardGeneric("obj_na_str"))
|
| 337 |
|
- #' case each string is word-wrapped separately with the behavior
+ #' @rdname lab_name
|
| 338 |
|
- #' described above.
+ #' @exportMethod obj_na_str
|
-
+
| 339 |
- |
+ 1x |
- #'
+ setMethod("obj_na_str", "ANY", function(obj) attr(obj, "format_na_str", exact = TRUE))
|
| 340 |
|
- #' @examples
+ #' @rdname lab_name
|
| 341 |
|
- #' mform <- basic_matrix_form(mtcars)
+ #' @export
|
-
+
| 342 |
- |
+ 2x |
- #' cat(toString(mform))
+ setMethod("obj_na_str", "fmt_config", function(obj) obj@format_na_str)
|
| 343 |
|
- #'
+
|
| 344 |
|
- #' @return A character string containing the ASCII rendering
+ #' @rdname lab_name
|
| 345 |
|
- #' of the table-like object represented by `x`
+ #' @export
|
-
+
| 346 |
- |
+ 2x |
- #'
+ setGeneric("obj_na_str<-", function(obj, value) standardGeneric("obj_na_str<-"))
|
| 347 |
|
- #' @exportMethod toString
+ #' @exportMethod obj_na_str<-
|
| 348 |
|
- setMethod("toString", "MatrixPrintForm", function(x,
+ #' @rdname lab_name
|
| 349 |
|
- widths = NULL,
+ setMethod("obj_na_str<-", "ANY", function(obj, value) {
|
-
+
| 350 |
- |
+ 1x |
- tf_wrap = FALSE,
+ attr(obj, "format_na_str") <- value
|
-
+
| 351 |
- |
+ 1x |
- max_width = NULL,
+ obj
|
| 352 |
|
- col_gap = mf_colgap(x),
+ })
|
| 353 |
|
- hsep = default_hsep()) {
+ #' @rdname lab_name
|
-
+
| 354 |
- 63x |
+ |
- assert_flag(tf_wrap)
+ #' @export
|
| 355 |
|
-
+ setMethod("obj_na_str<-", "fmt_config", function(obj, value) {
|
| 356 |
- 63x |
+ 1x |
- mat <- matrix_form(x, indent_rownames = TRUE)
+ obj@format_na_str <- value
|
| 357 |
- 63x |
+ 1x |
- inset <- table_inset(mat)
+ obj
|
| 358 |
|
-
+ })
|
| 359 |
|
- # if cells are decimal aligned, run propose column widths
+
|
| 360 |
|
- # if the provided widths is less than proposed width, return an error
+ #' @rdname lab_name
|
-
+
| 361 |
- 63x |
+ |
- if (any_dec_align(mf_aligns(mat))) {
+ #' @export
|
| 362 |
- 22x |
+ 3x |
- aligned <- propose_column_widths(x)
+ setGeneric("obj_align", function(obj) standardGeneric("obj_align"))
|
| 363 |
|
-
+ #' @rdname lab_name
|
| 364 |
|
- # catch any columns that require widths more than what is provided
+ #' @exportMethod obj_align
|
| 365 |
- 20x |
+ 1x |
- if (!is.null(widths)) {
+ setMethod("obj_align", "ANY", function(obj) attr(obj, "align", exact = TRUE))
|
-
+
| 366 |
- 9x |
+ |
- how_wide <- sapply(seq_along(widths), function(i) c(widths[i] - aligned[i]))
+ #' @rdname lab_name
|
-
+
| 367 |
- 9x |
+ |
- too_wide <- how_wide < 0
+ #' @export
|
| 368 |
- 9x |
+ 2x |
- if (any(too_wide)) {
+ setMethod("obj_align", "fmt_config", function(obj) obj@align)
|
-
+
| 369 |
- 2x |
+ |
- desc_width <- paste(paste(
+
|
-
+
| 370 |
- 2x |
+ |
- names(which(too_wide)),
+ #' @rdname lab_name
|
-
+
| 371 |
- 2x |
+ |
- paste0("(", how_wide[too_wide], ")")
+ #' @export
|
| 372 |
2x |
- ), collapse = ", ")
+ setGeneric("obj_align<-", function(obj, value) standardGeneric("obj_align<-"))
|
-
+
| 373 |
- 2x |
+ |
- stop(
+ #' @exportMethod obj_align<-
|
-
+
| 374 |
- 2x |
+ |
- "Inserted width(s) for column(s) ", desc_width,
+ #' @rdname lab_name
|
-
+
| 375 |
- 2x |
+ |
- " is(are) not wide enough for the desired alignment."
+ setMethod("obj_align<-", "ANY", function(obj, value) {
|
-
+
| 376 |
- |
+ 1x |
- )
+ attr(obj, "align") <- value
|
-
+
| 377 |
- |
+ 1x |
- }
+ obj
|
| 378 |
|
- }
+ })
|
| 379 |
|
- }
+ #' @rdname lab_name
|
| 380 |
|
-
+ #' @export
|
-
+
| 381 |
- 59x |
+ |
- if (is.null(widths)) {
+ setMethod("obj_align<-", "fmt_config", function(obj, value) {
|
| 382 |
- 49x |
+ 1x |
- widths <- mf_col_widths(x) %||% propose_column_widths(x)
+ obj@align <- value
|
-
+
| 383 |
- |
+ 1x |
- } else {
+ obj
|
-
+
| 384 |
- 10x |
+ |
- mf_col_widths(x) <- widths
+ })
|
| 385 |
|
- }
+
|
-
+
| 386 |
- 59x |
+ |
- ncchar <- sum(widths) + (length(widths) - 1) * col_gap
+ #' General title/footer accessors
|
| 387 |
|
-
+ #'
|
| 388 |
|
- ## Text wrapping checks
+ #' @param obj ANY. Object to extract information from.
|
-
+
| 389 |
- 59x |
+ |
- if (tf_wrap) {
+ #' @export
|
-
+
| 390 |
- 16x |
+ |
- if (is.null(max_width)) {
+ #' @rdname title_footer
|
-
+
| 391 |
- 11x |
+ |
- max_width <- getOption("width", 80L)
+ #' @return A character scalar (`main_title`), a character vector (`main_footer`), or
|
-
+
| 392 |
- 5x |
+ |
- } else if (is.character(max_width) && identical(max_width, "auto")) {
+ #' vector of length zero or more (`subtitles`, `page_titles`,
|
-
+
| 393 |
- 2x |
+ |
- max_width <- ncchar + inset
+ #' `prov_footer`) containing the relevant title/footer contents
|
-
+
| 394 |
- |
+ 90x |
- }
+ setGeneric("main_title", function(obj) standardGeneric("main_title"))
|
-
+
| 395 |
- 16x |
+ |
- assert_number(max_width, lower = 0)
+
|
| 396 |
|
- }
+ #' @export
|
| 397 |
|
-
+ #' @rdname title_footer
|
-
+
| 398 |
- 59x |
+ |
- mat <- do_cell_fnotes_wrap(mat, widths, max_width = max_width, tf_wrap = tf_wrap)
+ setMethod(
|
| 399 |
|
-
+ "main_title", "MatrixPrintForm",
|
| 400 |
- 58x |
+ 90x |
- body <- mf_strings(mat)
+ function(obj) obj$main_title
|
-
+
| 401 |
- 58x |
+ |
- aligns <- mf_aligns(mat)
+ )
|
-
+
| 402 |
- 58x |
+ |
- keep_mat <- mf_display(mat)
+
|
| 403 |
|
- ## spans <- mat$spans
+ ##' @rdname title_footer
|
| 404 |
|
- ## ri <- mat$row_info
+ ##' @export
|
| 405 |
- 58x |
+ 6x |
- ref_fnotes <- mf_rfnotes(mat)
+ setGeneric("main_title<-", function(obj, value) standardGeneric("main_title<-"))
|
-
+
| 406 |
- 58x |
+ |
- nl_header <- mf_nlheader(mat)
+ ##' @rdname title_footer
|
| 407 |
|
-
+ ##' @export
|
-
+
| 408 |
- 58x |
+ |
- cell_widths_mat <- .calc_cell_widths(mat, widths, col_gap)
+ setMethod(
|
| 409 |
|
-
+ "main_title<-", "MatrixPrintForm",
|
| 410 |
|
- # decimal alignment
+ function(obj, value) {
|
| 411 |
- 58x |
+ 6x |
- if (any_dec_align(aligns)) {
+ obj$main_title <- value
|
| 412 |
- 18x |
+ 6x |
- body <- decimal_align(body, aligns)
+ obj
|
| 413 |
|
- }
+ }
|
| 414 |
|
-
+ )
|
-
+
| 415 |
- 58x |
+ |
- content <- matrix(mapply(padstr, body, cell_widths_mat, aligns), ncol = ncol(body))
+
|
-
+
| 416 |
- 58x |
+ |
- content[!keep_mat] <- NA
+
|
| 417 |
|
- # apply(content, 1, function(x) sum(nchar(x), na.rm = TRUE))
+
|
| 418 |
|
-
+ #' @export
|
-
+
| 419 |
- 58x |
+ |
- gap_str <- strrep(" ", col_gap)
+ #' @rdname title_footer
|
| 420 |
|
-
+ setGeneric("subtitles", function(obj) standardGeneric("subtitles")) ## nocov
|
-
+
| 421 |
- 58x |
+ |
- div <- substr(strrep(hsep, ncchar), 1, ncchar)
+
|
-
+
| 422 |
- 58x |
+ |
- txt_head <- apply(head(content, nl_header), 1, .paste_no_na, collapse = gap_str)
+ #' @export
|
-
+
| 423 |
- 58x |
+ |
- sec_seps_df <- x$row_info[, c("abs_rownumber", "trailing_sep"), drop = FALSE]
+ #' @rdname title_footer
|
-
+
| 424 |
- 58x |
+ |
- if (!is.null(sec_seps_df) && any(!is.na(sec_seps_df$trailing_sep))) {
+ setMethod(
|
-
+
| 425 |
- 1x |
+ |
- bdy_cont <- tail(content, -nl_header)
+ "subtitles", "MatrixPrintForm",
|
-
+
| 426 |
- |
+ 91x |
- ## unfortunately we count "header rows" wrt line grouping so it
+ function(obj) obj$subtitles
|
| 427 |
|
- ## doesn't match the real (i.e. body) rows as is
+ )
|
-
+
| 428 |
- 1x |
+ |
- row_grouping <- tail(x$line_grouping, -nl_header) - mf_nrheader(x)
+
|
-
+
| 429 |
- 1x |
+ |
- nrbody <- NROW(bdy_cont)
+ ##' @rdname title_footer
|
-
+
| 430 |
- 1x |
+ |
- stopifnot(length(row_grouping) == nrbody)
+ ##' @export
|
| 431 |
|
- ## all rows with non-NA section divs and the final row (regardless of NA status)
+ setGeneric("subtitles<-", function(obj, value) standardGeneric("subtitles<-")) ## nocov
|
| 432 |
|
- ## fixes #77
+
|
-
+
| 433 |
- 1x |
+ |
- sec_seps_df <- sec_seps_df[unique(c(
+ ##' @rdname title_footer
|
-
+
| 434 |
- 1x |
+ |
- which(!is.na(sec_seps_df$trailing_sep)),
+ ##' @export
|
-
+
| 435 |
- 1x |
+ |
- NROW(sec_seps_df)
+ setMethod(
|
| 436 |
|
- )), ]
+ "subtitles<-", "MatrixPrintForm",
|
-
+
| 437 |
- 1x |
+ |
- txt_body <- character()
+ function(obj, value) {
|
| 438 |
- 1x |
+ 5x |
- sec_strt <- 1
+ obj$subtitles <- value
|
| 439 |
- 1x |
+ 5x |
- section_rws <- sec_seps_df$abs_rownumber
+ obj
|
-
+
| 440 |
- 1x |
+ |
- for (i in seq_len(NROW(section_rws))) {
+ }
|
-
+
| 441 |
- 2x |
+ |
- cur_rownum <- section_rws[i]
+ )
|
-
+
| 442 |
- 2x |
+ |
- sec_end <- max(which(row_grouping == cur_rownum))
+
|
-
+
| 443 |
- 2x |
+ |
- txt_body <- c(
+ #' @export
|
-
+
| 444 |
- 2x |
+ |
- txt_body,
+ #' @rdname title_footer
|
| 445 |
- 2x |
+ 107x |
- apply(bdy_cont[seq(sec_strt, sec_end), , drop = FALSE],
+ setGeneric("page_titles", function(obj) standardGeneric("page_titles"))
|
-
+
| 446 |
- 2x |
+ |
- 1,
+
|
-
+
| 447 |
- 2x |
+ |
- .paste_no_na,
+ #' @export
|
-
+
| 448 |
- 2x |
+ |
- collapse = gap_str
+ #' @rdname title_footer
|
| 449 |
|
- ),
+ setMethod(
|
| 450 |
|
- ## don't print section dividers if they would be the last thing before the
+ "page_titles", "MatrixPrintForm",
|
-
+
| 451 |
- |
+ 107x |
- ## footer divider
+ function(obj) obj$page_titles
|
| 452 |
|
- ## this also ensures an extraneous sec div won't be printed if we have non-sec-div
+ )
|
| 453 |
|
- ## rows after the last sec div row (#77)
+ #' @rdname title_footer
|
-
+
| 454 |
- 2x |
+ |
- if (sec_end < nrbody) {
+ #' @export
|
-
+
| 455 |
- 1x |
+ ! |
- substr(
+ setMethod("page_titles", "ANY", function(obj) NULL)
|
-
+
| 456 |
- 1x |
+ |
- strrep(sec_seps_df$trailing_sep[i], ncchar), 1,
+
|
-
+
| 457 |
- 1x |
+ |
- ncchar - inset
+ ##' @rdname title_footer
|
| 458 |
|
- )
+ ##' @export
|
-
+
| 459 |
- |
+ 2x |
- }
+ setGeneric("page_titles<-", function(obj, value) standardGeneric("page_titles<-"))
|
| 460 |
|
- )
+
|
-
+
| 461 |
- 2x |
+ |
- sec_strt <- sec_end + 1
+ #' @export
|
| 462 |
|
- }
+ #' @rdname title_footer
|
| 463 |
|
- } else {
+ setMethod(
|
-
+
| 464 |
- 57x |
+ |
- txt_body <- apply(tail(content, -nl_header), 1, .paste_no_na, collapse = gap_str)
+ "page_titles<-", "MatrixPrintForm",
|
| 465 |
|
- }
+ function(obj, value) {
|
-
+
| 466 |
- |
+ 2x |
-
+ if (!is.character(value)) {
|
-
+
| 467 |
- |
+ ! |
-
+ stop("page titles must be in the form of a character vector, got object of class ", class(value))
|
-
+
| 468 |
- 58x |
+ |
- allts <- all_titles(x)
+ }
|
-
+
| 469 |
- |
+ 2x |
-
+ obj$page_titles <- value
|
| 470 |
- 58x |
+ 2x |
- allfoots <- list(
+ obj
|
-
+
| 471 |
- 58x |
+ |
- "main_footer" = main_footer(x),
+ }
|
-
+
| 472 |
- 58x |
+ |
- "prov_footer" = prov_footer(x),
+ )
|
-
+
| 473 |
- 58x |
+ |
- "ref_footnotes" = ref_fnotes
+
|
| 474 |
|
- )
+
|
-
+
| 475 |
- 58x |
+ |
- allfoots <- allfoots[!sapply(allfoots, is.null)]
+
|
| 476 |
|
-
+ #' @export
|
| 477 |
|
-
+ #' @rdname title_footer
|
-
+
| 478 |
- |
+ 85x |
- ## Wrapping titles if they go beyond the horizontally allowed space
+ setGeneric("main_footer", function(obj) standardGeneric("main_footer"))
|
-
+
| 479 |
- 58x |
+ |
- if (tf_wrap) {
+
|
-
+
| 480 |
- 16x |
+ |
- new_line_warning(allts)
+ #' @export
|
-
+
| 481 |
- 16x |
+ |
- allts <- wrap_txt(allts, max_width = max_width)
+ #' @rdname title_footer
|
| 482 |
|
- }
+ setMethod(
|
| 483 |
|
-
+ "main_footer", "MatrixPrintForm",
|
| 484 |
- 58x |
+ 85x |
- titles_txt <- if (any(nzchar(allts))) c(allts, "", .do_inset(div, inset)) else NULL
+ function(obj) obj$main_footer
|
| 485 |
|
-
+ )
|
| 486 |
|
- # Wrapping footers if they go beyond the horizontally allowed space
+
|
-
+
| 487 |
- 58x |
+ |
- if (tf_wrap) {
+ #' @rdname title_footer
|
-
+
| 488 |
- 16x |
+ |
- new_line_warning(allfoots)
+ #' @param value character. New value.
|
-
+
| 489 |
- 16x |
+ |
- allfoots$main_footer <- wrap_txt(allfoots$main_footer, max_width - inset)
+ #' @export
|
| 490 |
- 16x |
+ 6x |
- allfoots$ref_footnotes <- wrap_txt(allfoots$ref_footnotes, max_width - inset)
+ setGeneric("main_footer<-", function(obj, value) standardGeneric("main_footer<-"))
|
| 491 |
|
- ## no - inset here because the prov_footer is not inset
+
|
-
+
| 492 |
- 16x |
+ |
- allfoots$prov_footer <- wrap_txt(allfoots$prov_footer, max_width)
+
|
| 493 |
|
- }
+
|
| 494 |
|
-
+ #' @export
|
-
+
| 495 |
- 58x |
+ |
- paste0(paste(
+ #' @rdname title_footer
|
-
+
| 496 |
- 58x |
+ |
- c(
+ setMethod(
|
-
+
| 497 |
- 58x |
+ |
- titles_txt,
+ "main_footer<-", "MatrixPrintForm",
|
-
+
| 498 |
- 58x |
+ |
- .do_inset(txt_head, inset),
+ function(obj, value) {
|
| 499 |
- 58x |
+ 6x |
- .do_inset(div, inset),
+ if (!is.character(value)) {
|
-
+
| 500 |
- 58x |
+ ! |
- .do_inset(txt_body, inset),
+ stop("main footer must be a character vector. Got object of class ", class(value))
|
-
+
| 501 |
- 58x |
+ |
- .footer_inset_helper(allfoots, div, inset)
+ }
|
-
+
| 502 |
- |
+ 6x |
- ),
+ obj$main_footer <- value
|
| 503 |
- 58x |
+ 6x |
- collapse = "\n"
+ obj
|
-
+
| 504 |
- 58x |
+ |
- ), "\n")
+ }
|
| 505 |
|
- })
+ )
|
@@ -18659,182 +18687,182 @@ formatters coverage - 94.52%
507 |
|
- .do_inset <- function(x, inset) {
+
|
-
+
| 508 |
- 322x |
-
- if (inset == 0 || !any(nzchar(x))) {
- |
-
-
- | 509 |
- 303x |
+ |
- return(x)
+ #' @export
|
- | 510 |
+ 509 |
|
- }
+ #' @rdname title_footer
|
+ | 510 |
+ 95x |
+
+ setGeneric("prov_footer", function(obj) standardGeneric("prov_footer"))
+ |
+
+
| 511 |
- 19x |
+ |
- padding <- strrep(" ", inset)
+
|
-
+
| 512 |
- 19x |
+ |
- if (is.character(x)) {
+ #' @export
|
-
+
| 513 |
- 19x |
+ |
- x <- paste0(padding, x)
+ #' @rdname title_footer
|
-
+
| 514 |
- ! |
+ |
- } else if (is(x, "matrix")) {
+ setMethod(
|
-
+
| 515 |
- ! |
+ |
- x[, 1] <- .do_inset(x[, 1, drop = TRUE], inset)
+ "prov_footer", "MatrixPrintForm",
|
-
+
| 516 |
- |
+ 95x |
- }
+ function(obj) obj$prov_footer
|
-
+
| 517 |
- 19x |
+ |
- x
+ )
|
| 518 |
|
- }
+
|
| 519 |
|
-
+ #' @rdname title_footer
|
| 520 |
|
-
+ #' @export
|
-
+
| 521 |
- |
+ 7x |
- .inset_div <- function(txt, div, inset) {
+ setGeneric("prov_footer<-", function(obj, value) standardGeneric("prov_footer<-"))
|
-
+
| 522 |
- 40x |
+ |
- c(.do_inset(div, inset), "", txt)
+
|
| 523 |
|
- }
+ #' @export
|
| 524 |
|
-
+ #' @rdname title_footer
|
| 525 |
|
- .footer_inset_helper <- function(footers_v, div, inset) {
+ setMethod(
|
-
+
| 526 |
- 58x |
+ |
- div_done <- FALSE # nolint
+ "prov_footer<-", "MatrixPrintForm",
|
-
+
| 527 |
- 58x |
+ |
- fter <- footers_v$main_footer
+ function(obj, value) {
|
| 528 |
- 58x |
+ 7x |
- prvf <- footers_v$prov_footer
+ if (!is.character(value)) {
|
-
+
| 529 |
- 58x |
+ ! |
- rfn <- footers_v$ref_footnotes
+ stop("provenance footer must be a character vector. Got object of class ", class(value))
|
-
+
| 530 |
- 58x |
+ |
- footer_txt <- .do_inset(rfn, inset)
+ }
|
| 531 |
- 58x |
+ 7x |
- if (any(nzchar(footer_txt))) {
+ obj$prov_footer <- value
|
| 532 |
- 14x |
+ 7x |
- footer_txt <- .inset_div(footer_txt, div, inset)
+ obj
|
@@ -18844,7423 +18872,7423 @@ formatters coverage - 94.52%
}
-
+
| 534 |
- 58x |
+ |
- if (any(vapply(
+ )
|
-
+
| 535 |
- 58x |
+ |
- footers_v, function(x) any(nzchar(x)),
+
|
-
+
| 536 |
- 58x |
+ |
- TRUE
+
|
| 537 |
|
- ))) {
+
|
-
+
| 538 |
- 26x |
+ |
- if (any(nzchar(prvf))) {
+
|
-
+
| 539 |
- 24x |
+ |
- provtxt <- c(
+ #' @rdname title_footer
|
-
+
| 540 |
- 24x |
+ |
- if (any(nzchar(fter))) "",
+ #' @export
|
| 541 |
- 24x |
+ 1x |
- prvf
+ all_footers <- function(obj) c(main_footer(obj), prov_footer(obj))
|
| 542 |
|
- )
+
|
| 543 |
|
- } else {
+ #' @rdname title_footer
|
-
+
| 544 |
- 2x |
+ |
- provtxt <- character()
+ #' @export
|
-
+
| 545 |
- |
+ 88x |
- }
+ all_titles <- function(obj) c(main_title(obj), subtitles(obj), page_titles(obj))
|
-
+
| 546 |
- 26x |
+ |
- footer_txt <- c(
+
|
-
+
| 547 |
- 26x |
+ |
- footer_txt,
+
|
-
+
| 548 |
- 26x |
+ |
- .inset_div(
+ #' Access or (recursively) set table inset.
|
-
+
| 549 |
- 26x |
+ |
- c(
+ #'
|
-
+
| 550 |
- 26x |
+ |
- .do_inset(fter, inset),
+ #' Table inset is the amount of characters that the body of
|
-
+
| 551 |
- 26x |
+ |
- provtxt
+ #' a table, referential footnotes, and main footer material
|
| 552 |
|
- ),
+ #' are inset from the left-alignment of the titles and provenance
|
-
+
| 553 |
- 26x |
+ |
- div,
+ #' footer materials.
|
-
+
| 554 |
- 26x |
+ |
- inset
+ #'
|
| 555 |
|
- )
+ #' @param obj ANY. Object to get or (recursively if necessary) set
|
| 556 |
|
- )
+ #' table inset for.
|
| 557 |
|
- }
+ #' @param value character(1). String to use as new header/body separator.
|
-
+
| 558 |
- 58x |
+ |
- footer_txt
+ #'
|
| 559 |
|
- }
+ #' @return for `table_inset` the integer value that the table body
|
| 560 |
|
-
+ #' (including column heading information and section dividers),
|
| 561 |
|
- new_line_warning <- function(str_v) {
+ #' referential footnotes, and main footer should be inset from the
|
-
+
| 562 |
- 32x |
+ |
- if (any(unlist(sapply(str_v, grepl, pattern = "\n")))) {
+ #' left alignment of the titles and provenance footers during rendering.
|
-
+
| 563 |
- 2x |
+ |
- msg <- c(
+ #' For `table_inset<-`, the `obj`, with the new table_inset value
|
-
+
| 564 |
- 2x |
+ |
- "Detected manual newlines when automatic title/footer word-wrapping is on.",
+ #' applied recursively to it and all its subtables.
|
-
+
| 565 |
- 2x |
+ |
- "This is unsupported and will result in undefined behavior. Please either ",
+ #'
|
-
+
| 566 |
- 2x |
+ |
- "utilize automatic word-wrapping with newline characters inserted, or ",
+ #' @export
|
| 567 |
- 2x |
+ 187x |
- "turn off automatic wrapping and wordwrap all contents manually by inserting ",
+ setGeneric("table_inset", function(obj) standardGeneric("table_inset"))
|
-
+
| 568 |
- 2x |
+ |
- "newlines."
+
|
| 569 |
|
- )
+ #' @rdname table_inset
|
-
+
| 570 |
- 2x |
+ |
- warning(paste0(msg, collapse = ""))
+ #' @export
|
| 571 |
|
- }
+ setMethod(
|
| 572 |
|
- }
+ "table_inset", "MatrixPrintForm",
|
-
+
| 573 |
- |
+ 187x |
-
+ function(obj) obj$table_inset
|
| 574 |
|
- #' Wrap a string to within a maximum width
+ )
|
| 575 |
|
- #' @param str character(1). String to be wrapped
+
|
| 576 |
|
- #' @param max_width numeric(1). Maximum width, in characters, that the
+
|
| 577 |
|
- #' text should be wrapped at.
+ #' @rdname table_inset
|
| 578 |
|
- #' @param hard logical(1). Should hard wrapping (embedding newlines in
+ #' @export
|
-
+
| 579 |
- |
+ 4x |
- #' the incoming strings) or soft (breaking wrapped strings into vectors
+ setGeneric("table_inset<-", function(obj, value) standardGeneric("table_inset<-"))
|
| 580 |
|
- #' of length >1) be used. Defaults to `FALSE` (i.e. soft wrapping).
+
|
| 581 |
|
- #'
+ #' @rdname table_inset
|
| 582 |
|
- #' @details Word wrapping happens as with \link[base:strwrap]{base::strwrap}
+ #' @export
|
| 583 |
|
- #' with the following exception: individual words which are longer
+ setMethod(
|
| 584 |
|
- #' than `max_width` are broken up in a way that fits with the rest of the
+ "table_inset<-", "MatrixPrintForm",
|
| 585 |
|
- #' word wrapping.
+ function(obj, value) {
|
-
+
| 586 |
- |
+ 4x |
- #'
+ newval <- as.integer(value)
|
-
+
| 587 |
- |
+ 4x |
- #' @return A string (`wrap_string` or character vector (`wrap_txt`) containing
+ if (is.na(newval) || newval < 0) {
|
-
+
| 588 |
- |
+ 1x |
- #' the hard or soft word-wrapped content.
+ stop("Got invalid value for table_inset: ", newval)
|
| 589 |
|
- #'
+ }
|
-
+
| 590 |
- |
+ 3x |
- #' @export
+ obj$table_inset <- newval
|
-
+
| 591 |
- |
+ 3x |
- wrap_string <- function(str, max_width, hard = FALSE) {
+ obj
|
-
+
| 592 |
- 16149x |
+ |
- stopifnot(is.character(str) && length(str) == 1)
+ }
|
-
+
| 593 |
- 16149x |
+ |
- naive <- strwrap(str, max_width + 1)
+ )
|
-
+
| 594 |
- 16149x |
+ |
- while (any(nchar(naive) > max_width)) {
+
|
-
+
| 595 |
- 14x |
+ |
- good <- character()
+
|
-
+
| 596 |
- 14x |
+ |
- bwi <- which(nchar(naive) > max_width)[1]
+
|
-
+
| 597 |
- 14x |
+ |
- curbw <- naive[bwi]
+
|
-
+
| 598 |
- 14x |
+ |
- if (bwi > 2) {
+ #' Generic for Performing "Forced Pagination"
|
-
+
| 599 |
- ! |
+ |
- good <- c(good, naive[1:(bwi - 2)])
+ #'
|
| 600 |
|
- }
+ #' Forced pagination is pagination which happens regardless of
|
-
+
| 601 |
- 14x |
+ |
- if (bwi > 1) {
+ #' position on page. The object is expected to have all information
|
-
+
| 602 |
- 4x |
+ |
- str_before <- naive[bwi - 1]
+ #' necessary to locate such page breaks, and the `do_forced_pag`
|
| 603 |
|
- } else {
+ #' method is expected to fully perform those paginations.
|
-
+
| 604 |
- 10x |
+ |
- str_before <- ""
+ #'
|
| 605 |
|
- }
+ #' @param obj The object to be paginated.
|
-
+
| 606 |
- 14x |
+ |
- room <- max_width - nchar(str_before) - (bwi > 1)
+ #'
|
-
+
| 607 |
- 14x |
+ |
- if (room <= 0) {
+ #' The `ANY` method simply returns a list of length one, containing
|
-
+
| 608 |
- 4x |
+ |
- toadd <- c(str_before, substr(curbw, 1, max_width))
+ #' `obj`.
|
-
+
| 609 |
- 4x |
+ |
- room <- 0
+ #'
|
-
+
| 610 |
- 4x |
+ |
- leftover <- substr(curbw, max_width + 1, nchar(curbw))
+ #' @return a list of subobjects, which will be further paginated
|
| 611 |
|
- } else {
+ #' by the standard pagination algorithm.
|
-
+
| 612 |
- 10x |
+ |
- goodpart <- substr(curbw, 1, room)
+ #'
|
-
+
| 613 |
- 10x |
+ |
- if (nzchar(str_before)) {
+ #'
|
-
+
| 614 |
- ! |
+ |
- toadd <- paste(str_before, goodpart)
+ #' @export
|
-
+
| 615 |
- |
+ 46x |
- } else {
+ setGeneric("do_forced_paginate", function(obj) standardGeneric("do_forced_paginate"))
|
-
+
| 616 |
- 10x |
+ |
- toadd <- goodpart
+
|
| 617 |
|
- }
+ #' @export
|
-
+
| 618 |
- 10x |
+ |
- leftover <- substr(curbw, room + 1, nchar(curbw))
+ #' @rdname do_forced_paginate
|
-
+
| 619 |
- |
+ 43x |
- }
+ setMethod("do_forced_paginate", "ANY", function(obj) list(obj))
|
-
+
| 620 |
- 14x |
+ |
- good <- c(good, toadd)
+
|
-
+
| 621 |
- 14x |
+ |
- if (bwi == length(naive)) {
+ #' Number of repeated columns
|
-
+
| 622 |
- 13x |
+ |
- good <- c(good, leftover)
+ #'
|
| 623 |
|
- } else {
+ #' When called on a table-like object using the formatters framework,
|
-
+
| 624 |
- 1x |
+ |
- good <- c(
+ #' this method should return the number of columns which are mandatorily
|
-
+
| 625 |
- 1x |
+ |
- good,
+ #' repeated after each horizontal pagination.
|
-
+
| 626 |
- 1x |
+ |
- paste(leftover, naive[bwi + 1]),
+ #'
|
-
+
| 627 |
- 1x |
+ |
- if (bwi < length(naive) - 1) naive[seq(bwi + 2, length(naive))]
+ #' Absent a class-specific method, this function returns 0, indicating
|
| 628 |
|
- )
+ #' no always-repeated columns.
|
| 629 |
|
- }
+ #'
|
-
+
| 630 |
- 14x |
+ |
- str <- paste(good, collapse = " ")
+ #' @param obj ANY. A table-like object.
|
-
+
| 631 |
- 14x |
+ |
- naive <- strwrap(str, max_width + 1)
+ #' @note This number \emph{does not include row labels}, the repetition
|
| 632 |
|
- }
+ #' of which is handled separately.
|
-
+
| 633 |
- 16149x |
+ |
- if (hard) {
+ #'
|
-
+
| 634 |
- 16016x |
+ |
- naive <- paste(naive, collapse = "\n")
+ #' @return an integer.
|
| 635 |
|
- }
+ #' @export
|
-
+
| 636 |
- 16149x |
+ |
- naive
+ #' @examples
|
| 637 |
|
- }
+ #' mpf <- basic_matrix_form(mtcars)
|
| 638 |
|
-
+ #' num_rep_cols(mpf)
|
-
+
| 639 |
- |
+ 25x |
- #' @param txt character. A vector of strings that should be (independently)
+ setGeneric("num_rep_cols", function(obj) standardGeneric("num_rep_cols"))
|
| 640 |
|
- #' text-wrapped.
+ #' @export
|
| 641 |
|
- #' @rdname wrap_string
+ #' @rdname num_rep_cols
|
-
+
| 642 |
- |
+ 25x |
- #' @export
+ setMethod("num_rep_cols", "ANY", function(obj) 0L)
|
+
+
+
+
+
+
- | 643 |
+ 1 |
|
- wrap_txt <- function(txt, max_width, hard = FALSE) {
+ # `toString` ----
|
-
- | 644 |
- 113x |
+
+ | 2 |
+ |
- unlist(lapply(txt, wrap_string, max_width = max_width, hard = hard), use.names = FALSE)
+
|
- | 645 |
+ 3 |
|
- }
+ ## this can't be tested from within R
|
- | 646 |
+ 4 |
|
-
+ # nocov start
|
- | 647 |
+ 5 |
|
- pad_vert_top <- function(x, len) {
+ #' @importFrom stats na.omit
|
-
- | 648 |
- 2376x |
+
+ | 6 |
+ |
- c(x, rep("", len - length(x)))
+ #' @importFrom utils head tail localeToCharset
|
- | 649 |
+ 7 |
|
- }
+ #' @import checkmate
|
- | 650 |
+ 8 |
|
|
- | 651 |
+ 9 |
|
- pad_vert_bottom <- function(x, len) {
+ d_hsep_factory <- function() {
|
-
- | 652 |
- 78x |
+
+ | 10 |
+ |
- c(rep("", len - length(x)), x)
+ warn_sent <- FALSE
|
- | 653 |
+ 11 |
|
- }
+ function() {
|
- | 654 |
+ 12 |
|
-
+ if (any(grepl("^UTF", localeToCharset()))) {
|
- | 655 |
+ 13 |
|
- pad_vec_to_len <- function(vec, len, cpadder = pad_vert_top, rlpadder = cpadder) {
+ "\u2014"
|
-
- | 656 |
- 204x |
+
+ | 14 |
+ |
- dat <- unlist(lapply(vec[-1], cpadder, len = len))
+ } else {
|
-
- | 657 |
- 204x |
+
+ | 15 |
+ |
- dat <- c(rlpadder(vec[[1]], len = len), dat)
+ if (!warn_sent && interactive()) {
|
-
- | 658 |
- 204x |
+
+ | 16 |
+ |
- matrix(dat, nrow = len)
+ message(
|
- | 659 |
+ 17 |
|
- }
+ "Detected non-UTF charset. Falling back to '-' ",
|
- | 660 |
+ 18 |
|
-
+ "as default header/body separator. This warning ",
|
- | 661 |
+ 19 |
|
- rep_vec_to_len <- function(vec, len, ...) {
+ "will only be shown once per R session."
|
-
- | 662 |
- 138x |
+
+ | 20 |
+ |
- matrix(unlist(lapply(vec, rep, times = len)),
+ )
|
-
- | 663 |
- 138x |
+
+ | 21 |
+ |
- nrow = len
+ warn_sent <<- TRUE
|
- | 664 |
+ 22 |
|
- )
+ }
|
- | 665 |
+ 23 |
|
- }
+ "-"
|
- | 666 |
+ 24 |
|
-
+ }
|
- | 667 |
+ 25 |
|
-
+ }
|
- | 668 |
+ 26 |
|
- safe_strsplit <- function(x, split, ...) {
+ }
|
-
- | 669 |
- 273x |
+
+ | 27 |
+ |
- ret <- strsplit(x, split, ...)
+
|
-
- | 670 |
- 273x |
+
+ | 28 |
+ |
- lapply(ret, function(reti) if (length(reti) == 0) "" else reti)
+ #' Default horizontal Separator
|
- | 671 |
+ 29 |
|
- }
+ #'
|
- | 672 |
+ 30 |
|
-
+ #' The default horizontal separator character which can be
|
- | 673 |
+ 31 |
|
- .expand_mat_rows_inner <- function(i, mat, row_nlines, expfun, ...) {
+ #' displayed in the current `charset` for use in rendering table-likes.
|
-
- | 674 |
- 342x |
+
+ | 32 |
+ |
- leni <- row_nlines[i]
+ #'
|
-
- | 675 |
- 342x |
+
+ | 33 |
+ |
- rw <- mat[i, ]
+ #' @return `unicode` 2014 (long dash for generating solid horizontal line)
|
-
- | 676 |
- 342x |
+
+ | 34 |
+ |
- if (is.character(rw)) {
+ #' if in a locale that uses a UTF character set, otherwise an ASCII hyphen
|
-
- | 677 |
- 273x |
+
+ | 35 |
+ |
- rw <- safe_strsplit(rw, "\n", fixed = TRUE)
+ #' with a once-per-session warning.
|
- | 678 |
+ 36 |
|
- }
+ #'
|
-
- | 679 |
- 342x |
+
+ | 37 |
+ |
- expfun(rw, len = leni, ...)
+ #' @export
|
- | 680 |
+ 38 |
|
- }
+ #' @examples
|
- | 681 |
+ 39 |
+ |
+
+ #' default_hsep()
+ |
+
+
+ | 40 |
+ |
+
+ default_hsep <- d_hsep_factory()
+ |
+
+
+ | 41 |
|
|
- | 682 |
+ 42 |
|
- expand_mat_rows <- function(mat, row_nlines = apply(mat, 1, nlines), expfun = pad_vec_to_len, ...) {
+ # nocov end
|
-
- | 683 |
- 22x |
+
+ | 43 |
+ |
- rinds <- seq_len(nrow(mat))
+
|
-
- | 684 |
- 22x |
+
+ | 44 |
+ |
- exprows <- lapply(rinds, .expand_mat_rows_inner,
+ .calc_cell_widths <- function(mat, colwidths, col_gap) {
|
- | 685 |
- 22x |
+ 45 |
+ 142x |
- mat = mat,
+ spans <- mat$spans
|
- | 686 |
- 22x |
+ 46 |
+ 142x |
- row_nlines = row_nlines,
+ keep_mat <- mat$display
|
- | 687 |
- 22x |
+ 47 |
+ 142x |
- expfun = expfun,
+ body <- mat$strings
|
- | 688 |
+ 48 |
|
- ...
+
+ |
+
+
+ | 49 |
+ 142x |
+
+ nr <- nrow(body)
|
- | 689 |
+ 50 |
|
- )
+
|
- | 690 |
- 22x |
+ 51 |
+ 142x |
- do.call(rbind, exprows)
+ cell_widths_mat <- matrix(rep(colwidths, nr), nrow = nr, byrow = TRUE)
|
-
- | 691 |
- |
+
+ | 52 |
+ 142x |
- }
+ nc <- ncol(cell_widths_mat)
|
- | 692 |
+ 53 |
|
|
-
- | 693 |
- |
+
+ | 54 |
+ 142x |
-
+ for (i in seq_len(nrow(body))) {
|
-
- | 694 |
- |
+
+ | 55 |
+ 2691x |
- #' Transform vectors of spans (with duplication) to Visibility vector
+ if (any(!keep_mat[i, ])) { # any spans?
|
-
- | 695 |
- |
+
+ | 56 |
+ 6x |
- #'
+ j <- 1
|
-
- | 696 |
- |
+
+ | 57 |
+ 6x |
- #' @param spans numeric. A vector of spans, with each span value repeated
+ while (j <= nc) {
|
-
- | 697 |
- |
+
+ | 58 |
+ 10x |
- #' for the cells it covers.
+ nj <- spans[i, j]
|
-
- | 698 |
- |
+
+ | 59 |
+ 10x |
- #'
+ j <- if (nj > 1) {
|
-
- | 699 |
- |
+
+ | 60 |
+ 6x |
- #' @details
+ js <- seq(j, j + nj - 1)
|
-
- | 700 |
- |
+
+ | 61 |
+ 6x |
- #'
+ cell_widths_mat[i, js] <- sum(cell_widths_mat[i, js]) + col_gap * (nj - 1)
|
-
- | 701 |
- |
+
+ | 62 |
+ 6x |
- #' The values of \code{spans} are assumed to be repeated to such that
+ j + nj
|
- | 702 |
+ 63 |
|
- #' each individual position covered by the span has the repeated value.
+ } else {
|
-
- | 703 |
- |
+
+ | 64 |
+ 4x |
- #'
+ j + 1
|
- | 704 |
+ 65 |
|
- #' This means that each block of values in \code{span} must be of a length
+ }
|
- | 705 |
+ 66 |
|
- #' at least equal to its value (i.e. two 2s, three 3s, etc).
+ }
|
- | 706 |
+ 67 |
|
- #'
+ }
|
- | 707 |
+ 68 |
|
- #' This function correctly handles cases where two spans of the same size
+ }
|
-
- | 708 |
- |
+
+ | 69 |
+ 142x |
- #' are next to each other; i.e., a block of four 2s represents two large
+ cell_widths_mat
|
- | 709 |
+ 70 |
|
- #' cells each of which span two individual cells.
+ }
|
- | 710 |
+ 71 |
|
- #' @export
+
|
- | 711 |
+ 72 |
|
- #' @note
+
|
- | 712 |
+ 73 |
|
- #'
- |
-
-
- | 713 |
- |
-
- #' Currently no checking or enforcement is done that the vector of
+
|
- | 714 |
+ 74 |
|
- #' spans is valid in the sense described in the Details section above.
+ do_cell_fnotes_wrap <- function(mat, widths, max_width, tf_wrap) {
|
- | 715 |
+ 75 |
|
- #' @examples
+
|
-
- | 716 |
- |
+
+ | 76 |
+ 84x |
- #'
+ col_gap <- mf_colgap(mat)
|
-
- | 717 |
- |
+
+ | 77 |
+ 84x |
- #' spans_to_viscell(c(2, 2, 2, 2, 1, 3, 3, 3))
+ ncchar <- sum(widths) + (length(widths) - 1) * col_gap
|
-
- | 718 |
- |
+
+ | 78 |
+ 84x |
- #' @return a logical vector the same length as `spans` indicating
+ inset <- table_inset(mat)
|
- | 719 |
+ 79 |
|
- #' whether the contents of a string vector with those spans
+
|
- | 720 |
+ 80 |
|
- spans_to_viscell <- function(spans) {
+ ## Text wrapping checks
|
- | 721 |
- 2x |
+ 81 |
+ 84x |
- if (!is.vector(spans)) {
+ if (tf_wrap) {
|
-
- | 722 |
- ! |
+
+ | 82 |
+ 19x |
- spans <- as.vector(spans)
+ if (is.null(max_width)) {
|
-
- | 723 |
- |
+
+ | 83 |
+ 3x |
- }
+ max_width <- getOption("width", 80L)
|
- | 724 |
- 2x |
+ 84 |
+ 16x |
- myrle <- rle(spans)
+ } else if (is.character(max_width) && identical(max_width, "auto")) {
|
-
- | 725 |
- 2x |
+
+ | 85 |
+ ! |
- unlist(
+ max_width <- ncchar + inset
|
-
- | 726 |
- 2x |
+
+ | 86 |
+ |
- mapply(
+ }
|
- | 727 |
- 2x |
+ 87 |
+ 19x |
- function(vl, ln) {
+ assert_number(max_width, lower = 0)
|
-
- | 728 |
- 4x |
+
+ | 88 |
+ |
- rep(c(TRUE, rep(FALSE, vl - 1L)), times = ln / vl)
+ }
|
- | 729 |
+ 89 |
|
- },
+
|
-
- | 730 |
- 2x |
+
+ | 90 |
+ |
- SIMPLIFY = FALSE,
+ ## Check for having the right number of widths
|
- | 731 |
- 2x |
+ 91 |
+ 84x |
- vl = myrle$values,
+ stopifnot(length(widths) == ncol(mat$strings))
|
-
- | 732 |
- 2x |
+
+ | 92 |
+ |
- ln = myrle$lengths
+
|
- | 733 |
+ 93 |
|
- ),
+ ## format the to ASCII
|
- | 734 |
- 2x |
+ 94 |
+ 84x |
- recursive = FALSE
+ cell_widths_mat <- .calc_cell_widths(mat, widths, col_gap)
|
- | 735 |
+ 95 |
|
- )
+ ## wrap_string calls strwrap, which destroys whitespace so we need to make
|
- | 736 |
+ 96 |
|
- }
+ ## sure to put the indents back in
|
- | 737 |
+ 97 |
|
|
- | 738 |
+ 98 |
|
-
+ ## See if indentation is properly set
|
-
- | 739 |
- |
+
+ | 99 |
+ 84x |
- #' Propose Column Widths based on an object's `MatrixPrintForm` form
+ ind_from_mf <- mf_rinfo(mat)$indent > 0
|
-
- | 740 |
- |
+
+ | 100 |
+ 84x |
- #'
+ nlh <- mf_nlheader(mat)
|
-
- | 741 |
- |
+
+ | 101 |
+ 84x |
- #' The row names are also considered a column for the output
+ ind_std <- paste0(rep(" ", mat$indent_size), collapse = "")
|
- | 742 |
+ 102 |
|
- #'
+ ## Body indentation
|
-
- | 743 |
- |
+
+ | 103 |
+ 84x |
- #' @param x `MatrixPrintForm` object, or an object with a `matrix_form`
+ old_indent <- sapply(mf_rinfo(mat)$indent, function(i) paste0(rep(ind_std, i), collapse = ""))
|
- | 744 |
+ 104 |
|
- #' method.
+ ## Header indentation (it happens with toplefts, not \n in titles, dealt afterwards)
|
- | 745 |
+ 105 |
|
- #' @param indent_size numeric(1). Indent size in characters. Ignored
+ ## NB: what about \n in topleft? -> not supported
|
-
- | 746 |
- |
+
+ | 106 |
+ 84x |
- #' when `x` is already a `MatrixPrintForm` object in favor of information
+ header_indent <- gsub("^([[:space:]]*).*", "\\1", mat$strings[1:nlh, 1]) # Supposedly never with empty strings " "
|
-
- | 747 |
- |
+
+ | 107 |
+ 84x |
- #' there.
+ old_indent <- c(header_indent, old_indent)
|
-
- | 748 |
- |
+
+ | 108 |
+ 84x |
- #'
+ need_reindent <- nzchar(old_indent)
|
- | 749 |
+ 109 |
|
- #' @examples
+ ## Check for which row has indent
|
-
- | 750 |
- |
+
+ | 110 |
+ 84x |
- #' mf <- basic_matrix_form(mtcars)
+ ind_from_strings <- nchar(old_indent)[-seq_len(nlh)] > 0
|
-
- | 751 |
- |
+
+ | 111 |
+ 84x |
- #' propose_column_widths(mf)
+ if (!all(ind_from_strings == ind_from_mf)) {
|
- | 752 |
+ 112 |
|
- #'
+ stop("Row-info and string indentations are different.", # nocov
|
- | 753 |
+ 113 |
|
- #' @export
+ " Please contact the maintainer, this should not happen.") # nocov
|
- | 754 |
+ 114 |
|
- #' @return a vector of column widths based on the content of \code{x}
+ }
|
-
- | 755 |
- |
+
+ | 115 |
+ 84x |
- #' for use in printing and pagination.
+ ori_mflg <- mf_lgrouping(mat) # Original groups
|
-
- | 756 |
- |
+
+ | 116 |
+ 84x |
- ## ' @examples
+ reindent_old_idx <- ori_mflg[need_reindent] # Indent groups bf wrap
|
- | 757 |
+ 117 |
|
- ## ' library(dplyr)
+
|
- | 758 |
+ 118 |
|
- ## ' library(rtables)
+ ## Taking care in advance of indented word wrappings
|
-
- | 759 |
- |
+
+ | 119 |
+ 84x |
- ## ' iris2 <- iris %>%
+ cell_widths_mat[need_reindent, 1] <- cell_widths_mat[need_reindent, 1] - nchar(old_indent)[need_reindent]
|
- | 760 |
+ 120 |
|
- ## ' group_by(Species) %>%
+
|
- | 761 |
+ 121 |
|
- ## ' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ ## Case in which the indentation is taking too much space vs desired wrapping
|
-
- | 762 |
- |
+
+ | 122 |
+ 84x |
- ## ' ungroup()
+ if (any(cell_widths_mat < 0)) {
|
-
- | 763 |
- |
+
+ | 123 |
+ 1x |
- ## '
+ col_culprits <- apply(cell_widths_mat, 2, function(i) any(i < 0))
|
-
- | 764 |
- |
+
+ | 124 |
+ 1x |
- ## ' l <- basic_table() %>%
+ stop(
|
-
- | 765 |
- |
+
+ | 125 |
+ 1x |
- ## ' split_cols_by("Species") %>%
+ "Inserted width(s) for column(s) ", which(col_culprits),
|
-
- | 766 |
- |
+
+ | 126 |
+ 1x |
- ## ' split_cols_by("group") %>%
+ " is(are) not wide enough for the desired indentation."
|
- | 767 |
+ 127 |
|
- ## ' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary) , format = "xx.xx")
+ )
|
- | 768 |
+ 128 |
|
- ## '
+ }
|
- | 769 |
+ 129 |
|
- ## ' tbl <- build_table(l, iris2)
+
|
-
- | 770 |
- |
+
+ | 130 |
+ 83x |
- ## ' mf <- matrix_form(tbl)
+ new_strings <- matrix(
|
-
- | 771 |
- |
+
+ | 131 |
+ 83x |
- ## ' propose_column_widths(mf)
+ unlist(mapply(wrap_string,
|
-
- | 772 |
- |
+
+ | 132 |
+ 83x |
- propose_column_widths <- function(x, indent_size = 2) {
+ str = mat$strings,
|
-
- | 773 |
- |
+
+ | 133 |
+ 83x |
- ## stopifnot(is(x, "VTableTree"))
+ max_width = cell_widths_mat,
|
- | 774 |
- 67x |
+ 134 |
+ 83x |
- if (!is(x, "MatrixPrintForm")) {
+ hard = TRUE
|
-
- | 775 |
- ! |
+
+ | 135 |
+ |
- x <- matrix_form(x, indent_rownames = TRUE, indent_size = indent_size)
+ )),
+ |
+
+
+ | 136 |
+ 83x |
+
+ ncol = ncol(mat$strings)
|
- | 776 |
+ 137 |
|
- }
+ )
|
- | 777 |
- 67x |
+ 138 |
+ 83x |
- body <- mf_strings(x)
+ mat$strings <- new_strings
|
-
- | 778 |
- 67x |
+
+ | 139 |
+ |
- spans <- mf_spans(x)
+
|
-
- | 779 |
- 67x |
+
+ | 140 |
+ |
- aligns <- mf_aligns(x)
+ ## XXXXX this is wrong and will break for listings cause we don't know when
+ |
+
+
+ | 141 |
+ |
+
+ ## we need has_topleft to be FALSE!!!!!!!!!!
|
- | 780 |
- 67x |
+ 142 |
+ 83x |
- display <- mf_display(x)
+ mat <- mform_handle_newlines(mat)
|
- | 781 |
+ 143 |
|
|
- | 782 |
+ 144 |
|
- # compute decimal alignment if asked in alignment matrix
+ ## Indent groups after newline
|
- | 783 |
- 67x |
+ 145 |
+ 83x |
- if (any_dec_align(aligns)) {
+ reindent_new_idx <- mf_lgrouping(mat) %in% reindent_old_idx
|
- | 784 |
- 27x |
+ 146 |
+ 83x |
- body <- decimal_align(body, aligns)
+ if (anyNA(reindent_new_idx)) {
|
- | 785 |
+ 147 |
|
- }
+ stop("Unable to remap indenting after cell content text wrapping. ", # nocov
|
- | 786 |
+ 148 |
|
-
+ "Please contact the maintainer, this should not happen.") # nocov
|
-
- | 787 |
- 64x |
+
+ | 149 |
+ |
- chars <- nchar(body)
+ }
|
- | 788 |
+ 150 |
|
|
- | 789 |
+ 151 |
|
- # first check column widths without colspan
- |
-
-
- | 790 |
- 64x |
-
- has_spans <- spans != 1
+ ## Adding the indentation back in
|
- | 791 |
- 64x |
+ 152 |
+ 83x |
- chars_ns <- chars
+ ind_v <- NULL
|
- | 792 |
- 64x |
+ 153 |
+ 83x |
- chars_ns[has_spans] <- 0
+ for (i in mf_lgrouping(mat)[reindent_new_idx]) {
|
- | 793 |
- 64x |
+ 154 |
+ 4x |
- widths <- apply(chars_ns, 2, max)
+ ind_v <- c(ind_v, which(i == ori_mflg)[1])
|
- | 794 |
+ 155 |
|
-
- |
-
-
- | 795 |
- |
-
- # now check if the colspans require extra width
- |
-
-
- | 796 |
- 64x |
-
- if (any(has_spans)) {
+ }
|
- | 797 |
- 1x |
+ 156 |
+ 83x |
- has_row_spans <- apply(has_spans, 1, any)
+ new_indent <- old_indent[ind_v]
|
- | 798 |
+ 157 |
|
|
-
- | 799 |
- 1x |
+
+ | 158 |
+ |
- chars_sp <- chars[has_row_spans, , drop = FALSE]
+ ## Additional safety check
|
- | 800 |
- 1x |
+ 159 |
+ 83x |
- spans_sp <- spans[has_row_spans, , drop = FALSE]
+ if (length(new_indent) > 0 && !all(nzchar(new_indent))) {
|
-
- | 801 |
- 1x |
+
+ | 160 |
+ |
- disp_sp <- display[has_row_spans, , drop = FALSE]
+ stop("Recovered indentation contains empty strings. This is an", # nocov
|
- | 802 |
+ 161 |
|
-
+ " indexing problem, please contact the maintainer, this should not happen.") # nocov
|
-
- | 803 |
- 1x |
+
+ | 162 |
+ |
- nc <- ncol(spans)
+ }
|
-
- | 804 |
- 1x |
+
+ | 163 |
+ |
- for (i in seq_len(nrow(chars_sp))) {
+
|
-
- | 805 |
- 1x |
+
+ | 164 |
+ |
- for (j in seq_len(nc)) {
+ ## Indentation is different for topleft material
|
- | 806 |
- 2x |
+ 165 |
+ 83x |
- if (disp_sp[i, j] && spans_sp[i, j] != 1) {
+ if (isTRUE(mf_has_topleft(mat))) {
|
-
- | 807 |
- 1x |
+
+ | 166 |
+ |
- i_cols <- seq(j, j + spans_sp[i, j] - 1)
+ ## mf_nlheader counts actual header lines while mf_nrheader is 'virtual'
|
- | 808 |
+ 167 |
|
-
+ ## A bit of an hack, but unforeseen behavior, related to \n in topleft is not supported
|
-
- | 809 |
- 1x |
+
+ | 168 |
+ |
- nchar_i <- chars_sp[i, j]
+ ## Therefore, this still suppose that we dealt with \n in the cols before
|
- | 810 |
- 1x |
+ 169 |
+ 2x |
- cw_i <- widths[i_cols]
+ indx_topleft <- which(reindent_new_idx[1:nlh])
|
- | 811 |
- 1x |
+ 170 |
+ 2x |
- available_width <- sum(cw_i)
+ new_indent[seq_along(indx_topleft)] <- old_indent[indx_topleft]
|
- | 812 |
+ 171 |
|
-
- |
-
-
- | 813 |
- 1x |
-
- if (nchar_i > available_width) {
+ }
|
- | 814 |
+ 172 |
|
- # need to update widths to fit content with colspans
+
|
- | 815 |
+ 173 |
|
- # spread width among columns
+ ## Main addition of the 'saved' indentation to strings
|
-
- | 816 |
- ! |
+
+ | 174 |
+ 83x |
- widths[i_cols] <- cw_i + spread_integer(nchar_i - available_width, length(cw_i))
+ mf_strings(mat)[reindent_new_idx, 1] <- paste0(
|
-
- | 817 |
- |
+
+ | 175 |
+ 83x |
- }
+ new_indent,
|
-
- | 818 |
- |
+
+ | 176 |
+ 83x |
- }
+ mat$strings[reindent_new_idx, 1]
|
- | 819 |
+ 177 |
|
- }
+ )
|
- | 820 |
+ 178 |
|
- }
+ ## this updates extents in rinfo AND nlines in ref_fnotes_df
|
-
- | 821 |
- |
+
+ | 179 |
+ 83x |
- }
+ mat <- update_mf_nlines(mat, max_width = max_width)
|
- | 822 |
- 64x |
+ 180 |
+ 83x |
- widths
+ mat
|
- | 823 |
+ 181 |
|
}
|
- | 824 |
+ 182 |
|
|
- | 825 |
+ 183 |
|
-
+ ## take a character vector and return whether the value is
|
- | 826 |
+ 184 |
|
-
+ ## a string version of a number or not
|
- | 827 |
+ 185 |
|
-
+ is_number_str <- function(vec) {
|
-
- | 828 |
- |
+
+ | 186 |
+ ! |
- #' Pad a string and align within string
+ is.na(as.numeric(vec))
|
- | 829 |
+ 187 |
|
- #'
+ }
|
- | 830 |
+ 188 |
|
- #' @param x string
+
|
- | 831 |
+ 189 |
|
- #' @param n number of character of the output string, if `n <
+ is_dec_align <- function(vec) {
|
- | 832 |
+ 190 |
|
- #' nchar(x)` an error is thrown
+ # "c" is not an alignment method we define in `formatters`,
|
- | 833 |
+ 191 |
|
- #' @param just character(1). Text alignment justification to
+ # but the reverse dependency package `tables` will need
|
-
- | 834 |
- |
+
+ | 192 |
+ 378x |
- #' use. Defaults to `center`. Must be `center`, `right`, `left`,
+ sdiff <- setdiff(vec, c(list_valid_aligns(), "c"))
|
-
- | 835 |
- |
+
+ | 193 |
+ 378x |
- #' `dec_right`, `dec_left` or `decimal`.
+ if(length(sdiff) > 0)
|
-
- | 836 |
- |
+
+ | 194 |
+ ! |
- #'
+ stop("Invalid text-alignment(s): ",
|
-
- | 837 |
- |
+
+ | 195 |
+ ! |
- #' @export
+ paste(sdiff, collapse = ", "))
|
-
- | 838 |
- |
+
+ | 196 |
+ 378x |
- #' @examples
+ grepl("dec", vec)
|
- | 839 |
+ 197 |
|
- #'
+ }
|
- | 840 |
+ 198 |
|
- #' padstr("abc", 3)
+
|
-
- | 841 |
- |
+
+ | 199 |
+ 233x |
- #' padstr("abc", 4)
+ any_dec_align <- function(vec) any(is_dec_align(vec))
|
- | 842 |
+ 200 |
|
- #' padstr("abc", 5)
+
|
- | 843 |
+ 201 |
|
- #' padstr("abc", 5, "left")
+ #' Decimal Alignment
|
- | 844 |
+ 202 |
|
- #' padstr("abc", 5, "right")
+ #'
|
- | 845 |
+ 203 |
|
- #'
+ #' @description Aligning decimal values of string matrix. Allowed alignments are: `dec_left`,
|
- | 846 |
+ 204 |
|
- #' if (interactive()) {
+ #' `dec_right` and `decimal`.
|
- | 847 |
+ 205 |
|
- #' padstr("abc", 1)
+ #'
|
- | 848 |
+ 206 |
|
- #' }
+ #' @param string_mat character matrix. String matrix component of matrix print form object.
|
- | 849 |
+ 207 |
|
- #' @return `x`, padded to be a string of `n` characters
+ #' @param align_mat character matrix. Aligns matrix component of matrix print form object.
|
- | 850 |
+ 208 |
|
- #'
+ #' Should contain either `dec_left`, `dec_right` or `decimal` for values to be decimal aligned.
|
- | 851 |
+ 209 |
|
- padstr <- function(x, n, just = list_valid_aligns()) {
+ #'
|
-
- | 852 |
- 5015x |
+
+ | 210 |
+ |
- just <- match.arg(just)
+ #' @details Decimal alignment left and right (`dec_left` and `dec_right`) are different to
|
- | 853 |
+ 211 |
|
-
+ #' center decimal alignment `decimal` only in the case some padding is present. This may
|
-
- | 854 |
- 1x |
+
+ | 212 |
+ |
- if (length(x) != 1) stop("length of x needs to be 1 and not", length(x))
+ #' happen if column widths are wider by setting parameters `widths` in `toString` or
|
-
- | 855 |
- 1x |
+
+ | 213 |
+ |
- if (is.na(n) || !is.numeric(n) || n < 0) stop("n needs to be numeric and > 0")
+ #' `colwidths` in `paginate_*` accordingly. It will be also the case (more common) of
|
- | 856 |
+ 214 |
|
-
+ #' wider column names. Decimal alignment is not supported along with cell wrapping.
|
-
- | 857 |
- 1x |
+
+ | 215 |
+ |
- if (is.na(x)) x <- "<NA>"
+ #'
|
- | 858 |
+ 216 |
|
-
+ #' @examples
|
-
- | 859 |
- 5013x |
+
+ | 217 |
+ |
- nc <- nchar(x)
+ #' dfmf <- basic_matrix_form(mtcars[1:5,])
|
- | 860 |
+ 218 |
|
-
+ #' aligns <- mf_aligns(dfmf)
|
-
- | 861 |
- ! |
+
+ | 219 |
+ |
- if (n < nc) stop("\"", x, "\" has more than ", n, " characters")
+ #' aligns[, -c(1)] <- "dec_left"
|
- | 862 |
+ 220 |
|
-
+ #' decimal_align(mf_strings(dfmf), aligns)
|
-
- | 863 |
- 5013x |
+
+ | 221 |
+ |
- switch(just,
+ #'
|
- | 864 |
+ 222 |
|
- center = {
+ #' @return Processed string matrix of matrix print form with decimal aligned values.
|
-
- | 865 |
- 269x |
+
+ | 223 |
+ |
- pad <- (n - nc) / 2
+ #'
|
-
- | 866 |
- 269x |
+
+ | 224 |
+ |
- paste0(spaces(floor(pad)), x, spaces(ceiling(pad)))
+ #' @seealso [toString] and [MatrixPrintForm]
|
- | 867 |
+ 225 |
|
- },
+ #'
|
-
- | 868 |
- 4595x |
+
+ | 226 |
+ |
- left = paste0(x, spaces(n - nc)),
+ #' @export
|
-
- | 869 |
- 10x |
+
+ | 227 |
+ |
- right = paste0(spaces(n - nc), x),
+ decimal_align <- function(string_mat, align_mat) {
|
- | 870 |
+ 228 |
|
- decimal = {
+ ## Evaluate if any values are to be decimal aligned
|
- | 871 |
- 60x |
+ 229 |
+ 45x |
- pad <- (n - nc) / 2
+ if (!any_dec_align(align_mat)) {
|
-
- | 872 |
- 60x |
+
+ | 230 |
+ ! |
- paste0(spaces(floor(pad)), x, spaces(ceiling(pad)))
+ return(string_mat)
|
- | 873 |
+ 231 |
|
- },
+ }
|
- | 874 |
- 44x |
+ 232 |
+ 45x |
- dec_left = paste0(x, spaces(n - nc)),
+ for (i in seq(1, ncol(string_mat))) {
+ |
+
+
+ | 233 |
+ |
+
+ ## Take a column and its decimal alignments
|
- | 875 |
- 35x |
+ 234 |
+ 145x |
- dec_right = paste0(spaces(n - nc), x)
+ col_i <- as.character(string_mat[, i])
|
-
- | 876 |
- |
+
+ | 235 |
+ 145x |
- )
+ align_col_i <- is_dec_align(align_mat[, i])
|
- | 877 |
+ 236 |
|
- }
+
|
- | 878 |
+ 237 |
|
-
+ ## !( A || B) -> !A && !B DeMorgan's Law
|
- | 879 |
+ 238 |
|
- spaces <- function(n) {
+ ## Are there any values to be decimal aligned? safe if
|
- | 880 |
- 5500x |
+ 239 |
+ 145x |
- strrep(" ", n)
+ if (any(align_col_i) && any(!grepl("^[0-9]\\.", col_i))) {
|
- | 881 |
+ 240 |
|
- }
+ ## Extract values not to be aligned (NAs, non-numbers,
|
- | 882 |
+ 241 |
|
-
+ ## doesn't say "decimal" in alignment matrix)
|
- | 883 |
+ 242 |
|
-
+ ## XXX FIXME because this happens after formatting, we can't tell the difference between
|
- | 884 |
+ 243 |
|
- .paste_no_na <- function(x, ...) {
+ ## non-number strings which come from na_str+ NA value and strings which just aren't numbers.
+ |
+
+
+ | 244 |
+ |
+
+ ## this is a problem that should eventually be fixed.
|
- | 885 |
- 870x |
+ 245 |
+ 82x |
- paste(na.omit(x), ...)
+ nas <- vapply(col_i, is.na, FUN.VALUE = logical(1))
|
-
- | 886 |
- |
+
+ | 246 |
+ 82x |
- }
+ nonnum <- !grepl("[0-9]", col_i)
|
- | 887 |
+ 247 |
|
-
+ ## No grepl("[a-zA-Z]", col_i) because this excludes N=xx, e.g.
|
-
- | 888 |
- |
+
+ | 248 |
+ 82x |
-
+ nonalign <- nas | nonnum | !align_col_i
|
-
- | 889 |
- |
+
+ | 249 |
+ 82x |
- #' spread `x` into `len` elements
+ col_ia <- col_i[!nonalign]
|
- | 890 |
+ 250 |
|
- #'
+
|
- | 891 |
+ 251 |
|
- #' @param x numeric(1). The number to spread
+ ## Do decimal alignment
|
-
- | 892 |
- |
+
+ | 252 |
+ 82x |
- #' @param len numeric(1). The number of times to repeat \code{x}
+ if (length(col_ia) > 0) {
|
- | 893 |
+ 253 |
|
- #'
+ # Special case: scientific notation
|
-
- | 894 |
- |
+
+ | 254 |
+ 82x |
- #' @export
+ has_sc_not <- grepl("\\d+[e|E][\\+|\\-]\\d+", col_ia)
|
-
- | 895 |
- |
+
+ | 255 |
+ 82x |
- #' @return if \code{x} is a scalar "whole number" value (see \code{\link{is.wholenumber}}),
+ if(any(has_sc_not)) {
|
-
- | 896 |
- |
+
+ | 256 |
+ 1x |
- #' the value \code{x} repeated \code{len} times. If not, an error is thrown.
+ stop("Found values using scientific notation between the ones that",
|
-
- | 897 |
- |
+
+ | 257 |
+ 1x |
- #' @examples
+ " needs to be decimal aligned (aligns is decimal, dec_left or dec_right).",
|
-
- | 898 |
- |
+
+ | 258 |
+ 1x |
- #' spread_integer(3, 1)
+ " Please consider using format functions to get a complete decimal ",
|
-
- | 899 |
- |
+
+ | 259 |
+ 1x |
- #' spread_integer(0, 3)
+ "(e.g. formatC).")
|
- | 900 |
+ 260 |
|
- #' spread_integer(1, 3)
+ }
|
- | 901 |
+ 261 |
|
- #' spread_integer(2, 3)
+
|
- | 902 |
+ 262 |
|
- #' spread_integer(3, 3)
+ ## Count the number of numbers in the string
|
-
- | 903 |
- |
+
+ | 263 |
+ 81x |
- #' spread_integer(4, 3)
+ matches <- gregexpr("\\d+\\.\\d+|\\d+", col_ia)
|
-
- | 904 |
- |
+
+ | 264 |
+ 81x |
- #' spread_integer(5, 3)
+ more_than_one <- vapply(matches, function(x) {
|
-
- | 905 |
- |
+
+ | 265 |
+ 685x |
- #' spread_integer(6, 3)
+ sum(attr(x, "match.length") > 0) > 1
|
-
- | 906 |
- |
+
+ | 266 |
+ 81x |
- #' spread_integer(7, 3)
+ }, logical(1))
|
- | 907 |
+ 267 |
|
- spread_integer <- function(x, len) {
+ ## Throw error in case any have more than 1 numbers
|
- | 908 |
+ 268 |
+ 81x |
+
+ if (any(more_than_one)) {
+ |
+
+
+ | 269 |
2x |
- stopifnot(
+ stop("Decimal alignment is not supported for multiple values. ",
|
- | 909 |
+ 270 |
2x |
- is.wholenumber(x), length(x) == 1, x >= 0,
+ "Found the following string with multiple numbers ",
|
- | 910 |
+ 271 |
2x |
- is.wholenumber(len), length(len) == 1, len >= 0,
+ "(first 3 selected from column ", col_i[1],"): '",
|
- | 911 |
+ 272 |
2x |
- !(len == 0 && x > 0)
+ paste0(col_ia[more_than_one][seq(1, 3)],
|
-
- | 912 |
- |
+
+ | 273 |
+ 2x |
- )
+ collapse = "', '"), "'")
|
- | 913 |
+ 274 |
|
-
+ }
|
- | 914 |
+ 275 |
|
-
+ ## General split (only one match -> the first)
|
- | 915 |
- 1x |
+ 276 |
+ 79x |
- if (len == 0) {
+ main_regexp <- regexpr("\\d+", col_ia)
|
-
- | 916 |
- ! |
+
+ | 277 |
+ 79x |
- integer(0)
+ left <- regmatches(col_ia, main_regexp, invert = FALSE)
|
-
- | 917 |
- |
+
+ | 278 |
+ 79x |
- } else {
+ right <- regmatches(col_ia, main_regexp, invert = TRUE)
|
- | 918 |
- 1x |
+ 279 |
+ 79x |
- y <- rep(floor(x / len), len)
+ right <- sapply(right, "[[", 2)
|
- | 919 |
- 1x |
+ 280 |
+ 79x |
- i <- 1
+ something_left <- sapply(strsplit(col_ia, "\\d+"), "[[", 1)
|
- | 920 |
- 1x |
+ 281 |
+ 79x |
- while (sum(y) < x) {
+ left <- paste0(something_left, left)
|
- | 921 |
- 1x |
+ 282 |
+ 79x |
- y[i] <- y[i] + 1
+ if (!checkmate::test_set_equal(paste0(left, right), col_ia))
|
-
- | 922 |
- 1x |
+
+ | 283 |
+ ! |
- if (i == len) {
+ stop("Split string list lost some piece along the way. This ",
|
- | 923 |
+ 284 |
! |
- i <- 1
+ "should not have happened. Please contact the maintainer.") # nocov
|
-
- | 924 |
- |
+
+ | 285 |
+ 79x |
- } else {
+ separator <- sapply(right, function(x) {
|
- | 925 |
- 1x |
+ 286 |
+ 639x |
- i <- i + 1
+ if (nzchar(x)) {
|
-
- | 926 |
- |
+
+ | 287 |
+ 346x |
- }
+ substr(x, 1, 1)
|
- | 927 |
+ 288 |
|
- }
+ } else {
|
- | 928 |
- 1x |
+ 289 |
+ 293x |
- y
+ c(" ")
|
- | 929 |
+ 290 |
|
- }
+ }
|
-
- | 930 |
- |
+
+ | 291 |
+ 79x |
- }
+ }, USE.NAMES = FALSE)
|
-
- | 931 |
- |
+
+ | 292 |
+ 79x |
-
+ right <- sapply(right, function(x) {
|
-
- | 932 |
- |
+
+ | 293 |
+ 639x |
-
+ if (nchar(x) > 1) {
|
-
- | 933 |
- |
+
+ | 294 |
+ 314x |
-
+ substr(x, 2, nchar(x))
|
- | 934 |
+ 295 |
|
- #' `is.wholenumber`
+ } else {
|
-
- | 935 |
- |
+
+ | 296 |
+ 325x |
- #'
+ c("")
|
- | 936 |
+ 297 |
|
- #' @param x numeric(1). A numeric value
+ }
|
-
- | 937 |
- |
+
+ | 298 |
+ 79x |
- #' @param tol numeric(1). A precision tolerance.
+ }, USE.NAMES = FALSE)
|
- | 938 |
+ 299 |
|
- #'
+ ## figure out whether we need space separators (at least one had a "." or not)
|
-
- | 939 |
- |
+
+ | 300 |
+ 79x |
- #' @return \code{TRUE} if \code{x} is within \code{tol} of zero,
+ if(!any(grepl("[^[:space:]]", separator)))
|
-
- | 940 |
- |
+
+ | 301 |
+ 26x |
- #' \code{FALSE} otherwise.
+ separator <- gsub("[[:space:]]*", "", separator)
|
- | 941 |
+ 302 |
|
- #'
+ ## modify the piece with spaces
|
-
- | 942 |
- |
+
+ | 303 |
+ 79x |
- #' @export
+ left_mod <- paste0(spaces(max(nchar(left), na.rm = TRUE) - nchar(left)), left)
|
-
- | 943 |
- |
+
+ | 304 |
+ 79x |
- #' @examples
+ right_mod <- paste0(right, spaces(max(nchar(right), na.rm = TRUE) - nchar(right)))
|
- | 944 |
+ 305 |
|
- #' is.wholenumber(5)
+ # Put everything together
|
-
- | 945 |
- |
+
+ | 306 |
+ 79x |
- #' is.wholenumber(5.00000000000000001)
+ aligned <- paste(left_mod, separator, right_mod, sep = "")
+ |
+
+
+ | 307 |
+ 79x |
+
+ string_mat[!nonalign, i] <- aligned
|
- | 946 |
+ 308 |
|
- #' is.wholenumber(.5)
+ }
|
- | 947 |
+ 309 |
|
- #'
+ }
|
- | 948 |
+ 310 |
|
- is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) {
+ }
|
- | 949 |
- 3x |
+ 311 |
+ 42x |
- abs(x - round(x)) < tol
+ string_mat
|
- | 950 |
+ 312 |
|
}
|
-
-
-
-
-
-
- | 1 |
+ 313 |
|
- ### This file defines the generics which make up the interface `formatters` offers.
+
|
- | 2 |
+ 314 |
|
- ### Defining methods for these generics for a new table-like class should be fully
+ #' @rdname tostring
|
- | 3 |
+ 315 |
|
- ### sufficient for hooking that class up to the `formatters` pagination and rendering
+ #'
|
- | 4 |
+ 316 |
|
- ### machinery.
+ #' @inheritParams MatrixPrintForm
|
- | 5 |
+ 317 |
|
-
+ #' @param widths numeric (or NULL). (proposed) widths for the columns
|
- | 6 |
+ 318 |
|
-
+ #' of \code{x}. The expected length of this numeric vector can be
|
- | 7 |
+ 319 |
|
- #' @import methods
+ #' retrieved with `ncol() + 1` as the column of row names must
|
- | 8 |
+ 320 |
|
- #' @include matrix_form.R
+ #' also be considered.
|
- | 9 |
+ 321 |
|
- #'
+ #' @param hsep character(1). Characters to repeat to create
|
- | 10 |
+ 322 |
|
- #' @title Make row layout summary data.frames for use during pagination
+ #' header/body separator line.
|
- | 11 |
+ 323 |
|
- #'
+ #' @param tf_wrap logical(1). Should the texts for title, subtitle,
|
- | 12 |
+ 324 |
|
- #' @description
+ #' and footnotes be wrapped?
|
- | 13 |
+ 325 |
|
- #' All relevant information about table rows (e.g. indentations) is summarized in a data.frames.
+ #' @param max_width integer(1), character(1) or NULL. Width that title
|
- | 14 |
+ 326 |
|
- #' This function works ONLY on `rtables` and `rlistings` objects, and not on their print counterparts
+ #' and footer (including footnotes) materials should be
|
- | 15 |
+ 327 |
|
- #' (like `MatrixPrintForm`).
+ #' word-wrapped to. If NULL, it is set to the current print width
|
- | 16 |
+ 328 |
|
- #'
+ #' of the session (`getOption("width")`). If set to `"auto"`,
|
- | 17 |
+ 329 |
|
- #' @name make_row_df
+ #' the width of the table (plus any table inset) is used. Ignored
|
- | 18 |
+ 330 |
|
- #'
+ #' completely if `tf_wrap` is `FALSE`.
|
- | 19 |
+ 331 |
|
- #' @param tt ANY. Object representing the table-like object to be summarized.
+ #'
|
- | 20 |
+ 332 |
|
- #' @param visible_only logical(1). Should only visible aspects of the table structure be reflected in this summary.
+ #' @details
|
- | 21 |
+ 333 |
|
- #' Defaults to \code{TRUE}. May not be supported by all methods.
+ #'
|
- | 22 |
+ 334 |
|
- #' @param incontent logical(1). Internal detail do not set manually.
+ #' Manual insertion of newlines is not supported when `tf_wrap` is on
|
- | 23 |
+ 335 |
|
- #' @param repr_ext integer(1). Internal detail do not set manually.
+ #' and will result in a warning and undefined wrapping behavior. Passing
|
- | 24 |
+ 336 |
|
- #' @param repr_inds integer. Internal detail do not set manually.
+ #' vectors of already split strings remains supported, however in this
|
- | 25 |
+ 337 |
|
- #' @param sibpos integer(1). Internal detail do not set manually.
+ #' case each string is word-wrapped separately with the behavior
|
- | 26 |
+ 338 |
|
- #' @param nsibs integer(1). Internal detail do not set manually.
+ #' described above.
|
- | 27 |
+ 339 |
|
- #' @param rownum numeric(1). Internal detail do not set manually.
+ #'
|
- | 28 |
+ 340 |
|
- #' @param indent integer(1). Internal detail do not set manually.
+ #' @examples
|
- | 29 |
+ 341 |
|
-
+ #' mform <- basic_matrix_form(mtcars)
|
- | 30 |
+ 342 |
|
- #' @param colwidths numeric. Internal detail do not set manually.
+ #' cat(toString(mform))
|
- | 31 |
+ 343 |
|
- #' @param path character. Path to the (sub)table represented by
+ #'
|
- | 32 |
+ 344 |
|
- #' \code{tt}. Defaults to \code{character()}
+ #' @return A character string containing the ASCII rendering
|
- | 33 |
+ 345 |
|
- #' @param max_width numeric(1) or NULL. Maximum width for title/footer
+ #' of the table-like object represented by `x`
|
- | 34 |
+ 346 |
|
- #' materials.
+ #'
|
- | 35 |
+ 347 |
|
- #'
+ #' @exportMethod toString
|
- | 36 |
+ 348 |
|
- #' @details When \code{visible_only} is \code{TRUE} (the default),
+ setMethod("toString", "MatrixPrintForm", function(x,
|
- | 37 |
+ 349 |
|
- #' methods should return a data.frame with exactly one row per
+ widths = NULL,
|
- | 38 |
+ 350 |
|
- #' visible row in the table-like object. This is useful when
+ tf_wrap = FALSE,
|
- | 39 |
+ 351 |
|
- #' reasoning about how a table will print, but does not reflect
+ max_width = NULL,
|
- | 40 |
+ 352 |
|
- #' the full pathing space of the structure (though the paths which
+ col_gap = mf_colgap(x),
|
- | 41 |
+ 353 |
|
- #' are given will all work as is).
+ hsep = default_hsep()) {
|
-
- | 42 |
- |
+
+ | 354 |
+ 63x |
- #'
+ assert_flag(tf_wrap)
|
- | 43 |
+ 355 |
|
- #' If supported, when \code{visible_only} is \code{FALSE}, every
+
|
-
- | 44 |
- |
+
+ | 356 |
+ 63x |
- #' structural element of the table (in row-space) will be reflected in
+ mat <- matrix_form(x, indent_rownames = TRUE)
|
-
- | 45 |
- |
+
+ | 357 |
+ 63x |
- #' the returned data.frame, meaning the full pathing-space will be
+ inset <- table_inset(mat)
|
- | 46 |
+ 358 |
|
- #' represented but some rows in the layout summary will not represent
+
|
- | 47 |
+ 359 |
|
- #' printed rows in the table as it is displayed.
+ # if cells are decimal aligned, run propose column widths
|
- | 48 |
+ 360 |
|
- #'
+ # if the provided widths is less than proposed width, return an error
|
-
- | 49 |
- |
+
+ | 361 |
+ 63x |
- #' Most arguments beyond \code{tt} and \code{visible_only} are present so that
+ if (any_dec_align(mf_aligns(mat))) {
|
-
- | 50 |
- |
+
+ | 362 |
+ 22x |
- #' `make_row_df` methods can call `make_row_df` recursively and retain information,
+ aligned <- propose_column_widths(x)
|
- | 51 |
+ 363 |
|
- #' and should not be set during a top-level call
+
|
- | 52 |
+ 364 |
|
- #'
+ # catch any columns that require widths more than what is provided
|
-
- | 53 |
- |
+
+ | 365 |
+ 20x |
- #' @note the technically present root tree node is excluded from the summary returned by
+ if (!is.null(widths)) {
|
-
- | 54 |
- |
+
+ | 366 |
+ 9x |
- #' both \code{make_row_df} and \code{make_col_df} (see `rtables::make_col_df`), as it is simply the
+ how_wide <- sapply(seq_along(widths), function(i) c(widths[i] - aligned[i]))
|
-
- | 55 |
- |
+
+ | 367 |
+ 9x |
- #' row/column structure of \code{tt} and thus not useful for pathing or pagination.
+ too_wide <- how_wide < 0
|
-
- | 56 |
- |
+
+ | 368 |
+ 9x |
- #' @return a data.frame of row/column-structure information used by the pagination machinery.
+ if (any(too_wide)) {
|
-
- | 57 |
- |
+
+ | 369 |
+ 2x |
- #'
+ desc_width <- paste(paste(
|
-
- | 58 |
- |
+
+ | 370 |
+ 2x |
- #' @rdname make_row_df
+ names(which(too_wide)),
|
-
- | 59 |
- |
+
+ | 371 |
+ 2x |
- #' @export
+ paste0("(", how_wide[too_wide], ")")
|
-
- | 60 |
- |
+
+ | 372 |
+ 2x |
- ## nocov start
+ ), collapse = ", ")
|
-
- | 61 |
- |
+
+ | 373 |
+ 2x |
- setGeneric("make_row_df", function(tt, colwidths = NULL, visible_only = TRUE,
+ stop(
|
-
- | 62 |
- |
+
+ | 374 |
+ 2x |
- rownum = 0,
+ "Inserted width(s) for column(s) ", desc_width,
|
-
- | 63 |
- |
+
+ | 375 |
+ 2x |
- indent = 0L,
+ " is(are) not wide enough for the desired alignment."
|
- | 64 |
+ 376 |
|
- path = character(),
+ )
|
- | 65 |
+ 377 |
|
- incontent = FALSE,
+ }
|
- | 66 |
+ 378 |
|
- repr_ext = 0L,
+ }
|
- | 67 |
+ 379 |
|
- repr_inds = integer(),
+ }
|
- | 68 |
+ 380 |
|
- sibpos = NA_integer_,
+
|
-
- | 69 |
- |
+
+ | 381 |
+ 59x |
- nsibs = NA_integer_,
+ if (is.null(widths)) {
|
-
- | 70 |
- |
+
+ | 382 |
+ 49x |
- max_width = NULL) {
+ widths <- mf_col_widths(x) %||% propose_column_widths(x)
|
- | 71 |
+ 383 |
|
- standardGeneric("make_row_df")
+ } else {
|
-
- | 72 |
- |
+
+ | 384 |
+ 10x |
- })
+ mf_col_widths(x) <- widths
|
- | 73 |
+ 385 |
|
-
+ }
|
-
- | 74 |
- |
+
+ | 386 |
+ 59x |
- #' @rdname make_row_df
+ ncchar <- sum(widths) + (length(widths) - 1) * col_gap
|
- | 75 |
+ 387 |
|
- setMethod("make_row_df", "MatrixPrintForm", function(tt, colwidths = NULL, visible_only = TRUE,
+
|
- | 76 |
+ 388 |
|
- rownum = 0,
+ ## Text wrapping checks
|
-
- | 77 |
- |
+
+ | 389 |
+ 59x |
- indent = 0L,
+ if (tf_wrap) {
|
-
- | 78 |
- |
+
+ | 390 |
+ 16x |
- path = character(),
+ if (is.null(max_width)) {
|
-
- | 79 |
- |
+
+ | 391 |
+ 11x |
- incontent = FALSE,
+ max_width <- getOption("width", 80L)
|
-
- | 80 |
- |
+
+ | 392 |
+ 5x |
- repr_ext = 0L,
+ } else if (is.character(max_width) && identical(max_width, "auto")) {
|
-
- | 81 |
- |
+
+ | 393 |
+ 2x |
- repr_inds = integer(),
+ max_width <- ncchar + inset
|
- | 82 |
+ 394 |
|
- sibpos = NA_integer_,
+ }
|
-
- | 83 |
- |
+
+ | 395 |
+ 16x |
- nsibs = NA_integer_,
+ assert_number(max_width, lower = 0)
|
- | 84 |
+ 396 |
|
- max_width = NULL) {
+ }
|
- | 85 |
+ 397 |
|
- stop("make_row_df can be used only on {rtables} table objects, and not on `matrix_form`-",
+
|
-
- | 86 |
- |
+
+ | 398 |
+ 59x |
- "generated objects (MatrixPrintForm).")
+ mat <- do_cell_fnotes_wrap(mat, widths, max_width = max_width, tf_wrap = tf_wrap)
|
- | 87 |
+ 399 |
|
- })
+
|
-
- | 88 |
- |
+
+ | 400 |
+ 58x |
- ## nocov end
+ body <- mf_strings(mat)
|
-
- | 89 |
- |
+
+ | 401 |
+ 58x |
-
+ aligns <- mf_aligns(mat)
|
-
- | 90 |
- |
+
+ | 402 |
+ 58x |
-
+ keep_mat <- mf_display(mat)
|
- | 91 |
+ 403 |
|
- #' Transform `rtable` to a list of matrices which can be used for outputting
+ ## spans <- mat$spans
|
- | 92 |
+ 404 |
|
- #'
+ ## ri <- mat$row_info
|
-
- | 93 |
- |
+
+ | 405 |
+ 58x |
- #' Although `rtables` are represented as a tree data structure when outputting the table to ASCII or HTML it is useful to
+ ref_fnotes <- mf_rfnotes(mat)
|
-
- | 94 |
- |
+
+ | 406 |
+ 58x |
- #' map the `rtable` to an in between state with the formatted cells in a matrix form.
+ nl_header <- mf_nlheader(mat)
|
- | 95 |
+ 407 |
|
- #'
+
|
-
- | 96 |
- |
+
+ | 408 |
+ 58x |
- #' @param obj ANY. Object to be transformed into a ready-to-render form (a `MatrixPrintForm` object)
+ cell_widths_mat <- .calc_cell_widths(mat, widths, col_gap)
|
- | 97 |
+ 409 |
|
- #' @param indent_rownames logical(1), if TRUE the column with the row names in the `strings` matrix of has indented row
+
|
- | 98 |
+ 410 |
|
- #' names (strings pre-fixed)
+ # decimal alignment
|
-
- | 99 |
- |
+
+ | 411 |
+ 58x |
- #' @param expand_newlines logical(1). Should the matrix form generated
+ if (any_dec_align(aligns)) {
|
-
- | 100 |
- |
+
+ | 412 |
+ 18x |
- #' expand rows whose values contain newlines into multiple
+ body <- decimal_align(body, aligns)
|
- | 101 |
+ 413 |
|
- #' 'physical' rows (as they will appear when rendered into
+ }
|
- | 102 |
+ 414 |
|
- #' ASCII). Defaults to \code{TRUE}
+
|
-
- | 103 |
- |
+
+ | 415 |
+ 58x |
- #' @param indent_size numeric(1). Number of spaces to be used per level of indent (if supported by
+ content <- matrix(mapply(padstr, body, cell_widths_mat, aligns), ncol = ncol(body))
|
-
- | 104 |
- |
+
+ | 416 |
+ 58x |
- #' the relevant method). Defaults to 2.
+ content[!keep_mat] <- NA
|
- | 105 |
+ 417 |
|
- #' @export
+ # apply(content, 1, function(x) sum(nchar(x), na.rm = TRUE))
|
- | 106 |
+ 418 |
|
- #'
+
|
-
- | 107 |
- |
+
+ | 419 |
+ 58x |
- #' @details
+ gap_str <- strrep(" ", col_gap)
|
- | 108 |
+ 420 |
|
- #'
+
|
-
- | 109 |
- |
+
+ | 421 |
+ 58x |
- #' The strings in the return object are defined as follows: row labels are those determined by \code{summarize_rows} and
+ div <- substr(strrep(hsep, ncchar), 1, ncchar)
|
-
- | 110 |
- |
-
- #' cell values are determined using \code{get_formatted_cells}.
- |
-
-
- | 111 |
- |
-
- #' (Column labels are calculated using a non-exported internal function.
- |
-
-
- | 112 |
- |
-
- #'
- |
-
-
- | 113 |
- |
-
- #' @return A `MatrixPrintForm` classed list with the following elements:
- |
-
-
- | 114 |
- |
-
- #' \describe{
- |
-
-
- | 115 |
- |
-
- #' \item{strings}{The content, as it should be printed, of the top-left material, column headers, row labels, and
- |
-
-
- | 116 |
- |
-
- #' cell values of \code{tt}}
- |
-
-
- | 117 |
- |
-
- #' \item{spans}{The column-span information for each print-string in the strings matrix}
- |
-
-
- | 118 |
- |
-
- #' \item{aligns}{The text alignment for each print-string in the strings matrix}
- |
-
-
- | 119 |
- |
-
- #' \item{display}{Whether each print-string in the strings matrix should be printed or not}.
- |
-
-
- | 120 |
- |
-
- #' \item{row_info}{the data.frame generated by \code{summarize_rows(tt)}}
- |
-
-
- | 121 |
- |
-
- #' }
- |
-
-
- | 122 |
- |
-
- #'
- |
-
-
- | 123 |
- |
-
- #' With an additional \code{nrow_header} attribute indicating the number of pseudo "rows" the
- |
-
-
- | 124 |
- |
-
- #' column structure defines.
- |
-
-
- | 125 |
- |
-
- setGeneric("matrix_form", function(obj,
- |
-
-
- | 126 |
- |
-
- indent_rownames = FALSE,
- |
-
-
- | 127 |
- |
-
- expand_newlines = TRUE,
- |
-
-
- | 128 |
- |
+
+ | 422 |
+ 58x |
- indent_size = 2) {
+ txt_head <- apply(head(content, nl_header), 1, .paste_no_na, collapse = gap_str)
|
- | 129 |
- 152x |
+ 423 |
+ 58x |
- standardGeneric("matrix_form")
+ sec_seps_df <- x$row_info[, c("abs_rownumber", "trailing_sep"), drop = FALSE]
|
-
- | 130 |
- |
+
+ | 424 |
+ 58x |
- })
+ if (!is.null(sec_seps_df) && any(!is.na(sec_seps_df$trailing_sep))) {
|
-
- | 131 |
- |
+
+ | 425 |
+ 1x |
-
+ bdy_cont <- tail(content, -nl_header)
|
- | 132 |
+ 426 |
|
-
+ ## unfortunately we count "header rows" wrt line grouping so it
|
- | 133 |
+ 427 |
|
- #' @rdname matrix_form
+ ## doesn't match the real (i.e. body) rows as is
|
-
- | 134 |
- |
+
+ | 428 |
+ 1x |
- #' @export
+ row_grouping <- tail(x$line_grouping, -nl_header) - mf_nrheader(x)
|
-
- | 135 |
- |
+
+ | 429 |
+ 1x |
- setMethod("matrix_form", "MatrixPrintForm", function(obj,
+ nrbody <- NROW(bdy_cont)
|
-
- | 136 |
- |
+
+ | 430 |
+ 1x |
- indent_rownames = FALSE,
+ stopifnot(length(row_grouping) == nrbody)
|
- | 137 |
+ 431 |
|
- expand_newlines = TRUE,
+ ## all rows with non-NA section divs and the final row (regardless of NA status)
|
- | 138 |
+ 432 |
|
- indent_size = 2) {
+ ## fixes #77
|
- | 139 |
- 152x |
+ 433 |
+ 1x |
- obj
+ sec_seps_df <- sec_seps_df[unique(c(
|
-
- | 140 |
- |
+
+ | 434 |
+ 1x |
- })
+ which(!is.na(sec_seps_df$trailing_sep)),
|
-
- | 141 |
- |
+
+ | 435 |
+ 1x |
-
+ NROW(sec_seps_df)
|
- | 142 |
+ 436 |
|
-
+ )), ]
|
-
- | 143 |
- |
+
+ | 437 |
+ 1x |
- ## Generics for `toString` and helper functions
+ txt_body <- character()
|
-
- | 144 |
- |
+
+ | 438 |
+ 1x |
-
+ sec_strt <- 1
|
-
- | 145 |
- |
+
+ | 439 |
+ 1x |
-
+ section_rws <- sec_seps_df$abs_rownumber
|
-
- | 146 |
- |
+
+ | 440 |
+ 1x |
- ## this is where we will take word wrapping
+ for (i in seq_len(NROW(section_rws))) {
|
-
- | 147 |
- |
+
+ | 441 |
+ 2x |
- ## into account when it is added
+ cur_rownum <- section_rws[i]
|
-
- | 148 |
- |
+
+ | 442 |
+ 2x |
- ##
+ sec_end <- max(which(row_grouping == cur_rownum))
|
-
- | 149 |
- |
+
+ | 443 |
+ 2x |
- ## ALL calculations of vertical space for pagination
+ txt_body <- c(
|
-
- | 150 |
- |
+
+ | 444 |
+ 2x |
- ## purposes must go through nlines and divider_height!!!!!!!!
+ txt_body,
|
-
- | 151 |
- |
+
+ | 445 |
+ 2x |
-
+ apply(bdy_cont[seq(sec_strt, sec_end), , drop = FALSE],
|
-
-
- | 152 |
- |
+
+
+ | 446 |
+ 2x |
- ## this will be customizable someday. I have foreseen it (spooky noises)
+ 1,
|
-
- | 153 |
- |
+
+ | 447 |
+ 2x |
- #' Divider Height
+ .paste_no_na,
|
-
- | 154 |
- |
+
+ | 448 |
+ 2x |
- #'
+ collapse = gap_str
|
- | 155 |
+ 449 |
|
- #' @param obj ANY. Object.
+ ),
|
- | 156 |
+ 450 |
|
- #' @return The height, in lines of text, of the divider between
+ ## don't print section dividers if they would be the last thing before the
|
- | 157 |
+ 451 |
|
- #' header and body. Currently returns \code{1L} for the default method.
+ ## footer divider
|
- | 158 |
+ 452 |
|
- #' @export
+ ## this also ensures an extraneous sec div won't be printed if we have non-sec-div
|
- | 159 |
+ 453 |
|
- #' @examples
+ ## rows after the last sec div row (#77)
|
-
- | 160 |
- |
+
+ | 454 |
+ 2x |
- #' divider_height(mtcars)
+ if (sec_end < nrbody) {
|
- | 161 |
- 20x |
+ 455 |
+ 1x |
- setGeneric("divider_height", function(obj) standardGeneric("divider_height"))
+ substr(
|
-
- | 162 |
- |
+
+ | 456 |
+ 1x |
-
+ strrep(sec_seps_df$trailing_sep[i], ncchar), 1,
|
-
- | 163 |
- |
+
+ | 457 |
+ 1x |
- #' @rdname divider_height
+ ncchar - inset
|
- | 164 |
+ 458 |
|
- #' @export
+ )
|
- | 165 |
+ 459 |
|
- setMethod(
+ }
|
- | 166 |
+ 460 |
|
- "divider_height", "ANY",
+ )
|
- | 167 |
- 20x |
+ 461 |
+ 2x |
- function(obj) 1L
+ sec_strt <- sec_end + 1
|
- | 168 |
+ 462 |
|
- )
+ }
|
- | 169 |
+ 463 |
|
-
+ } else {
|
-
- | 170 |
- |
+
+ | 464 |
+ 57x |
- #' Number of lines required to print a value
+ txt_body <- apply(tail(content, -nl_header), 1, .paste_no_na, collapse = gap_str)
|
- | 171 |
+ 465 |
|
- #' @param x ANY. The object to be printed
+ }
|
- | 172 |
+ 466 |
|
- #' @param colwidths numeric. Column widths (if necessary).
+
|
- | 173 |
+ 467 |
|
- #' @param max_width numeric(1). Width strings should be wrapped to
+
|
-
- | 174 |
- |
+
+ | 468 |
+ 58x |
- #' when determining how many lines they require.
+ allts <- all_titles(x)
|
- | 175 |
+ 469 |
|
- #' @return A scalar numeric indicating the number of lines needed
+
|
-
- | 176 |
- |
+
+ | 470 |
+ 58x |
- #' to render the object \code{x}.
+ allfoots <- list(
|
-
- | 177 |
- |
+
+ | 471 |
+ 58x |
- #' @export
+ "main_footer" = main_footer(x),
|
-
- | 178 |
- |
+
+ | 472 |
+ 58x |
- setGeneric(
+ "prov_footer" = prov_footer(x),
+ |
+
+
+ | 473 |
+ 58x |
+
+ "ref_footnotes" = ref_fnotes
|
- | 179 |
+ 474 |
|
- "nlines",
+ )
|
- | 180 |
- 26621x |
+ 475 |
+ 58x |
- function(x, colwidths = NULL, max_width = NULL) standardGeneric("nlines")
+ allfoots <- allfoots[!sapply(allfoots, is.null)]
|
- | 181 |
+ 476 |
|
- )
+
|
- | 182 |
+ 477 |
|
|
- | 183 |
+ 478 |
|
- ## XXX beware. I think it is dangerous
+ ## Wrapping titles if they go beyond the horizontally allowed space
|
-
- | 184 |
- |
+
+ | 479 |
+ 58x |
- #' @export
+ if (tf_wrap) {
|
-
- | 185 |
- |
+
+ | 480 |
+ 16x |
- #' @rdname nlines
+ new_line_warning(allts)
|
-
- | 186 |
- |
+
+ | 481 |
+ 16x |
- setMethod(
+ allts <- wrap_txt(allts, max_width = max_width)
|
- | 187 |
+ 482 |
|
- "nlines", "list",
+ }
|
- | 188 |
+ 483 |
|
- function(x, colwidths, max_width) {
+
|
- | 189 |
- 2x |
+ 484 |
+ 58x |
- if (length(x) == 0) {
+ titles_txt <- if (any(nzchar(allts))) c(allts, "", .do_inset(div, inset)) else NULL
|
-
- | 190 |
- 1x |
+
+ | 485 |
+ |
- 0L
+
|
- | 191 |
+ 486 |
|
- } else {
+ # Wrapping footers if they go beyond the horizontally allowed space
|
- | 192 |
- 1x |
+ 487 |
+ 58x |
- sum(unlist(vapply(x, nlines, NA_integer_,
+ if (tf_wrap) {
|
- | 193 |
- 1x |
+ 488 |
+ 16x |
- colwidths = colwidths,
+ new_line_warning(allfoots)
|
- | 194 |
- 1x |
+ 489 |
+ 16x |
- max_width = max_width
+ allfoots$main_footer <- wrap_txt(allfoots$main_footer, max_width - inset)
+ |
+
+
+ | 490 |
+ 16x |
+
+ allfoots$ref_footnotes <- wrap_txt(allfoots$ref_footnotes, max_width - inset)
|
- | 195 |
+ 491 |
|
- )))
+ ## no - inset here because the prov_footer is not inset
|
-
- | 196 |
- |
+
+ | 492 |
+ 16x |
- }
+ allfoots$prov_footer <- wrap_txt(allfoots$prov_footer, max_width)
|
- | 197 |
+ 493 |
|
- }
+ }
|
- | 198 |
+ 494 |
|
- )
+
|
-
- | 199 |
- |
+
+ | 495 |
+ 58x |
-
+ paste0(paste(
|
-
- | 200 |
- |
+
+ | 496 |
+ 58x |
- #' @export
+ c(
|
-
- | 201 |
- |
+
+ | 497 |
+ 58x |
- #' @rdname nlines
+ titles_txt,
|
-
- | 202 |
- |
+
+ | 498 |
+ 58x |
- setMethod("nlines", "NULL", function(x, colwidths, max_width) 0L)
+ .do_inset(txt_head, inset),
|
-
- | 203 |
- |
+
+ | 499 |
+ 58x |
-
+ .do_inset(div, inset),
|
-
- | 204 |
- |
+
+ | 500 |
+ 58x |
- #' @export
+ .do_inset(txt_body, inset),
|
-
- | 205 |
- |
+
+ | 501 |
+ 58x |
- #' @rdname nlines
+ .footer_inset_helper(allfoots, div, inset)
|
- | 206 |
+ 502 |
|
- setMethod("nlines", "character", function(x, colwidths, max_width) {
+ ),
|
- | 207 |
- 26618x |
+ 503 |
+ 58x |
- if (length(x) == 0) {
+ collapse = "\n"
|
- | 208 |
- 1x |
+ 504 |
+ 58x |
- return(0L)
+ ), "\n")
|
- | 209 |
+ 505 |
|
- }
+ })
|
- | 210 |
+ 506 |
|
|
-
- | 211 |
- 26617x |
+
+ | 507 |
+ |
- sum(vapply(strsplit(x, "\n", fixed = TRUE),
+ .do_inset <- function(x, inset) {
|
- | 212 |
- 26617x |
+ 508 |
+ 322x |
- function(xi, max_width) {
+ if (inset == 0 || !any(nzchar(x))) {
|
- | 213 |
- 26623x |
+ 509 |
+ 303x |
- if (length(xi) == 0) {
+ return(x)
+ |
+
+
+ | 510 |
+ |
+
+ }
|
- | 214 |
- 2415x |
+ 511 |
+ 19x |
- 1L
+ padding <- strrep(" ", inset)
|
- | 215 |
- 24208x |
+ 512 |
+ 19x |
- } else if (length(max_width) == 0) { ## this happens with strsplit("", "\n")
+ if (is.character(x)) {
|
- | 216 |
- 24159x |
+ 513 |
+ 19x |
- length(xi)
+ x <- paste0(padding, x)
|
-
- | 217 |
- |
+
+ | 514 |
+ ! |
- } else {
+ } else if (is(x, "matrix")) {
|
-
- | 218 |
- 49x |
+
+ | 515 |
+ ! |
- length(wrap_txt(xi, max_width))
+ x[, 1] <- .do_inset(x[, 1, drop = TRUE], inset)
|
- | 219 |
+ 516 |
|
- }
+ }
|
- | 220 |
- 26617x |
+ 517 |
+ 19x |
- }, 1L,
+ x
|
-
- | 221 |
- 26617x |
+
+ | 518 |
+ |
- max_width = max_width
+ }
|
- | 222 |
+ 519 |
|
- ))
+
|
- | 223 |
+ 520 |
|
- })
+
|
- | 224 |
+ 521 |
|
-
+ .inset_div <- function(txt, div, inset) {
+ |
+
+
+ | 522 |
+ 40x |
+
+ c(.do_inset(div, inset), "", txt)
|
- | 225 |
+ 523 |
|
-
+ }
|
- | 226 |
+ 524 |
|
|
- | 227 |
+ 525 |
|
- #' @title `toString`
+ .footer_inset_helper <- function(footers_v, div, inset) {
|
-
- | 228 |
- |
+
+ | 526 |
+ 58x |
- #'
+ div_done <- FALSE # nolint
|
-
- | 229 |
- |
+
+ | 527 |
+ 58x |
- #' @description Transform a complex object into a string representation ready
+ fter <- footers_v$main_footer
|
-
- | 230 |
- |
+
+ | 528 |
+ 58x |
+
+ prvf <- footers_v$prov_footer
+ |
+
+
+ | 529 |
+ 58x |
+
+ rfn <- footers_v$ref_footnotes
+ |
+
+
+ | 530 |
+ 58x |
+
+ footer_txt <- .do_inset(rfn, inset)
+ |
+
+
+ | 531 |
+ 58x |
+
+ if (any(nzchar(footer_txt))) {
+ |
+
+
+ | 532 |
+ 14x |
- #' to be printed or written to a plain-text file
+ footer_txt <- .inset_div(footer_txt, div, inset)
|
- | 231 |
+ 533 |
|
- #'
+ }
|
-
- | 232 |
- |
+
+ | 534 |
+ 58x |
- #' @param x ANY. Object to be prepared for rendering.
+ if (any(vapply(
|
-
- | 233 |
- |
+
+ | 535 |
+ 58x |
- #' @param ... Passed to individual methods.
+ footers_v, function(x) any(nzchar(x)),
|
-
- | 234 |
- |
+
+ | 536 |
+ 58x |
- #' @rdname tostring
+ TRUE
|
- | 235 |
+ 537 |
|
- #' @export
+ ))) {
|
-
- | 236 |
- |
+
+ | 538 |
+ 26x |
- setGeneric("toString", function(x, ...) standardGeneric("toString"))
+ if (any(nzchar(prvf))) {
|
-
- | 237 |
- |
+
+ | 539 |
+ 24x |
-
+ provtxt <- c(
|
-
- | 238 |
- |
+
+ | 540 |
+ 24x |
- ## preserve S3 behavior
+ if (any(nzchar(fter))) "",
|
-
- | 239 |
- |
+
+ | 541 |
+ 24x |
- setMethod("toString", "ANY", base::toString) ## nocov
+ prvf
|
- | 240 |
+ 542 |
|
-
+ )
|
- | 241 |
+ 543 |
|
- #' @title Print
+ } else {
|
-
- | 242 |
- |
+
+ | 544 |
+ 2x |
- #'
+ provtxt <- character()
|
- | 243 |
+ 545 |
|
- #' @description Print an R object. see \code{[base::print()]}
+ }
|
-
- | 244 |
- |
+
+ | 546 |
+ 26x |
- #' @inheritParams base::print
+ footer_txt <- c(
|
-
- | 245 |
- |
+
+ | 547 |
+ 26x |
- #' @rdname basemethods
+ footer_txt,
|
-
- | 246 |
- |
+
+ | 548 |
+ 26x |
- setMethod("print", "ANY", base::print) ## nocov
+ .inset_div(
|
-
- | 247 |
- |
+
+ | 549 |
+ 26x |
-
+ c(
|
-
- | 248 |
- |
+
+ | 550 |
+ 26x |
-
+ .do_inset(fter, inset),
|
-
- | 249 |
- |
+
+ | 551 |
+ 26x |
-
+ provtxt
|
- | 250 |
+ 552 |
|
-
+ ),
|
-
- | 251 |
- |
+
+ | 553 |
+ 26x |
-
+ div,
|
-
- | 252 |
- |
+
+ | 554 |
+ 26x |
-
+ inset
|
- | 253 |
+ 555 |
|
-
+ )
|
- | 254 |
+ 556 |
|
-
+ )
|
- | 255 |
+ 557 |
|
-
+ }
|
-
- | 256 |
- |
+
+ | 558 |
+ 58x |
-
+ footer_txt
|
- | 257 |
+ 559 |
|
- ## General/"universal" property `getter` and `setter` generics and stubs
+ }
|
- | 258 |
+ 560 |
|
|
- | 259 |
+ 561 |
|
- #' @title Label, Name and Format accessor generics
+ new_line_warning <- function(str_v) {
|
-
- | 260 |
- |
+
+ | 562 |
+ 32x |
- #'
+ if (any(unlist(sapply(str_v, grepl, pattern = "\n")))) {
|
-
- | 261 |
- |
+
+ | 563 |
+ 2x |
- #' @description `Getters` and `setters` for basic, relatively universal attributes
+ msg <- c(
|
-
- | 262 |
- |
+
+ | 564 |
+ 2x |
- #' of "table-like" objects"
+ "Detected manual newlines when automatic title/footer word-wrapping is on.",
|
-
- | 263 |
- |
+
+ | 565 |
+ 2x |
- #'
+ "This is unsupported and will result in undefined behavior. Please either ",
|
-
- | 264 |
- |
+
+ | 566 |
+ 2x |
- #' @name lab_name
+ "utilize automatic word-wrapping with newline characters inserted, or ",
|
-
- | 265 |
- |
+
+ | 567 |
+ 2x |
- #' @param obj ANY. The object.
+ "turn off automatic wrapping and wordwrap all contents manually by inserting ",
|
-
- | 266 |
- |
+
+ | 568 |
+ 2x |
- #' @param value character(1)/FormatSpec. The new value of the attribute.
+ "newlines."
|
- | 267 |
+ 569 |
|
- #' @return the name, format or label of \code{obj} for `getters`, or \code{obj} after modification
+ )
|
-
- | 268 |
- |
+
+ | 570 |
+ 2x |
- #' for setters.
+ warning(paste0(msg, collapse = ""))
|
- | 269 |
+ 571 |
|
- #' @aliases obj_name
+ }
|
- | 270 |
+ 572 |
|
- #' @export
+ }
|
- | 271 |
+ 573 |
|
|
- | 272 |
+ 574 |
|
- ## no exported methods so we do nocov
+ #' Wrap a string to within a maximum width
|
- | 273 |
+ 575 |
|
- # nocov start
+ #' @param str character(1). String to be wrapped
|
- | 274 |
+ 576 |
|
- setGeneric("obj_name", function(obj) standardGeneric("obj_name"))
+ #' @param max_width numeric(1). Maximum width, in characters, that the
|
- | 275 |
+ 577 |
|
-
+ #' text should be wrapped at.
|
- | 276 |
+ 578 |
|
-
+ #' @param hard logical(1). Should hard wrapping (embedding newlines in
|
- | 277 |
+ 579 |
|
- #' @rdname lab_name
+ #' the incoming strings) or soft (breaking wrapped strings into vectors
|
- | 278 |
+ 580 |
|
- #' @export
+ #' of length >1) be used. Defaults to `FALSE` (i.e. soft wrapping).
|
- | 279 |
+ 581 |
|
- setGeneric("obj_name<-", function(obj, value) standardGeneric("obj_name<-"))
+ #'
|
- | 280 |
+ 582 |
|
- # nocov end
+ #' @details Word wrapping happens as with \link[base:strwrap]{base::strwrap}
|
- | 281 |
+ 583 |
|
-
+ #' with the following exception: individual words which are longer
|
- | 282 |
+ 584 |
|
- #' @seealso with_label
+ #' than `max_width` are broken up in a way that fits with the rest of the
|
- | 283 |
+ 585 |
|
- #' @rdname lab_name
+ #' word wrapping.
|
- | 284 |
+ 586 |
|
- #' @export
+ #'
|
-
- | 285 |
- 3x |
+
+ | 587 |
+ |
- setGeneric("obj_label", function(obj) standardGeneric("obj_label"))
+ #' @return A string (`wrap_string` or character vector (`wrap_txt`) containing
|
- | 286 |
+ 588 |
|
-
+ #' the hard or soft word-wrapped content.
|
- | 287 |
+ 589 |
|
- #' @rdname lab_name
+ #'
|
- | 288 |
+ 590 |
|
- #' @param value character(1). The new label
+ #' @export
|
- | 289 |
+ 591 |
|
- #' @export
+ wrap_string <- function(str, max_width, hard = FALSE) {
|
- | 290 |
- 2x |
+ 592 |
+ 16149x |
- setGeneric("obj_label<-", function(obj, value) standardGeneric("obj_label<-"))
+ stopifnot(is.character(str) && length(str) == 1)
|
-
- | 291 |
- |
+
+ | 593 |
+ 16149x |
-
+ naive <- strwrap(str, max_width + 1)
|
-
- | 292 |
- |
+
+ | 594 |
+ 16149x |
- #' @rdname lab_name
+ while (any(nchar(naive) > max_width)) {
|
-
- | 293 |
- |
+
+ | 595 |
+ 14x |
- #' @exportMethod obj_label
+ good <- character()
|
- | 294 |
- 3x |
+ 596 |
+ 14x |
- setMethod("obj_label", "ANY", function(obj) attr(obj, "label"))
+ bwi <- which(nchar(naive) > max_width)[1]
|
-
- | 295 |
- |
+
+ | 597 |
+ 14x |
-
+ curbw <- naive[bwi]
|
-
- | 296 |
- |
+
+ | 598 |
+ 14x |
- #' @rdname lab_name
+ if (bwi > 2) {
|
-
- | 297 |
- |
+
+ | 599 |
+ ! |
- #' @exportMethod obj_label<-
+ good <- c(good, naive[1:(bwi - 2)])
|
- | 298 |
+ 600 |
|
- setMethod(
+ }
+ |
+
+
+ | 601 |
+ 14x |
+
+ if (bwi > 1) {
+ |
+
+
+ | 602 |
+ 4x |
+
+ str_before <- naive[bwi - 1]
|
- | 299 |
+ 603 |
|
- "obj_label<-", "ANY",
+ } else {
+ |
+
+
+ | 604 |
+ 10x |
+
+ str_before <- ""
|
- | 300 |
+ 605 |
|
- function(obj, value) {
+ }
|
- | 301 |
- 2x |
+ 606 |
+ 14x |
- attr(obj, "label") <- value
+ room <- max_width - nchar(str_before) - (bwi > 1)
|
- | 302 |
- 2x |
+ 607 |
+ 14x |
- obj
+ if (room <= 0) {
|
-
- | 303 |
- |
+
+ | 608 |
+ 4x |
- }
+ toadd <- c(str_before, substr(curbw, 1, max_width))
|
-
- | 304 |
- |
+
+ | 609 |
+ 4x |
- )
+ room <- 0
|
-
- | 305 |
- |
+
+ | 610 |
+ 4x |
-
+ leftover <- substr(curbw, max_width + 1, nchar(curbw))
|
- | 306 |
+ 611 |
|
- #' @rdname lab_name
+ } else {
|
-
- | 307 |
- |
+
+ | 612 |
+ 10x |
- #' @export
+ goodpart <- substr(curbw, 1, room)
|
- | 308 |
- 131x |
+ 613 |
+ 10x |
- setGeneric("obj_format", function(obj) standardGeneric("obj_format"))
+ if (nzchar(str_before)) {
|
-
- | 309 |
- |
+
+ | 614 |
+ ! |
- ## this covers rcell, etc
+ toadd <- paste(str_before, goodpart)
|
- | 310 |
+ 615 |
|
- #' @rdname lab_name
+ } else {
+ |
+
+
+ | 616 |
+ 10x |
+
+ toadd <- goodpart
|
- | 311 |
+ 617 |
|
- #' @exportMethod obj_format
+ }
|
- | 312 |
- 129x |
+ 618 |
+ 10x |
- setMethod("obj_format", "ANY", function(obj) attr(obj, "format", exact = TRUE))
+ leftover <- substr(curbw, room + 1, nchar(curbw))
|
- | 313 |
+ 619 |
|
- #' @rdname lab_name
+ }
|
-
- | 314 |
- |
+
+ | 620 |
+ 14x |
- #' @export
+ good <- c(good, toadd)
|
- | 315 |
- 2x |
+ 621 |
+ 14x |
- setMethod("obj_format", "fmt_config", function(obj) obj@format)
+ if (bwi == length(naive)) {
|
-
- | 316 |
- |
+
+ | 622 |
+ 13x |
-
+ good <- c(good, leftover)
|
- | 317 |
+ 623 |
|
- #' @export
+ } else {
|
-
- | 318 |
- |
+
+ | 624 |
+ 1x |
- #' @rdname lab_name
+ good <- c(
|
- | 319 |
- 3x |
+ 625 |
+ 1x |
- setGeneric("obj_format<-", function(obj, value) standardGeneric("obj_format<-"))
+ good,
|
-
- | 320 |
- |
+
+ | 626 |
+ 1x |
- ## this covers rcell, etc
+ paste(leftover, naive[bwi + 1]),
|
-
- | 321 |
- |
+
+ | 627 |
+ 1x |
- #' @exportMethod obj_format<-
+ if (bwi < length(naive) - 1) naive[seq(bwi + 2, length(naive))]
|
- | 322 |
+ 628 |
|
- #' @rdname lab_name
+ )
|
- | 323 |
+ 629 |
|
- setMethod("obj_format<-", "ANY", function(obj, value) {
+ }
|
- | 324 |
- 2x |
+ 630 |
+ 14x |
- attr(obj, "format") <- value
+ str <- paste(good, collapse = " ")
|
- | 325 |
- 2x |
+ 631 |
+ 14x |
- obj
+ naive <- strwrap(str, max_width + 1)
|
- | 326 |
+ 632 |
|
- })
+ }
|
-
- | 327 |
- |
+
+ | 633 |
+ 16149x |
- #' @rdname lab_name
+ if (hard) {
|
-
- | 328 |
- |
+
+ | 634 |
+ 16016x |
- #' @export
+ naive <- paste(naive, collapse = "\n")
|
- | 329 |
+ 635 |
|
- setMethod("obj_format<-", "fmt_config", function(obj, value) {
- |
-
-
- | 330 |
- 1x |
-
- obj@format <- value
+ }
|
- | 331 |
- 1x |
+ 636 |
+ 16149x |
- obj
+ naive
|
- | 332 |
+ 637 |
|
- })
+ }
|
- | 333 |
+ 638 |
|
|
- | 334 |
+ 639 |
|
- #' @rdname lab_name
+ #' @param txt character. A vector of strings that should be (independently)
|
- | 335 |
+ 640 |
|
- #' @export
+ #' text-wrapped.
|
-
- | 336 |
- 3x |
+
+ | 641 |
+ |
- setGeneric("obj_na_str", function(obj) standardGeneric("obj_na_str"))
+ #' @rdname wrap_string
|
- | 337 |
+ 642 |
|
- #' @rdname lab_name
+ #' @export
|
- | 338 |
+ 643 |
|
- #' @exportMethod obj_na_str
+ wrap_txt <- function(txt, max_width, hard = FALSE) {
|
- | 339 |
- 1x |
+ 644 |
+ 113x |
- setMethod("obj_na_str", "ANY", function(obj) attr(obj, "format_na_str", exact = TRUE))
+ unlist(lapply(txt, wrap_string, max_width = max_width, hard = hard), use.names = FALSE)
|
- | 340 |
+ 645 |
|
- #' @rdname lab_name
+ }
|
- | 341 |
+ 646 |
|
- #' @export
+
+ |
+
+
+ | 647 |
+ |
+
+ pad_vert_top <- function(x, len) {
|
- | 342 |
- 2x |
+ 648 |
+ 2376x |
- setMethod("obj_na_str", "fmt_config", function(obj) obj@format_na_str)
+ c(x, rep("", len - length(x)))
|
- | 343 |
+ 649 |
|
-
+ }
|
- | 344 |
+ 650 |
|
- #' @rdname lab_name
+
|
- | 345 |
+ 651 |
|
- #' @export
+ pad_vert_bottom <- function(x, len) {
|
- | 346 |
- 2x |
+ 652 |
+ 78x |
- setGeneric("obj_na_str<-", function(obj, value) standardGeneric("obj_na_str<-"))
+ c(rep("", len - length(x)), x)
|
- | 347 |
+ 653 |
|
- #' @exportMethod obj_na_str<-
+ }
|
- | 348 |
+ 654 |
|
- #' @rdname lab_name
+
|
- | 349 |
+ 655 |
|
- setMethod("obj_na_str<-", "ANY", function(obj, value) {
+ pad_vec_to_len <- function(vec, len, cpadder = pad_vert_top, rlpadder = cpadder) {
|
- | 350 |
- 1x |
+ 656 |
+ 204x |
- attr(obj, "format_na_str") <- value
+ dat <- unlist(lapply(vec[-1], cpadder, len = len))
|
- | 351 |
- 1x |
+ 657 |
+ 204x |
- obj
+ dat <- c(rlpadder(vec[[1]], len = len), dat)
|
-
- | 352 |
- |
+
+ | 658 |
+ 204x |
- })
+ matrix(dat, nrow = len)
|
- | 353 |
+ 659 |
|
- #' @rdname lab_name
+ }
|
- | 354 |
+ 660 |
|
- #' @export
+
|
- | 355 |
+ 661 |
|
- setMethod("obj_na_str<-", "fmt_config", function(obj, value) {
+ rep_vec_to_len <- function(vec, len, ...) {
|
- | 356 |
- 1x |
+ 662 |
+ 138x |
- obj@format_na_str <- value
+ matrix(unlist(lapply(vec, rep, times = len)),
|
- | 357 |
- 1x |
+ 663 |
+ 138x |
- obj
+ nrow = len
+ |
+
+
+ | 664 |
+ |
+
+ )
|
- | 358 |
+ 665 |
|
- })
+ }
|
- | 359 |
+ 666 |
|
|
- | 360 |
+ 667 |
|
- #' @rdname lab_name
+
|
- | 361 |
+ 668 |
|
- #' @export
+ safe_strsplit <- function(x, split, ...) {
|
- | 362 |
- 3x |
+ 669 |
+ 273x |
- setGeneric("obj_align", function(obj) standardGeneric("obj_align"))
+ ret <- strsplit(x, split, ...)
|
-
- | 363 |
- |
+
+ | 670 |
+ 273x |
- #' @rdname lab_name
+ lapply(ret, function(reti) if (length(reti) == 0) "" else reti)
|
- | 364 |
+ 671 |
|
- #' @exportMethod obj_align
+ }
|
-
- | 365 |
- 1x |
+
+ | 672 |
+ |
- setMethod("obj_align", "ANY", function(obj) attr(obj, "align", exact = TRUE))
+
|
- | 366 |
+ 673 |
|
- #' @rdname lab_name
+ .expand_mat_rows_inner <- function(i, mat, row_nlines, expfun, ...) {
|
-
- | 367 |
- |
+
+ | 674 |
+ 342x |
- #' @export
+ leni <- row_nlines[i]
|
- | 368 |
- 2x |
+ 675 |
+ 342x |
- setMethod("obj_align", "fmt_config", function(obj) obj@align)
+ rw <- mat[i, ]
|
-
- | 369 |
- |
+
+ | 676 |
+ 342x |
-
+ if (is.character(rw)) {
|
-
- | 370 |
- |
+
+ | 677 |
+ 273x |
- #' @rdname lab_name
+ rw <- safe_strsplit(rw, "\n", fixed = TRUE)
|
- | 371 |
+ 678 |
|
- #' @export
+ }
|
- | 372 |
- 2x |
+ 679 |
+ 342x |
- setGeneric("obj_align<-", function(obj, value) standardGeneric("obj_align<-"))
+ expfun(rw, len = leni, ...)
|
- | 373 |
+ 680 |
|
- #' @exportMethod obj_align<-
+ }
|
- | 374 |
+ 681 |
|
- #' @rdname lab_name
+
|
- | 375 |
+ 682 |
|
- setMethod("obj_align<-", "ANY", function(obj, value) {
+ expand_mat_rows <- function(mat, row_nlines = apply(mat, 1, nlines), expfun = pad_vec_to_len, ...) {
|
- | 376 |
- 1x |
+ 683 |
+ 22x |
- attr(obj, "align") <- value
+ rinds <- seq_len(nrow(mat))
|
- | 377 |
- 1x |
+ 684 |
+ 22x |
- obj
+ exprows <- lapply(rinds, .expand_mat_rows_inner,
|
-
- | 378 |
- |
+
+ | 685 |
+ 22x |
- })
+ mat = mat,
|
-
- | 379 |
- |
+
+ | 686 |
+ 22x |
- #' @rdname lab_name
+ row_nlines = row_nlines,
+ |
+
+
+ | 687 |
+ 22x |
+
+ expfun = expfun,
|
- | 380 |
+ 688 |
|
- #' @export
+ ...
|
- | 381 |
+ 689 |
|
- setMethod("obj_align<-", "fmt_config", function(obj, value) {
+ )
|
- | 382 |
- 1x |
+ 690 |
+ 22x |
- obj@align <- value
+ do.call(rbind, exprows)
|
-
- | 383 |
- 1x |
+
+ | 691 |
+ |
- obj
+ }
|
- | 384 |
+ 692 |
|
- })
+
|
- | 385 |
+ 693 |
|
|
- | 386 |
+ 694 |
|
- #' General title/footer accessors
+ #' Transform vectors of spans (with duplication) to Visibility vector
|
- | 387 |
+ 695 |
|
#'
|
- | 388 |
+ 696 |
|
- #' @param obj ANY. Object to extract information from.
+ #' @param spans numeric. A vector of spans, with each span value repeated
|
- | 389 |
+ 697 |
|
- #' @export
+ #' for the cells it covers.
|
- | 390 |
+ 698 |
|
- #' @rdname title_footer
+ #'
|
- | 391 |
+ 699 |
|
- #' @return A character scalar (`main_title`), a character vector (`main_footer`), or
+ #' @details
|
- | 392 |
+ 700 |
|
- #' vector of length zero or more (`subtitles`, `page_titles`,
+ #'
|
- | 393 |
+ 701 |
|
- #' `prov_footer`) containing the relevant title/footer contents
+ #' The values of \code{spans} are assumed to be repeated to such that
|
-
- | 394 |
- 90x |
+
+ | 702 |
+ |
- setGeneric("main_title", function(obj) standardGeneric("main_title"))
+ #' each individual position covered by the span has the repeated value.
|
- | 395 |
+ 703 |
|
-
+ #'
|
- | 396 |
+ 704 |
|
- #' @export
+ #' This means that each block of values in \code{span} must be of a length
|
- | 397 |
+ 705 |
|
- #' @rdname title_footer
+ #' at least equal to its value (i.e. two 2s, three 3s, etc).
|
- | 398 |
+ 706 |
|
- setMethod(
+ #'
|
- | 399 |
+ 707 |
|
- "main_title", "MatrixPrintForm",
+ #' This function correctly handles cases where two spans of the same size
|
-
- | 400 |
- 90x |
+
+ | 708 |
+ |
- function(obj) obj$main_title
+ #' are next to each other; i.e., a block of four 2s represents two large
|
- | 401 |
+ 709 |
|
- )
+ #' cells each of which span two individual cells.
|
- | 402 |
+ 710 |
|
-
+ #' @export
|
- | 403 |
+ 711 |
|
- ##' @rdname title_footer
+ #' @note
|
- | 404 |
+ 712 |
|
- ##' @export
+ #'
+ |
+
+
+ | 713 |
+ |
+
+ #' Currently no checking or enforcement is done that the vector of
+ |
+
+
+ | 714 |
+ |
+
+ #' spans is valid in the sense described in the Details section above.
|
-
- | 405 |
- 6x |
+
+ | 715 |
+ |
- setGeneric("main_title<-", function(obj, value) standardGeneric("main_title<-"))
+ #' @examples
|
- | 406 |
+ 716 |
|
- ##' @rdname title_footer
+ #'
|
- | 407 |
+ 717 |
|
- ##' @export
+ #' spans_to_viscell(c(2, 2, 2, 2, 1, 3, 3, 3))
|
- | 408 |
+ 718 |
|
- setMethod(
+ #' @return a logical vector the same length as `spans` indicating
|
- | 409 |
+ 719 |
|
- "main_title<-", "MatrixPrintForm",
+ #' whether the contents of a string vector with those spans
|
- | 410 |
+ 720 |
|
- function(obj, value) {
+ spans_to_viscell <- function(spans) {
|
- | 411 |
- 6x |
+ 721 |
+ 2x |
- obj$main_title <- value
+ if (!is.vector(spans)) {
|
-
- | 412 |
- 6x |
+
+ | 722 |
+ ! |
- obj
+ spans <- as.vector(spans)
|
- | 413 |
+ 723 |
|
}
|
-
- | 414 |
- |
+
+ | 724 |
+ 2x |
- )
+ myrle <- rle(spans)
|
-
- | 415 |
- |
+
+ | 725 |
+ 2x |
-
+ unlist(
|
-
- | 416 |
- |
+
+ | 726 |
+ 2x |
-
+ mapply(
|
-
- | 417 |
- |
+
+ | 727 |
+ 2x |
-
+ function(vl, ln) {
|
-
- | 418 |
- |
+
+ | 728 |
+ 4x |
- #' @export
+ rep(c(TRUE, rep(FALSE, vl - 1L)), times = ln / vl)
|
- | 419 |
+ 729 |
|
- #' @rdname title_footer
+ },
|
-
- | 420 |
- |
+
+ | 730 |
+ 2x |
- setGeneric("subtitles", function(obj) standardGeneric("subtitles")) ## nocov
+ SIMPLIFY = FALSE,
|
-
- | 421 |
- |
+
+ | 731 |
+ 2x |
-
+ vl = myrle$values,
|
-
- | 422 |
- |
+
+ | 732 |
+ 2x |
- #' @export
+ ln = myrle$lengths
|
- | 423 |
+ 733 |
|
- #' @rdname title_footer
+ ),
|
-
- | 424 |
- |
+
+ | 734 |
+ 2x |
- setMethod(
+ recursive = FALSE
|
- | 425 |
+ 735 |
|
- "subtitles", "MatrixPrintForm",
+ )
|
-
- | 426 |
- 91x |
+
+ | 736 |
+ |
- function(obj) obj$subtitles
+ }
|
- | 427 |
+ 737 |
|
- )
+
|
- | 428 |
+ 738 |
|
|
- | 429 |
+ 739 |
|
- ##' @rdname title_footer
+ #' Propose Column Widths based on an object's `MatrixPrintForm` form
|
- | 430 |
+ 740 |
|
- ##' @export
+ #'
|
- | 431 |
+ 741 |
|
- setGeneric("subtitles<-", function(obj, value) standardGeneric("subtitles<-")) ## nocov
+ #' The row names are also considered a column for the output
|
- | 432 |
+ 742 |
|
-
+ #'
|
- | 433 |
+ 743 |
|
- ##' @rdname title_footer
+ #' @param x `MatrixPrintForm` object, or an object with a `matrix_form`
|
- | 434 |
+ 744 |
|
- ##' @export
+ #' method.
|
- | 435 |
+ 745 |
|
- setMethod(
+ #' @param indent_size numeric(1). Indent size in characters. Ignored
|
- | 436 |
+ 746 |
|
- "subtitles<-", "MatrixPrintForm",
+ #' when `x` is already a `MatrixPrintForm` object in favor of information
|
- | 437 |
+ 747 |
|
- function(obj, value) {
+ #' there.
|
-
- | 438 |
- 5x |
+
+ | 748 |
+ |
- obj$subtitles <- value
+ #'
|
-
- | 439 |
- 5x |
+
+ | 749 |
+ |
- obj
+ #' @examples
|
- | 440 |
+ 750 |
|
- }
+ #' mf <- basic_matrix_form(mtcars)
|
- | 441 |
+ 751 |
|
- )
+ #' propose_column_widths(mf)
|
- | 442 |
+ 752 |
|
-
+ #'
|
- | 443 |
+ 753 |
|
#' @export
|
- | 444 |
+ 754 |
|
- #' @rdname title_footer
- |
-
-
- | 445 |
- 107x |
-
- setGeneric("page_titles", function(obj) standardGeneric("page_titles"))
+ #' @return a vector of column widths based on the content of \code{x}
|
- | 446 |
+ 755 |
|
-
+ #' for use in printing and pagination.
|
- | 447 |
+ 756 |
|
- #' @export
+ ## ' @examples
|
- | 448 |
+ 757 |
|
- #' @rdname title_footer
+ ## ' library(dplyr)
|
- | 449 |
+ 758 |
|
- setMethod(
+ ## ' library(rtables)
|
- | 450 |
+ 759 |
|
- "page_titles", "MatrixPrintForm",
- |
-
-
- | 451 |
- 107x |
-
- function(obj) obj$page_titles
+ ## ' iris2 <- iris %>%
|
- | 452 |
+ 760 |
|
- )
+ ## ' group_by(Species) %>%
|
- | 453 |
+ 761 |
|
- #' @rdname title_footer
+ ## ' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
|
- | 454 |
+ 762 |
|
- #' @export
+ ## ' ungroup()
|
-
- | 455 |
- ! |
+
+ | 763 |
+ |
- setMethod("page_titles", "ANY", function(obj) NULL)
+ ## '
|
- | 456 |
+ 764 |
|
-
+ ## ' l <- basic_table() %>%
|
- | 457 |
+ 765 |
|
- ##' @rdname title_footer
+ ## ' split_cols_by("Species") %>%
|
- | 458 |
+ 766 |
|
- ##' @export
+ ## ' split_cols_by("group") %>%
|
-
- | 459 |
- 2x |
+
+ | 767 |
+ |
- setGeneric("page_titles<-", function(obj, value) standardGeneric("page_titles<-"))
+ ## ' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary) , format = "xx.xx")
|
- | 460 |
+ 768 |
|
-
+ ## '
|
- | 461 |
+ 769 |
|
- #' @export
+ ## ' tbl <- build_table(l, iris2)
|
- | 462 |
+ 770 |
|
- #' @rdname title_footer
+ ## ' mf <- matrix_form(tbl)
|
- | 463 |
+ 771 |
|
- setMethod(
+ ## ' propose_column_widths(mf)
|
- | 464 |
+ 772 |
|
- "page_titles<-", "MatrixPrintForm",
+ propose_column_widths <- function(x, indent_size = 2) {
|
- | 465 |
+ 773 |
|
- function(obj, value) {
+ ## stopifnot(is(x, "VTableTree"))
|
- | 466 |
- 2x |
+ 774 |
+ 67x |
- if (!is.character(value)) {
+ if (!is(x, "MatrixPrintForm")) {
|
- | 467 |
+ 775 |
! |
- stop("page titles must be in the form of a character vector, got object of class ", class(value))
+ x <- matrix_form(x, indent_rownames = TRUE, indent_size = indent_size)
|
- | 468 |
+ 776 |
|
- }
+ }
|
- | 469 |
- 2x |
+ 777 |
+ 67x |
- obj$page_titles <- value
+ body <- mf_strings(x)
|
- | 470 |
- 2x |
+ 778 |
+ 67x |
- obj
+ spans <- mf_spans(x)
|
-
- | 471 |
- |
+
+ | 779 |
+ 67x |
- }
+ aligns <- mf_aligns(x)
|
-
- | 472 |
- |
+
+ | 780 |
+ 67x |
- )
+ display <- mf_display(x)
|
- | 473 |
+ 781 |
|
|
- | 474 |
+ 782 |
|
-
+ # compute decimal alignment if asked in alignment matrix
|
-
- | 475 |
- |
+
+ | 783 |
+ 67x |
-
+ if (any_dec_align(aligns)) {
|
-
- | 476 |
- |
+
+ | 784 |
+ 27x |
- #' @export
+ body <- decimal_align(body, aligns)
|
- | 477 |
+ 785 |
|
- #' @rdname title_footer
- |
-
-
- | 478 |
- 85x |
-
- setGeneric("main_footer", function(obj) standardGeneric("main_footer"))
+ }
|
- | 479 |
+ 786 |
|
|
-
- | 480 |
- |
+
+ | 787 |
+ 64x |
- #' @export
+ chars <- nchar(body)
|
- | 481 |
+ 788 |
|
- #' @rdname title_footer
+
|
- | 482 |
+ 789 |
|
- setMethod(
+ # first check column widths without colspan
|
-
- | 483 |
- |
+
+ | 790 |
+ 64x |
- "main_footer", "MatrixPrintForm",
+ has_spans <- spans != 1
|
- | 484 |
- 85x |
+ 791 |
+ 64x |
- function(obj) obj$main_footer
+ chars_ns <- chars
|
-
- | 485 |
- |
+
+ | 792 |
+ 64x |
- )
+ chars_ns[has_spans] <- 0
|
-
- | 486 |
- |
+
+ | 793 |
+ 64x |
-
+ widths <- apply(chars_ns, 2, max)
|
- | 487 |
+ 794 |
|
- #' @rdname title_footer
+
|
- | 488 |
+ 795 |
|
- #' @param value character. New value.
+ # now check if the colspans require extra width
|
-
- | 489 |
- |
+
+ | 796 |
+ 64x |
- #' @export
+ if (any(has_spans)) {
|
- | 490 |
- 6x |
+ 797 |
+ 1x |
- setGeneric("main_footer<-", function(obj, value) standardGeneric("main_footer<-"))
+ has_row_spans <- apply(has_spans, 1, any)
|
- | 491 |
+ 798 |
|
|
-
- | 492 |
- |
+
+ | 799 |
+ 1x |
-
+ chars_sp <- chars[has_row_spans, , drop = FALSE]
|
-
- | 493 |
- |
+
+ | 800 |
+ 1x |
-
+ spans_sp <- spans[has_row_spans, , drop = FALSE]
|
-
- | 494 |
- |
+
+ | 801 |
+ 1x |
- #' @export
+ disp_sp <- display[has_row_spans, , drop = FALSE]
|
- | 495 |
+ 802 |
|
- #' @rdname title_footer
+
|
-
- | 496 |
- |
+
+ | 803 |
+ 1x |
- setMethod(
+ nc <- ncol(spans)
|
-
- | 497 |
- |
+
+ | 804 |
+ 1x |
- "main_footer<-", "MatrixPrintForm",
+ for (i in seq_len(nrow(chars_sp))) {
|
-
- | 498 |
- |
+
+ | 805 |
+ 1x |
- function(obj, value) {
+ for (j in seq_len(nc)) {
|
- | 499 |
- 6x |
+ 806 |
+ 2x |
- if (!is.character(value)) {
+ if (disp_sp[i, j] && spans_sp[i, j] != 1) {
|
-
- | 500 |
- ! |
+
+ | 807 |
+ 1x |
- stop("main footer must be a character vector. Got object of class ", class(value))
+ i_cols <- seq(j, j + spans_sp[i, j] - 1)
|
- | 501 |
+ 808 |
|
- }
+
|
- | 502 |
- 6x |
+ 809 |
+ 1x |
- obj$main_footer <- value
+ nchar_i <- chars_sp[i, j]
|
- | 503 |
- 6x |
-
- obj
- |
-
-
- | 504 |
- |
+ 810 |
+ 1x |
- }
+ cw_i <- widths[i_cols]
|
-
- | 505 |
- |
+
+ | 811 |
+ 1x |
- )
+ available_width <- sum(cw_i)
|
- | 506 |
+ 812 |
|
|
-
- | 507 |
- |
+
+ | 813 |
+ 1x |
-
+ if (nchar_i > available_width) {
|
- | 508 |
+ 814 |
|
- #' @export
+ # need to update widths to fit content with colspans
|
- | 509 |
+ 815 |
|
- #' @rdname title_footer
+ # spread width among columns
|
-
- | 510 |
- 95x |
+
+ | 816 |
+ ! |
- setGeneric("prov_footer", function(obj) standardGeneric("prov_footer"))
+ widths[i_cols] <- cw_i + spread_integer(nchar_i - available_width, length(cw_i))
|
- | 511 |
+ 817 |
|
-
+ }
|
- | 512 |
+ 818 |
|
- #' @export
+ }
|
- | 513 |
+ 819 |
|
- #' @rdname title_footer
+ }
|
- | 514 |
+ 820 |
|
- setMethod(
+ }
|
- | 515 |
+ 821 |
|
- "prov_footer", "MatrixPrintForm",
+ }
|
- | 516 |
- 95x |
+ 822 |
+ 64x |
- function(obj) obj$prov_footer
+ widths
|
- | 517 |
+ 823 |
|
- )
+ }
|
- | 518 |
+ 824 |
|
|
- | 519 |
+ 825 |
|
- #' @rdname title_footer
+
|
- | 520 |
+ 826 |
|
- #' @export
+
|
-
- | 521 |
- 7x |
+
+ | 827 |
+ |
- setGeneric("prov_footer<-", function(obj, value) standardGeneric("prov_footer<-"))
+
|
- | 522 |
+ 828 |
|
-
+ #' Pad a string and align within string
|
- | 523 |
+ 829 |
|
- #' @export
+ #'
|
- | 524 |
+ 830 |
|
- #' @rdname title_footer
+ #' @param x string
|
- | 525 |
+ 831 |
|
- setMethod(
+ #' @param n number of character of the output string, if `n <
|
- | 526 |
+ 832 |
|
- "prov_footer<-", "MatrixPrintForm",
+ #' nchar(x)` an error is thrown
|
- | 527 |
+ 833 |
|
- function(obj, value) {
+ #' @param just character(1). Text alignment justification to
|
-
- | 528 |
- 7x |
+
+ | 834 |
+ |
- if (!is.character(value)) {
+ #' use. Defaults to `center`. Must be `center`, `right`, `left`,
|
-
- | 529 |
- ! |
+
+ | 835 |
+ |
- stop("provenance footer must be a character vector. Got object of class ", class(value))
+ #' `dec_right`, `dec_left` or `decimal`.
|
- | 530 |
+ 836 |
|
- }
+ #'
|
-
- | 531 |
- 7x |
+
+ | 837 |
+ |
- obj$prov_footer <- value
+ #' @export
|
-
- | 532 |
- 7x |
+
+ | 838 |
+ |
- obj
+ #' @examples
|
- | 533 |
+ 839 |
|
- }
+ #'
|
- | 534 |
+ 840 |
|
- )
+ #' padstr("abc", 3)
|
- | 535 |
+ 841 |
|
-
+ #' padstr("abc", 4)
|
- | 536 |
+ 842 |
|
-
+ #' padstr("abc", 5)
|
- | 537 |
+ 843 |
|
-
+ #' padstr("abc", 5, "left")
|
- | 538 |
+ 844 |
|
-
+ #' padstr("abc", 5, "right")
|
- | 539 |
+ 845 |
|
- #' @rdname title_footer
+ #'
|
- | 540 |
+ 846 |
|
- #' @export
+ #' if (interactive()) {
|
-
- | 541 |
- 1x |
+
+ | 847 |
+ |
- all_footers <- function(obj) c(main_footer(obj), prov_footer(obj))
+ #' padstr("abc", 1)
|
- | 542 |
+ 848 |
|
-
+ #' }
|
- | 543 |
+ 849 |
|
- #' @rdname title_footer
+ #' @return `x`, padded to be a string of `n` characters
|
- | 544 |
+ 850 |
|
- #' @export
+ #'
+ |
+
+
+ | 851 |
+ |
+
+ padstr <- function(x, n, just = list_valid_aligns()) {
|
- | 545 |
- 88x |
+ 852 |
+ 5015x |
- all_titles <- function(obj) c(main_title(obj), subtitles(obj), page_titles(obj))
+ just <- match.arg(just)
|
- | 546 |
+ 853 |
|
|
-
- | 547 |
- |
+
+ | 854 |
+ 1x |
-
+ if (length(x) != 1) stop("length of x needs to be 1 and not", length(x))
|
-
- | 548 |
- |
+
+ | 855 |
+ 1x |
- #' Access or (recursively) set table inset.
+ if (is.na(n) || !is.numeric(n) || n < 0) stop("n needs to be numeric and > 0")
|
- | 549 |
+ 856 |
|
- #'
+
|
-
- | 550 |
- |
+
+ | 857 |
+ 1x |
- #' Table inset is the amount of characters that the body of
+ if (is.na(x)) x <- "<NA>"
|
- | 551 |
+ 858 |
|
- #' a table, referential footnotes, and main footer material
+
|
-
- | 552 |
- |
+
+ | 859 |
+ 5013x |
- #' are inset from the left-alignment of the titles and provenance
+ nc <- nchar(x)
|
- | 553 |
+ 860 |
|
- #' footer materials.
+
|
-
- | 554 |
- |
+
+ | 861 |
+ ! |
- #'
+ if (n < nc) stop("\"", x, "\" has more than ", n, " characters")
|
- | 555 |
+ 862 |
|
- #' @param obj ANY. Object to get or (recursively if necessary) set
+
|
-
- | 556 |
- |
+
+ | 863 |
+ 5013x |
- #' table inset for.
+ switch(just,
|
- | 557 |
+ 864 |
|
- #' @param value character(1). String to use as new header/body separator.
+ center = {
|
-
- | 558 |
- |
+
+ | 865 |
+ 269x |
- #'
+ pad <- (n - nc) / 2
|
-
- | 559 |
- |
+
+ | 866 |
+ 269x |
- #' @return for `table_inset` the integer value that the table body
+ paste0(spaces(floor(pad)), x, spaces(ceiling(pad)))
|
- | 560 |
+ 867 |
|
- #' (including column heading information and section dividers),
+ },
|
-
- | 561 |
- |
+
+ | 868 |
+ 4595x |
- #' referential footnotes, and main footer should be inset from the
+ left = paste0(x, spaces(n - nc)),
|
-
- | 562 |
- |
+
+ | 869 |
+ 10x |
- #' left alignment of the titles and provenance footers during rendering.
+ right = paste0(spaces(n - nc), x),
|
- | 563 |
+ 870 |
|
- #' For `table_inset<-`, the `obj`, with the new table_inset value
+ decimal = {
|
-
- | 564 |
- |
+
+ | 871 |
+ 60x |
- #' applied recursively to it and all its subtables.
+ pad <- (n - nc) / 2
|
-
- | 565 |
- |
+
+ | 872 |
+ 60x |
- #'
+ paste0(spaces(floor(pad)), x, spaces(ceiling(pad)))
|
- | 566 |
+ 873 |
|
- #' @export
+ },
|
- | 567 |
- 187x |
+ 874 |
+ 44x |
- setGeneric("table_inset", function(obj) standardGeneric("table_inset"))
+ dec_left = paste0(x, spaces(n - nc)),
|
-
- | 568 |
- |
+
+ | 875 |
+ 35x |
-
+ dec_right = paste0(spaces(n - nc), x)
|
- | 569 |
+ 876 |
|
- #' @rdname table_inset
+ )
|
- | 570 |
+ 877 |
|
- #' @export
+ }
|
- | 571 |
+ 878 |
|
- setMethod(
+
|
- | 572 |
+ 879 |
|
- "table_inset", "MatrixPrintForm",
+ spaces <- function(n) {
|
- | 573 |
- 187x |
+ 880 |
+ 5500x |
- function(obj) obj$table_inset
+ strrep(" ", n)
|
- | 574 |
+ 881 |
|
- )
+ }
|
- | 575 |
+ 882 |
|
|
- | 576 |
+ 883 |
|
|
- | 577 |
- |
-
- #' @rdname table_inset
- |
-
-
- | 578 |
+ 884 |
|
- #' @export
+ .paste_no_na <- function(x, ...) {
|
- | 579 |
- 4x |
+ 885 |
+ 870x |
- setGeneric("table_inset<-", function(obj, value) standardGeneric("table_inset<-"))
+ paste(na.omit(x), ...)
|
- | 580 |
+ 886 |
|
-
+ }
|
- | 581 |
+ 887 |
|
- #' @rdname table_inset
+
|
- | 582 |
+ 888 |
|
- #' @export
+
|
- | 583 |
+ 889 |
|
- setMethod(
+ #' spread `x` into `len` elements
|
- | 584 |
+ 890 |
|
- "table_inset<-", "MatrixPrintForm",
+ #'
|
- | 585 |
+ 891 |
|
- function(obj, value) {
+ #' @param x numeric(1). The number to spread
|
-
- | 586 |
- 4x |
+
+ | 892 |
+ |
- newval <- as.integer(value)
+ #' @param len numeric(1). The number of times to repeat \code{x}
|
-
- | 587 |
- 4x |
+
+ | 893 |
+ |
- if (is.na(newval) || newval < 0) {
+ #'
|
-
- | 588 |
- 1x |
+
+ | 894 |
+ |
- stop("Got invalid value for table_inset: ", newval)
+ #' @export
|
- | 589 |
+ 895 |
|
- }
+ #' @return if \code{x} is a scalar "whole number" value (see \code{\link{is.wholenumber}}),
|
-
- | 590 |
- 3x |
+
+ | 896 |
+ |
- obj$table_inset <- newval
+ #' the value \code{x} repeated \code{len} times. If not, an error is thrown.
|
-
- | 591 |
- 3x |
+
+ | 897 |
+ |
- obj
+ #' @examples
|
- | 592 |
+ 898 |
|
- }
+ #' spread_integer(3, 1)
|
- | 593 |
+ 899 |
|
- )
+ #' spread_integer(0, 3)
|
- | 594 |
+ 900 |
|
-
+ #' spread_integer(1, 3)
|
- | 595 |
+ 901 |
|
-
+ #' spread_integer(2, 3)
|
- | 596 |
+ 902 |
|
-
+ #' spread_integer(3, 3)
|
- | 597 |
+ 903 |
|
-
+ #' spread_integer(4, 3)
|
- | 598 |
+ 904 |
|
- #' Generic for Performing "Forced Pagination"
+ #' spread_integer(5, 3)
|
- | 599 |
+ 905 |
|
- #'
+ #' spread_integer(6, 3)
|
- | 600 |
+ 906 |
|
- #' Forced pagination is pagination which happens regardless of
+ #' spread_integer(7, 3)
|
- | 601 |
+ 907 |
|
- #' position on page. The object is expected to have all information
+ spread_integer <- function(x, len) {
|
-
- | 602 |
- |
+
+ | 908 |
+ 2x |
- #' necessary to locate such page breaks, and the `do_forced_pag`
+ stopifnot(
|
-
- | 603 |
- |
+
+ | 909 |
+ 2x |
- #' method is expected to fully perform those paginations.
+ is.wholenumber(x), length(x) == 1, x >= 0,
|
-
- | 604 |
- |
+
+ | 910 |
+ 2x |
- #'
+ is.wholenumber(len), length(len) == 1, len >= 0,
|
-
- | 605 |
- |
+
+ | 911 |
+ 2x |
- #' @param obj The object to be paginated.
+ !(len == 0 && x > 0)
|
- | 606 |
+ 912 |
|
- #'
+ )
|
- | 607 |
+ 913 |
|
- #' The `ANY` method simply returns a list of length one, containing
+
|
- | 608 |
+ 914 |
|
- #' `obj`.
+
|
-
- | 609 |
- |
+
+ | 915 |
+ 1x |
- #'
+ if (len == 0) {
|
-
- | 610 |
- |
+
+ | 916 |
+ ! |
- #' @return a list of subobjects, which will be further paginated
+ integer(0)
|
- | 611 |
+ 917 |
|
- #' by the standard pagination algorithm.
+ } else {
|
-
- | 612 |
- |
+
+ | 918 |
+ 1x |
- #'
+ y <- rep(floor(x / len), len)
|
-
- | 613 |
- |
+
+ | 919 |
+ 1x |
- #'
+ i <- 1
|
-
- | 614 |
- |
+
+ | 920 |
+ 1x |
- #' @export
+ while (sum(y) < x) {
|
- | 615 |
- 46x |
+ 921 |
+ 1x |
- setGeneric("do_forced_paginate", function(obj) standardGeneric("do_forced_paginate"))
+ y[i] <- y[i] + 1
|
-
- | 616 |
- |
+
+ | 922 |
+ 1x |
-
+ if (i == len) {
|
-
- | 617 |
- |
+
+ | 923 |
+ ! |
- #' @export
+ i <- 1
|
- | 618 |
+ 924 |
|
- #' @rdname do_forced_paginate
+ } else {
|
- | 619 |
- 43x |
+ 925 |
+ 1x |
- setMethod("do_forced_paginate", "ANY", function(obj) list(obj))
+ i <- i + 1
|
- | 620 |
+ 926 |
|
-
+ }
|
- | 621 |
+ 927 |
|
- #' Number of repeated columns
+ }
+ |
+
+
+ | 928 |
+ 1x |
+
+ y
|
- | 622 |
+ 929 |
|
- #'
+ }
|
- | 623 |
+ 930 |
|
- #' When called on a table-like object using the formatters framework,
+ }
|
- | 624 |
+ 931 |
|
- #' this method should return the number of columns which are mandatorily
+
|
- | 625 |
+ 932 |
|
- #' repeated after each horizontal pagination.
+
|
- | 626 |
+ 933 |
|
- #'
+
|
- | 627 |
+ 934 |
|
- #' Absent a class-specific method, this function returns 0, indicating
+ #' `is.wholenumber`
|
- | 628 |
+ 935 |
|
- #' no always-repeated columns.
+ #'
|
- | 629 |
+ 936 |
|
- #'
+ #' @param x numeric(1). A numeric value
|
- | 630 |
+ 937 |
|
- #' @param obj ANY. A table-like object.
+ #' @param tol numeric(1). A precision tolerance.
|
- | 631 |
+ 938 |
|
- #' @note This number \emph{does not include row labels}, the repetition
+ #'
|
- | 632 |
+ 939 |
|
- #' of which is handled separately.
+ #' @return \code{TRUE} if \code{x} is within \code{tol} of zero,
|
- | 633 |
+ 940 |
|
- #'
+ #' \code{FALSE} otherwise.
|
- | 634 |
+ 941 |
|
- #' @return an integer.
+ #'
|
- | 635 |
+ 942 |
|
#' @export
|
- | 636 |
+ 943 |
|
#' @examples
|
- | 637 |
+ 944 |
|
- #' mpf <- basic_matrix_form(mtcars)
+ #' is.wholenumber(5)
|
- | 638 |
+ 945 |
|
- #' num_rep_cols(mpf)
+ #' is.wholenumber(5.00000000000000001)
|
-
- | 639 |
- 25x |
+
+ | 946 |
+ |
- setGeneric("num_rep_cols", function(obj) standardGeneric("num_rep_cols"))
+ #' is.wholenumber(.5)
|
- | 640 |
+ 947 |
|
- #' @export
+ #'
|
- | 641 |
+ 948 |
|
- #' @rdname num_rep_cols
+ is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) {
|
- | 642 |
- 25x |
+ 949 |
+ 3x |
- setMethod("num_rep_cols", "ANY", function(obj) 0L)
+ abs(x - round(x)) < tol
+ |
+
+
+ | 950 |
+ |
+
+ }
|
diff --git a/main/coverage-report/lib/datatables-binding-0.29/datatables.js b/main/coverage-report/lib/datatables-binding-0.30/datatables.js
similarity index 99%
rename from main/coverage-report/lib/datatables-binding-0.29/datatables.js
rename to main/coverage-report/lib/datatables-binding-0.30/datatables.js
index b930851b0..d968d8be0 100644
--- a/main/coverage-report/lib/datatables-binding-0.29/datatables.js
+++ b/main/coverage-report/lib/datatables-binding-0.30/datatables.js
@@ -493,7 +493,9 @@ HTMLWidgets.widget({
$input.parent().hide(); $x.show().trigger('show'); filter[0].selectize.focus();
},
input: function() {
- if ($input.val() === '') filter[0].selectize.setValue([]);
+ var v1 = JSON.stringify(filter[0].selectize.getValue()), v2 = $input.val();
+ if (v1 === '[]') v1 = '';
+ if (v1 !== v2) filter[0].selectize.setValue(v2 === '' ? [] : JSON.parse(v2));
}
});
var $input2 = $x.children('select');
@@ -1398,7 +1400,7 @@ HTMLWidgets.widget({
console.log('The search keyword for column ' + i + ' is undefined')
return;
}
- $(td).find('input').first().val(v);
+ $(td).find('input').first().val(v).trigger('input');
searchColumn(i, v);
});
table.draw();
|