| 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") { |
| 32 | message("The LaTeX version of row_spec has not yet been implemented. ") |
| 33 | return(kable_input) |
| 34 | } |
| 35 | } |
| 36 | |
| 37 | row_spec_html <- function(kable_input, row, bold, italic) { |
| 38 | kable_attrs <- attributes(kable_input) |
| 39 | kable_xml <- read_xml(as.character(kable_input), options = "COMPACT") |
| 40 | kable_tbody <- xml_tpart(kable_xml, "tbody") |
| 41 | |
| 42 | group_header_rows <- attr(kable_input, "group_header_rows") |
| 43 | if (!is.null(group_header_rows)) { |
| 44 | row <- positions_corrector(row, group_header_rows, |
| 45 | length(xml_children(kable_tbody))) |
| 46 | } |
| 47 | |
| 48 | target_row <- xml_child(kable_tbody, row) |
| 49 | |
| 50 | for (i in 1:length(xml_children(target_row))) { |
| 51 | target_cell <- xml_child(target_row, i) |
| 52 | if (bold) { |
| 53 | xml_attr(target_cell, "style") <- paste0(xml_attr(target_cell, "style"), |
| 54 | "font-weight: bold;") |
| 55 | } |
| 56 | if (italic) { |
| 57 | xml_attr(target_cell, "style") <- paste0(xml_attr(target_cell, "style"), |
| 58 | "font-style: italic;") |
| 59 | } |
| 60 | } |
| 61 | out <- structure(as.character(kable_xml), format = "html", |
| 62 | class = "knitr_kable") |
| 63 | attributes(out) <- kable_attrs |
| 64 | return(out) |
| 65 | } |
| 66 | |
| 67 | # row_spec_latex <- function(kable_input, row, bold, italic) { |
| 68 | # table_info <- magic_mirror(kable_input) |
| 69 | # align_collapse <- ifelse(table_info$booktabs, "", "\\|") |
| 70 | # kable_align_old <- paste(table_info$align_vector, collapse = align_collapse) |
| 71 | # |
| 72 | # if (bold | italic) { |
| 73 | # usepackage_latex("array") |
| 74 | # latex_array_options <- c("\\\\bfseries", "\\\\em")[c(bold, italic)] |
| 75 | # latex_array_options <- paste0( |
| 76 | # "\\>\\{", paste(latex_array_options, collapse = ""), "\\}" |
| 77 | # ) |
| 78 | # table_info$align_vector[row] <- paste0(latex_array_options, |
| 79 | # table_info$align_vector[row]) |
| 80 | # } |
| 81 | # |
| 82 | # kable_align_new <- paste(table_info$align_vector, collapse = align_collapse) |
| 83 | # |
| 84 | # out <- sub(kable_align_old, kable_align_new, as.character(kable_input), |
| 85 | # perl = T) |
| 86 | # out <- structure(out, format = "latex", class = "knitr_kable") |
| 87 | # attr(out, "original_kable_meta") <- table_info |
| 88 | # return(out) |
| 89 | # } |