diff --git a/R/utils.R b/R/utils.R index 41f697566..c4ae4b1f9 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1190,42 +1190,40 @@ markdown_to_xml <- function(text) { if (inherits(x, "xml_nodeset")) { - results <- lapply(x, apply_rules) + results <- lapply(x, apply_rules) do.call("paste0", c(results, collapse = "\n")) - } else { + } else { output <- if (xml2::xml_type(x) == "element") { + rule <- cmark_rules_xml[[xml2::xml_name(x)]] - rule <- cmark_rules_xml[[xml2::xml_name(x)]] + if (is.null(rule)) { - if (is.null(rule)) { - - rlang::warn( - paste0("Unknown commonmark element encountered: ", xml2::xml_name(x)), - .frequency = "once", - .frequency_id = "gt_commonmark_unknown_element" - ) + cli::cli_warn( + "Unknown commonmark element encountered: {xml2::xml_name(x)}", + .frequency = "once", + .frequency_id = "gt_commonmark_unknown_element" + ) - apply_rules(xml2::xml_children(x)) + apply_rules(xml2::xml_children(x)) - } else if (is.function(rule)) { + } else if (is.function(rule)) { - rule(x, apply_rules, ...) + rule(x, apply_rules, ...) - } } + } paste0(output, collapse = "") - } } - - res <- lapply(children, apply_rules) - res <- vapply(res, FUN = as.character, FUN.VALUE = character(1L)) - res <- paste0(res, collapse = "") - paste0("", res, "") } - ) + + res <- lapply(children, apply_rules) + res <- vapply(res, FUN = as.character, FUN.VALUE = character(1L)) + res <- paste0(res, collapse = "") + paste0("", res, "") + }) } diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 919d82432..684aa4a5e 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -359,13 +359,24 @@ resolve_secondary_pattern <- function(x) { while (grepl("<<.*?>>", x)) { - m <- gregexpr("<<[^<]*?>>", x, perl = TRUE) + # stringr::str_extract_all(x, regexp)[1] + # (?) means not followed by > + # Which means we take the outer match + # safeguarding about potential html elements within + # rstudio/gt#1880 + m <- gregexpr("(?>(?!>)", x, perl = TRUE) matched <- unlist(regmatches(x, m))[1] m_start <- as.integer(m[[1]]) m_length <- attr(m[[1]], "match.length") + if (m_start == -1) { + # Add safeguard instead of going in a very long loop + # rstudio/gt#1880 + cli::cli_abort("Can't resolve pattern.", .internal = TRUE) + } if (grepl(missing_val_token, matched)) { # Remove `matched` text from `x` diff --git a/R/utils_render_xml.R b/R/utils_render_xml.R index fe6f9f307..63daa3b4e 100644 --- a/R/utils_render_xml.R +++ b/R/utils_render_xml.R @@ -2926,7 +2926,7 @@ parse_to_xml <- function(x, ...) { ## add namespace for later processing parsed_xml_contents <- - suppressWarnings(read_xml(add_ns(x))) + suppressWarnings(xml2::read_xml(add_ns(x))) xml_children(parsed_xml_contents) } diff --git a/tests/testthat/test-cols_merge.R b/tests/testthat/test-cols_merge.R index a92ec16bd..4f46fdbbd 100644 --- a/tests/testthat/test-cols_merge.R +++ b/tests/testthat/test-cols_merge.R @@ -1,30 +1,3 @@ -# Create a table with four columns of values -tbl <- - dplyr::tribble( - ~col_1, ~col_2, ~col_3, ~col_4, - 767.6, 928.1, 382.0, 674.5, - 403.3, 461.5, 15.1, 242.8, - 686.4, 54.1, 282.7, 56.3, - 662.6, 148.8, 984.6, 928.1, - 198.5, 65.1, 127.4, 219.3, - 132.1, 118.1, 91.2, 874.3, - 349.7, 307.1, 566.7, 542.9, - 63.7, 504.3, 152.0, 724.5, - 105.4, 729.8, 962.4, 336.4, - 924.2, 424.6, 740.8, 104.2 - ) - -# Create a table with three columns, the last two having different -# combinations of NA values -tbl_na <- - dplyr::tibble( - a = 1:4, - b = c(1, NA, 3, NA), - c = c(1, 2, NA, NA), - d = c("1", "2", NA_character_, NA_character_), - e = c(TRUE, FALSE, NA, NA) - ) - # Function to skip tests if Suggested packages not available on system check_suggests <- function() { skip_if_not_installed("rvest") @@ -154,12 +127,10 @@ test_that("cols_merge() works correctly", { expect_snapshot_html(gt_tbl_3) # Ensure that `group` columns don't get the same treatment - expect_equal( + expect_equal_gt( + gt(tbl, groupname_col = "row"), gt(tbl, groupname_col = "row") %>% - render_as_html(), - gt(tbl, groupname_col = "row") %>% - cols_merge(columns = c(row, a)) %>% - render_as_html() + cols_merge(columns = c(row, a)) ) # Use `cols_merge()` with a vector of `rows` which limits the rows @@ -179,6 +150,17 @@ test_that("cols_merge() works correctly", { test_that("The secondary pattern language works well in `cols_merge()`", { + # Create a table with three columns, the last two having different + # combinations of NA values + tbl_na <- + dplyr::tibble( + a = 1:4, + b = c(1, NA, 3, NA), + c = c(1, 2, NA, NA), + d = c("1", "2", NA_character_, NA_character_), + e = c(TRUE, FALSE, NA, NA) + ) + # Create a `tbl_html` object with `gt()` tbl_gt <- gt(tbl_na) @@ -298,9 +280,44 @@ test_that("The secondary pattern language works well in `cols_merge()`", { (tbl_gt_13 %>% render_formats_test("html"))[["a"]], c("11TRUE", "2", "33X", "4") ) + #1880 + base_tab <- gt(data.frame( + x = c("dice-one", "dice-two", "dice-three"), + y = c("dice-one", NA, "dice-three") + )) + + tbl_gt_14 <- base_tab %>% fmt_icon() %>% + cols_merge( + columns = everything(), + pattern = "({1}<< {2}>>)" + ) + + expect_equal( + (tbl_gt_14 %>% render_formats_test("html"))[["x"]], + c( + '(Dice One Dice One)', + '(Dice Two)', + '(Dice Three Dice Three)' + ) + ) }) test_that("cols_merge_uncert() works correctly", { + # Create a table with four columns of values + tbl <- + dplyr::tribble( + ~col_1, ~col_2, ~col_3, ~col_4, + 767.6, 928.1, 382.0, 674.5, + 403.3, 461.5, 15.1, 242.8, + 686.4, 54.1, 282.7, 56.3, + 662.6, 148.8, 984.6, 928.1, + 198.5, 65.1, 127.4, 219.3, + 132.1, 118.1, 91.2, 874.3, + 349.7, 307.1, 566.7, 542.9, + 63.7, 504.3, 152.0, 724.5, + 105.4, 729.8, 962.4, 336.4, + 924.2, 424.6, 740.8, 104.2 + ) # Check that specific suggested packages are available check_suggests() @@ -509,6 +526,21 @@ test_that("cols_merge_uncert() works nicely with different error bounds", { }) test_that("cols_merge_range() works correctly", { + # Create a table with four columns of values + tbl <- + dplyr::tribble( + ~col_1, ~col_2, ~col_3, ~col_4, + 767.6, 928.1, 382.0, 674.5, + 403.3, 461.5, 15.1, 242.8, + 686.4, 54.1, 282.7, 56.3, + 662.6, 148.8, 984.6, 928.1, + 198.5, 65.1, 127.4, 219.3, + 132.1, 118.1, 91.2, 874.3, + 349.7, 307.1, 566.7, 542.9, + 63.7, 504.3, 152.0, 724.5, + 105.4, 729.8, 962.4, 336.4, + 924.2, 424.6, 740.8, 104.2 + ) # Create a `tbl_html` object with `gt()`; merge two columns # with `cols_merge_range()` @@ -529,6 +561,21 @@ test_that("cols_merge_range() works correctly", { }) test_that("cols_merge_range works 2", { + # Create a table with four columns of values + tbl <- + dplyr::tribble( + ~col_1, ~col_2, ~col_3, ~col_4, + 767.6, 928.1, 382.0, 674.5, + 403.3, 461.5, 15.1, 242.8, + 686.4, 54.1, 282.7, 56.3, + 662.6, 148.8, 984.6, 928.1, + 198.5, 65.1, 127.4, 219.3, + 132.1, 118.1, 91.2, 874.3, + 349.7, 307.1, 566.7, 542.9, + 63.7, 504.3, 152.0, 724.5, + 105.4, 729.8, 962.4, 336.4, + 924.2, 424.6, 740.8, 104.2 + ) # Create a `tbl_html` object with `gt()`; merge two columns # with `cols_merge_range()` @@ -549,6 +596,22 @@ test_that("cols_merge_range works 2", { }) test_that("cols_merge_range() works with 2 statements", { + # Create a table with four columns of values + tbl <- + dplyr::tribble( + ~col_1, ~col_2, ~col_3, ~col_4, + 767.6, 928.1, 382.0, 674.5, + 403.3, 461.5, 15.1, 242.8, + 686.4, 54.1, 282.7, 56.3, + 662.6, 148.8, 984.6, 928.1, + 198.5, 65.1, 127.4, 219.3, + 132.1, 118.1, 91.2, 874.3, + 349.7, 307.1, 566.7, 542.9, + 63.7, 504.3, 152.0, 724.5, + 105.4, 729.8, 962.4, 336.4, + 924.2, 424.6, 740.8, 104.2 + ) + # Create a `tbl_html` object with `gt()`; merge two columns, twice, # with `cols_merge_range()` tbl_html <- @@ -594,6 +657,22 @@ test_that("cols_merge_range() respects locale for separators", { }) test_that("cols_merge_range() works", { + # Create a table with four columns of values + tbl <- + dplyr::tribble( + ~col_1, ~col_2, ~col_3, ~col_4, + 767.6, 928.1, 382.0, 674.5, + 403.3, 461.5, 15.1, 242.8, + 686.4, 54.1, 282.7, 56.3, + 662.6, 148.8, 984.6, 928.1, + 198.5, 65.1, 127.4, 219.3, + 132.1, 118.1, 91.2, 874.3, + 349.7, 307.1, 566.7, 542.9, + 63.7, 504.3, 152.0, 724.5, + 105.4, 729.8, 962.4, 336.4, + 924.2, 424.6, 740.8, 104.2 + ) + # Create a `tbl_html` object with `gt()`; merge two # columns with `cols_merge_range()` but use the `I()` # function to keep the `--` separator text as is @@ -645,6 +724,22 @@ test_that("cols_merge_range() works", { }) test_that("cols_merge_range() works well", { + # Create a table with four columns of values + tbl <- + dplyr::tribble( + ~col_1, ~col_2, ~col_3, ~col_4, + 767.6, 928.1, 382.0, 674.5, + 403.3, 461.5, 15.1, 242.8, + 686.4, 54.1, 282.7, 56.3, + 662.6, 148.8, 984.6, 928.1, + 198.5, 65.1, 127.4, 219.3, + 132.1, 118.1, 91.2, 874.3, + 349.7, 307.1, 566.7, 542.9, + 63.7, 504.3, 152.0, 724.5, + 105.4, 729.8, 962.4, 336.4, + 924.2, 424.6, 740.8, 104.2 + ) + # Create two gt table objects; the first will be based # on `tbl` while the second will use a different column name # in `tbl` (`sep`) that collides with a pattern element name