1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
#' Magic mirror that returns kable's attributes
#'
#' @description Mirror mirror tell me, how does this kable look like?
#'
#' @param kable_input The output of kable
#'
#' @examples magic_mirror(knitr::kable(head(mtcars), "html"))
#' @export
magic_mirror <- function(kable_input){
kable_format <- attr(kable_input, "format")
if (kable_format == "latex") {
table_info <- magic_mirror_latex(kable_input)
}
if (kable_format == "html") {
table_info <- magic_mirror_html(kable_input)
}
if ("kable_meta" %in% names(attributes(kable_input))) {
out <- attr(kable_input, "kable_meta")
# if we return `kable_meta` immediately, `kable_styling` will use the
# original `table_env` value. So if we call `kable_styling` twice on the
# same object, it will nest a table within a table. Make sure this does not
# happen.
if (kable_format == "latex") {
table_info <- magic_mirror_latex(kable_input)
if (table_info$table_env && !out$table_env) {
out$table_env <- table_info$table_env
}
}
return(out)
}
return(table_info)
}
# Magic mirror for latex tables --------------
magic_mirror_latex <- function(kable_input){
table_info <- list(tabular = NULL, booktabs = FALSE, align = NULL,
valign = NULL, ncol = NULL, nrow = NULL, colnames = NULL,
rownames = NULL, caption = NULL, caption.short = NULL,
contents = NULL,
centering = FALSE, table_env = FALSE)
# Tabular
table_info$tabular <- ifelse(
grepl("\\\\begin\\{tabular\\}", kable_input),
"tabular", "longtable"
)
# Booktabs
table_info$booktabs <- grepl(toprule_regexp, kable_input)
# Align
table_info$align <- gsub("\\|", "", str_match(
kable_input, paste0("\\\\begin\\{",
table_info$tabular,"\\}.*\\{(.*?)\\}"))[2])
table_info$align_vector <- unlist(strsplit(table_info$align, ""))
table_info$align_vector_origin <- table_info$align_vector
# valign
table_info$valign <- gsub("\\|", "", str_match(
kable_input, paste0("\\\\begin\\{", table_info$tabular,"\\}(.*)\\{.*?\\}"))[2])
table_info$valign2 <- sub("\\[", "\\\\[", table_info$valign)
table_info$valign2 <- sub("\\]", "\\\\]", table_info$valign2)
table_info$valign3 <- sub("\\[", "", table_info$valign)
table_info$valign3 <- sub("\\]", "", table_info$valign3)
table_info$begin_tabular <- paste0("\\\\begin\\{", table_info$tabular, "\\}",
table_info$valign2)
table_info$end_tabular <- paste0("\\\\end\\{", table_info$tabular, "\\}")
# N of columns
table_info$ncol <- nchar(table_info$align)
# Caption
if (str_detect(kable_input, "caption\\[")) {
caption_line <- str_match(kable_input, "\\\\caption(.*)\\n")[2]
table_info$caption.short <- str_match(caption_line, "\\[(.*?)\\]")[2]
table_info$caption <- substr(caption_line,
nchar(table_info$caption.short) + 4,
nchar(caption_line))
} else {
table_info$caption <- str_match(kable_input, "caption\\{(.*?)\\n")[2]
}
if (table_info$tabular == "longtable") {
table_info$caption <- str_sub(table_info$caption, 1, -4)
} else {
table_info$caption <- str_sub(table_info$caption, 1, -2)
}
# Contents
table_info$contents <- str_match_all(kable_input, "\n(.*)\\\\\\\\")[[1]][,2]
table_info$contents <- regex_escape(table_info$contents, T)
if (table_info$tabular == "longtable" & !is.na(table_info$caption) &
!str_detect(kable_input, "\\\\begin\\{table\\}\\n\\n\\\\caption")) {
table_info$contents <- table_info$contents[-1]
}
if (!is.null(attr(kable_input, "n_head"))) {
n_head <- attr(kable_input, "n_head")
table_info$new_header_row <- table_info$contents[seq(n_head - 1, 1)]
table_info$contents <- table_info$contents[-seq(1, n_head - 1)]
table_info$header_df <- extra_header_to_header_df(table_info$new_header_row)
table_info$new_header_row <- paste0(table_info$new_header_row, "\\\\\\\\")
}
table_info$nrow <- length(table_info$contents)
table_info$duplicated_rows <- (sum(duplicated(table_info$contents)) != 0)
# Column names
if (table_info$booktabs & !grepl(midrule_regexp, kable_input)) {
table_info$colnames <- NULL
table_info$position_offset <- 0
} else {
table_info$colnames <- str_split(table_info$contents[1], " \\& ")[[1]]
table_info$position_offset <- 1
}
# Row names
table_info$rownames <- str_extract(table_info$contents, "^[^ &]*")
table_info$centering <- grepl("\\\\centering", kable_input)
table_info$table_env <- (!is.na(table_info$caption) &
table_info$tabular != "longtable") ||
grepl("\\\\begin\\{table\\}", kable_input)
return(table_info)
}
extra_header_to_header_df <- function(extra_header_rows) {
lapply(str_split(extra_header_rows, " \\& "), function(x) {
as.data.frame(t(sapply(x, extra_header_to_header_df_)), row.names = NA)
})
}
extra_header_to_header_df_ <- function(x) {
if (trimws(x) == "") return(c(header = " ", colspan = "1"))
x <- trimws(x)
x_header <- str_match(x, "([^\\}\\{]*)\\\\\\}$")[2]
x_colspan <- str_match(x, "^\\\\\\\\multicolumn\\\\\\{([^\\\\\\}]*)")[2]
return(c(header = x_header, colspan = x_colspan))
}
# Magic Mirror for html table --------
magic_mirror_html <- function(kable_input){
table_info <- list()
important_nodes <- read_kable_as_xml(kable_input)
body_node <- important_nodes$body
kable_xml <- important_nodes$table
# Caption
table_info$caption <- xml_text(xml_child(kable_xml, "caption"))
# colnames
table_info$colnames <- lapply(xml_children(xml_child(kable_xml, "thead")),
xml_children)
table_info$colnames <- table_info$colnames[[length(table_info$colnames)]]
table_info$colnames <- trimws(xml_text(table_info$colnames))
table_info$ncol <- length(table_info$colnames)
table_info$nrow_header <- length(xml_children(xml_child(kable_xml, "thead")))
table_info$nrow_body <- nrow(table_info$contents)
table_info$table_class <- xml_attr(kable_xml, "class")
table_info$table_style <- xml_attr(kable_xml, "style")
return(table_info)
}
|
