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
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
set_dftbl_hooks <- function() {
width <- 40
set_dftbl_opts_hook(width)
set_dftbl_knit_hook(width)
set_dftbl_source_hook()
set_dftbl_chunk_hook()
set_dftbl_error_hook()
set_dftbl_warning_hook()
}
# Defines a `dftbl` knitr option. If this chunk option is set, code is duplicated
# (running with tibbles or data frames, respectively): one line of df code
# followed by the same line of the corresponding tibble code.
# The code is also evaluated, if the results are identical (disregarding the
# class), only the tibble copy is retained.
#
set_dftbl_opts_hook <- function(width) {
force(width)
dftbl_opts_hook <- function(options) {
df_code <- options$code
tbl_code <- gsub("df", "tbl", df_code, fixed = TRUE)
# FIXME: Evaluate, but surround in <details> element
if (!isTRUE(options$dftbl_always) && isTRUE(options$eval)) {
same <- map2_lgl(df_code, tbl_code, same_as_tbl_code)
df_code[same] <- ""
}
new_code <- as.vector(t(matrix(c(df_code, tbl_code), ncol = 2)))
options$code <- new_code
options$width <- width - 4
options
}
knitr::opts_hooks$set(dftbl = dftbl_opts_hook)
}
utils::globalVariables(c("new_df", "new_tbl"))
same_as_tbl_code <- function(df_code, tbl_code) {
handler <- evaluate::new_output_handler(
value = function(x, visible) {
if (visible) x else NULL
}
)
same_as_tbl(
evaluate::evaluate(df_code, output_handler = handler),
evaluate::evaluate(tbl_code, output_handler = handler)
)
}
same_as_tbl <- function(df, tbl) {
if (length(df) != length(tbl)) return(FALSE)
if (length(df) < 2) return(FALSE)
df <- df[-1]
tbl <- tbl[-1]
df_obj <- df[[length(df)]]
tbl_obj <- tbl[[length(tbl)]]
if (is.data.frame(df_obj) != is.data.frame(tbl_obj)) return(FALSE)
if (is.data.frame(tbl_obj)) {
df[[length(df)]] <- as_tibble_deep(df_obj)
}
identical(df, tbl)
}
as_tibble_deep <- function(x) {
is_tibble <- which(map_lgl(x, is.data.frame))
x[is_tibble] <- map(x[is_tibble], as_tibble)
as_tibble(x)
}
# dftbl chunks have a reduced width
set_dftbl_knit_hook <- function(width) {
force(width)
# Need to use a closure here to keep state
old_width <- NULL
dftbl_knit_hook <- function(before, options, envir) {
if (before) {
old_width <<- options(width = width)
} else {
options(old_width)
old_width <<- NULL
}
}
knitr::knit_hooks$set(dftbl = dftbl_knit_hook)
}
# dftbl chunks are shown side by side, with the help of an HTML table.
# Each source chunk introduces a new table cell, even chunks also introduce
# a new table row.
# vertical-align: top keeps the table rows nicely aligned.
# This places some limitations on the chunk sources but works well so far.
set_dftbl_source_hook <- function() {
# Need to use a closure here to daisy-chain hooks and to keep state
old_source_hook <- knitr::knit_hooks$get("source")
dftbl_source_even <- TRUE
dftbl_source_hook_one <- function(x) {
if (dftbl_source_even) {
x <- paste0('</td></tr><tr style="vertical-align:top"><td>\n\n', x)
} else {
x <- paste0("</td><td>\n\n", x)
}
dftbl_source_even <<- !dftbl_source_even
x
}
dftbl_source_hook <- function(x, options) {
nonempty <- which(x != "")
x[nonempty] <- vapply(x[nonempty], old_source_hook, options, FUN.VALUE = character(1))
if (isTRUE(options$dftbl)) {
x <- vapply(x, dftbl_source_hook_one, FUN.VALUE = character(1))
}
paste(x, collapse = "\n")
}
knitr::knit_hooks$set(source = dftbl_source_hook)
}
# The entire chunk needs to be surrounded by <table><tbody><tr><td>...</...> .
# We use the dftbl CSS class for the HTML table.
set_dftbl_chunk_hook <- function() {
# Need to use a closure here to daisy-chain hooks
old_chunk_hook <- knitr::knit_hooks$get("chunk")
dftbl_chunk_hook <- function(x, options) {
x <- old_chunk_hook(x, options)
if (isTRUE(options$dftbl)) {
x <- paste0('<table class="dftbl"><tbody><tr><td>\n\n', x, "\n\n</td></tr></tbody></table>")
x <- gsub("<tr><td>\n\n</td></tr>", "", x, fixed = TRUE)
}
x
}
knitr::knit_hooks$set(chunk = dftbl_chunk_hook)
}
# I don't understand why knitr doesn't wrap error output.
set_dftbl_error_hook <- function() {
# Need to use a closure here to daisy-chain hooks
old_error_hook <- knitr::knit_hooks$get("error")
dftbl_error_hook <- function(x, options) {
if (isTRUE(options$dftbl)) {
x <- strsplit(x, "\n", fixed = TRUE)[[1]]
x <- unlist(map(x, fansi::strwrap_sgr, getOption("width") + 4, prefix = "#> ", initial = ""))
x <- paste(paste0(x, "\n"), collapse = "")
}
x <- old_error_hook(x, options)
paste0('<div class="error">', x, '</div>')
}
knitr::knit_hooks$set(error = dftbl_error_hook)
}
# I don't understand why knitr doesn't wrap warning output.
set_dftbl_warning_hook <- function() {
# Need to use a closure here to daisy-chain hooks
old_warning_hook <- knitr::knit_hooks$get("warning")
dftbl_warning_hook <- function(x, options) {
if (isTRUE(options$dftbl)) {
x <- strsplit(x, "\n", fixed = TRUE)[[1]]
x <- unlist(map(x, fansi::strwrap_sgr, getOption("width") + 4, prefix = "#> ", initial = ""))
x <- paste(paste0(x, "\n"), collapse = "")
}
x <- old_warning_hook(x, options)
paste0('<div class="warning">', x, '</div>')
}
knitr::knit_hooks$set(warning = dftbl_warning_hook)
}
|
