Nothing
# content is the file content from readLines
extract_r_source <- function(filename, lines, error = identity) {
pattern <- get_knitr_pattern(filename, lines)
if (is.null(pattern$chunk.begin) || is.null(pattern$chunk.end)) {
return(lines)
}
# mask non-source lines by NA, but keep total line count identical so the line number for EOF is correct, see #1400
output <- rep.int(NA_character_, length(lines))
chunks <- tryCatch(get_chunk_positions(pattern = pattern, lines = lines), error = error)
if (inherits(chunks, "error") || inherits(chunks, "lint")) {
assign("e", chunks, envir = parent.frame())
# error, so return empty code
return(output)
}
# no chunks found, so just return the lines
if (length(chunks[["starts"]]) == 0L || length(chunks[["ends"]]) == 0L) {
return(output)
}
output_env <- environment() # nolint: object_usage_linter. False positive-ish -- used below.
Map(
function(start, end, indent) {
line_seq <- seq(start + 1L, end - 1L)
chunk_code <- lines[line_seq]
output_env$output[line_seq] <- if (indent > 0L) substr(chunk_code, indent + 1L, nchar(chunk_code)) else chunk_code
},
chunks[["starts"]],
chunks[["ends"]],
chunks[["indents"]]
)
# drop <<chunk>> references, too
is.na(output) <- grep(pattern$ref.chunk, output)
replace_prefix(output, pattern$chunk.code)
}
get_knitr_pattern <- function(filename, lines) {
# Early return if the source code is parseable as plain R code.
# Otherwise, R code containing a line which matches any knitr pattern will be treated as a knitr file.
# See #1406 for details.
if (parsable(lines)) {
return(NULL)
}
# suppressWarnings for #1920. TODO(michaelchirico): this is a bit sloppy -- we ignore
# warnings here because encoding issues are caught later and that code path handles them
# correctly by converting to a lint. It would require some refactoring to get that
# right here as well, but it would avoid the duplication.
pattern <- withCallingHandlers(
("knitr" %:::% "detect_pattern")(lines, tolower(("knitr" %:::% "file_ext")(filename))),
warning = function(cond) {
if (!grepl("invalid UTF-8", conditionMessage(cond), fixed = TRUE)) {
warning(cond)
}
invokeRestart("muffleWarning")
}
)
if (!is.null(pattern)) {
knitr::all_patterns[[pattern]]
} else {
NULL
}
}
get_chunk_positions <- function(pattern, lines) {
starts <- filter_chunk_start_positions(
starts = grep(pattern$chunk.begin, lines, perl = TRUE),
lines = lines
)
ends <- filter_chunk_end_positions(
starts = starts,
ends = grep(pattern$chunk.end, lines, perl = TRUE)
)
# only keep those blocks that contain at least one line of code
keep <- which(ends - starts > 1L)
starts <- starts[keep]
ends <- ends[keep]
# Check indent on all lines in the chunk to allow for staggered indentation within a chunk;
# set the initial column to the leftmost one within each chunk (including the start+end gates). See tests.
# use 'ws_re' to make clear that we're matching knitr's definition of initial whitespace.
ws_re <- sub("```.*", "", pattern$chunk.begin)
extract_min_chunk_indent <- function(start, end) {
indents <- attr(regexpr(ws_re, lines[start:end], perl = TRUE), "match.length")
min(indents)
}
# NB: min() guarantees length(indents) == length(starts)
indents <- unlist(Map(extract_min_chunk_indent, starts, ends))
list(starts = starts, ends = ends, indents = indents)
}
filter_chunk_start_positions <- function(starts, lines) {
# keep blocks that don't set a knitr engine (and so contain evaluated R code)
drop <- defines_knitr_engine(lines[starts])
starts[!drop]
}
filter_chunk_end_positions <- function(starts, ends) {
# In a valid file, possibly with plain-code-blocks,
# - there should be at least as many ends as starts
# In Rmarkdown and Quarto, unevaluated blocks may open & close with the same ``` pattern
# that defines the end-pattern for an evaluated block
# This returns the first end-position that succeeds each start-position
# starts (1, 3, 5, 7, 11) --> (1, 3, 5, 7, 11)
# ends (2, 4, 6, 8, 9, 10, 12) --> (2, 4, 6, 8, 12) # return this
length_difference <- length(ends) - length(starts)
if (length_difference == 0L && all(ends > starts)) {
return(ends)
}
positions <- sort(c(starts = starts, ends = ends))
code_start_indexes <- grep("starts", names(positions), fixed = TRUE)
code_ends <- positions[pmin(1L + code_start_indexes, length(positions))]
bad_end_indexes <- grep("starts", names(code_ends), fixed = TRUE)
if (length(bad_end_indexes) > 0L) {
bad_start_positions <- positions[code_start_indexes[bad_end_indexes]]
# This error message is formatted like a parse error
stop(sprintf(
"<rmd>:%1$d:1: Missing chunk end for chunk (maybe starting at line %1$d).\n",
bad_start_positions[1L]
), call. = FALSE)
}
code_ends
}
defines_knitr_engine <- function(start_lines) {
# Other packages defining custom engines should have them loaded and thus visible
# via knitr_engines$get() below. It seems the simplest way to accomplish this is
# for those packages to set some code in their .onLoad() hook, but that's not
# always done (nor quite recommended as a "best practice" by knitr).
# See the discussion on #1552.
# TODO(#1617): explore running loadNamespace() automatically.
engines <- names(knitr::knit_engines$get())
# {some_engine}, {some_engine label, ...} or {some_engine, ...}
bare_engine_pattern <- rex(
"{", or(engines), one_of("}", " ", ",")
)
# {... engine = "some_engine" ...}
explicit_engine_pattern <- rex(
boundary, "engine", any_spaces, "="
)
re_matches(start_lines, explicit_engine_pattern) |
re_matches(start_lines, bare_engine_pattern)
}
replace_prefix <- function(lines, prefix_pattern) {
if (is.null(prefix_pattern)) {
return(lines)
}
m <- gregexpr(prefix_pattern, lines)
non_na <- !is.na(m)
prefix_lengths <- lapply(regmatches(lines[non_na], m[non_na]), nchar)
regmatches(lines[non_na], m[non_na]) <- lapply(prefix_lengths, strrep, x = " ")
lines
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.