Skip to content

Commit 73dcf83

Browse files
dgkfdgkf
committed
feat(knitr-extras): adding mutable header and extra logging features
1 parent 8b30d51 commit 73dcf83

File tree

6 files changed

+325
-96
lines changed

6 files changed

+325
-96
lines changed

‎R/reporter.R‎

Lines changed: 123 additions & 96 deletions
Original file line numberDiff line numberDiff line change
@@ -25,116 +25,143 @@
2525
#' pr
2626
#' file.remove(pr)
2727
package_report <- function(
28-
package_name,
29-
package_version,
30-
package = NULL,
31-
template_path = system.file("report/package", package = "val.report"),
32-
output_format = "all",
33-
params = list(),
34-
...
28+
package_name,
29+
package_version,
30+
package = NULL,
31+
template_path = system.file("report/package", package = "val.report"),
32+
output_format = "all",
33+
params = list(),
34+
...
3535
) {
36-
empty_pkg_info <- is.empty(package_name) && is.empty(package_version)
37-
if (empty_pkg_info && !is.empty(package)) {
38-
package_name <- basename(package)
39-
desc <- read.dcf(file.path(package, "DESCRIPTION"))
40-
41-
stopifnot("Mismatch between path and DESCRIPTION name" = package_name == desc[, "Package"])
42-
package_version <- desc[, "Version"]
43-
params$package <- package
44-
Sys.setenv("INPUT_REPORT_PKG_DIR" = package)
45-
} else if (empty_pkg_info && is.empty(package)) {
46-
stop("Package information missing for the report")
47-
} else {
48-
params$package <- package_name
49-
}
50-
51-
full_name <- paste0(package_name, "_v", package_version)
52-
output_file <- paste0("validation_report_", full_name, ".qmd")
53-
54-
params$package_name <- package_name
55-
params$package_version <- package_version
56-
params$image <- get_image_name(params)
57-
58-
if (is.null(template_path) || !nzchar(template_path)) {
59-
template_path <- system.file("report/package",
60-
package = "val.report")
61-
} else if (!dir.exists(template_path)) {
62-
stop("Template directory is not available")
63-
}
64-
65-
params$package <- normalizePath(params$package, mustWork = FALSE, winslash = "/")
66-
if (length(params$assessment_path) == 1L && !nzchar(params$assessment_path)) {
67-
params$assessment_path <- normalizePath(params$assessment_path, mustWork = TRUE, winslash = "/")
68-
}
69-
70-
# Bug on https://github.com/quarto-dev/quarto-cli/issues/5765
71-
v <- quarto::quarto_version()
72-
if (v < package_version("1.7.13")) {
73-
warning("Please install the latest (devel) version of Quarto")
74-
}
75-
76-
if (is.null(params$source)) warning("Please provide the source of the package assessment")
77-
78-
# https://github.com/quarto-dev/quarto-r/issues/81#issuecomment-1375691267
79-
# quarto rendering happens in the same place as the file/project
80-
# To avoid issues copy to a different place and render there.
81-
render_dir <- output_dir()
36+
empty_pkg_info <- is.empty(package_name) && is.empty(package_version)
37+
if (empty_pkg_info && !is.empty(package)) {
38+
package_name <- basename(package)
39+
desc <- read.dcf(file.path(package, "DESCRIPTION"))
40+
41+
stopifnot(
42+
"Mismatch between path and DESCRIPTION name" = package_name ==
43+
desc[, "Package"]
44+
)
45+
package_version <- desc[, "Version"]
46+
params$package <- package
47+
Sys.setenv("INPUT_REPORT_PKG_DIR" = package)
48+
} else if (empty_pkg_info && is.empty(package)) {
49+
stop("Package information missing for the report")
50+
} else {
51+
params$package <- package_name
52+
}
53+
54+
full_name <- paste0(package_name, "_v", package_version)
55+
output_file <- paste0("validation_report_", full_name, ".qmd")
56+
57+
params$package_name <- package_name
58+
params$package_version <- package_version
59+
params$image <- get_image_name(params)
60+
61+
if (is.null(template_path) || !nzchar(template_path)) {
62+
template_path <- system.file("report/package", package = "val.report")
63+
} else if (!dir.exists(template_path)) {
64+
stop("Template directory is not available")
65+
}
66+
67+
params$package <- normalizePath(
68+
params$package,
69+
mustWork = FALSE,
70+
winslash = "/"
71+
)
72+
if (length(params$assessment_path) == 1L && !nzchar(params$assessment_path)) {
73+
params$assessment_path <- normalizePath(
74+
params$assessment_path,
75+
mustWork = TRUE,
76+
winslash = "/"
77+
)
78+
}
79+
80+
# Bug on https://github.com/quarto-dev/quarto-cli/issues/5765
81+
v <- quarto::quarto_version()
82+
if (v < package_version("1.7.13")) {
83+
warning("Please install the latest (devel) version of Quarto")
84+
}
85+
86+
if (is.null(params$source)) {
87+
warning("Please provide the source of the package assessment")
88+
}
89+
90+
# https://github.com/quarto-dev/quarto-r/issues/81#issuecomment-1375691267
91+
# quarto rendering happens in the same place as the file/project
92+
# To avoid issues copy to a different place and render there.
93+
render_dir <- output_dir()
94+
if (!dir.exists(render_dir)) {
95+
render_dir <- paste0(render_dir, "/")
8296
if (!dir.exists(render_dir)) {
83-
render_dir <- paste0(render_dir, "/")
84-
if (!dir.exists(render_dir)) {
85-
stop("Render directory doesn't exists. Please check the 'getOptions(\"valreport_output_dir\")' and sys.getEnv(\"VALREPORT_OUTPUT_DIR\")" )
86-
}
87-
}
88-
files_to_copy <- list.files(template_path, full.names = TRUE)
89-
fc <- file.copy(from = files_to_copy,
90-
to = render_dir,
91-
overwrite = TRUE,
92-
copy.date = TRUE)
93-
94-
if (any(!fc)) {
95-
stop("Copying to the rendering directory failed.")
96-
}
97-
98-
template_all_files <- list.files(render_dir, full.names = TRUE)
99-
template <- template_all_files[endsWith(template_all_files, "qmd")]
100-
101-
if (length(template) > 1) {
102-
stop("There are more than one template!\n",
103-
"Please have only one quarto file on the directory.")
97+
stop(
98+
"Render directory doesn't exists. Please check the 'getOptions(\"valreport_output_dir\")' and sys.getEnv(\"VALREPORT_OUTPUT_DIR\")"
99+
)
104100
}
101+
}
102+
files_to_copy <- list.files(template_path, full.names = TRUE)
103+
fc <- file.copy(
104+
from = files_to_copy,
105+
to = render_dir,
106+
overwrite = TRUE,
107+
copy.date = TRUE
108+
)
109+
110+
if (any(!fc)) {
111+
stop("Copying to the rendering directory failed.")
112+
}
113+
114+
template_all_files <- list.files(render_dir, full.names = TRUE)
115+
template <- template_all_files[endsWith(template_all_files, "qmd")]
116+
117+
if (length(template) > 1) {
118+
stop(
119+
"There are more than one template!\n",
120+
"Please have only one quarto file on the directory."
121+
)
122+
}
123+
124+
file_template <- file.path(
125+
render_dir,
126+
paste0("validation_report_", full_name, ".qmd")
127+
)
128+
file.rename(template, file_template)
129+
130+
# replace the title of the place header by the package name and header
131+
top_page_file <- readLines(file.path(render_dir, "top_page.html"))
132+
title_line <- grep("<p", top_page_file)
133+
top_page_file[title_line] <- htmltools::p(paste0(
134+
"Validation Report - ",
135+
package_name,
136+
"@",
137+
package_version
138+
)) |>
139+
as.character()
140+
writeLines(top_page_file, file.path(render_dir, "top_page.html"))
105141

106-
file_template <- file.path(render_dir,
107-
paste0("validation_report_", full_name, ".qmd"))
108-
file.rename(template, file_template)
109-
110-
# replace the title of the place header by the package name and header
111-
top_page_file <- readLines(file.path(render_dir, "top_page.html"))
112-
title_line <- grep("<p", top_page_file)
113-
top_page_file[title_line] <- htmltools::p(paste0("Validation Report - ", package_name, "@", package_version)) |>
114-
as.character()
115-
writeLines(top_page_file, file.path(render_dir, "top_page.html"))
116-
117-
pre_rendering <- list.files(render_dir, full.names = TRUE)
142+
pre_rendering <- list.files(render_dir, full.names = TRUE)
118143

119-
suppressMessages({suppressWarnings({
144+
suppressMessages({
145+
suppressWarnings({
120146
out <- quarto::quarto_render(
121147
input = file_template,
122148
output_format = output_format,
123149
execute_params = params,
124150
...
125151
)
126-
})})
152+
})
153+
})
127154

128-
post_rendering <- list.files(render_dir, full.names = TRUE)
155+
post_rendering <- list.files(render_dir, full.names = TRUE)
129156

130-
files_to_remove <- intersect(pre_rendering, post_rendering)
131-
fr <- file.remove(files_to_remove)
132-
if (any(!fr)) {
133-
warning("Failed to remove the quarto template used from the directory.")
134-
}
157+
files_to_remove <- intersect(pre_rendering, post_rendering)
158+
fr <- file.remove(files_to_remove)
159+
if (any(!fr)) {
160+
warning("Failed to remove the quarto template used from the directory.")
161+
}
135162

136-
output_files <- setdiff(post_rendering, pre_rendering)
137-
invisible(output_files)
163+
output_files <- setdiff(post_rendering, pre_rendering)
164+
invisible(output_files)
138165
}
139166

