diff --git a/R/tt_as_df.R b/R/tt_as_df.R index d323a20a2..911d5145d 100644 --- a/R/tt_as_df.R +++ b/R/tt_as_df.R @@ -49,18 +49,18 @@ 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 } @@ -69,7 +69,7 @@ as_result_df <- function(tt, spec = "v0_experimental", simplify = FALSE, ...) { 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)] } @@ -126,12 +126,12 @@ result_df_v0_experimental <- function(tt, 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 @@ -139,15 +139,15 @@ result_df_v0_experimental <- function(tt, 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) @@ -171,17 +171,17 @@ result_df_v0_experimental <- function(tt, 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 + 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, @@ -192,7 +192,7 @@ result_df_v0_experimental <- function(tt, } ) ) - + # Should we keep label rows with NAs instead of values? if (keep_label_rows) { cellvals_mat_struct <- as.data.frame( @@ -207,7 +207,7 @@ result_df_v0_experimental <- function(tt, cellvals ) } - + # If we want to expand colnames if (expand_colnames) { col_name_structure <- .get_formatted_colnames(clayout(tt)) @@ -218,15 +218,15 @@ result_df_v0_experimental <- function(tt, " 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) @@ -239,7 +239,7 @@ result_df_v0_experimental <- function(tt, } 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 @@ -253,7 +253,7 @@ result_df_v0_experimental <- function(tt, } else { rownames(ret) <- NULL } - + ret } @@ -261,7 +261,7 @@ result_df_v0_experimental <- function(tt, 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)]) } @@ -270,14 +270,14 @@ result_df_v0_experimental <- function(tt, 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) } @@ -294,12 +294,12 @@ 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_))), @@ -316,9 +316,9 @@ do_label_row <- function(rdfrow, maxlen) { 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_))), @@ -371,23 +371,23 @@ do_data_row <- function(rdfrow, maxlen) { } 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") + 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)) } diff --git a/R/tt_as_flextable.R b/R/tt_as_flextable.R index b8cc45544..4063518db 100644 --- a/R/tt_as_flextable.R +++ b/R/tt_as_flextable.R @@ -1,5 +1,5 @@ # Flextable conversion --------------------------------------------------------- -# +# #' Create a `flextable` from an `rtables` table #' @@ -106,25 +106,25 @@ tt_to_flextable <- function(tt, 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, ... + 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 + 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 @@ -132,7 +132,7 @@ tt_to_flextable <- function(tt, 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) @@ -141,20 +141,20 @@ tt_to_flextable <- function(tt, 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]+\\)$") @@ -164,23 +164,23 @@ tt_to_flextable <- function(tt, 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, 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) { @@ -197,7 +197,7 @@ tt_to_flextable <- function(tt, 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] @@ -212,10 +212,10 @@ tt_to_flextable <- function(tt, } } } - + # Fix for empty strings hdr[hdr == ""] <- " " - + flx <- flx %>% flextable::set_header_labels( # Needed bc headers must be unique values = setNames( @@ -223,7 +223,7 @@ tt_to_flextable <- function(tt, names(content) ) ) - + # If there are more rows -> add them if (hnum > 1) { for (i in seq(hnum - 1, 1)) { @@ -236,21 +236,21 @@ tt_to_flextable <- function(tt, ) } } - + # 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)) { @@ -259,51 +259,51 @@ tt_to_flextable <- function(tt, } 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" + 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" + 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) @@ -315,9 +315,9 @@ tt_to_flextable <- function(tt, } 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) %>% @@ -326,12 +326,12 @@ tt_to_flextable <- function(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 } @@ -353,7 +353,7 @@ tt_to_flextable <- function(tt, .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 @@ -365,7 +365,7 @@ tt_to_flextable <- function(tt, 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)) { @@ -374,7 +374,7 @@ tt_to_flextable <- function(tt, } flx <- flextable::bold(flx, part = "header", i = bold) } - + flx } @@ -391,7 +391,7 @@ tt_to_flextable <- function(tt, tbl_row_class = tbl_row_class # These are ignored if not in the theme ) } - + flx } @@ -399,14 +399,14 @@ tt_to_flextable <- function(tt, 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) @@ -419,7 +419,7 @@ tt_to_flextable <- function(tt, part = part ) } - + flx } @@ -500,28 +500,28 @@ theme_docx_default <- function(font = "Arial", 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 + 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_titles <- args$titles 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") %>% @@ -529,29 +529,29 @@ theme_docx_default <- function(font = "Arial", # 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 + 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" + 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" + # 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 @@ -573,10 +573,10 @@ theme_docx_default <- function(font = "Arial", 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 } } @@ -606,27 +606,27 @@ theme_html_default <- function(font = "Courier", } 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) + 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, @@ -640,7 +640,7 @@ theme_html_default <- function(font = "Courier", ) } flx <- flextable::bg(flx, i = seq_len(nr_header), bg = "grey", part = "header") - + return(flx) } } @@ -668,7 +668,7 @@ theme_html_default <- function(font = "Courier", 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 @@ -689,7 +689,7 @@ theme_html_default <- function(font = "Courier", } } } - + flx } @@ -710,11 +710,11 @@ theme_html_default <- function(font = "Courier", ) } flx <- flextable::bold(flx, - i = bld_tmp$i, j = bld_tmp$j, - part = names(bold_manual)[bi] + i = bld_tmp$i, j = bld_tmp$j, + part = names(bold_manual)[bi] ) } - + flx } @@ -724,14 +724,14 @@ theme_html_default <- function(font = "Courier", 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] + 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( @@ -740,7 +740,7 @@ theme_html_default <- function(font = "Courier", padding.bottom = cell_margins[4], part = "header" ) - + flx } @@ -764,17 +764,17 @@ word_inch_to_pt <- function(inch) { # nocov 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 + 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 + border = flextable::fp_border_default(width = 0), + part = part ) } # Inner horizontal lines removal @@ -791,9 +791,9 @@ word_inch_to_pt <- function(inch) { # nocov # 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) + i = ii, part = part, + border.left = flextable::fp_border_default(width = 0), + border.right = flextable::fp_border_default(width = 0) ) } diff --git a/tests/testthat/test-exporters.R b/tests/testthat/test-exporters.R index 8c42e07bb..291941941 100644 --- a/tests/testthat/test-exporters.R +++ b/tests/testthat/test-exporters.R @@ -274,4 +274,3 @@ test_that("export_as_doc works thanks to tt_to_flextable", { expect_true(file.exists(doc_file)) }) - diff --git a/tests/testthat/test-tt_as_flextable.R b/tests/testthat/test-tt_as_flextable.R index c78ae50e9..2c1a94495 100644 --- a/tests/testthat/test-tt_as_flextable.R +++ b/tests/testthat/test-tt_as_flextable.R @@ -1,7 +1,7 @@ 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, @@ -10,7 +10,7 @@ test_that("Can create flextable object that works with different styles", { .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"))) %>% @@ -18,14 +18,14 @@ test_that("Can create flextable object that works with different styles", { 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)), @@ -39,7 +39,7 @@ test_that("Can create flextable object that works with different styles", { 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)), @@ -52,29 +52,29 @@ test_that("Can create flextable object that works with different styles", { 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) @@ -84,7 +84,7 @@ test_that("Can create flextable object that works with different styles", { 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") %>% @@ -92,18 +92,18 @@ test_that("tt_to_flextable does not create different cells when colcounts (or mu 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") %>% @@ -111,12 +111,12 @@ test_that("check titles bold and html theme", { 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))) @@ -126,7 +126,7 @@ test_that("check titles bold and html theme", { 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") %>% @@ -134,13 +134,13 @@ test_that("check pagination", { 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)) -}) \ No newline at end of file +})