Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Allowing multiple spanning headers with modify_spanning_header(level) #2105

Open
wants to merge 15 commits into
base: main
Choose a base branch
from
Open

Allowing multiple spanning headers with modify_spanning_header(level) #2105

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
15 commits
Select commit Hold shift + click to select a range
c978235
first draft
ddsjoberg Dec 19, 2024
6c5631c
adding unit tests
ddsjoberg Dec 19, 2024
b8dcdf6
doc updates
ddsjoberg Dec 19, 2024
1ef07a9
Update test-as_gt.R
ddsjoberg Dec 19, 2024
a5ce4c0
Update test-as_flex_table.R
ddsjoberg Dec 19, 2024
c7d990a
Update test-as_hux_table.R
ddsjoberg Dec 20, 2024
d8478a5
Update test-as_kable_extra.R
ddsjoberg Dec 20, 2024
e9972b1
Update as_gt.R
ddsjoberg Dec 26, 2024
2efc392
Update gtsummary.Rproj
ddsjoberg Dec 26, 2024
5bc0a0f
2108 modify footnote spanning header (#2112)
ddsjoberg Dec 26, 2024
70f277a
Update test-as_hux_table.R
ddsjoberg Dec 26, 2024
9c719f9
Update gtsummary_definition.Rmd
ddsjoberg Dec 27, 2024
6c34629
Merge branch 'main' into 2099-spanning-headers
ddsjoberg Dec 28, 2024
b055121
more updates
ddsjoberg Dec 29, 2024
adce4ea
Merge branch 'main' into 2099-spanning-headers
ddsjoberg Dec 29, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 3 additions & 0 deletions NAMESPACE
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -165,6 +165,7 @@ export(modify_fmt_fun)
export(modify_footnote)
export(modify_footnote_body)
export(modify_footnote_header)
export(modify_footnote_spanning_header)
export(modify_header)
export(modify_source_note)
export(modify_spanning_header)
Expand All @@ -186,8 +187,10 @@ export(ratio_summary)
export(remove_abbreviation)
export(remove_footnote_body)
export(remove_footnote_header)
export(remove_footnote_spanning_header)
export(remove_row_type)
export(remove_source_note)
export(remove_spanning_header)
export(reset_gtsummary_theme)
export(scope_header)
export(scope_table_body)
Expand Down
104 changes: 60 additions & 44 deletions R/as_flex_table.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -118,51 +118,60 @@ table_styling_to_flextable_calls <- function(x, ...) {

# add_header_row -------------------------------------------------------------
# this is the spanning rows
any_spanning_header <- any(!is.na(x$table_styling$header$spanning_header))
any_spanning_header <- nrow(x$table_styling$spanning_header) > 0L
if (any_spanning_header == FALSE) {
flextable_calls[["add_header_row"]] <- list()
} else {
df_header0 <-
x$table_styling$header |>
dplyr::filter(.data$hide == FALSE) |>
dplyr::select("spanning_header") |>
flextable_calls[["add_header_row"]] <-
tidyr::expand_grid(
level = unique(x$table_styling$spanning_header$level),
column = x$table_styling$header$column[!x$table_styling$header$hide]
) |>
dplyr::left_join(
x$table_styling$spanning_header[c("level", "column", "spanning_header")],
by = c("level", "column")
) |>
dplyr::mutate(
spanning_header = ifelse(is.na(.data$spanning_header),
" ", .data$spanning_header
),
.by = "level",
spanning_header =
ifelse(is.na(.data$spanning_header), " ", .data$spanning_header),
spanning_header_id = dplyr::row_number()
)
# assigning an ID for each spanning header group
for (i in seq(2, nrow(df_header0))) {
if (df_header0$spanning_header[i] == df_header0$spanning_header[i - 1]) {
df_header0$spanning_header_id[i] <- df_header0$spanning_header_id[i - 1]
}
}

df_header <-
df_header0 |>
dplyr::group_by(.data$spanning_header_id) |>
dplyr::mutate(width = dplyr::n()) |>
dplyr::distinct() |>
dplyr::ungroup() |>
dplyr::mutate(
column_id = map2(.data$spanning_header_id, .data$width, ~ seq(.x, .x + .y - 1L, by = 1L))
)
) |>
dplyr::group_by(.data$level) |>
dplyr::group_map(
\(df_values, df_group) {
# assigning an ID for each spanning header group
for (i in seq(2, nrow(df_values))) {
if (df_values$spanning_header[i] == df_values$spanning_header[i - 1]) {
df_values$spanning_header_id[i] <- df_values$spanning_header_id[i - 1]
}
}

flextable_calls[["add_header_row"]] <- list(
expr(
# add the header row with the spanning headers
flextable::add_header_row(
values = !!df_header$spanning_header,
colwidths = !!df_header$width
)
)
)
df_header <-
dplyr::bind_cols(df_group, df_values) |>
dplyr::select(-"column") |>
dplyr::group_by(.data$spanning_header_id) |>
dplyr::mutate(width = dplyr::n()) |>
dplyr::distinct() |>
dplyr::ungroup() |>
dplyr::mutate(
column_id = map2(.data$spanning_header_id, .data$width, ~ seq(.x, .x + .y - 1L, by = 1L))
)

flextable_calls[["compose_header_row"]] <-
.chr_with_md_to_ft_compose(
x = df_header$spanning_header,
j = df_header$column_id
c(
list(expr(
# add the header row with the spanning headers
flextable::add_header_row(
values = !!df_header$spanning_header,
colwidths = !!df_header$width
)
)),
.chr_with_md_to_ft_compose(
x = df_header$spanning_header,
j = df_header$column_id
)
)
}
)
}

Expand Down Expand Up @@ -207,20 +216,28 @@ table_styling_to_flextable_calls <- function(x, ...) {
flextable_calls[["autofit"]] <- expr(flextable::autofit())

# footnote_header ------------------------------------------------------------
spanning_header_lvls <- x$table_styling$spanning_header$level |> append(0L) |> max()
df_footnote_header <-
.number_footnotes(x, "footnote_header") |>
tidyr::nest(df_location = c("column", "column_id")) |>
dplyr::bind_rows(
x$table_styling$footnote_header |> dplyr::mutate(level = 0L),
x$table_styling$footnote_spanning_header
) |>
dplyr::mutate(
row_numbers = .env$spanning_header_lvls - .data$level + 1L
) %>%
.number_footnotes(x, type = .) |>
tidyr::nest(df_location = c("column", "column_id", "row_numbers")) |>
dplyr::mutate(
row_numbers = map(.data$df_location, ~ getElement(.x, "row_numbers")),
column_id = map(.data$df_location, ~ getElement(.x, "column_id"))
)
header_i_index <- ifelse(any_spanning_header == TRUE, 2L, 1L)

flextable_calls[["footnote_header"]] <-
map(
seq_len(nrow(df_footnote_header)),
~ expr(
flextable::footnote(
i = !!header_i_index,
i = !!df_footnote_header$row_numbers[[.x]],
j = !!df_footnote_header$column_id[[.x]],
value = flextable::as_paragraph(!!df_footnote_header$footnote[[.x]]),
part = "header",
Expand All @@ -231,7 +248,7 @@ table_styling_to_flextable_calls <- function(x, ...) {

# footnote_body --------------------------------------------------------------
df_footnote_body <-
.number_footnotes(x, "footnote_body", start_with = nrow(df_footnote_header)) |>
.number_footnotes(x, type = x$table_styling$footnote_body, start_with = nrow(df_footnote_header)) |>
tidyr::nest(df_location = c("column", "column_id", "row_numbers")) |>
dplyr::mutate(
row_numbers = map(.data$df_location, ~ getElement(.x, "row_numbers")),
Expand All @@ -252,7 +269,6 @@ table_styling_to_flextable_calls <- function(x, ...) {
)
)


# abbreviation ---------------------------------------------------------------
flextable_calls[["abbreviations"]] <-
case_switch(
Expand Down
64 changes: 39 additions & 25 deletions R/as_gt.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -234,6 +234,25 @@ table_styling_to_gt_calls <- function(x, ...) {
expr(gt::cols_label_with(fn = function(x) gsub(x = x, pattern = "\\n(?!\\\\)", replacement = "", fixed = FALSE, perl = TRUE)))
)

# spanning_header ------------------------------------------------------------
gt_calls[["tab_spanner"]] <-
case_switch(
nrow(x$table_styling$spanning_header) > 0L ~
x$table_styling$spanning_header |>
dplyr::group_by(.data$level, .data$spanning_header, .data$text_interpret) |>
dplyr::group_map(
\(.x, .y) {
expr(gt::tab_spanner(
columns = !!.x$column,
label = !!call2(parse_expr(.y$text_interpret), .y$spanning_header),
level = !!.y$level,
id = !!paste0("level ", .y$level, "; ", .x$column[1]),
gather = FALSE
))
}
),
.default = list()
)

# tab_footnote ---------------------------------------------------------------
gt_calls[["tab_footnote"]] <-
Expand Down Expand Up @@ -270,32 +289,27 @@ table_styling_to_gt_calls <- function(x, ...) {
)
)
}
)
)

# spanning_header ------------------------------------------------------------
df_spanning_header <-
x$table_styling$header |>
dplyr::select("column", "interpret_spanning_header", "spanning_header") |>
dplyr::filter(!is.na(.data$spanning_header)) |>
tidyr::nest(cols = "column") |>
dplyr::mutate(
spanning_header = map2(
.data$interpret_spanning_header, .data$spanning_header,
~ call2(parse_expr(.x), .y)
),
cols = map(.data$cols, ~ dplyr::pull(.x))
) |>
dplyr::select("spanning_header", "cols")

gt_calls[["tab_spanner"]] <-
map(
seq_len(nrow(df_spanning_header)),
~ expr(gt::tab_spanner(
columns = !!df_spanning_header$cols[[.x]],
label = gt::md(!!df_spanning_header$spanning_header[[.x]]),
gather = FALSE
))
# spanning header footnotes
map(
seq_len(nrow(x$table_styling$footnote_spanning_header)),
function(i) {
expr(
gt::tab_footnote(
footnote =
!!call2(
parse_expr(x$table_styling$footnote_spanning_header$text_interpret[i]),
x$table_styling$footnote_spanning_header$footnote[i]
),
locations =
gt::cells_column_spanners(
spanners = !!paste0("level ", x$table_styling$footnote_spanning_header$level[i], "; ", x$table_styling$footnote_spanning_header$column[i]),
levels = !!x$table_styling$footnote_spanning_header$level[i]
)
)
)
}
)
)

# horizontal_line ------------------------------------------------------------
Expand Down
56 changes: 31 additions & 25 deletions R/as_hux_table.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -187,8 +187,9 @@ table_styling_to_huxtable_calls <- function(x, ...) {
# footnote -------------------------------------------------------------------
vct_footnote <-
dplyr::bind_rows(
.number_footnotes(x, "footnote_header"),
.number_footnotes(x, "footnote_body")
.number_footnotes(x, x$table_styling$footnote_spanning_header),
.number_footnotes(x, x$table_styling$footnote_header),
.number_footnotes(x, x$table_styling$footnote_body)
) |>
dplyr::pull("footnote") %>%
unique()
Expand Down Expand Up @@ -331,30 +332,35 @@ table_styling_to_huxtable_calls <- function(x, ...) {
expr(huxtable::insert_row(after = 0, !!!col_labels))
)

any_spanning_header <- sum(!is.na(x$table_styling$header$spanning_header)) > 0
if (any_spanning_header) {
header_content <- x$table_styling$header$spanning_header[x$table_styling$header$hide == FALSE]
huxtable_calls[["insert_row"]] <- append(
huxtable_calls[["insert_row"]],
expr(huxtable::insert_row(after = 0, !!!header_content))
)

header_colspans <- rle(header_content)$lengths
header_colspan_cols <- cumsum(c(
1,
header_colspans[-length(header_colspans)]
))
huxtable_calls[["insert_row"]] <- append(
huxtable_calls[["insert_row"]],
expr(
huxtable::set_colspan(
row = 1, col = !!header_colspan_cols,
value = !!header_colspans
)
if (nrow(x$table_styling$spanning_header) > 0L) {
huxtable_calls[["insert_row"]] <-
huxtable_calls[["insert_row"]] |>
append(
tidyr::expand_grid(
level = unique(x$table_styling$spanning_header$level),
column = x$table_styling$header$column[!x$table_styling$header$hide]
) |>
dplyr::left_join(
x$table_styling$spanning_header[c("level", "column", "spanning_header")],
by = c("level", "column")
) |>
dplyr::group_by(.data$level) |>
dplyr::group_map(
\(df_values, df_group) {
header_content <- df_values$spanning_header
header_colspans <- rle(header_content)$lengths
header_colspan_cols <- cumsum(c(1, header_colspans[-length(header_colspans)]))

list(
expr(huxtable::insert_row(after = 0, !!!header_content)),
expr(huxtable::set_colspan(row = 1, col = !!header_colspan_cols, value = !!header_colspans))
)
}
)
)
)
}
header_bottom_row <- if (any_spanning_header) 2 else 1

header_bottom_row <- length(unique(x$table_styling$spanning_header$level)) + 1L
huxtable_calls[["insert_row"]] <- append(
huxtable_calls[["insert_row"]],
expr(
Expand All @@ -366,7 +372,7 @@ table_styling_to_huxtable_calls <- function(x, ...) {
)

# set_markdown ---------------------------------------------------------------
header_rows <- switch(any_spanning_header, 1:2) %||% 1L # styler: off
header_rows <- seq_len(length(unique(x$table_styling$spanning_header$level)) + 1L) # styler: off
huxtable_calls[["set_markdown"]] <-
list(
set_markdown =
Expand Down
Loading
Loading