|
| 1 | +#' Wrap a table in a patchwork compliant patch |
| 2 | +#' |
| 3 | +#' This function works much like [wrap_elements()] in that it turns the input |
| 4 | +#' into patchwork compliant objects that can be added to a composition. However, |
| 5 | +#' `wrap_table()` uses the knowledge that the input is a table to provide some |
| 6 | +#' very nifty layout options that makes it generally better to use than |
| 7 | +#' [wrap_elements()] for this type of object. |
| 8 | +#' |
| 9 | +#' @param table A gt table or an object coercible to a data frame |
| 10 | +#' @param panel what portion of the table should be aligned with the panel |
| 11 | +#' region? `"body"` means that any column and row headers will be placed outside |
| 12 | +#' the panel region, i.e. the topleft corner of the panel region will be aligned |
| 13 | +#' with the topleft data cell. `"full"` means that the whole table will be |
| 14 | +#' placed inside the panel region. `"rows"` means that all rows (including column |
| 15 | +#' headers) will be placed inside the panel region but row headers will be |
| 16 | +#' placed to the left. `"cols"` is the opposite, placing all columns within the |
| 17 | +#' panel region but keeping the column header on top of it. |
| 18 | +#' @param space How should the dimension of the table influence the final |
| 19 | +#' composition? `"fixed"` means that the table width will set the width of the |
| 20 | +#' column it occupies and the table height will set the height of the row it |
| 21 | +#' occupies. `"free"` is the opposite meaning that the table dimension will not |
| 22 | +#' have any influence on the sizing. `"free_x"` and `"free_y"` allows you to |
| 23 | +#' free either direction while keeping the remaining fixed. Do note that if you |
| 24 | +#' set a specific width or height in [plot_layout()] it will have higher |
| 25 | +#' priority than the table dimensions |
| 26 | +#' @inheritParams wrap_elements |
| 27 | +#' |
| 28 | +#' @return A wrapped_table object |
| 29 | +#' |
| 30 | +#' @export |
| 31 | +#' |
| 32 | +#' @note This functionality requires v0.11.0 or higher of the gt package |
| 33 | +#' |
| 34 | +#' @examplesIf requireNamespace("gt", quietly = TRUE) && packageVersion("gt") >= "0.11.0" |
| 35 | +#' library(ggplot2) |
| 36 | +#' library(gt) |
| 37 | +#' |
| 38 | +#' p1 <- ggplot(airquality) + |
| 39 | +#' geom_line(aes(x = Day, y = Temp, colour = month.name[Month])) + |
| 40 | +#' labs(colour = "Month") |
| 41 | +#' |
| 42 | +#' table <- data.frame( |
| 43 | +#' Month = month.name[5:9], |
| 44 | +#' "Mean temp." = tapply(airquality$Temp, airquality$Month, mean), |
| 45 | +#' "Min temp." = tapply(airquality$Temp, airquality$Month, min), |
| 46 | +#' "Max temp." = tapply(airquality$Temp, airquality$Month, max) |
| 47 | +#' ) |
| 48 | +#' gt_tab <- gt(table, rowname_col = "Month") |
| 49 | +#' |
| 50 | +#' # Default addition usees wrap_table |
| 51 | +#' p1 + gt_tab |
| 52 | +#' |
| 53 | +#' # Default places column and row headers outside panel area. Use wrap_table |
| 54 | +#' # to control this |
| 55 | +#' p1 + wrap_table(gt_tab, panel = "full") |
| 56 | +#' |
| 57 | +#' # Tables generally have fixed dimensions and these can be used to control |
| 58 | +#' # the size of the area they occupy |
| 59 | +#' p2 <- ggplot(airquality) + |
| 60 | +#' geom_boxplot(aes(y = month.name[Month], x = Temp)) + |
| 61 | +#' scale_y_discrete(name = NULL, limits = month.name[5:9], guide = "none") |
| 62 | +#' |
| 63 | +#' wrap_table(gt_tab, space = "fixed") + p2 |
| 64 | +#' |
| 65 | +wrap_table <- function(table, panel = c("body", "full", "rows", "cols"), space = c("free", "free_x", "free_y", "fixed"), ignore_tag = FALSE) { |
| 66 | + check_installed("gt", version = "0.11.0") |
| 67 | + if (!inherits(table, "gt_tbl")) { |
| 68 | + table <- try_fetch( |
| 69 | + gt::gt(as.data.frame(table)), |
| 70 | + error = function(cnd, ...) cli::cli_abort("Unable to convert input table to {.cls gt_tbl}", parent = cnd) |
| 71 | + ) |
| 72 | + } |
| 73 | + n_row_headers <- (!all(is.na(table[["_stub_df"]]$row_id))) + (!all(is.na(table[["_stub_df"]]$group_id))) |
| 74 | + if (n_row_headers == 2 && !table[["_options"]]$value[[which(table[["_options"]]$parameter == "row_group_as_column")]]) { |
| 75 | + n_row_headers <- 1 |
| 76 | + } |
| 77 | + table <- wrap_elements(table, ignore_tag = ignore_tag) |
| 78 | + attr(table, "patch_settings")$panel <- arg_match(panel) |
| 79 | + attr(table, "patch_settings")$n_row_headers <- n_row_headers |
| 80 | + attr(table, "patch_settings")$space <- c(space %in% c("free", "free_x"), space %in% c("free", "free_y")) |
| 81 | + class(table) <- c("wrapped_table", class(table)) |
| 82 | + table |
| 83 | +} |
| 84 | + |
| 85 | +#' @export |
| 86 | +patchGrob.wrapped_table <- function(x, guides = 'auto') { |
| 87 | + panel <- attr(x, "patch_settings")$panel |
| 88 | + row_head <- attr(x, "patch_settings")$n_row_headers |
| 89 | + space <- attr(x, "patch_settings")$space |
| 90 | + |
| 91 | + x <- NextMethod() |
| 92 | + |
| 93 | + table_loc <- which(x$layout$name == "panel") |
| 94 | + table_width <- x$grobs[[table_loc]]$widths |
| 95 | + table_height <- x$grobs[[table_loc]]$heights |
| 96 | + |
| 97 | + if (panel %in% c("body", "rows")) { |
| 98 | + col_head <- x$grobs[[table_loc]]$layout$t[x$grobs[[table_loc]]$layout$name == "table_body"] - 1 |
| 99 | + if (col_head > 0) { |
| 100 | + height <- sum(x$grobs[[table_loc]]$heights[1:col_head]) |
| 101 | + x$grobs[[table_loc]]$vp$y <- x$grobs[[table_loc]]$vp$y + height |
| 102 | + x$heights[PANEL_ROW - 2] <- height |
| 103 | + |
| 104 | + table_height <- table_height[-(1:col_head)] |
| 105 | + } |
| 106 | + } |
| 107 | + if (panel %in% c("body", "cols") && row_head > 0) { |
| 108 | + width <- sum(x$grobs[[table_loc]]$widths[1:row_head]) |
| 109 | + x$grobs[[table_loc]]$vp$x <- x$grobs[[table_loc]]$vp$x - width |
| 110 | + x$widths[PANEL_COL - 2] <- width |
| 111 | + |
| 112 | + table_width <- table_width[-(1:row_head)] |
| 113 | + } |
| 114 | + if (!space[1]) { |
| 115 | + x$widths[PANEL_COL] <- if (inherits(table_width, "simpleUnit")) sum(table_width) else Reduce(`+`, table_width) |
| 116 | + } |
| 117 | + if (!space[2]) { |
| 118 | + x$heights[PANEL_ROW] <- if (inherits(table_height, "simpleUnit")) sum(table_height) else Reduce(`+`, table_height) |
| 119 | + } |
| 120 | + x |
| 121 | +} |
| 122 | + |
| 123 | +#' @export |
| 124 | +#' @importFrom grid viewport grobWidth grobHeight grobTree |
| 125 | +as_patch.gt_tbl <- function(x, ...) { |
| 126 | + check_installed("gt", version = "0.11.0") |
| 127 | + grob <- gt::as_gtable(x) |
| 128 | + loc <- grob$layout[grob$layout$name == "table",] |
| 129 | + grob <- grob[loc$t:loc$b, loc$l:loc$r] |
| 130 | + grob$vp <- viewport( |
| 131 | + x = 0, |
| 132 | + y = 1, |
| 133 | + width = grobWidth(grob), |
| 134 | + height = grobHeight(grob), |
| 135 | + default.units = "npc", |
| 136 | + just = c(0, 1) |
| 137 | + ) |
| 138 | + grob |
| 139 | +} |
0 commit comments