140167
is.empty <- function(x) {

‎R/utils_knitr.R‎

Lines changed: 139 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,139 @@
1+
#' Create mutable header object
2+
#'
3+
#' Inject a custom document rendering hook into the knitr engine and return
4+
#' a mutable environment that we can modify, which will be used to update the
5+
#' knitr document header upon render completion.
6+
#'
7+
#' @param params Optionally, provide default parameters to initialize with
8+
#' @param envir Only used when `params` is not provided, as the source for where
9+
#' to try to discover the default knitr frontmatter parameters.
10+
#'
11+
#' @export
12+
knitr_mutable_header <- function(params = NULL, envir = parent.frame()) {
13+
header <- new.env(parent = emptyenv())
14+
15+
# if not provided, try to get params from envir
16+
if (is.null(params)) {
17+
params <- get0("params", envir = envir, ifnotfound = list())
18+
}
19+
20+
# initialize with param values
21+
for (name in names(params)) {
22+
header[[name]] <- params[[name]]
23+
}
24+
25+
# add a hook that will replace the hard-coded front-matter with dynamic
26+
# front-matter just before rendering.
27+
knitr::knit_hooks$set(
28+
document = local({
29+
default_document_hook <- knitr::knit_hooks$get("document")
30+
function(x, output) {
31+
# extract and split our document front-matter and body
32+
fm <- knitr:::yaml_front_matter(strsplit(x, "\n")[[1L]])
33+
body <- sub("^\\s*---.*---", "", x)
34+
35+
# pragmatically update front-matter at build-time
36+
fm <- yaml::yaml.load(fm)
37+
for (name in names(header)) {
38+
fm[[name]] <- header[[name]]
39+
}
40+
41+
# rebuild our document
42+
x <- paste0(c("---", yaml::as.yaml(fm), "---", body), collapse = "\n")
43+
default_document_hook(x)
44+
}
45+
})
46+
)
47+
48+
header
49+
}
50+
51+
#' Special handler for emitting knitr logs
52+
#'
53+
#' @inheritParams knitr::knit_print
54+
#'
55+
#' @export
56+
# nolint start
57+
knit_print.knitr_log <- local({
58+
# nolint end
59+
60+
prefix <- " \u205A " # vertical two dot punctuation
61+
last_log_trailing_newline <- FALSE
62+
63+
function(x, ...) {
64+
# prefix newline only for the first message in each chunk
65+
knitr_log_env <- environment(knitr_logger)
66+
first_chunk_log <- knitr_log_env$first_chunk_log
67+
knitr_log_env$first_chunk_log <- FALSE
68+
69+
# split content on non-character (or AsIs) objects
70+
is_char <- vapply(x, is.character, logical(1L))
71+
is_asis <- vapply(x, inherits, logical(1L), "AsIs")
72+
is_char <- is_char & !is_asis
73+
chunks <- cumsum(
74+
!is_char | c(FALSE, tail(is_char, -1) & !head(is_char, -1))
75+
)
76+
is_char_chunk <- vapply(split(is_char, chunks), any, logical(1L))
77+
78+
# if output is a string, join them for pretty printing; otherwise capture
79+
# console output for logging
80+
x <- Map(
81+
function(chunk, is_char) {
82+
if (is_char) {
83+
paste(chunk, collapse = "")
84+
} else {
85+
paste(capture.output(chunk[[1L]]), collapse = "\n")
86+
}
87+
},
88+
chunk = split(x, chunks),
89+
is_char = is_char_chunk
90+
)
91+
92+
# determine where to inject newline prefixes
93+
x <- paste0(x, collapse = "")
94+
x <- strsplit(x, "(?<=\n)", perl = TRUE)[[1L]]
95+
prefixed <- if (first_chunk_log || last_log_trailing_newline) TRUE else -1L
96+
x[prefixed] <- paste0(prefix, x[prefixed])
97+
x <- paste0(x, collapse = "")
98+
last_log_trailing_newline <<- endsWith(x[[length(x)]], "\n")
99+
100+
# emit to stderr so that we see it immediately
101+
if (first_chunk_log) {
102+
cat("\n", file = stderr(), sep = "")
103+
}
104+
cat(x, file = stderr(), sep = "")
105+
}
106+
})
107+
108+
#' Create a knitr log function
109+
#'
110+
#' Sets necessary knitr hooks and returns a logging function that will emit
111+
#' messages to the console during knitting.
112+
#'
113+
#' @return A `function` accepting `...` arguments, which will be used for
114+
#' printing out to the console while rendering the knitr document. Character
115+
#' values are logged directrly, while any other object is printed as though
116+
#' being printed to the console. To render character values as they would
117+
#' be printed, mark them as "AsIs" using [I()].
118+
#'
119+
#' @export
120+
knitr_logger <- local({
121+
first_chunk_log <- TRUE
122+
123+
function() {
124+
# reset our chunk start flag on chunk output
125+
knitr::knit_hooks$set(
126+
chunk = local({
127+
default_chunk_hook <- knitr::knit_hooks$get("chunk")
128+
function(x, options) {
129+
first_chunk_log <<- TRUE
130+
default_chunk_hook(x, options)
131+
}
132+
})
133+
)
134+
135+
function(...) {
136+
knitr::knit_print(structure(list(...), class = c("knitr_log", "list")))
137+
}
138+
}
139+
})

0 commit comments

Comments
 (0)