| Hao Zhu | 79f1e2a | 2017-06-11 20:55:30 -0400 | [diff] [blame] | 1 | #' Specify the look of the selected row |
| 2 | #' |
| 3 | #' @description This function allows users to select a row and then specify |
| 4 | #' its look. Right now it supports the following two properties: bold text and |
| 5 | #' italic text. |
| 6 | #' |
| 7 | #' @param kable_input Output of `knitr::kable()` with `format` specified |
| 8 | #' @param row A numeric value indicating which row to be selected |
| 9 | #' @param bold A T/F value to control whether the text of the selected row |
| 10 | #' need to be bolded. |
| 11 | #' @param italic A T/F value to control whether the text of the selected row |
| 12 | #' need to be emphasized. |
| 13 | #' |
| 14 | #' @examples x <- knitr::kable(head(mtcars), "html") |
| 15 | #' row_spec(x, 1, bold = TRUE, italic = TRUE) |
| 16 | #' |
| 17 | #' @export |
| 18 | row_spec <- function(kable_input, row, |
| 19 | bold = FALSE, italic = FALSE) { |
| 20 | if (!is.numeric(row)) { |
| 21 | stop("row must be a numeric value") |
| 22 | } |
| 23 | kable_format <- attr(kable_input, "format") |
| 24 | if (!kable_format %in% c("html", "latex")) { |
| 25 | message("Currently generic markdown table using pandoc is not supported.") |
| 26 | return(kable_input) |
| 27 | } |
| 28 | if (kable_format == "html") { |
| 29 | return(row_spec_html(kable_input, row, bold, italic)) |
| 30 | } |
| 31 | if (kable_format == "latex") { |
| Hao Zhu | 7360428 | 2017-06-11 22:08:48 -0400 | [diff] [blame^] | 32 | return(row_spec_latex(kable_input, row, bold, italic)) |
| Hao Zhu | 79f1e2a | 2017-06-11 20:55:30 -0400 | [diff] [blame] | 33 | } |
| 34 | } |
| 35 | |
| 36 | row_spec_html <- function(kable_input, row, bold, italic) { |
| 37 | kable_attrs <- attributes(kable_input) |
| 38 | kable_xml <- read_xml(as.character(kable_input), options = "COMPACT") |
| 39 | kable_tbody <- xml_tpart(kable_xml, "tbody") |
| 40 | |
| 41 | group_header_rows <- attr(kable_input, "group_header_rows") |
| 42 | if (!is.null(group_header_rows)) { |
| 43 | row <- positions_corrector(row, group_header_rows, |
| 44 | length(xml_children(kable_tbody))) |
| 45 | } |
| 46 | |
| 47 | target_row <- xml_child(kable_tbody, row) |
| 48 | |
| 49 | for (i in 1:length(xml_children(target_row))) { |
| 50 | target_cell <- xml_child(target_row, i) |
| 51 | if (bold) { |
| 52 | xml_attr(target_cell, "style") <- paste0(xml_attr(target_cell, "style"), |
| 53 | "font-weight: bold;") |
| 54 | } |
| 55 | if (italic) { |
| 56 | xml_attr(target_cell, "style") <- paste0(xml_attr(target_cell, "style"), |
| 57 | "font-style: italic;") |
| 58 | } |
| 59 | } |
| 60 | out <- structure(as.character(kable_xml), format = "html", |
| 61 | class = "knitr_kable") |
| 62 | attributes(out) <- kable_attrs |
| 63 | return(out) |
| 64 | } |
| 65 | |
| Hao Zhu | 7360428 | 2017-06-11 22:08:48 -0400 | [diff] [blame^] | 66 | row_spec_latex <- function(kable_input, row, bold, italic) { |
| 67 | table_info <- magic_mirror(kable_input) |
| 68 | target_row <- table_info$contents[row + 1] |
| 69 | new_row <- latex_row_cells(target_row) |
| 70 | if (bold) { |
| 71 | new_row <- paste0("\\{bfseries", new_row, "}") |
| 72 | } |
| 73 | if (italic) { |
| 74 | new_row <- paste0("\\{em", new_row, "}") |
| 75 | } |
| 76 | new_row <- paste(new_row, collapse = " & ") |
| 77 | |
| 78 | out <- sub(target_row, new_row, as.character(kable_input), perl = T) |
| 79 | out <- structure(out, format = "latex", class = "knitr_kable") |
| 80 | attr(out, "original_kable_meta") <- table_info |
| 81 | return(out) |
| 82 | } |