| Hao Zhu | 2a87e8e | 2017-06-14 15:49:33 -0400 | [diff] [blame] | 1 | #' Collapse repeat rows to multirow cell |
| 2 | #' |
| Hao Zhu | 1111f72 | 2017-06-14 15:58:40 -0400 | [diff] [blame] | 3 | #' @description Experimenting. Don't use it in production. |
| Hao Zhu | 2a87e8e | 2017-06-14 15:49:33 -0400 | [diff] [blame] | 4 | #' @export |
| 5 | collapse_rows <- function(kable_input, columns) { |
| 6 | if (is.null(columns)) { |
| 7 | stop("Please specify numeric positions of columns you want to collapse.") |
| 8 | } |
| 9 | kable_format <- attr(kable_input, "format") |
| 10 | if (!kable_format %in% c("html", "latex")) { |
| 11 | message("Currently generic markdown table using pandoc is not supported.") |
| 12 | return(kable_input) |
| 13 | } |
| 14 | if (kable_format == "html") { |
| 15 | return(collapse_rows_html(kable_input, columns)) |
| 16 | } |
| 17 | if (kable_format == "latex") { |
| 18 | return(collapse_rows_latex(kable_input, columns)) |
| 19 | } |
| 20 | } |
| 21 | |
| 22 | collapse_rows_html <- function(kable_input, columns) { |
| 23 | kable_attrs <- attributes(kable_input) |
| 24 | kable_xml <- read_xml(as.character(kable_input), options = "COMPACT") |
| 25 | kable_tbody <- xml_tpart(kable_xml, "tbody") |
| 26 | |
| 27 | kable_dt <- rvest::html_table(xml2::read_html(as.character(kable_input)))[[1]] |
| 28 | kable_dt$row_id <- rownames(kable_dt) |
| 29 | collapse_matrix <- collapse_row_matrix(kable_dt, columns) |
| 30 | |
| 31 | for (i in 1:nrow(collapse_matrix)) { |
| 32 | matrix_row <- collapse_matrix[i, ] |
| 33 | if (sum(matrix_row) != length(matrix_row)) { |
| 34 | target_row <- xml_child(kable_tbody, i) |
| 35 | row_node_rm_count <- 0 |
| 36 | for (j in 1:length(matrix_row)) { |
| 37 | if (matrix_row[j] != 1) { |
| 38 | collapsing_col <- as.numeric(sub("x", "", names(matrix_row)[j])) - |
| 39 | row_node_rm_count |
| 40 | target_cell <- xml_child(target_row, collapsing_col) |
| 41 | if (matrix_row[j] == 0) { |
| 42 | xml_remove(target_cell) |
| 43 | row_node_rm_count <- row_node_rm_count + 1 |
| 44 | } else { |
| 45 | xml_attr(target_cell, "rowspan") <- matrix_row[j] |
| 46 | xml_attr(target_cell, "style") <- paste0( |
| 47 | xml_attr(target_cell, "style"), |
| 48 | "vertical-align: middle !important;") |
| 49 | } |
| 50 | } |
| 51 | } |
| 52 | } |
| 53 | } |
| 54 | |
| 55 | out <- structure(as.character(kable_xml), format = "html", |
| 56 | class = "knitr_kable") |
| 57 | attributes(out) <- kable_attrs |
| 58 | return(out) |
| 59 | } |
| 60 | |
| 61 | collapse_rows_latex <- function(kable_input, columns) { |
| 62 | # table_info <- magic_mirror(kable_input) |
| 63 | # target_row <- table_info$contents[row + 1] |
| 64 | # new_row <- latex_row_cells(target_row) |
| 65 | # if (bold) { |
| 66 | # new_row <- lapply(new_row, function(x) { |
| 67 | # paste0("\\\\bfseries{", x, "}") |
| 68 | # }) |
| 69 | # } |
| 70 | # if (italic) { |
| 71 | # new_row <- lapply(new_row, function(x) { |
| 72 | # paste0("\\\\em{", x, "}") |
| 73 | # }) |
| 74 | # } |
| 75 | # new_row <- paste(unlist(new_row), collapse = " & ") |
| 76 | # |
| 77 | # out <- sub(target_row, new_row, as.character(kable_input), perl = T) |
| 78 | # out <- structure(out, format = "latex", class = "knitr_kable") |
| 79 | # attr(out, "original_kable_meta") <- table_info |
| 80 | # return(out) |
| 81 | kable_input |
| 82 | } |