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