From 49fdf5bba381c9d4987eb65ad9619c995050ff7a Mon Sep 17 00:00:00 2001 From: Davide Garolini Date: Fri, 20 Sep 2024 17:12:17 +0200 Subject: [PATCH] bug fixes and init pagination (#932) fixes #929 still some things to brew --------- Signed-off-by: Davide Garolini Signed-off-by: Davide Garolini Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: 27856297+dependabot-preview[bot]@users.noreply.github.com <27856297+dependabot-preview[bot]@users.noreply.github.com> Co-authored-by: Joe Zhu --- DESCRIPTION | 2 + NAMESPACE | 1 + NEWS.md | 12 +- R/tt_as_df.R | 459 +++++++++++ R/tt_as_flextable.R | 809 +++++++++++++++++++ R/tt_export.R | 1037 +------------------------ man/data.frame_export.Rd | 2 +- man/tt_to_flextable.Rd | 70 +- rtables.Rproj | 2 + tests/testthat/test-exporters.R | 87 --- tests/testthat/test-tt_as_flextable.R | 146 ++++ 11 files changed, 1501 insertions(+), 1126 deletions(-) create mode 100644 R/tt_as_df.R create mode 100644 R/tt_as_flextable.R create mode 100644 tests/testthat/test-tt_as_flextable.R diff --git a/DESCRIPTION b/DESCRIPTION index e64e0979d..4e4d4c9c5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -87,6 +87,8 @@ Collate: 'package.R' 'tree_accessors.R' 'tt_afun_utils.R' + 'tt_as_df.R' + 'tt_as_flextable.R' 'tt_compare_tables.R' 'tt_compatibility.R' 'tt_dotabulation.R' diff --git a/NAMESPACE b/NAMESPACE index 384601896..777a9c786 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -181,6 +181,7 @@ export(table_shell_str) export(table_structure) export(tail) export(theme_docx_default) +export(theme_html_default) export(top_left) export(top_level_section_div) export(tree_children) diff --git a/NEWS.md b/NEWS.md index 193034e16..4e2b6aa9f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,10 +4,17 @@ * Removed `tt` input from `theme_docx_default()` and added internal handling for row classes and number of columns. * Reworked padding and spacing in default theme `theme_docx_default()`. * Added top left information handling (now bold and bottom aligned). + * Now users can add more than one theme to `tt_to_flextable()`, and/or extend themes. + * Added default theme for `.html` outputs. + * Added parameter `bold_titles` to `tt_to_flextable()` to bold titles. ### Bug Fixes * Fixed `"\n"` newline issues in `as_html` by relying onto output devices for newline handling. Added `expand_newlines = FALSE` default to allow previous behavior. - * `keep_split_levels` throws now an error if the user requests to keep levels that are not present in data. + * `keep_split_levels()` throws now an error if the user requests to keep levels that are not present in data. + * Fixed issue with removal of horizontal lines in `tt_as_flextable()` header when title was added. + * Fixed multiple counts in header issue when exporting to `flextable`. + * Fixed issue with empty cells `""` having larger imposed margins than filled cell. They are transformed into `" "` before rendering. + * Fixed issue with borders appearing in `theme_docx_default()` when only one line of column names is present, but top left information is on multiple lines. ### Miscellaneous * Added option to change `sep = "\t"` and set other parameters via `...` parameter propagation in `export_as_tsv`. @@ -15,6 +22,9 @@ of each function and relative examples. * Addition of developer's guide vignette about printing methods, specifically `matrix_form` and `toString`. * Moved `simple_analysis` into utils file. + * Added examples to `theme_docx_default()` showing how to extend the default theme. + * Added the possibility to remove internal borders from label rows in `theme_html_default()`. + * Split export functions into separate source files. Similarly for test files. ## rtables 0.6.9 ### Miscellaneous diff --git a/R/tt_as_df.R b/R/tt_as_df.R new file mode 100644 index 000000000..911d5145d --- /dev/null +++ b/R/tt_as_df.R @@ -0,0 +1,459 @@ +# data.frame output ------------------------------------------------------------ + +#' Generate a result data frame +#' +#' Collection of utilities to extract `data.frame` objects from `TableTree` objects. +#' +#' @inheritParams gen_args +#' @param spec (`string`)\cr the specification to use to extract the result data frame. See Details below. +#' @param simplify (`flag`)\cr whether the result data frame should only have labels and result columns visible. +#' @param ... additional arguments passed to spec-specific result data frame conversion function. Currently it can be +#' one or more of the following parameters (valid only for `v0_experimental` spec. for now): +#' - `expand_colnames`: when `TRUE`, the result data frame will have expanded column names above the usual +#' output. This is useful when the result data frame is used for further processing. +#' - `simplify`: when `TRUE`, the result data frame will have only visible labels and result columns. +#' - `as_strings`: when `TRUE`, the result data frame will have all values as strings, as they appear +#' in the final table (it can also be retrieved from `matrix_form(tt)$strings`). This is also true for +#' column counts if `expand_colnames = TRUE`. +#' - `as_viewer`: when `TRUE`, the result data frame will have all values as they appear in the final table, +#' i.e. with the same precision and numbers, but in easy-to-use numeric form. +#' - `keep_label_rows`: when `TRUE`, the result data frame will have all labels as they appear in the +#' final table. +#' - `as_is`: when `TRUE`, the result data frame will have all the values as they appear in the final table, +#' but without information about the row structure. Row labels will be assigned to rows so to work well +#' with [df_to_tt()]. +#' +#' @details `as_result_df()`: Result data frame specifications may differ in the exact information +#' they include and the form in which they represent it. Specifications whose names end in "_experimental" +#' are subject to change without notice, but specifications without the "_experimental" +#' suffix will remain available *including any bugs in their construction* indefinitely. +#' +#' @return +#' * `as_result_df` returns a result `data.frame`. +#' +#' @seealso [df_to_tt()] when using `as_is = TRUE` and [formatters::make_row_df()] to have a comprehensive view of the +#' hierarchical structure of the rows. +#' +#' @examples +#' lyt <- basic_table() %>% +#' split_cols_by("ARM") %>% +#' split_rows_by("STRATA1") %>% +#' analyze(c("AGE", "BMRKR2")) +#' +#' tbl <- build_table(lyt, ex_adsl) +#' as_result_df(tbl) +#' +#' @name data.frame_export +#' @export +as_result_df <- function(tt, spec = "v0_experimental", simplify = FALSE, ...) { + checkmate::assert_class(tt, "VTableTree") + checkmate::assert_string(spec) + checkmate::assert_flag(simplify) + + if (nrow(tt) == 0) { + return(sanitize_table_struct(tt)) + } + + result_df_fun <- lookup_result_df_specfun(spec) + out <- result_df_fun(tt, ...) + + if (simplify) { + out <- .simplify_result_df(out) + } + + out +} + +# Function that selects specific outputs from the result data frame +.simplify_result_df <- function(df) { + col_df <- colnames(df) + row_names_col <- which(col_df == "row_name") + result_cols <- seq(which(col_df == "node_class") + 1, length(col_df)) + + df[, c(row_names_col, result_cols)] +} + +# Not used in rtables +# .split_colwidths <- function(ptabs, nctot, colwidths) { +# ret <- list() +# i <- 1L +# +# rlw <- colwidths[1] +# colwidths <- colwidths[-1] +# donenc <- 0 +# while (donenc < nctot) { +# curnc <- NCOL(ptabs[[i]]) +# ret[[i]] <- c(rlw, colwidths[seq_len(curnc)]) +# colwidths <- colwidths[-1 * seq_len(curnc)] +# donenc <- donenc + curnc +# i <- i + 1 +# } +# ret +# } + +#' @describeIn data.frame_export A list of functions that extract result data frames from `TableTree`s. +#' +#' @return +#' * `result_df_specs()` returns a named list of result data frame extraction functions by "specification". +#' +#' @examples +#' result_df_specs() +#' +#' @export +result_df_specs <- function() { + list(v0_experimental = result_df_v0_experimental) +} + +lookup_result_df_specfun <- function(spec) { + if (!(spec %in% names(result_df_specs()))) { + stop( + "unrecognized result data frame specification: ", + spec, + "If that specification is correct you may need to update your version of rtables" + ) + } + result_df_specs()[[spec]] +} + +result_df_v0_experimental <- function(tt, + as_viewer = FALSE, + as_strings = FALSE, + expand_colnames = FALSE, + keep_label_rows = FALSE, + as_is = FALSE) { + checkmate::assert_flag(as_viewer) + checkmate::assert_flag(as_strings) + checkmate::assert_flag(expand_colnames) + checkmate::assert_flag(keep_label_rows) + checkmate::assert_flag(as_is) + + if (as_is) { + keep_label_rows <- TRUE + expand_colnames <- FALSE + } + + raw_cvals <- cell_values(tt) + ## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values + ## rather than a list of length 1 representing the single row. This is bad but may not be changeable + ## at this point. + if (nrow(tt) == 1 && length(raw_cvals) > 1) { + raw_cvals <- list(raw_cvals) + } + + # Flatten the list of lists (rows) of cell values into a data frame + cellvals <- as.data.frame(do.call(rbind, raw_cvals)) + row.names(cellvals) <- NULL + + if (nrow(tt) == 1 && ncol(tt) == 1) { + colnames(cellvals) <- names(raw_cvals) + } + + if (as_viewer || as_strings) { + # we keep previous calculations to check the format of the data + mf_tt <- matrix_form(tt) + mf_result_chars <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), -1] + mf_result_chars <- .remove_empty_elements(mf_result_chars) + mf_result_numeric <- as.data.frame( + .make_numeric_char_mf(mf_result_chars) + ) + mf_result_chars <- as.data.frame(mf_result_chars) + if (!setequal(dim(mf_result_numeric), dim(cellvals)) || !setequal(dim(mf_result_chars), dim(cellvals))) { + stop( + "The extracted numeric data.frame does not have the same dimension of the", + " cell values extracted with cell_values(). This is a bug. Please report it." + ) # nocov + } + if (as_strings) { + colnames(mf_result_chars) <- colnames(cellvals) + cellvals <- mf_result_chars + } else { + colnames(mf_result_numeric) <- colnames(cellvals) + cellvals <- mf_result_numeric + } + } + + rdf <- make_row_df(tt) + + df <- rdf[, c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class")] + # Removing initial root elements from path (out of the loop -> right maxlen) + df$path <- lapply(df$path, .remove_root_elems_from_path, + which_root_name = c("root", "rbind_root"), + all = TRUE + ) + maxlen <- max(lengths(df$path)) + + # Loop for metadata (path and details from make_row_df) + metadf <- do.call( + rbind.data.frame, + lapply( + seq_len(NROW(df)), + function(ii) { + handle_rdf_row(df[ii, ], maxlen = maxlen) + } + ) + ) + + # Should we keep label rows with NAs instead of values? + if (keep_label_rows) { + cellvals_mat_struct <- as.data.frame( + matrix(NA, nrow = nrow(rdf), ncol = ncol(cellvals)) + ) + colnames(cellvals_mat_struct) <- colnames(cellvals) + cellvals_mat_struct[metadf$node_class != "LabelRow", ] <- cellvals + ret <- cbind(metadf, cellvals_mat_struct) + } else { + ret <- cbind( + metadf[metadf$node_class != "LabelRow", ], + cellvals + ) + } + + # If we want to expand colnames + if (expand_colnames) { + col_name_structure <- .get_formatted_colnames(clayout(tt)) + number_of_non_data_cols <- which(colnames(ret) == "node_class") + if (NCOL(ret) - number_of_non_data_cols != NCOL(col_name_structure)) { + stop( + "When expanding colnames structure, we were not able to find the same", + " number of columns as in the result data frame. This is a bug. Please report it." + ) # nocov + } + + buffer_rows_for_colnames <- matrix( + rep("", number_of_non_data_cols * NROW(col_name_structure)), + nrow = NROW(col_name_structure) + ) + + header_colnames_matrix <- cbind(buffer_rows_for_colnames, data.frame(col_name_structure)) + colnames(header_colnames_matrix) <- colnames(ret) + + count_row <- NULL + if (disp_ccounts(tt)) { + ccounts <- col_counts(tt) + if (as_strings) { + ccounts <- mf_strings(mf_tt)[mf_nlheader(mf_tt), ] + ccounts <- .remove_empty_elements(ccounts) + } + count_row <- c(rep("", number_of_non_data_cols), ccounts) + header_colnames_matrix <- rbind(header_colnames_matrix, count_row) + } + ret <- rbind(header_colnames_matrix, ret) + } + + # Using only labels for row names and losing information about paths + if (as_is) { + tmp_rownames <- ret$label_name + ret <- ret[, -seq_len(which(colnames(ret) == "node_class"))] + if (length(unique(tmp_rownames)) == length(tmp_rownames)) { + rownames(ret) <- tmp_rownames + } else { + ret <- cbind("label_name" = tmp_rownames, ret) + rownames(ret) <- NULL + } + } else { + rownames(ret) <- NULL + } + + ret +} + +.remove_empty_elements <- function(char_df) { + if (is.null(dim(char_df))) { + return(char_df[nzchar(char_df, keepNA = TRUE)]) + } + + apply(char_df, 2, function(col_i) col_i[nzchar(col_i, keepNA = TRUE)]) +} + +# Helper function to make the character matrix numeric +.make_numeric_char_mf <- function(char_df) { + if (is.null(dim(char_df))) { + return(as.numeric(stringi::stri_extract_all(char_df, regex = "\\d+.\\d+|\\d+"))) + } + + ret <- apply(char_df, 2, function(col_i) { + lapply( + stringi::stri_extract_all(col_i, regex = "\\d+.\\d+|\\d+"), + as.numeric + ) + }) + + do.call(cbind, ret) +} + +make_result_df_md_colnames <- function(maxlen) { + spllen <- floor((maxlen - 2) / 2) + ret <- character() + if (spllen > 0) { + ret <- paste(c("spl_var", "spl_value"), rep(seq_len(spllen), rep(2, spllen)), sep = "_") + } + ret <- c(ret, c("avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class")) +} + +do_label_row <- function(rdfrow, maxlen) { + pth <- rdfrow$path[[1]] + # Adjusting for the fact that we have two columns for each split + extra_nas_from_splits <- floor((maxlen - length(pth)) / 2) * 2 + + # Special cases with hidden labels + if (length(pth) %% 2 == 1) { + extra_nas_from_splits <- extra_nas_from_splits + 1 + } + + c( + as.list(pth[seq_len(length(pth) - 1)]), + as.list(replicate(extra_nas_from_splits, list(NA_character_))), + as.list(tail(pth, 1)), + list( + label_name = rdfrow$label, + row_num = rdfrow$abs_rownumber, + content = FALSE, + node_class = rdfrow$node_class + ) + ) +} + +do_content_row <- function(rdfrow, maxlen) { + pth <- rdfrow$path[[1]] + contpos <- which(pth == "@content") + + seq_before <- seq_len(contpos - 1) + + c( + as.list(pth[seq_before]), + as.list(replicate(maxlen - contpos, list(NA_character_))), + list(tail(pth, 1)), + list( + label_name = rdfrow$label, + row_num = rdfrow$abs_rownumber, + content = TRUE, + node_class = rdfrow$node_class + ) + ) +} + +do_data_row <- function(rdfrow, maxlen) { + pth <- rdfrow$path[[1]] + pthlen <- length(pth) + ## odd means we have a multi-analsysis step in the path, we dont' want that in the result data frame + if (pthlen %% 2 == 1) { + pth <- pth[-1 * (pthlen - 2)] + } + pthlen_new <- length(pth) + if (maxlen == 1) pthlen_new <- 3 + c( + as.list(pth[seq_len(pthlen_new - 2)]), + replicate(maxlen - pthlen, list(NA_character_)), + as.list(tail(pth, 2)), + list( + label_name = rdfrow$label, + row_num = rdfrow$abs_rownumber, + content = FALSE, + node_class = rdfrow$node_class + ) + ) +} + +.remove_root_elems_from_path <- function(path, which_root_name = c("root", "rbind_root"), all = TRUE) { + any_root_paths <- path[1] %in% which_root_name + if (any_root_paths) { + if (isTRUE(all)) { + # Selecting the header grouping of root and rbind_root (we do not want to remove other root labels-path later) + root_indices <- which(path %in% which_root_name) + if (any(diff(root_indices) > 1)) { # integer(0) for diff means FALSE + end_point_root_headers <- which(diff(root_indices) > 1)[1] + } else { + end_point_root_headers <- length(root_indices) + } + root_path_to_remove <- seq_len(end_point_root_headers) + } else { + root_path_to_remove <- 1 + } + path <- path[-root_path_to_remove] + } + + # Fix for very edge case where we have only root elements + if (length(path) == 0) { + path <- which_root_name[1] + } + + path +} + +handle_rdf_row <- function(rdfrow, maxlen) { + nclass <- rdfrow$node_class + + ret <- switch(nclass, + LabelRow = do_label_row(rdfrow, maxlen), + ContentRow = do_content_row(rdfrow, maxlen), + DataRow = do_data_row(rdfrow, maxlen), + stop("Unrecognized node type in row dataframe, unable to generate result data frame") + ) + setNames(ret, make_result_df_md_colnames(maxlen)) +} + +# Helper recurrent function to get the column names for the result data frame from the VTableTree +.get_formatted_colnames <- function(clyt) { + ret <- obj_label(clyt) + if (!nzchar(ret)) { + ret <- NULL + } + if (is.null(tree_children(clyt))) { + return(ret) + } else { + ret <- rbind(ret, do.call(cbind, lapply(tree_children(clyt), .get_formatted_colnames))) + colnames(ret) <- NULL + rownames(ret) <- NULL + return(ret) + } +} + +#' @describeIn data.frame_export Transform a `TableTree` object to a path-enriched `data.frame`. +#' +#' @param path_fun (`function`)\cr function to transform paths into single-string row/column names. +#' @param value_fun (`function`)\cr function to transform cell values into cells of a `data.frame`. Defaults to +#' `collapse_values`, which creates strings where multi-valued cells are collapsed together, separated by `|`. +#' +#' @return +#' * `path_enriched_df()` returns a `data.frame` of `tt`'s cell values (processed by `value_fun`, with columns named by +#' the full column paths (processed by `path_fun` and an additional `row_path` column with the row paths (processed +#' by `path_fun`). +#' +#' @examples +#' lyt <- basic_table() %>% +#' split_cols_by("ARM") %>% +#' analyze(c("AGE", "BMRKR2")) +#' +#' tbl <- build_table(lyt, ex_adsl) +#' path_enriched_df(tbl) +#' +#' @export +path_enriched_df <- function(tt, path_fun = collapse_path, value_fun = collapse_values) { + rdf <- make_row_df(tt) + cdf <- make_col_df(tt) + cvs <- as.data.frame(do.call(rbind, cell_values(tt))) + cvs <- as.data.frame(lapply(cvs, value_fun)) + row.names(cvs) <- NULL + colnames(cvs) <- path_fun(cdf$path) + preppaths <- path_fun(rdf[rdf$node_class != "LabelRow", ]$path) + cbind.data.frame(row_path = preppaths, cvs) +} + +.collapse_char <- "|" +.collapse_char_esc <- "\\|" + +collapse_path <- function(paths) { + if (is.list(paths)) { + return(vapply(paths, collapse_path, "")) + } + paste(paths, collapse = .collapse_char) +} + +collapse_values <- function(colvals) { + if (!is.list(colvals)) { ## || all(vapply(colvals, length, 1L) == 1)) + return(colvals) + } else if (all(vapply(colvals, length, 1L) == 1)) { + return(unlist(colvals)) + } + vapply(colvals, paste, "", collapse = .collapse_char) +} diff --git a/R/tt_as_flextable.R b/R/tt_as_flextable.R new file mode 100644 index 000000000..543c51e00 --- /dev/null +++ b/R/tt_as_flextable.R @@ -0,0 +1,809 @@ +# Flextable conversion --------------------------------------------------------- +# + +#' Create a `flextable` from an `rtables` table +#' +#' Principally used for export ([export_as_docx()]), this function produces a `flextable` +#' from an `rtables` table. If `theme = NULL`, `rtables`-like style will be used. Otherwise, +#' [theme_docx_default()] will produce a `.docx`-friendly table. +#' +#' @inheritParams gen_args +#' @inheritParams paginate_table +#' @param theme (`function` or `NULL`)\cr A theme function that is designed internally as a function of a `flextable` +#' object to change its layout and style. If `NULL`, it will produce a table similar to `rtables` default. Defaults +#' to `theme_docx_default()` that is a classic Word output. See details for more information. +#' @param border (`officer` border object)\cr defaults to `officer::fp_border(width = 0.5)`. +#' @param indent_size (`numeric(1)`)\cr if `NULL`, the default indent size of the table (see [formatters::matrix_form()] +#' `indent_size`, default is 2) is used. To work with `docx`, any size is multiplied by 1 mm (2.83 pt) by default. +#' @param titles_as_header (`flag`)\cr defaults to `TRUE` for [tt_to_flextable()], so the table is self-contained +#' as it makes additional header rows for [formatters::main_title()] string and [formatters::subtitles()] character +#' vector (one per element). `FALSE` is suggested for [export_as_docx()]. This adds titles and subtitles as a text +#' paragraph above the table. The same style is applied. +#' @param bold_titles (`flag` or `integer`)\cr defaults to `TRUE` for [tt_to_flextable()], so the titles are bold. If +#' it is one or more integers, those lines will be bold. +#' @param footers_as_text (`flag`)\cr defaults to `FALSE` for [tt_to_flextable()], so the table is self-contained with +#' the `flextable` definition of footnotes. `TRUE` is used for [export_as_docx()] to add the footers as a new +#' paragraph after the table. The same style is applied, but with a smaller font. +#' @param counts_in_newline (`flag`)\cr defaults to `FALSE`. In `rtables` text printing ([formatters::toString()]), +#' the column counts, i.e. `(N=xx)`, are always on a new line. For `docx` exports it could be necessary to print it +#' on the same line. +#' @param paginate (`flag`)\cr when exporting `.docx` documents using `export_as_docx`, we suggest relying on the +#' Microsoft Word pagination system. If `TRUE`, this option splits `tt` into different "pages" as multiple +#' `flextables`. Cooperation between the two mechanisms is not guaranteed. Defaults to `FALSE`. +#' @param total_width (`numeric(1)`)\cr total width (in inches) for the resulting flextable(s). Defaults to 10. +#' +#' @return A `flextable` object. +#' +#' @details +#' Themes can also be extended when you need only a minor change from a default style. You can either +#' add your own theme to the theme call (e.g. `c(theme_docx_default(), my_theme)`) or create a new +#' theme like shown in the examples. Please pay attention to the parameters' inputs as they are relevant +#' for this to work properly. +#' Indeed, it is possible to use some hidden values for building your own theme (hence the need of `...`). +#' In particular, `tt_to_flextable` sends in the following variable: `tbl_row_class = make_row_df(tt)$node_class`. +#' This is ignored if not used in the theme. See `theme_docx_default` for an example on own to retrieve +#' these values and how to use them. +#' +#' @seealso [export_as_docx()] +#' +#' @examples +#' analysisfun <- function(x, ...) { +#' in_rows( +#' row1 = 5, +#' row2 = c(1, 2), +#' .row_footnotes = list(row1 = "row 1 - row footnote"), +#' .cell_footnotes = list(row2 = "row 2 - cell footnote") +#' ) +#' } +#' +#' lyt <- basic_table( +#' title = "Title says Whaaaat", subtitles = "Oh, ok.", +#' main_footer = "ha HA! Footer!" +#' ) %>% +#' split_cols_by("ARM") %>% +#' analyze("AGE", afun = analysisfun) +#' +#' tbl <- build_table(lyt, ex_adsl) +#' +#' @examplesIf require(flextable) +#' library(flextable) +#' # example code +#' +#' # rtables style +#' tt_to_flextable(tbl, theme = NULL) +#' +#' tt_to_flextable(tbl, theme = theme_docx_default(font_size = 6)) +#' +#' # Example with multiple themes (only extending the docx default!) +#' my_theme <- function(x, ...) { +#' border_inner(x, part = "body", border = flextable::fp_border_default(width = 0.5)) +#' } +#' flx <- tt_to_flextable(tbl, theme = c(theme_docx_default(), my_theme)) +#' +#' @export +tt_to_flextable <- function(tt, + theme = theme_docx_default(), + border = flextable::fp_border_default(width = 0.5), + indent_size = NULL, + titles_as_header = TRUE, + bold_titles = TRUE, + footers_as_text = FALSE, + counts_in_newline = FALSE, + paginate = FALSE, + fontspec = NULL, + lpp = NULL, + cpp = NULL, + ..., + colwidths = NULL, + tf_wrap = !is.null(cpp), + max_width = cpp, + total_width = 10) { + check_required_packages("flextable") + if (!inherits(tt, "VTableTree")) { + stop("Input table is not an rtables' object.") + } + checkmate::assert_flag(titles_as_header) + checkmate::assert_flag(footers_as_text) + checkmate::assert_flag(counts_in_newline) + left_right_fixed_margins <- word_mm_to_pt(1.9) + + ## if we're paginating, just call -> pagination happens also afterwards if needed + if (paginate) { + if (is.null(lpp)) { + stop("lpp must be specified when calling tt_to_flextable with paginate=TRUE") + } + tabs <- paginate_table(tt, + fontspec = fontspec, + lpp = lpp, cpp = cpp, + tf_wrap = tf_wrap, max_width = max_width, ... + ) + cinds <- lapply(tabs, function(tb) c(1, .figure_out_colinds(tb, tt) + 1L)) + return(mapply(tt_to_flextable, + tt = tabs, colwidths = cinds, + MoreArgs = list(paginate = FALSE, total_width = total_width), + SIMPLIFY = FALSE + )) + } + + # Extract relevant information + matform <- matrix_form(tt, fontspec = fontspec, indent_rownames = FALSE) + body <- mf_strings(matform) # Contains header + spans <- mf_spans(matform) # Contains header + mpf_aligns <- mf_aligns(matform) # Contains header + hnum <- mf_nlheader(matform) # Number of lines for the header + rdf <- make_row_df(tt) # Row-wise info + + # decimal alignment pre-proc + if (any(grepl("dec", mpf_aligns))) { + body <- decimal_align(body, mpf_aligns) + # Coercion for flextable + mpf_aligns[mpf_aligns == "decimal"] <- "center" + mpf_aligns[mpf_aligns == "dec_left"] <- "left" + mpf_aligns[mpf_aligns == "dec_right"] <- "right" + } + + # Fundamental content of the table + content <- as.data.frame(body[-seq_len(hnum), , drop = FALSE]) + + # Fix for empty strings -> they used to get wrong font and size + content[content == ""] <- " " + + flx <- flextable::qflextable(content) %>% + # Default rtables if no footnotes + .remove_hborder(part = "body", w = "bottom") + + # Header addition -> NB: here we have a problem with (N=xx) + hdr <- body[seq_len(hnum), , drop = FALSE] + + # Change of (N=xx) behavior as we need it in the same cell, even if on diff lines + if (hnum > 1) { # otherwise nothing to do + det_nclab <- apply(hdr, 2, grepl, pattern = "\\(N=[0-9]+\\)$") + has_nclab <- apply(det_nclab, 1, any) # vector of rows with (N=xx) + whsnc <- which(has_nclab) # which rows have it + if (any(has_nclab)) { + for (i in seq_along(whsnc)) { + wi <- whsnc[i] + what_is_nclab <- det_nclab[wi, ] # extract detected row + + colcounts_split_chr <- if (isFALSE(counts_in_newline)) { + " " + } else { + "\n" + } + + # condition for popping the interested row by merging the upper one + hdr[wi, what_is_nclab] <- paste(hdr[wi - 1, what_is_nclab], + hdr[wi, what_is_nclab], + sep = colcounts_split_chr + ) + hdr[wi - 1, what_is_nclab] <- "" + + # Removing unused rows if necessary + row_to_pop <- wi - 1 + + # Case where topleft is not empty, we reconstruct the header pushing empty up + what_to_put_up <- hdr[row_to_pop, what_is_nclab, drop = FALSE] + if (all(!nzchar(what_to_put_up)) && row_to_pop > 1) { + reconstructed_hdr <- rbind( + cbind( + hdr[seq(row_to_pop), !what_is_nclab], + rbind( + what_to_put_up, + hdr[seq(row_to_pop - 1), what_is_nclab] + ) + ), + hdr[seq(row_to_pop + 1, nrow(hdr)), ] + ) + row_to_pop <- 1 + hdr <- reconstructed_hdr + } + + # We can remove the row if they are all "" + if (all(!nzchar(hdr[row_to_pop, ]))) { + hdr <- hdr[-row_to_pop, , drop = FALSE] + spans <- spans[-row_to_pop, , drop = FALSE] + body <- body[-row_to_pop, , drop = FALSE] + mpf_aligns <- mpf_aligns[-row_to_pop, , drop = FALSE] + hnum <- hnum - 1 + # for multiple lines + whsnc <- whsnc - 1 + det_nclab <- det_nclab[-row_to_pop, , drop = FALSE] + } + } + } + } + + # Fix for empty strings + hdr[hdr == ""] <- " " + + flx <- flx %>% + flextable::set_header_labels( # Needed bc headers must be unique + values = setNames( + as.vector(hdr[hnum, , drop = TRUE]), + names(content) + ) + ) + + # If there are more rows -> add them + if (hnum > 1) { + for (i in seq(hnum - 1, 1)) { + sel <- spans_to_viscell(spans[i, ]) + flx <- flextable::add_header_row( + flx, + top = TRUE, + values = as.vector(hdr[i, sel]), + colwidths = as.integer(spans[i, sel]) # xxx to fix + ) + } + } + + # Re-set the number of row count + nr_body <- flextable::nrow_part(flx, part = "body") + nr_header <- flextable::nrow_part(flx, part = "header") + + # Polish the inner horizontal borders from the header + flx <- flx %>% + .remove_hborder(part = "header", w = "all") %>% + .add_hborder("header", ii = c(0, hnum), border = border) + + # ALIGNS - horizontal + flx <- flx %>% + .apply_alignments(mpf_aligns[seq_len(hnum), , drop = FALSE], "header") %>% + .apply_alignments(mpf_aligns[-seq_len(hnum), , drop = FALSE], "body") + + # Rownames indentation + checkmate::check_number(indent_size, null.ok = TRUE) + if (is.null(indent_size)) { + # Default indent_size in {rtables} is 2 characters + indent_size <- matform$indent_size * word_mm_to_pt(1) # default is 2mm (5.7pt) + } else { + indent_size <- indent_size * word_mm_to_pt(1) + } + + # rdf contains information about indentation + for (i in seq_len(nr_body)) { + flx <- flextable::padding(flx, + i = i, j = 1, + padding.left = indent_size * rdf$indent[[i]] + left_right_fixed_margins, # margins + padding.right = left_right_fixed_margins, # 0.19 mmm in pt (so not to touch the border) + part = "body" + ) + } + + # TOPLEFT + # Principally used for topleft indentation, this is a bit of a hack xxx + for (i in seq_len(nr_header)) { + leading_spaces_count <- nchar(hdr[i, 1]) - nchar(stringi::stri_replace(hdr[i, 1], regex = "^ +", "")) + header_indent_size <- leading_spaces_count * word_mm_to_pt(1) + + # This solution does not keep indentation + # top_left_tmp2 <- paste0(top_left_tmp, collapse = "\n") %>% + # flextable::as_chunk() %>% + # flextable::as_paragraph() + # flx <- flextable::compose(flx, i = hnum, j = 1, value = top_left_tmp2, part = "header") + flx <- flextable::padding(flx, + i = i, j = 1, + padding.left = header_indent_size + left_right_fixed_margins, # margins + padding.right = left_right_fixed_margins, # 0.19 mmm in pt (so not to touch the border) + part = "header" + ) + } + + # Adding referantial footer line separator if present + if (length(matform$ref_footnotes) > 0 && isFALSE(footers_as_text)) { + flx <- flextable::add_footer_lines(flx, values = matform$ref_footnotes) %>% + .add_hborder(part = "body", ii = nrow(tt), border = border) + } + + # Footer lines + if (length(all_footers(tt)) > 0 && isFALSE(footers_as_text)) { + flx <- flextable::add_footer_lines(flx, values = all_footers(tt)) %>% + .add_hborder(part = "body", ii = nrow(tt), border = border) + } + + # Apply the theme + flx <- .apply_themes(flx, theme = theme, tbl_row_class = make_row_df(tt)$node_class) + + # lets do some digging into the choice of fonts etc + if (is.null(fontspec)) { + fontspec <- .extract_fontspec(flx) + } + # Calculate the needed colwidths + if (is.null(colwidths)) { + # what about margins? + colwidths <- propose_column_widths(matform, fontspec = fontspec, indent_size = indent_size) + } + final_cwidths <- total_width * colwidths / sum(colwidths) # xxx to fix + # xxx FIXME missing transformer from character based widths to mm or pt + + flx <- flextable::width(flx, width = final_cwidths) # xxx to fix + + # Title lines (after theme for problems with lines) + if (titles_as_header && length(all_titles(tt)) > 0 && any(nzchar(all_titles(tt)))) { + flx <- .add_titles_as_header(flx, all_titles = all_titles(tt), bold = bold_titles) %>% + flextable::border( + part = "header", i = length(all_titles(tt)), + border.bottom = border + ) + } + + # These final formatting need to work with colwidths + flx <- flextable::set_table_properties(flx, layout = "autofit", align = "left") # xxx to fix + # NB: autofit or fixed may be switched if widths are correctly staying in the page + flx <- flextable::fix_border_issues(flx) # Fixes some rendering gaps in borders + + flx +} + + +# only used in pagination +.tab_to_colpath_set <- function(tt) { + vapply( + collect_leaves(coltree(tt)), + function(y) paste(pos_to_path(tree_pos(y)), collapse = " "), + "" + ) +} +.figure_out_colinds <- function(subtab, fulltab) { + match( + .tab_to_colpath_set(subtab), + .tab_to_colpath_set(fulltab) + ) +} + +.add_titles_as_header <- function(flx, all_titles, bold = TRUE) { + all_titles <- all_titles[nzchar(all_titles)] # Remove empty titles (use " ") + + flx <- flx %>% + flextable::add_header_lines(values = all_titles, top = TRUE) %>% + # Remove the added borders + flextable::border( + part = "header", i = seq_along(all_titles), + border.top = flextable::fp_border_default(width = 0), + border.bottom = flextable::fp_border_default(width = 0), + border.left = flextable::fp_border_default(width = 0), + border.right = flextable::fp_border_default(width = 0) + ) %>% + flextable::bg(part = "header", i = seq_along(all_titles), bg = "white") + + if (isTRUE(bold)) { + flx <- flextable::bold(flx, part = "header", i = seq_along(all_titles)) + } else if (checkmate::test_integerish(bold)) { + if (any(bold > length(all_titles))) { + stop("bold values are greater than the number of titles lines.") + } + flx <- flextable::bold(flx, part = "header", i = bold) + } + + flx +} + +.apply_themes <- function(flx, theme, tbl_row_class = "") { + if (is.null(theme)) { + return(flx) + } + # Wrap theme in a list if it's not already a list + theme_list <- if (is.list(theme)) theme else list(theme) + # Loop through the themes + for (them in theme_list) { + flx <- them( + flx, + tbl_row_class = tbl_row_class # These are ignored if not in the theme + ) + } + + flx +} + +.extract_fontspec <- function(test_flx) { + font_sz <- test_flx$header$styles$text$font.size$data[1, 1] + font_fam <- test_flx$header$styles$text$font.family$data[1, 1] + font_fam <- "Courier" # Fix if we need it -> coming from gpar and fontfamily Arial not being recognized + + font_spec(font_family = font_fam, font_size = font_sz, lineheight = 1) +} + +.apply_alignments <- function(flx, aligns_df, part) { + # List of characters you want to search for + search_chars <- unique(c(aligns_df)) + + # Loop through each character and find its indexes + for (char in search_chars) { + indexes <- which(aligns_df == char, arr.ind = TRUE) + tmp_inds <- as.data.frame(indexes) + flx <- flx %>% + flextable::align( + i = tmp_inds[["row"]], + j = tmp_inds[["col"]], + align = char, + part = part + ) + } + + flx +} + +# Themes ----------------------------------------------------------------------- +# + +#' @describeIn tt_to_flextable Main theme function for [export_as_docx()]. +#' +#' @param font (`string`)\cr defaults to `"Arial"`. If the font is not available, `flextable` default is used. +#' Please consider consulting the family column from `systemfonts::system_fonts()`. +#' @param font_size (`integer(1)`)\cr font size. Defaults to 9. +#' @param cell_margins (`numeric(1)` or `numeric(4)`)\cr a numeric or a vector of four numbers indicating +#' `c("left", "right", "top", "bottom")`. It defaults to 0 for top and bottom, and to 0.19 `mm` in word `pt` +#' for left and right. +#' @param bold (`character`)\cr parts of the table text that should be in bold. Can be any combination of +#' `c("header", "content_rows", "label_rows", "top_left")`. The first one renders all column names bold +#' (not `topleft` content). The second and third option use [formatters::make_row_df()] to render content or/and +#' label rows as bold. +#' @param bold_manual (named `list` or `NULL`)\cr list of index lists. See example for needed structure. Accepted +#' groupings/names are `c("header", "body")`. +#' @param border (`flextable::fp_border()`)\cr border style. Defaults to `flextable::fp_border_default(width = 0.5)`. +#' +#' @seealso [export_as_docx()] +#' +#' @examplesIf require(flextable) +#' library(flextable) +#' # Custom theme +#' special_bold <- list( +#' "header" = list("i" = 1, "j" = c(1, 3)), +#' "body" = list("i" = c(1, 2), "j" = 1) +#' ) +#' custom_theme <- theme_docx_default( +#' font_size = 10, +#' font = "Brush Script MT", +#' border = flextable::fp_border_default(color = "pink", width = 2), +#' bold = NULL, +#' bold_manual = special_bold +#' ) +#' tt_to_flextable(tbl, +#' border = flextable::fp_border_default(color = "pink", width = 2), +#' theme = custom_theme +#' ) +#' +#' # Extending themes +#' my_theme <- function(font_size = 6) { # here can pass additional arguments for default theme +#' function(flx, ...) { +#' # First apply theme_docx_default +#' flx <- theme_docx_default(font_size = font_size)(flx, ...) +#' +#' # Then apply additional styling +#' flx <- border_inner(flx, part = "body", border = flextable::fp_border_default(width = 0.5)) +#' +#' return(flx) +#' } +#' } +#' flx <- tt_to_flextable(tbl, theme = my_theme()) +#' +#' @export +theme_docx_default <- function(font = "Arial", + font_size = 9, + cell_margins = c( + word_mm_to_pt(1.9), + word_mm_to_pt(1.9), + 0, + 0 + ), # Default in docx + bold = c("header", "content_rows", "label_rows", "top_left"), + bold_manual = NULL, + border = flextable::fp_border_default(width = 0.5)) { + function(flx, ...) { + check_required_packages("flextable") + if (!inherits(flx, "flextable")) { + stop(sprintf( + "Function `%s` supports only flextable objects.", + "theme_box()" + )) + } + checkmate::assert_int(font_size, lower = 6, upper = 12) + checkmate::assert_string(font) + checkmate::assert_subset(bold, + eval(formals(theme_docx_default)$bold), + empty.ok = TRUE + ) + if (length(cell_margins) == 1) { + cell_margins <- rep(cell_margins, 4) + } + checkmate::assert_numeric(cell_margins, lower = 0, len = 4) + + # Setting values coming from ... + args <- list(...) + tbl_row_class <- args$tbl_row_class + tbl_ncol_body <- flextable::ncol_keys(flx) # tbl_ncol_body respects if rownames = FALSE (only rlistings) + + # Font setting + flx <- flextable::fontsize(flx, size = font_size, part = "all") %>% + flextable::fontsize(size = font_size - 1, part = "footer") %>% + flextable::font(fontname = font, part = "all") + + # Add all borders (very specific fix too) + flx <- .add_borders(flx, border = border, ncol = tbl_ncol_body) + + # Vertical alignment -> all top for now + flx <- flx %>% + flextable::valign(j = seq(2, tbl_ncol_body), valign = "top", part = "body") %>% + flextable::valign(j = 1, valign = "top", part = "all") %>% + # topleft styling (-> bottom aligned) xxx merge_at() could merge these, but let's see + flextable::valign(j = 1, valign = "top", part = "header") %>% + flextable::valign(j = seq(2, tbl_ncol_body), valign = "top", part = "header") + + flx <- .apply_indentation_and_margin(flx, + cell_margins = cell_margins, tbl_row_class = tbl_row_class, + tbl_ncol_body = tbl_ncol_body + ) + + # Vertical padding/spaces - rownames + if (any(tbl_row_class == "LabelRow")) { # label rows - 3pt top + flx <- flextable::padding(flx, + j = 1, i = which(tbl_row_class == "LabelRow"), + padding.top = 3 + cell_margins[3], padding.bottom = cell_margins[4], part = "body" + ) + } + if (any(tbl_row_class == "ContentRow")) { # content rows - 1pt top + flx <- flextable::padding(flx, + # j = 1, # removed because I suppose we want alignment with body + i = which(tbl_row_class == "ContentRow"), + padding.top = 1 + cell_margins[3], padding.bottom = cell_margins[4], part = "body" + ) + } + # single line spacing (for safety) -> space = 1 + flx <- flextable::line_spacing(flx, space = 1, part = "all") + + # Bold settings + if (any(bold == "header")) { + flx <- flextable::bold(flx, j = seq(2, tbl_ncol_body), part = "header") # Done with theme + } + # Content rows are effectively our labels in row names + if (any(bold == "content_rows")) { + if (is.null(tbl_row_class)) { + stop('bold = "content_rows" needs tbl_row_class = make_row_df(tt).') + } + flx <- flextable::bold(flx, j = 1, i = which(tbl_row_class == "ContentRow"), part = "body") + } + if (any(bold == "label_rows")) { + if (is.null(tbl_row_class)) { + stop('bold = "content_rows" needs tbl_row_class = make_row_df(tt).') + } + flx <- flextable::bold(flx, j = 1, i = which(tbl_row_class == "LabelRow"), part = "body") + } + # topleft information is also bold if content or label rows are bold + if (any(bold == "top_left")) { + flx <- flextable::bold(flx, j = 1, part = "header") + } + + # If you want specific cells to be bold + flx <- .apply_bold_manual(flx, bold_manual) + + flx + } +} + +#' @describeIn tt_to_flextable Theme function for html outputs. +#' @param remove_internal_borders (`character`)\cr defaults to `"label_rows"`. Remove internal borders between rows. +#' Currently there are no other options and can be turned off by providing any character value. +#' +#' @export +theme_html_default <- function(font = "Courier", + font_size = 9, + cell_margins = 0.2, + remove_internal_borders = "label_rows", + border = flextable::fp_border_default(width = 1, color = "black")) { + function(flx, ...) { + check_required_packages("flextable") + if (!inherits(flx, "flextable")) { + stop(sprintf( + "Function `%s` supports only flextable objects.", + "theme_box()" + )) + } + checkmate::assert_int(font_size, lower = 6, upper = 12) + checkmate::assert_string(font) + if (length(cell_margins) == 1) { + cell_margins <- rep(cell_margins, 4) + } + checkmate::assert_numeric(cell_margins, lower = 0, len = 4) + checkmate::assert_character(remove_internal_borders) + + # Setting values coming from ... + args <- list(...) + tbl_row_class <- args$tbl_row_class # This is internal info + nc_body <- flextable::ncol_keys(flx) # respects if rownames = FALSE (only rlistings) + nr_header <- flextable::nrow_part(flx, "header") + + # Font setting + flx <- flextable::fontsize(flx, size = font_size, part = "all") %>% + flextable::fontsize(size = font_size - 1, part = "footer") %>% + flextable::font(fontname = font, part = "all") + + # all borders + flx <- .add_borders(flx, border = border, ncol = nc_body) + + if (any(remove_internal_borders == "label_rows") && any(tbl_row_class == "LabelRow")) { + flx <- flextable::border(flx, + j = seq(2, nc_body - 1), + i = which(tbl_row_class == "LabelRow"), part = "body", + border.left = flextable::fp_border_default(width = 0), + border.right = flextable::fp_border_default(width = 0) + ) %>% + flextable::border( + j = 1, + i = which(tbl_row_class == "LabelRow"), part = "body", + border.right = flextable::fp_border_default(width = 0) + ) %>% + flextable::border( + j = nc_body, + i = which(tbl_row_class == "LabelRow"), part = "body", + border.left = flextable::fp_border_default(width = 0) + ) + } + flx <- flextable::bg(flx, i = seq_len(nr_header), bg = "grey", part = "header") + + return(flx) + } +} + +.add_borders <- function(flx, border, ncol) { + # all borders + flx <- flx %>% + flextable::border_outer(part = "body", border = border) %>% + # flextable::border_outer(part = "header", border = border) %>% + flextable::border( + part = "header", j = 1, + border.left = border, + border.right = border + ) %>% + flextable::border( + part = "header", j = 1, i = 1, + border.top = border + ) %>% + flextable::border( + part = "header", j = 1, i = flextable::nrow_part(flx, "header"), + border.bottom = border + ) %>% + flextable::border( + part = "header", j = seq(2, ncol), + border.left = border, + border.right = border + ) + + # Special bottom and top for when there is no empty row + raw_header <- flx$header$content$data # HACK xxx + extracted_header <- NULL + for (ii in seq_len(nrow(raw_header))) { + extracted_header <- rbind( + extracted_header, + sapply(raw_header[ii, ], function(x) x$txt) + ) + } + for (ii in seq_len(nrow(extracted_header))) { + for (jj in seq(2, ncol)) { + if (extracted_header[ii, jj] != " ") { + flx <- flextable::border( + flx, + part = "header", j = jj, i = ii, + border.bottom = border + ) + } + } + } + + flx +} + +.apply_bold_manual <- function(flx, bold_manual) { + if (is.null(bold_manual)) { + return(flx) + } + checkmate::assert_list(bold_manual) + valid_sections <- c("header", "body") # Only valid values + checkmate::assert_subset(names(bold_manual), valid_sections) + for (bi in seq_along(bold_manual)) { + bld_tmp <- bold_manual[[bi]] + checkmate::assert_list(bld_tmp) + if (!all(c("i", "j") %in% names(bld_tmp)) || !all(vapply(bld_tmp, checkmate::test_integerish, logical(1)))) { + stop( + "Found an allowed section for manual bold (", names(bold_manual)[bi], + ") that was not a named list with i (row) and j (col) integer vectors." + ) + } + flx <- flextable::bold(flx, + i = bld_tmp$i, j = bld_tmp$j, + part = names(bold_manual)[bi] + ) + } + + flx +} + +.apply_indentation_and_margin <- function(flx, cell_margins, tbl_row_class, tbl_ncol_body) { + flx <- flx %>% # summary/data rows and cells + flextable::padding( + padding.top = cell_margins[3], + padding.bottom = cell_margins[4], part = "body" + ) + + # Horizontal padding all table margin 0.19 mm + flx <- flextable::padding(flx, + j = seq(2, tbl_ncol_body), + padding.left = cell_margins[1], + padding.right = cell_margins[2] + ) + + # Vertical padding/spaces - header (3pt after) + flx <- flx %>% + flextable::padding( + j = seq(1, tbl_ncol_body), # also topleft + padding.top = cell_margins[3], + padding.bottom = cell_margins[4], + part = "header" + ) + + flx +} + +#' @describeIn tt_to_flextable Padding helper functions to transform mm to pt. +#' @param mm (`numeric(1)`)\cr the value in mm to transform to pt. +#' +#' @export +word_mm_to_pt <- function(mm) { + mm / 0.3527777778 +} + +# Padding helper functions to transform mm to pt and viceversa +# # General note for word: 1pt -> 0.3527777778mm -> 0.013888888888889" +word_inch_to_pt <- function(inch) { # nocov + inch / 0.013888888888889 # nocov +} + +# Polish horizontal borders +.remove_hborder <- function(flx, part, w = c("top", "bottom", "inner")) { + # If you need to remove all of them + if (length(w) == 1 && w == "all") { + w <- eval(formals(.remove_hborder)$w) + } + + if (any(w == "top")) { + flx <- flextable::hline_top(flx, + border = flextable::fp_border_default(width = 0), + part = part + ) + } + if (any(w == "bottom")) { + flx <- flextable::hline_bottom(flx, + border = flextable::fp_border_default(width = 0), + part = part + ) + } + # Inner horizontal lines removal + if (any(w == "inner")) { + flx <- flextable::border_inner_h( + flx, + border = flextable::fp_border_default(width = 0), + part = part + ) + } + flx +} + +# Remove vertical borders from both sides (for titles) +remove_vborder <- function(flx, part, ii) { + flx <- flextable::border(flx, + i = ii, part = part, + border.left = flextable::fp_border_default(width = 0), + border.right = flextable::fp_border_default(width = 0) + ) +} + +# Add horizontal border +.add_hborder <- function(flx, part, ii, border) { + if (any(ii == 0)) { + flx <- flextable::border(flx, i = 1, border.top = border, part = part) + ii <- ii[!(ii == 0)] + } + if (length(ii) > 0) { + flx <- flextable::border(flx, i = ii, border.bottom = border, part = part) + } + flx +} diff --git a/R/tt_export.R b/R/tt_export.R index 9106f7ece..13fc1cb12 100644 --- a/R/tt_export.R +++ b/R/tt_export.R @@ -49,9 +49,7 @@ import_from_tsv <- function(file) { } )) } - -### Migrated to formatters ---- - +# txt (formatters) -------------------------------------------------------------------- #' @importFrom formatters export_as_txt #' #' @examples @@ -72,470 +70,7 @@ import_from_tsv <- function(file) { #' @export formatters::export_as_txt -# data.frame output ------------------------------------------------------------ - -#' Generate a result data frame -#' -#' Collection of utilities to extract `data.frame` objects from `TableTree` objects. -#' -#' @inheritParams gen_args -#' @param spec (`string`)\cr the specification to use to extract the result data frame. See Details below. -#' @param simplify (`flag`)\cr whether the result data frame should only have labels and result columns visible. -#' @param ... additional arguments passed to spec-specific result data frame conversion function. Currently it can be -#' one or more of the following parameters (valid only for `v0_experimental` spec. for now): -#' - `expand_colnames`: when `TRUE`, the result data frame will have expanded column names above the usual -#' output. This is useful when the result data frame is used for further processing. -#' - `simplify`: when `TRUE`, the result data frame will have only visible labels and result columns. -#' - `as_strings`: when `TRUE`, the result data frame will have all values as strings, as they appear -#' in the final table (it can also be retrieved from `matrix_form(tt)$strings`). This is also true for -#' column counts if `expand_colnames = TRUE`. -#' - `as_viewer`: when `TRUE`, the result data frame will have all values as they appear in the final table, -#' i.e. with the same precision and numbers, but in easy-to-use numeric form. -#' - `keep_label_rows`: when `TRUE`, the result data frame will have all labels as they appear in the -#' final table. -#' - `as_is`: when `TRUE`, the result data frame will have all the values as they appear in the final table, -#' but without information about the row structure. Row labels will be assigned to rows so to work well -#' with [df_to_tt()]. -#' -#' @details `as_result_df()`: Result data frame specifications may differ in the exact information -#' they include and the form in which they represent it. Specifications whose names end in "_experimental" -#' are subject to change without notice, but specifications without the "_experimental" -#' suffix will remain available *including any bugs in their construction* indefinitely. -#' -#' @return -#' * `as_result_df` returns a result `data.frame`. -#' -#' @seealso [df_to_tt()] when using `as_is = TRUE` and [formatters::make_row_df()] to have a comprehensive view of the -#' hierarchical structure of the rows. -#' -#' @examples -#' lyt <- basic_table() %>% -#' split_cols_by("ARM") %>% -#' split_rows_by("STRATA1") %>% -#' analyze(c("AGE", "BMRKR2")) -#' -#' tbl <- build_table(lyt, ex_adsl) -#' as_result_df(tbl) -#' -#' @name data.frame_export -#' @export -as_result_df <- function(tt, spec = "v0_experimental", simplify = FALSE, ...) { - checkmate::assert_class(tt, "VTableTree") - checkmate::assert_string(spec) - checkmate::assert_flag(simplify) - - if (nrow(tt) == 0) { - return(sanitize_table_struct(tt)) - } - - result_df_fun <- lookup_result_df_specfun(spec) - out <- result_df_fun(tt, ...) - - if (simplify) { - out <- .simplify_result_df(out) - } - - out -} - -# Function that selects specific outputs from the result data frame -.simplify_result_df <- function(df) { - col_df <- colnames(df) - row_names_col <- which(col_df == "row_name") - result_cols <- seq(which(col_df == "node_class") + 1, length(col_df)) - - df[, c(row_names_col, result_cols)] -} - -# Not used in rtables -# .split_colwidths <- function(ptabs, nctot, colwidths) { -# ret <- list() -# i <- 1L -# -# rlw <- colwidths[1] -# colwidths <- colwidths[-1] -# donenc <- 0 -# while (donenc < nctot) { -# curnc <- NCOL(ptabs[[i]]) -# ret[[i]] <- c(rlw, colwidths[seq_len(curnc)]) -# colwidths <- colwidths[-1 * seq_len(curnc)] -# donenc <- donenc + curnc -# i <- i + 1 -# } -# ret -# } - -#' @describeIn data.frame_export A list of functions that extract result data frames from `TableTree`s. -#' -#' @return -#' * `result_df_specs()` returns a named list of result data frame extraction functions by "specification". -#' -#' @examples -#' result_df_specs() -#' -#' @export -result_df_specs <- function() { - list(v0_experimental = result_df_v0_experimental) -} - -lookup_result_df_specfun <- function(spec) { - if (!(spec %in% names(result_df_specs()))) { - stop( - "unrecognized result data frame specification: ", - spec, - "If that specification is correct you may need to update your version of rtables" - ) - } - result_df_specs()[[spec]] -} - -result_df_v0_experimental <- function(tt, - as_viewer = FALSE, - as_strings = FALSE, - expand_colnames = FALSE, - keep_label_rows = FALSE, - as_is = FALSE) { - checkmate::assert_flag(as_viewer) - checkmate::assert_flag(as_strings) - checkmate::assert_flag(expand_colnames) - checkmate::assert_flag(keep_label_rows) - checkmate::assert_flag(as_is) - - if (as_is) { - keep_label_rows <- TRUE - expand_colnames <- FALSE - } - - raw_cvals <- cell_values(tt) - ## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values - ## rather than a list of length 1 representing the single row. This is bad but may not be changeable - ## at this point. - if (nrow(tt) == 1 && length(raw_cvals) > 1) { - raw_cvals <- list(raw_cvals) - } - - # Flatten the list of lists (rows) of cell values into a data frame - cellvals <- as.data.frame(do.call(rbind, raw_cvals)) - row.names(cellvals) <- NULL - - if (nrow(tt) == 1 && ncol(tt) == 1) { - colnames(cellvals) <- names(raw_cvals) - } - - if (as_viewer || as_strings) { - # we keep previous calculations to check the format of the data - mf_tt <- matrix_form(tt) - mf_result_chars <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), -1] - mf_result_chars <- .remove_empty_elements(mf_result_chars) - mf_result_numeric <- as.data.frame( - .make_numeric_char_mf(mf_result_chars) - ) - mf_result_chars <- as.data.frame(mf_result_chars) - if (!setequal(dim(mf_result_numeric), dim(cellvals)) || !setequal(dim(mf_result_chars), dim(cellvals))) { - stop( - "The extracted numeric data.frame does not have the same dimension of the", - " cell values extracted with cell_values(). This is a bug. Please report it." - ) # nocov - } - if (as_strings) { - colnames(mf_result_chars) <- colnames(cellvals) - cellvals <- mf_result_chars - } else { - colnames(mf_result_numeric) <- colnames(cellvals) - cellvals <- mf_result_numeric - } - } - - rdf <- make_row_df(tt) - - df <- rdf[, c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class")] - # Removing initial root elements from path (out of the loop -> right maxlen) - df$path <- lapply(df$path, .remove_root_elems_from_path, - which_root_name = c("root", "rbind_root"), - all = TRUE - ) - maxlen <- max(lengths(df$path)) - - # Loop for metadata (path and details from make_row_df) - metadf <- do.call( - rbind.data.frame, - lapply( - seq_len(NROW(df)), - function(ii) { - handle_rdf_row(df[ii, ], maxlen = maxlen) - } - ) - ) - - # Should we keep label rows with NAs instead of values? - if (keep_label_rows) { - cellvals_mat_struct <- as.data.frame( - matrix(NA, nrow = nrow(rdf), ncol = ncol(cellvals)) - ) - colnames(cellvals_mat_struct) <- colnames(cellvals) - cellvals_mat_struct[metadf$node_class != "LabelRow", ] <- cellvals - ret <- cbind(metadf, cellvals_mat_struct) - } else { - ret <- cbind( - metadf[metadf$node_class != "LabelRow", ], - cellvals - ) - } - - # If we want to expand colnames - if (expand_colnames) { - col_name_structure <- .get_formatted_colnames(clayout(tt)) - number_of_non_data_cols <- which(colnames(ret) == "node_class") - if (NCOL(ret) - number_of_non_data_cols != NCOL(col_name_structure)) { - stop( - "When expanding colnames structure, we were not able to find the same", - " number of columns as in the result data frame. This is a bug. Please report it." - ) # nocov - } - - buffer_rows_for_colnames <- matrix( - rep("", number_of_non_data_cols * NROW(col_name_structure)), - nrow = NROW(col_name_structure) - ) - - header_colnames_matrix <- cbind(buffer_rows_for_colnames, data.frame(col_name_structure)) - colnames(header_colnames_matrix) <- colnames(ret) - - count_row <- NULL - if (disp_ccounts(tt)) { - ccounts <- col_counts(tt) - if (as_strings) { - ccounts <- mf_strings(mf_tt)[mf_nlheader(mf_tt), ] - ccounts <- .remove_empty_elements(ccounts) - } - count_row <- c(rep("", number_of_non_data_cols), ccounts) - header_colnames_matrix <- rbind(header_colnames_matrix, count_row) - } - ret <- rbind(header_colnames_matrix, ret) - } - - # Using only labels for row names and losing information about paths - if (as_is) { - tmp_rownames <- ret$label_name - ret <- ret[, -seq_len(which(colnames(ret) == "node_class"))] - if (length(unique(tmp_rownames)) == length(tmp_rownames)) { - rownames(ret) <- tmp_rownames - } else { - ret <- cbind("label_name" = tmp_rownames, ret) - rownames(ret) <- NULL - } - } else { - rownames(ret) <- NULL - } - - ret -} - -.remove_empty_elements <- function(char_df) { - if (is.null(dim(char_df))) { - return(char_df[nzchar(char_df, keepNA = TRUE)]) - } - - apply(char_df, 2, function(col_i) col_i[nzchar(col_i, keepNA = TRUE)]) -} - -# Helper function to make the character matrix numeric -.make_numeric_char_mf <- function(char_df) { - if (is.null(dim(char_df))) { - return(as.numeric(stringi::stri_extract_all(char_df, regex = "\\d+.\\d+|\\d+"))) - } - - ret <- apply(char_df, 2, function(col_i) { - lapply( - stringi::stri_extract_all(col_i, regex = "\\d+.\\d+|\\d+"), - as.numeric - ) - }) - - do.call(cbind, ret) -} - -make_result_df_md_colnames <- function(maxlen) { - spllen <- floor((maxlen - 2) / 2) - ret <- character() - if (spllen > 0) { - ret <- paste(c("spl_var", "spl_value"), rep(seq_len(spllen), rep(2, spllen)), sep = "_") - } - ret <- c(ret, c("avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class")) -} - -do_label_row <- function(rdfrow, maxlen) { - pth <- rdfrow$path[[1]] - # Adjusting for the fact that we have two columns for each split - extra_nas_from_splits <- floor((maxlen - length(pth)) / 2) * 2 - - # Special cases with hidden labels - if (length(pth) %% 2 == 1) { - extra_nas_from_splits <- extra_nas_from_splits + 1 - } - - c( - as.list(pth[seq_len(length(pth) - 1)]), - as.list(replicate(extra_nas_from_splits, list(NA_character_))), - as.list(tail(pth, 1)), - list( - label_name = rdfrow$label, - row_num = rdfrow$abs_rownumber, - content = FALSE, - node_class = rdfrow$node_class - ) - ) -} - -do_content_row <- function(rdfrow, maxlen) { - pth <- rdfrow$path[[1]] - contpos <- which(pth == "@content") - - seq_before <- seq_len(contpos - 1) - - c( - as.list(pth[seq_before]), - as.list(replicate(maxlen - contpos, list(NA_character_))), - list(tail(pth, 1)), - list( - label_name = rdfrow$label, - row_num = rdfrow$abs_rownumber, - content = TRUE, - node_class = rdfrow$node_class - ) - ) -} - -do_data_row <- function(rdfrow, maxlen) { - pth <- rdfrow$path[[1]] - pthlen <- length(pth) - ## odd means we have a multi-analsysis step in the path, we dont' want that in the result data frame - if (pthlen %% 2 == 1) { - pth <- pth[-1 * (pthlen - 2)] - } - pthlen_new <- length(pth) - if (maxlen == 1) pthlen_new <- 3 - c( - as.list(pth[seq_len(pthlen_new - 2)]), - replicate(maxlen - pthlen, list(NA_character_)), - as.list(tail(pth, 2)), - list( - label_name = rdfrow$label, - row_num = rdfrow$abs_rownumber, - content = FALSE, - node_class = rdfrow$node_class - ) - ) -} - -.remove_root_elems_from_path <- function(path, which_root_name = c("root", "rbind_root"), all = TRUE) { - any_root_paths <- path[1] %in% which_root_name - if (any_root_paths) { - if (isTRUE(all)) { - # Selecting the header grouping of root and rbind_root (we do not want to remove other root labels-path later) - root_indices <- which(path %in% which_root_name) - if (any(diff(root_indices) > 1)) { # integer(0) for diff means FALSE - end_point_root_headers <- which(diff(root_indices) > 1)[1] - } else { - end_point_root_headers <- length(root_indices) - } - root_path_to_remove <- seq_len(end_point_root_headers) - } else { - root_path_to_remove <- 1 - } - path <- path[-root_path_to_remove] - } - - # Fix for very edge case where we have only root elements - if (length(path) == 0) { - path <- which_root_name[1] - } - - path -} - -handle_rdf_row <- function(rdfrow, maxlen) { - nclass <- rdfrow$node_class - - ret <- switch(nclass, - LabelRow = do_label_row(rdfrow, maxlen), - ContentRow = do_content_row(rdfrow, maxlen), - DataRow = do_data_row(rdfrow, maxlen), - stop("Unrecognized node type in row dataframe, unable to generate result data frame") - ) - setNames(ret, make_result_df_md_colnames(maxlen)) -} - -# Helper recurrent function to get the column names for the result data frame from the VTableTree -.get_formatted_colnames <- function(clyt) { - ret <- obj_label(clyt) - if (!nzchar(ret)) { - ret <- NULL - } - if (is.null(tree_children(clyt))) { - return(ret) - } else { - ret <- rbind(ret, do.call(cbind, lapply(tree_children(clyt), .get_formatted_colnames))) - colnames(ret) <- NULL - rownames(ret) <- NULL - return(ret) - } -} - -#' @describeIn data.frame_export Transform a `TableTree` object to a path-enriched `data.frame`. -#' -#' @param path_fun (`function`)\cr function to transform paths into single-string row/column names. -#' @param value_fun (`function`)\cr function to transform cell values into cells of a `data.frame`. Defaults to -#' `collapse_values`, which creates strings where multi-valued cells are collapsed together, separated by `|`. -#' -#' @return -#' * `path_enriched_df()` returns a `data.frame` of `tt`'s cell values (processed by `value_fun`, with columns named by -#' the full column paths (processed by `path_fun` and an additional `row_path` column with the row paths (processed -#' by `path_fun`). -#' -#' @examples -#' lyt <- basic_table() %>% -#' split_cols_by("ARM") %>% -#' analyze(c("AGE", "BMRKR2")) -#' -#' tbl <- build_table(lyt, ex_adsl) -#' path_enriched_df(tbl) -#' -#' @export -path_enriched_df <- function(tt, path_fun = collapse_path, value_fun = collapse_values) { - rdf <- make_row_df(tt) - cdf <- make_col_df(tt) - cvs <- as.data.frame(do.call(rbind, cell_values(tt))) - cvs <- as.data.frame(lapply(cvs, value_fun)) - row.names(cvs) <- NULL - colnames(cvs) <- path_fun(cdf$path) - preppaths <- path_fun(rdf[rdf$node_class != "LabelRow", ]$path) - cbind.data.frame(row_path = preppaths, cvs) -} - -.collapse_char <- "|" -.collapse_char_esc <- "\\|" - -collapse_path <- function(paths) { - if (is.list(paths)) { - return(vapply(paths, collapse_path, "")) - } - paste(paths, collapse = .collapse_char) -} - -collapse_values <- function(colvals) { - if (!is.list(colvals)) { ## || all(vapply(colvals, length, 1L) == 1)) - return(colvals) - } else if (all(vapply(colvals, length, 1L) == 1)) { - return(unlist(colvals)) - } - vapply(colvals, paste, "", collapse = .collapse_char) -} - -# pdf output ------------------------------------------------------------------- - -### Export as PDF - migrated to formatters - +# pdf (formatters) ---------------------------------------------------------- #' @importFrom formatters export_as_pdf #' #' @examples @@ -555,23 +90,7 @@ collapse_values <- function(colvals) { #' @export formatters::export_as_pdf -# only used in pagination -.tab_to_colpath_set <- function(tt) { - vapply( - collect_leaves(coltree(tt)), - function(y) paste(pos_to_path(tree_pos(y)), collapse = " "), - "" - ) -} -.figure_out_colinds <- function(subtab, fulltab) { - match( - .tab_to_colpath_set(subtab), - .tab_to_colpath_set(fulltab) - ) -} - -# Flextable and docx ----------------------------------------------------------- - +# docx (flextable) ----------------------------------------------------------- #' Export as word document #' #' From a table, produce a self-contained word document or attach it to a template word @@ -630,12 +149,17 @@ export_as_docx <- function(tt, ) if (isFALSE(titles_as_header) || isTRUE(footers_as_text)) { # Ugly but I could not find a getter for font.size - font_sz <- flex_tbl$header$styles$text$font.size$data[1, 1] - font_sz_footer <- flex_tbl$header$styles$text$font.size$data[1, 1] - 1 + font_sz_body <- flex_tbl$header$styles$text$font.size$data[1, 1] + font_size_footer <- flex_tbl$footer$styles$text$font.size$data + font_sz_footer <- if (length(font_size_footer) > 0) { + font_size_footer[1, 1] + } else { + font_sz_body - 1 + } font_fam <- flex_tbl$header$styles$text$font.family$data[1, 1] # Set the test as the tt - fpt <- officer::fp_text(font.family = font_fam, font.size = font_sz) + fpt <- officer::fp_text(font.family = font_fam, font.size = font_sz_body) fpt_footer <- officer::fp_text(font.family = font_fam, font.size = font_sz_footer) } } else { @@ -748,542 +272,3 @@ margins_potrait <- function() { margins_landscape <- function() { officer::page_mar(bottom = 1, top = 1.5, left = 0.98, right = 0.95, gutter = 0) } - -#' Create a `flextable` from an `rtables` table -#' -#' Principally used for export ([export_as_docx()]), this function produces a `flextable` -#' from an `rtables` table. If `theme = NULL`, `rtables`-like style will be used. Otherwise, -#' [theme_docx_default()] will produce a `.docx`-friendly table. -#' -#' @inheritParams gen_args -#' @inheritParams paginate_table -#' @param theme (`function` or `NULL`)\cr A theme function that is designed internally as a function of a `flextable` -#' object to change its layout and style. If `NULL`, it will produce a table similar to `rtables` default. Defaults -#' to `theme_docx_default()`. See details for more information. -#' @param border (`officer` border object)\cr defaults to `officer::fp_border(width = 0.5)`. -#' @param indent_size (`numeric(1)`)\cr if `NULL`, the default indent size of the table (see [formatters::matrix_form()] -#' `indent_size`, default is 2) is used. To work with `docx`, any size is multiplied by 1 mm (2.83 pt) by default. -#' @param titles_as_header (`flag`)\cr defaults to `TRUE` for [tt_to_flextable()], so the table is self-contained -#' as it makes additional header rows for [formatters::main_title()] string and [formatters::subtitles()] character -#' vector (one per element). `FALSE` is suggested for [export_as_docx()]. This adds titles and subtitles as a text -#' paragraph above the table. The same style is applied. -#' @param footers_as_text (`flag`)\cr defaults to `FALSE` for [tt_to_flextable()], so the table is self-contained with -#' the `flextable` definition of footnotes. `TRUE` is used for [export_as_docx()] to add the footers as a new -#' paragraph after the table. The same style is applied, but with a smaller font. -#' @param counts_in_newline (`flag`)\cr defaults to `FALSE`. In `rtables` text printing ([formatters::toString()]), -#' the column counts, i.e. `(N=xx)`, are always on a new line. For `docx` exports it could be necessary to print it -#' on the same line. -#' @param paginate (`flag`)\cr when exporting `.docx` documents using `export_as_docx`, we suggest relying on the -#' Microsoft Word pagination system. If `TRUE`, this option splits `tt` into different "pages" as multiple -#' `flextables`. Cooperation between the two mechanisms is not guaranteed. Defaults to `FALSE`. -#' @param total_width (`numeric(1)`)\cr total width (in inches) for the resulting flextable(s). Defaults to 10. -#' -#' @return A `flextable` object. -#' -#' @details -#' It is possible to use some hidden values for building your own theme. In particular, `tt_to_flextable` -#' sends in the following variables `tbl_ncol_body = NCOL(tt)` and `tbl_row_class = make_row_df(tt)$node_class`. -#' These are ignored if not used in the theme. See `theme_docx_default` for an example on own to retrieve -#' these values and how to use them. -#' -#' -#' @seealso [export_as_docx()] -#' -#' @examples -#' analysisfun <- function(x, ...) { -#' in_rows( -#' row1 = 5, -#' row2 = c(1, 2), -#' .row_footnotes = list(row1 = "row 1 - row footnote"), -#' .cell_footnotes = list(row2 = "row 2 - cell footnote") -#' ) -#' } -#' -#' lyt <- basic_table( -#' title = "Title says Whaaaat", subtitles = "Oh, ok.", -#' main_footer = "ha HA! Footer!" -#' ) %>% -#' split_cols_by("ARM") %>% -#' analyze("AGE", afun = analysisfun) -#' -#' tbl <- build_table(lyt, ex_adsl) -#' -#' @examplesIf require(flextable) -#' library(flextable) -#' # example code -#' -#' # rtables style -#' tt_to_flextable(tbl, theme = NULL) -#' -#' tt_to_flextable(tbl, theme = theme_docx_default(font_size = 6)) -#' -#' @export -tt_to_flextable <- function(tt, - theme = theme_docx_default(), - border = flextable::fp_border_default(width = 0.5), - indent_size = NULL, - titles_as_header = TRUE, - footers_as_text = FALSE, - counts_in_newline = FALSE, - paginate = FALSE, - lpp = NULL, - cpp = NULL, - ..., - colwidths = propose_column_widths(matrix_form(tt, indent_rownames = TRUE)), - tf_wrap = !is.null(cpp), - max_width = cpp, - total_width = 10) { - check_required_packages("flextable") - if (!inherits(tt, "VTableTree")) { - stop("Input table is not an rtables' object.") - } - checkmate::assert_flag(titles_as_header) - checkmate::assert_flag(footers_as_text) - checkmate::assert_flag(counts_in_newline) - left_right_fixed_margins <- word_mm_to_pt(1.9) - - ## if we're paginating, just call -> pagination happens also afterwards if needed - if (paginate) { - if (is.null(lpp)) { - stop("lpp must be specified when calling tt_to_flextable with paginate=TRUE") - } - tabs <- paginate_table(tt, lpp = lpp, cpp = cpp, tf_wrap = tf_wrap, max_width = max_width, ...) - cinds <- lapply(tabs, function(tb) c(1, .figure_out_colinds(tb, tt) + 1L)) - return(mapply(tt_to_flextable, - tt = tabs, colwidths = cinds, - MoreArgs = list(paginate = FALSE, total_width = total_width), - SIMPLIFY = FALSE - )) - } - - # Calculate the needed colwidths - final_cwidths <- total_width * colwidths / sum(colwidths) # xxx to fix - # xxx FIXME missing transformer from character based widths to mm or pt - - # Extract relevant information - matform <- matrix_form(tt, indent_rownames = FALSE) - body <- mf_strings(matform) # Contains header - spans <- mf_spans(matform) # Contains header - mpf_aligns <- mf_aligns(matform) # Contains header - hnum <- mf_nlheader(matform) # Number of lines for the header - rdf <- make_row_df(tt) # Row-wise info - - # decimal alignment pre-proc - if (any(grepl("dec", mpf_aligns))) { - body <- decimal_align(body, mpf_aligns) - # Coercion for flextable - mpf_aligns[mpf_aligns == "decimal"] <- "center" - mpf_aligns[mpf_aligns == "dec_left"] <- "left" - mpf_aligns[mpf_aligns == "dec_right"] <- "right" - } - - # Fundamental content of the table - content <- as.data.frame(body[-seq_len(hnum), , drop = FALSE]) - flx <- flextable::qflextable(content) %>% - # Default rtables if no footnotes - remove_hborder(part = "body", w = "bottom") - - # Header addition -> NB: here we have a problem with (N=xx) - hdr <- body[seq_len(hnum), , drop = FALSE] - - # XXX NOT NECESSARY change of (N=xx) which is by default on a new line but we do not - # want this in docx, and it depends on the size of the table, it is not another - # row with different columns -> All of this should be fixed at source (in matrix_form) - # See .tbl_header_mat for this change - if (hnum > 1) { # otherwise nothing to do - det_nclab <- apply(hdr, 2, grepl, pattern = "\\(N=[0-9]+\\)$") - has_nclab <- apply(det_nclab, 1, any) - whsnc <- which(has_nclab) # which rows have it -> more than one is not supported - if (isFALSE(counts_in_newline) && any(has_nclab) && length(whsnc) == 1L) { - what_is_nclab <- det_nclab[whsnc, ] - - # condition for popping the interested row by merging the upper one - hdr[whsnc, what_is_nclab] <- paste(hdr[whsnc - 1, what_is_nclab], - hdr[whsnc, what_is_nclab], - sep = " " - ) - hdr[whsnc - 1, what_is_nclab] <- "" - - # We can remove the row if they are all "" - row_to_pop <- whsnc - 1 - if (all(!nzchar(hdr[row_to_pop, ]))) { - hdr <- hdr[-row_to_pop, , drop = FALSE] - spans <- spans[-row_to_pop, , drop = FALSE] - body <- body[-row_to_pop, , drop = FALSE] - mpf_aligns <- mpf_aligns[-row_to_pop, , drop = FALSE] - hnum <- hnum - 1 - } - } - } - - flx <- flx %>% - flextable::set_header_labels( # Needed bc headers must be unique - values = setNames( - as.vector(hdr[hnum, , drop = TRUE]), - names(content) - ) - ) - # If there are more rows - if (hnum > 1) { - for (i in seq(hnum - 1, 1)) { - sel <- spans_to_viscell(spans[i, ]) - flx <- flextable::add_header_row( - flx, - top = TRUE, - values = as.vector(hdr[i, sel]), - colwidths = as.integer(spans[i, sel]) # xxx to fix - ) - } - } - - # Re-set the number of row count - nr_body <- flextable::nrow_part(flx, part = "body") - nr_header <- flextable::nrow_part(flx, part = "header") - - # Polish the inner horizontal borders from the header - flx <- flx %>% - remove_hborder(part = "header", w = "all") %>% - add_hborder("header", ii = c(0, hnum), border = border) - - # ALIGNS - flx <- flx %>% - apply_alignments(mpf_aligns[seq_len(hnum), , drop = FALSE], "header") %>% - apply_alignments(mpf_aligns[-seq_len(hnum), , drop = FALSE], "body") - - # Rownames indentation - checkmate::check_number(indent_size, null.ok = TRUE) - if (is.null(indent_size)) { - # Default indent_size in {rtables} is 2 characters - indent_size <- matform$indent_size * word_mm_to_pt(1) # default is 2mm (5.7pt) - } else { - indent_size <- indent_size * word_mm_to_pt(1) - } - - # rdf contains information about indentation - for (i in seq_len(nr_body)) { - flx <- flextable::padding(flx, - i = i, j = 1, - padding.left = indent_size * rdf$indent[[i]] + left_right_fixed_margins, # margins - padding.right = left_right_fixed_margins, # 0.19 mmm in pt (so not to touch the border) - part = "body" - ) - } - - # TOPLEFT - # Principally used for topleft indentation, this is a bit of a hack xxx - for (i in seq_len(nr_header)) { - leading_spaces_count <- nchar(hdr[i, 1]) - nchar(stringi::stri_replace(hdr[i, 1], regex = "^ +", "")) - header_indent_size <- leading_spaces_count * word_mm_to_pt(1) - flx <- flextable::padding(flx, - i = i, j = 1, - padding.left = header_indent_size + left_right_fixed_margins, # margins - padding.right = left_right_fixed_margins, # 0.19 mmm in pt (so not to touch the border) - part = "header" - ) - } - # topleft styling (-> bottom aligned) xxx merge_at() could merge these, but let's see - flx <- flextable::valign(flx, j = 1, valign = "bottom", part = "header") - - # Adding referantial footer line separator if present - if (length(matform$ref_footnotes) > 0 && isFALSE(footers_as_text)) { - flx <- flextable::add_footer_lines(flx, values = matform$ref_footnotes) %>% - add_hborder(part = "body", ii = nrow(tt), border = border) - } - - # Footer lines - if (length(all_footers(tt)) > 0 && isFALSE(footers_as_text)) { - flx <- flextable::add_footer_lines(flx, values = all_footers(tt)) - } - - flx <- flextable::width(flx, width = final_cwidths) # xxx to fix - - if (!is.null(theme)) { - flx <- theme( - flx, - tbl_ncol_body = flextable::ncol_keys(flx), # NCOL(tt) + 1, # +1 for rownames - tbl_row_class = make_row_df(tt)$node_class # These are ignored if not in the theme - ) - } - - # Title lines (after theme for problems with lines) - if (titles_as_header && length(all_titles(tt)) > 0 && any(nzchar(all_titles(tt)))) { - real_titles <- all_titles(tt) - real_titles <- real_titles[nzchar(real_titles)] - flx <- flextable::add_header_lines(flx, values = real_titles, top = TRUE) %>% - # Remove the added borders - remove_hborder(part = "header", w = c("inner", "top")) %>% - # Re-add the separator between titles and real headers - add_hborder( - part = "header", ii = length(real_titles), - border = border - ) %>% - # Remove vertical borders added by theme eventually - remove_vborder(part = "header", ii = seq_along(real_titles)) - } - - # These final formatting need to work with colwidths - flx <- flextable::set_table_properties(flx, layout = "autofit", align = "left") # xxx to fix - # NB: autofit or fixed may be switched if widths are correctly staying in the page - flx <- flextable::fix_border_issues(flx) # Fixes some rendering gaps in borders - - flx -} - -#' @describeIn tt_to_flextable Main theme function for [export_as_docx()] -#' -#' @param font (`string`)\cr defaults to `"Arial"`. If the font is not available, `flextable` default is used. -#' @param font_size (`integer(1)`)\cr font size. Defaults to 9. -#' @param cell_margins (`numeric(1)` or `numeric(4)`)\cr a numeric or a vector of four numbers indicating -#' `c("left", "right", "top", "bottom")`. It defaults to 0 for top and bottom, and to 0.19 `mm` in word `pt` -#' for left and right. -#' @param bold (`character`)\cr parts of the table text that should be in bold. Can be any combination of -#' `c("header", "content_rows", "label_rows")`. The first one renders all column names bold (not `topleft` content). -#' The second and third option use [formatters::make_row_df()] to render content or/and label rows as bold. -#' @param bold_manual (named `list` or `NULL`)\cr list of index lists. See example for needed structure. Accepted -#' groupings/names are `c("header", "body")`. -#' @param border (`flextable::fp_border()`)\cr border style. Defaults to `flextable::fp_border_default(width = 0.5)`. -#' -#' @seealso [export_as_docx()] -#' -#' @examplesIf require(flextable) -#' library(flextable) -#' # Custom theme -#' special_bold <- list( -#' "header" = list("i" = 1, "j" = c(1, 3)), -#' "body" = list("i" = c(1, 2), "j" = 1) -#' ) -#' custom_theme <- theme_docx_default( -#' font_size = 10, -#' font = "Brush Script MT", -#' border = flextable::fp_border_default(color = "pink", width = 2), -#' bold = NULL, -#' bold_manual = special_bold -#' ) -#' tt_to_flextable(tbl, -#' border = flextable::fp_border_default(color = "pink", width = 2), -#' theme = custom_theme -#' ) -#' -#' @export -theme_docx_default <- function(font = "Arial", - font_size = 9, - cell_margins = c( - word_mm_to_pt(1.9), - word_mm_to_pt(1.9), - 0, - 0 - ), # Default in docx - bold = c("header", "content_rows", "label_rows"), - bold_manual = NULL, - border = flextable::fp_border_default(width = 0.5)) { - function(flx, ...) { - check_required_packages("flextable") - if (!inherits(flx, "flextable")) { - stop(sprintf( - "Function `%s` supports only flextable objects.", - "theme_box()" - )) - } - checkmate::assert_int(font_size, lower = 6, upper = 12) - checkmate::assert_string(font) - checkmate::assert_subset(bold, - eval(formals(theme_docx_default)$bold), - empty.ok = TRUE - ) - if (length(cell_margins) == 1) { - cell_margins <- rep(cell_margins, 4) - } - checkmate::assert_numeric(cell_margins, lower = 0, len = 4) - - # Setting values coming from ... - args <- list(...) - tbl_row_class <- args$tbl_row_class # This is internal info - tbl_ncol_body <- args$tbl_ncol_body # This is internal info - if (is.null(tbl_ncol_body)) { - tbl_ncol_body <- flextable::ncol_keys(flx) # tbl_ncol_body respects if rownames = FALSE - } - - # Font setting - flx <- flextable::fontsize(flx, size = font_size, part = "all") %>% - flextable::fontsize(size = font_size - 1, part = "footer") %>% - flextable::font(fontname = font, part = "all") - - # Vertical borders - flx <- flx %>% - flextable::border_outer(part = "body", border = border) %>% - flextable::border_outer(part = "header", border = border) %>% - flextable::border_inner(part = "header", border = border) # xxx - - # Vertical alignment -> all top for now - flx <- flx %>% - flextable::valign(j = seq(2, tbl_ncol_body), valign = "top", part = "body") %>% - flextable::valign(j = 1, valign = "top", part = "body") %>% - flextable::valign(j = seq(2, tbl_ncol_body), valign = "top", part = "header") - - # Vertical padding/spaces - rownames - flx <- flx %>% # summary/data rows and cells - flextable::padding(padding.top = cell_margins[3], padding.bottom = cell_margins[4], part = "body") - if (any(tbl_row_class == "LabelRow")) { # label rows - 3pt top - flx <- flextable::padding(flx, - j = 1, i = which(tbl_row_class == "LabelRow"), - padding.top = 3 + cell_margins[3], padding.bottom = cell_margins[4], part = "body" - ) - } - if (any(tbl_row_class == "ContentRow")) { # content rows - 1pt top - flx <- flextable::padding(flx, - # j = 1, # removed because I suppose we want alignment with body - i = which(tbl_row_class == "ContentRow"), - padding.top = 1 + cell_margins[3], padding.bottom = cell_margins[4], part = "body" - ) - } - - # Horizontal padding all table margin 0.19 mm - flx <- flextable::padding(flx, - j = seq(2, tbl_ncol_body), - padding.left = cell_margins[1], - padding.right = cell_margins[2] - ) - - # Vertical padding/spaces - header (3pt after) - flx <- flx %>% - flextable::padding( - j = seq(2, tbl_ncol_body), - padding.top = cell_margins[3], - padding.bottom = cell_margins[4], - part = "header" - ) - - # single line spacing (for safety) -> space = 1 - flx <- flextable::line_spacing(flx, space = 1, part = "all") - - # Bold settings - if (any(bold == "header")) { - flx <- flextable::bold(flx, j = seq(2, tbl_ncol_body), part = "header") # Done with theme - } - # Content rows are effectively our labels in row names - if (any(bold == "content_rows")) { - if (is.null(tbl_row_class)) { - stop('bold = "content_rows" needs tbl_row_class = make_row_df(tt).') - } - flx <- flextable::bold(flx, j = 1, i = which(tbl_row_class == "ContentRow"), part = "body") - } - if (any(bold == "label_rows")) { - if (is.null(tbl_row_class)) { - stop('bold = "content_rows" needs tbl_row_class = make_row_df(tt).') - } - flx <- flextable::bold(flx, j = 1, i = which(tbl_row_class == "LabelRow"), part = "body") - } - # topleft information is also bold if content or label rows are bold - if (any(bold %in% c("content_rows", "label_rows"))) { - flx <- flextable::bold(flx, j = 1, part = "header") - } - - # If you want specific cells to be bold - if (!is.null(bold_manual)) { - checkmate::assert_list(bold_manual) - valid_sections <- c("header", "body") # Only valid values - checkmate::assert_subset(names(bold_manual), valid_sections) - for (bi in seq_along(bold_manual)) { - bld_tmp <- bold_manual[[bi]] - checkmate::assert_list(bld_tmp) - if (!all(c("i", "j") %in% names(bld_tmp)) || !all(vapply(bld_tmp, checkmate::test_integerish, logical(1)))) { - stop( - "Found an allowed section for manual bold (", names(bold_manual)[bi], - ") that was not a named list with i (row) and j (col) integer vectors." - ) - } - flx <- flextable::bold(flx, - i = bld_tmp$i, j = bld_tmp$j, - part = names(bold_manual)[bi] - ) - } - } - - flx - } -} - -#' @describeIn tt_to_flextable Padding helper functions to transform mm to pt. -#' @param mm (`numeric(1)`)\cr the value in mm to transform to pt. -#' -#' @export -word_mm_to_pt <- function(mm) { - mm / 0.3527777778 -} - -# Padding helper functions to transform mm to pt and viceversa -# # General note for word: 1pt -> 0.3527777778mm -> 0.013888888888889" -word_inch_to_pt <- function(inch) { # nocov - inch / 0.013888888888889 # nocov -} - -# Polish horizontal borders -remove_hborder <- function(flx, part, w = c("top", "bottom", "inner")) { - # If you need to remove all of them - if (length(w) == 1 && w == "all") { - w <- eval(formals(remove_hborder)$w) - } - - if (any(w == "top")) { - flx <- flextable::hline_top(flx, - border = flextable::fp_border_default(width = 0), - part = part - ) - } - if (any(w == "bottom")) { - flx <- flextable::hline_bottom(flx, - border = flextable::fp_border_default(width = 0), - part = part - ) - } - # Inner horizontal lines removal - if (any(w == "inner")) { - flx <- flextable::border_inner_h( - flx, - border = flextable::fp_border_default(width = 0), - part = part - ) - } - flx -} - -# Remove vertical borders from both sides (for titles) -remove_vborder <- function(flx, part, ii) { - flx <- flextable::border(flx, - i = ii, part = part, - border.left = flextable::fp_border_default(width = 0), - border.right = flextable::fp_border_default(width = 0) - ) -} - -# Add horizontal border -add_hborder <- function(flx, part, ii, border) { - if (any(ii == 0)) { - flx <- flextable::border(flx, i = 1, border.top = border, part = part) - ii <- ii[!(ii == 0)] - } - if (length(ii) > 0) { - flx <- flextable::border(flx, i = ii, border.bottom = border, part = part) - } - flx -} - -apply_alignments <- function(flx, aligns_df, part) { - # List of characters you want to search for - search_chars <- unique(c(aligns_df)) - - # Loop through each character and find its indexes - for (char in search_chars) { - indexes <- which(aligns_df == char, arr.ind = TRUE) - tmp_inds <- as.data.frame(indexes) - flx <- flx %>% - flextable::align( - i = tmp_inds[["row"]], - j = tmp_inds[["col"]], - align = char, - part = part - ) - } - - flx -} diff --git a/man/data.frame_export.Rd b/man/data.frame_export.Rd index ff8b3c529..4e952446d 100644 --- a/man/data.frame_export.Rd +++ b/man/data.frame_export.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tt_export.R +% Please edit documentation in R/tt_as_df.R \name{data.frame_export} \alias{data.frame_export} \alias{as_result_df} diff --git a/man/tt_to_flextable.Rd b/man/tt_to_flextable.Rd index 05fa2f4d9..e82a8092d 100644 --- a/man/tt_to_flextable.Rd +++ b/man/tt_to_flextable.Rd @@ -1,8 +1,9 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tt_export.R +% Please edit documentation in R/tt_as_flextable.R \name{tt_to_flextable} \alias{tt_to_flextable} \alias{theme_docx_default} +\alias{theme_html_default} \alias{word_mm_to_pt} \title{Create a \code{flextable} from an \code{rtables} table} \usage{ @@ -12,13 +13,15 @@ tt_to_flextable( border = flextable::fp_border_default(width = 0.5), indent_size = NULL, titles_as_header = TRUE, + bold_titles = TRUE, footers_as_text = FALSE, counts_in_newline = FALSE, paginate = FALSE, + fontspec = NULL, lpp = NULL, cpp = NULL, ..., - colwidths = propose_column_widths(matrix_form(tt, indent_rownames = TRUE)), + colwidths = NULL, tf_wrap = !is.null(cpp), max_width = cpp, total_width = 10 @@ -28,11 +31,19 @@ theme_docx_default( font = "Arial", font_size = 9, cell_margins = c(word_mm_to_pt(1.9), word_mm_to_pt(1.9), 0, 0), - bold = c("header", "content_rows", "label_rows"), + bold = c("header", "content_rows", "label_rows", "top_left"), bold_manual = NULL, border = flextable::fp_border_default(width = 0.5) ) +theme_html_default( + font = "Courier", + font_size = 9, + cell_margins = 0.2, + remove_internal_borders = "label_rows", + border = flextable::fp_border_default(width = 1, color = "black") +) + word_mm_to_pt(mm) } \arguments{ @@ -40,7 +51,7 @@ word_mm_to_pt(mm) \item{theme}{(\code{function} or \code{NULL})\cr A theme function that is designed internally as a function of a \code{flextable} object to change its layout and style. If \code{NULL}, it will produce a table similar to \code{rtables} default. Defaults -to \code{theme_docx_default()}. See details for more information.} +to \code{theme_docx_default()} that is a classic Word output. See details for more information.} \item{border}{(\code{flextable::fp_border()})\cr border style. Defaults to \code{flextable::fp_border_default(width = 0.5)}.} @@ -52,6 +63,9 @@ as it makes additional header rows for \code{\link[formatters:title_footer]{form vector (one per element). \code{FALSE} is suggested for \code{\link[=export_as_docx]{export_as_docx()}}. This adds titles and subtitles as a text paragraph above the table. The same style is applied.} +\item{bold_titles}{(\code{flag} or \code{integer})\cr defaults to \code{TRUE} for \code{\link[=tt_to_flextable]{tt_to_flextable()}}, so the titles are bold. If +it is one or more integers, those lines will be bold.} + \item{footers_as_text}{(\code{flag})\cr defaults to \code{FALSE} for \code{\link[=tt_to_flextable]{tt_to_flextable()}}, so the table is self-contained with the \code{flextable} definition of footnotes. \code{TRUE} is used for \code{\link[=export_as_docx]{export_as_docx()}} to add the footers as a new paragraph after the table. The same style is applied, but with a smaller font.} @@ -64,6 +78,9 @@ on the same line.} Microsoft Word pagination system. If \code{TRUE}, this option splits \code{tt} into different "pages" as multiple \code{flextables}. Cooperation between the two mechanisms is not guaranteed. Defaults to \code{FALSE}.} +\item{fontspec}{(\code{font_spec})\cr a font_spec object specifying the font information to use for +calculating string widths and heights, as returned by \code{\link[formatters:font_spec]{font_spec()}}.} + \item{lpp}{(\code{numeric(1)})\cr maximum lines per page including (re)printed header and context rows.} \item{cpp}{(\code{numeric(1)} or \code{NULL})\cr width (in characters) of the pages for horizontal pagination. @@ -83,7 +100,8 @@ used. Parameter is ignored if \code{tf_wrap = FALSE}.} \item{total_width}{(\code{numeric(1)})\cr total width (in inches) for the resulting flextable(s). Defaults to 10.} -\item{font}{(\code{string})\cr defaults to \code{"Arial"}. If the font is not available, \code{flextable} default is used.} +\item{font}{(\code{string})\cr defaults to \code{"Arial"}. If the font is not available, \code{flextable} default is used. +Please consider consulting the family column from \code{systemfonts::system_fonts()}.} \item{font_size}{(\code{integer(1)})\cr font size. Defaults to 9.} @@ -92,12 +110,16 @@ used. Parameter is ignored if \code{tf_wrap = FALSE}.} for left and right.} \item{bold}{(\code{character})\cr parts of the table text that should be in bold. Can be any combination of -\code{c("header", "content_rows", "label_rows")}. The first one renders all column names bold (not \code{topleft} content). -The second and third option use \code{\link[formatters:make_row_df]{formatters::make_row_df()}} to render content or/and label rows as bold.} +\code{c("header", "content_rows", "label_rows", "top_left")}. The first one renders all column names bold +(not \code{topleft} content). The second and third option use \code{\link[formatters:make_row_df]{formatters::make_row_df()}} to render content or/and +label rows as bold.} \item{bold_manual}{(named \code{list} or \code{NULL})\cr list of index lists. See example for needed structure. Accepted groupings/names are \code{c("header", "body")}.} +\item{remove_internal_borders}{(\code{character})\cr defaults to \code{"label_rows"}. Remove internal borders between rows. +Currently there are no other options and can be turned off by providing any character value.} + \item{mm}{(\code{numeric(1)})\cr the value in mm to transform to pt.} } \value{ @@ -109,14 +131,20 @@ from an \code{rtables} table. If \code{theme = NULL}, \code{rtables}-like style \code{\link[=theme_docx_default]{theme_docx_default()}} will produce a \code{.docx}-friendly table. } \details{ -It is possible to use some hidden values for building your own theme. In particular, \code{tt_to_flextable} -sends in the following variables \code{tbl_ncol_body = NCOL(tt)} and \code{tbl_row_class = make_row_df(tt)$node_class}. -These are ignored if not used in the theme. See \code{theme_docx_default} for an example on own to retrieve +Themes can also be extended when you need only a minor change from a default style. You can either +add your own theme to the theme call (e.g. \code{c(theme_docx_default(), my_theme)}) or create a new +theme like shown in the examples. Please pay attention to the parameters' inputs as they are relevant +for this to work properly. +Indeed, it is possible to use some hidden values for building your own theme (hence the need of \code{...}). +In particular, \code{tt_to_flextable} sends in the following variable: \code{tbl_row_class = make_row_df(tt)$node_class}. +This is ignored if not used in the theme. See \code{theme_docx_default} for an example on own to retrieve these values and how to use them. } \section{Functions}{ \itemize{ -\item \code{theme_docx_default()}: Main theme function for \code{\link[=export_as_docx]{export_as_docx()}} +\item \code{theme_docx_default()}: Main theme function for \code{\link[=export_as_docx]{export_as_docx()}}. + +\item \code{theme_html_default()}: Theme function for html outputs. \item \code{word_mm_to_pt()}: Padding helper functions to transform mm to pt. @@ -148,6 +176,12 @@ library(flextable) tt_to_flextable(tbl, theme = NULL) tt_to_flextable(tbl, theme = theme_docx_default(font_size = 6)) + +# Example with multiple themes (only extending the docx default!) +my_theme <- function(x, ...) { + border_inner(x, part = "body", border = flextable::fp_border_default(width = 0.5)) +} +flx <- tt_to_flextable(tbl, theme = c(theme_docx_default(), my_theme)) \dontshow{\}) # examplesIf} \dontshow{if (require(flextable)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} library(flextable) @@ -167,6 +201,20 @@ tt_to_flextable(tbl, border = flextable::fp_border_default(color = "pink", width = 2), theme = custom_theme ) + +# Extending themes +my_theme <- function(font_size = 6) { # here can pass additional arguments for default theme + function(flx, ...) { + # First apply theme_docx_default + flx <- theme_docx_default(font_size = font_size)(flx, ...) + + # Then apply additional styling + flx <- border_inner(flx, part = "body", border = flextable::fp_border_default(width = 0.5)) + + return(flx) + } +} +flx <- tt_to_flextable(tbl, theme = my_theme()) \dontshow{\}) # examplesIf} } \seealso{ diff --git a/rtables.Rproj b/rtables.Rproj index eaa6b8186..d574f8263 100644 --- a/rtables.Rproj +++ b/rtables.Rproj @@ -16,3 +16,5 @@ BuildType: Package PackageUseDevtools: Yes PackageInstallArgs: --no-multiarch --with-keep.source PackageRoxygenize: rd,collate,namespace + +UseNativePipeOperator: No diff --git a/tests/testthat/test-exporters.R b/tests/testthat/test-exporters.R index 33013e149..291941941 100644 --- a/tests/testthat/test-exporters.R +++ b/tests/testthat/test-exporters.R @@ -233,93 +233,6 @@ test_that("export_as_rtf works", { expect_true(file.exists(tmpf)) }) -# Flextable and docx support --------------------------------------------------- -test_that("Can create flextable object that works with different styles", { - skip_if_not_installed("flextable") - require("flextable", quietly = TRUE) - - analysisfun <- function(x, ...) { - in_rows( - row1 = 5, - row2 = c(1, 2), - .row_footnotes = list(row1 = "row 1 - row footnote"), - .cell_footnotes = list(row2 = "row 2 - cell footnote") - ) - } - - lyt <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SEX", split_fun = keep_split_levels(c("M", "F"))) %>% - split_rows_by("STRATA1") %>% - summarize_row_groups() %>% - split_rows_by("RACE", split_fun = keep_split_levels(c("WHITE", "ASIAN"))) %>% - analyze("AGE", afun = analysisfun) - - - tbl <- build_table(lyt, ex_adsl) - ft <- tt_to_flextable(tbl, total_width = 20) - expect_equal(sum(unlist(nrow(ft))), 20) - - ft2 <- tt_to_flextable(tbl, paginate = TRUE, lpp = 20, verbose = TRUE) - expect_equal(length(ft2), 2) - - expect_silent(ft3 <- tt_to_flextable(tbl, theme = NULL)) - - # Custom theme - special_bold <- list( - "header" = list("i" = c(1, 2), "j" = c(1, 3)), - "body" = list("i" = c(1, 2), "j" = 1) - ) - custom_theme <- theme_docx_default( - font_size = 10, - font = "Brush Script MT", - border = officer::fp_border(color = "pink", width = 2), - bold = NULL, - bold_manual = special_bold - ) - expect_silent(tt_to_flextable(tbl, theme = custom_theme)) - - # Custom theme error - special_bold <- list( - "header" = list("asdai" = c(1, 2), "j" = c(1, 3)), - "body" = list("i" = c(1, 2), "j" = 1) - ) - custom_theme <- theme_docx_default( - font_size = 10, - font = "Brush Script MT", - bold = NULL, - bold_manual = special_bold - ) - expect_error(tt_to_flextable(tbl, theme = custom_theme), regexp = "header") - - - # header colcounts not in a newline works - topleft_t1 <- topleft_t2 <- basic_table(show_colcounts = TRUE) %>% - split_rows_by("ARM", label_pos = "topleft") %>% - split_cols_by("STRATA1") - - topleft_t1 <- topleft_t1 %>% - analyze("BMRKR1") %>% - build_table(DM) - topleft_t1a <- tt_to_flextable(topleft_t1, counts_in_newline = FALSE) - topleft_t1b <- tt_to_flextable(topleft_t1, counts_in_newline = TRUE) - - topleft_t2 <- topleft_t2 %>% - split_rows_by("SEX", label_pos = "topleft") %>% - analyze("BMRKR1") %>% - build_table(DM) %>% - tt_to_flextable(counts_in_newline = FALSE) - - expect_equal(flextable::nrow_part(topleft_t2, part = "header"), 2L) - expect_equal(flextable::nrow_part(topleft_t1a, part = "header"), 1L) - expect_equal(flextable::nrow_part(topleft_t1b, part = "header"), 2L) - - - # internal package check - not_a_pkg <- "bwrereloakdosirabttjtaeerr" - expect_error(check_required_packages(c("flextable", not_a_pkg)), not_a_pkg) -}) - test_that("export_as_doc works thanks to tt_to_flextable", { skip_if_not_installed("flextable") require("flextable", quietly = TRUE) diff --git a/tests/testthat/test-tt_as_flextable.R b/tests/testthat/test-tt_as_flextable.R new file mode 100644 index 000000000..2c1a94495 --- /dev/null +++ b/tests/testthat/test-tt_as_flextable.R @@ -0,0 +1,146 @@ +test_that("Can create flextable object that works with different styles", { + skip_if_not_installed("flextable") + require("flextable", quietly = TRUE) + + analysisfun <- function(x, ...) { + in_rows( + row1 = 5, + row2 = c(1, 2), + .row_footnotes = list(row1 = "row 1 - row footnote"), + .cell_footnotes = list(row2 = "row 2 - cell footnote") + ) + } + + lyt <- basic_table() %>% + split_cols_by("ARM") %>% + split_cols_by("SEX", split_fun = keep_split_levels(c("M", "F"))) %>% + split_rows_by("STRATA1") %>% + summarize_row_groups() %>% + split_rows_by("RACE", split_fun = keep_split_levels(c("WHITE", "ASIAN"))) %>% + analyze("AGE", afun = analysisfun) + + + tbl <- build_table(lyt, ex_adsl) + ft <- tt_to_flextable(tbl, total_width = 20) + expect_equal(sum(unlist(nrow(ft))), 20) + + expect_silent(ft3 <- tt_to_flextable(tbl, theme = NULL)) + + # Custom theme + special_bold <- list( + "header" = list("i" = c(1, 2), "j" = c(1, 3)), + "body" = list("i" = c(1, 2), "j" = 1) + ) + custom_theme <- theme_docx_default( + font_size = 10, + font = "Brush Script MT", + border = officer::fp_border(color = "pink", width = 2), + bold = NULL, + bold_manual = special_bold + ) + expect_silent(tt_to_flextable(tbl, theme = custom_theme)) + + # Custom theme error + special_bold <- list( + "header" = list("asdai" = c(1, 2), "j" = c(1, 3)), + "body" = list("i" = c(1, 2), "j" = 1) + ) + custom_theme <- theme_docx_default( + font_size = 10, + font = "Brush Script MT", + bold = NULL, + bold_manual = special_bold + ) + expect_error(tt_to_flextable(tbl, theme = custom_theme), regexp = "header") + + # header colcounts not in a newline works + topleft_t1 <- topleft_t2 <- basic_table(show_colcounts = TRUE) %>% + split_rows_by("ARM", label_pos = "topleft") %>% + split_cols_by("STRATA1") + + topleft_t1 <- topleft_t1 %>% + analyze("BMRKR1") %>% + build_table(DM) + topleft_t1a <- tt_to_flextable(topleft_t1, counts_in_newline = FALSE) + topleft_t1b <- tt_to_flextable(topleft_t1, counts_in_newline = TRUE) + + topleft_t2 <- topleft_t2 %>% + split_rows_by("SEX", label_pos = "topleft") %>% + analyze("BMRKR1") %>% + build_table(DM) %>% + tt_to_flextable(counts_in_newline = FALSE) + + expect_equal(flextable::nrow_part(topleft_t2, part = "header"), 2L) + expect_equal(flextable::nrow_part(topleft_t1a, part = "header"), 1L) + expect_equal(flextable::nrow_part(topleft_t1b, part = "header"), 1L) + + + # internal package check + not_a_pkg <- "bwrereloakdosirabttjtaeerr" + expect_error(check_required_packages(c("flextable", not_a_pkg)), not_a_pkg) +}) + + +test_that("tt_to_flextable does not create different cells when colcounts (or multiple) on different lines", { + skip_if_not_installed("flextable") + require("flextable", quietly = TRUE) + + lyt <- basic_table(show_colcounts = TRUE) %>% + split_rows_by("ARM", label_pos = "topleft") %>% + split_rows_by("STRATA1", label_pos = "topleft") %>% + split_cols_by("STRATA1", split_fun = keep_split_levels("B"), show_colcounts = TRUE) %>% + split_cols_by("SEX", split_fun = keep_split_levels(c("F", "M"))) %>% + split_cols_by("COUNTRY", split_fun = keep_split_levels("CHN")) %>% + analyze("AGE") + + tbl <- build_table(lyt, ex_adsl) + ft1 <- tt_to_flextable(tbl, counts_in_newline = FALSE) + ft2 <- tt_to_flextable(tbl, counts_in_newline = TRUE) + + expect_equal(flextable::nrow_part(ft1, "header"), flextable::nrow_part(ft2, "header")) +}) + +test_that("check titles bold and html theme", { + skip_if_not_installed("flextable") + require("flextable", quietly = TRUE) + + lyt <- basic_table(show_colcounts = TRUE) %>% + split_rows_by("ARM", label_pos = "topleft") %>% + split_rows_by("STRATA1", label_pos = "topleft") %>% + split_cols_by("STRATA1", split_fun = keep_split_levels("B"), show_colcounts = TRUE) %>% + split_cols_by("SEX", split_fun = keep_split_levels(c("F", "M"))) %>% + split_cols_by("COUNTRY", split_fun = keep_split_levels("CHN")) %>% + analyze("AGE") + + tbl <- build_table(lyt, ex_adsl) + main_title(tbl) <- "Main title" + subtitles(tbl) <- c("Some Many", "Subtitles") + main_footer(tbl) <- c("Some Footer", "Mehr") + + expect_silent(ft1 <- tt_to_flextable(tbl, theme = theme_html_default(), bold_titles = FALSE)) + expect_silent(ft1 <- tt_to_flextable(tbl, theme = theme_html_default(), bold_titles = c(2, 3))) + expect_error(ft1 <- tt_to_flextable(tbl, theme = theme_html_default(), bold_titles = c(2, 3, 5))) +}) + + +test_that("check pagination", { + skip_if_not_installed("flextable") + require("flextable", quietly = TRUE) + + lyt <- basic_table(show_colcounts = TRUE) %>% + split_rows_by("ARM", label_pos = "topleft", page_by = TRUE) %>% + split_rows_by("STRATA1", label_pos = "topleft") %>% + split_cols_by("STRATA1", split_fun = keep_split_levels("B"), show_colcounts = TRUE) %>% + split_cols_by("SEX", split_fun = keep_split_levels(c("F", "M"))) %>% + split_cols_by("COUNTRY", split_fun = keep_split_levels("CHN")) %>% + analyze("AGE") + + tbl <- build_table(lyt, ex_adsl) + + main_title(tbl) <- "Main title" + subtitles(tbl) <- c("Some Many", "Subtitles") + main_footer(tbl) <- c("Some Footer", "Mehr") + prov_footer(tbl) <- "Some prov Footer" + + expect_silent(out <- tt_to_flextable(tbl, paginate = TRUE, lpp = 100)) +})